~ chicken-core (chicken-5) 848afe8c440b3f487b88e10ae691020989f19fd4
commit 848afe8c440b3f487b88e10ae691020989f19fd4
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Nov 29 08:07:23 2011 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Tue Nov 29 09:29:25 2011 +0100
removed some obsolete scripts
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/distribution/manifest b/distribution/manifest
index 134546d0..03d9e35d 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -294,6 +294,7 @@ CHICKEN.icns
scripts/reconstruct-egg-name.scm
scripts/mini-salmonella.scm
scripts/make-wrapper.scm
+scripts/makedist.scm
manual-html/Accessing external objects.html
manual-html/Acknowledgements.html
manual-html/Basic mode of operation.html
diff --git a/rules.make b/rules.make
index 929b0a31..e35cb658 100644
--- a/rules.make
+++ b/rules.make
@@ -601,7 +601,7 @@ setup-download.c: $(SRCDIR)setup-download.scm setup-api.c
distfiles: $(DISTFILES)
dist: distfiles html
- CSI=$(CSI) $(CSI) -s $(SRCDIR)scripts$(SEP)makedist.scm --platform=$(PLATFORM) CHICKEN=$(CHICKEN)
+ CSI=$(CSI) $(CSI) -s $(SRCDIR)scripts$(SEP)makedist.scm -platform $(PLATFORM) CHICKEN=$(CHICKEN)
# Jim's `manual-labor' must be installed (just run "chicken-install manual-labor")
html:
diff --git a/scripts/README b/scripts/README
index e427a1ff..ca845742 100644
--- a/scripts/README
+++ b/scripts/README
@@ -4,20 +4,11 @@ README for scripts/
This directory contains a couple of things that might be useful:
- tools.scm
-
- Helper functions for some of the scripts here.
-
test-dist.sh
Takes a platform-designator and the path to a tarball and unpacks,
builds and tests the chicken distribution contained therein.
- wiki2html.scm
-
- A simple svnwiki -> HTML translator used for the manual. Needs
- `htmlprag' and `matchable' eggs installed.
-
makedist.scm
Creates a distribution tarball from a chicken svn checkout.
@@ -28,8 +19,3 @@ This directory contains a couple of things that might be useful:
takes a path to a local checkout of the extensions repository
and compiles each egg from scratch, reporting success or
failure.
-
- identify-branch
-
- Obtains the branchname, if this is a git(1) checkout, otherwise
- does nothing.
diff --git a/scripts/dpkg-eggs.scm b/scripts/dpkg-eggs.scm
deleted file mode 100644
index a0b9da1e..00000000
--- a/scripts/dpkg-eggs.scm
+++ /dev/null
@@ -1,151 +0,0 @@
-;;
-;; Given a directory tree with egg directories, build Debian packages
-;; for all eggs that have a debian subdirectory.
-;;
-;; Usage: dpkg-eggs --eggdir=DIR --output-dir=DIR
-;;
-
-(require-extension srfi-1)
-(require-extension srfi-13)
-(require-extension posix)
-(require-extension regex)
-(require-extension utils)
-(require-extension args)
-
-(include "tools.scm")
-
-(define s+ string-append)
-
-(define opts
- `(
- ,(args:make-option (extension-path) (required: "DIR")
- (s+ "path to stream-wiki extensions"))
- ,(args:make-option (wiki-dir) (required: "DIR")
- (s+ "use wiki documentation in directory DIR"))
- ,(args:make-option (egg-dir) (required: "DIR")
- (s+ "operate on eggs in directory DIR"))
- ,(args:make-option (output-dir) (required: "DIR")
- (s+ "place Debian packages in directory DIR (will be created if it does not exist)"))
- ,(args:make-option (verbose) #:none
- (s+ "enable verbose mode")
- (set! *verbose* #t))
- ,(args:make-option (exclude) (required: "EGGS")
- (s+ "a comma separated list of eggs to exclude from building"))
- ,(args:make-option (h help) #:none "Print help"
- (usage))
-
- ))
-
-
-;; Use args:usage to generate a formatted list of options (from OPTS),
-;; suitable for embedding into help text.
-(define (usage)
- (print "Usage: " (car (argv)) " options... [list of eggs to be built] ")
- (newline)
- (print "The following options are recognized: ")
- (newline)
- (print (parameterize ((args:indent 5)) (args:usage opts)))
- (exit 1))
-
-
-;; Process arguments and collate options and arguments into OPTIONS
-;; alist, and operands (filenames) into OPERANDS. You can handle
-;; options as they are processed, or afterwards.
-(define args (command-line-arguments))
-(set!-values (options operands) (args:parse args opts))
-
-(define dirsep (string ##sys#pathname-directory-separator))
-
-(define (read-subdirs path)
- (find-files path directory? cons (list) 0))
-
-;; Compare versions of the format x.x...
-(define (version< v1 v2)
- (let ((v1 (string-split v1 "."))
- (v2 (string-split v2 ".")))
- (every (lambda (s1 s2)
- (let ((n1 (string->number s1))
- (n2 (string->number s2)))
- (cond ((and n1 n2) (<= n1 n2))
- (else (string<= s1 s2)))))
- v1 v2)))
-
-;; Find the latest release in a given egg directory
-(define (find-latest-release path)
- (let ((tags (s+ path dirsep "tags")))
- (cond ((file-exists? tags)
- (let ((lst (filter-map (lambda (x) (and (not (string=? (pathname-strip-directory x) ".svn")) x))
- (read-subdirs tags)))
- (cmp (lambda (x y) (version< (pathname-strip-directory x) (pathname-strip-directory y)))))
- (if (pair? lst) (car (reverse (sort lst cmp))) path)))
- (else path))))
-
-;; Find the debian subdirectory in a given egg directory
-(define (find-debian-subdir path . rest)
- (let-optionals rest ((release (find-latest-release path)))
- (cond ((file-exists? (s+ path dirsep "trunk" dirsep "debian")) => identity)
- ((file-exists? (s+ release dirsep "debian")) => identity)
- (else #f))))
-
-;; Find wiki documentation for given egg
-(define (find-wiki-doc name wikidir)
- (cond ((file-exists? (s+ wikidir dirsep name)) => identity)
- (else #f)))
-
-(define (build-deb eggdir wiki-dir output-dir ext-path path)
- (let* ((name (pathname-strip-directory path))
- (release (find-latest-release path))
- (debdir (find-debian-subdir path release)))
- (if debdir
- (let ((start (cwd))
- (build-dir (s+ output-dir dirsep name))
- (doc (cond ((file-exists? (s+ release dirsep name ".html")) => identity)
- ((and wiki-dir (file-exists? (s+ wiki-dir dirsep name))) => identity)
- (else #f))))
- (message "Release directory is ~a" release)
- (message "debian subdirectory found in ~a" path)
- (run (rm -rf ,build-dir))
- (run (cp -R ,release ,build-dir))
- (run (cp -R ,debdir ,build-dir))
- (if (and doc (not (string-suffix? ".html" doc)))
- (let ((html-path (s+ "html/" name ".html")))
- (run (csi -s ,(cond ((file-exists? (s+ start "/makehtml.scm")) => identity)
- (else 'makehtml.scm))
- ,(s+ "--extension-path=" ext-path)
- ,(s+ "--wikipath=" wiki-dir)
- ,(s+ "--only=" name)))
- (run (cp ,html-path ,build-dir))))
- (cd build-dir)
- (run (chmod a+rx debian/rules))
- (run (,(s+ "EGG_TREE=\"" eggdir "\"") dpkg-buildpackage -us -uc))
- (cd start))
- (message "No debian subdirectory found in ~a" path))))
-
-(define (main options operands)
- (let ((opt_wikidir (alist-ref 'wiki-dir options))
- (opt_eggdir (alist-ref 'egg-dir options))
- (opt_extpath (alist-ref 'extension-path options))
- (opt_exclude ((lambda (x) (and x (string-split x ","))) (alist-ref 'exclude options)))
- (opt_output-dir (alist-ref 'output-dir options)))
- (if (not (and opt_eggdir opt_output-dir))
- (begin
- (error-message "Both egg directory and output directory must be specified!")
- (usage)))
- (message "Egg directory tree: ~a" opt_eggdir)
- (message "Output directory tree: ~a" opt_output-dir)
- ;; make sure target dir exists
- (if (not (file-exists? opt_output-dir))
- (begin
- (message "Creating directory ~a" opt_output-dir)
- (create-directory opt_output-dir)))
- (let ((eggdirs (filter-map
- (lambda (x) (and (not (member (pathname-strip-directory x) opt_exclude)) x))
- (or (and (pair? operands) (map (lambda (x) (s+ opt_eggdir dirsep (->string x))) operands))
- (read-subdirs opt_eggdir)))))
- (if (null? eggdirs)
- (message "No egg directories found in ~a" opt_eggdir)
- (message "Found egg directories: ~a" eggdirs))
- (for-each (lambda (x) (build-deb opt_eggdir opt_wikidir opt_output-dir opt_extpath x))
- eggdirs))))
-
-(main options operands)
diff --git a/scripts/make-eggdoc.scm b/scripts/make-eggdoc.scm
deleted file mode 100644
index d92f2e03..00000000
--- a/scripts/make-eggdoc.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;;;; make-eggdoc.scm - create HTML files for eggs that use eggdoc.
-
-(include "tools.scm")
-
-(use setup-download matchable data-structures regex)
-
-(import foreign)
-
-(define csi (foreign-value "C_CSI_PROGRAM" c-string))
-
-(define *help* #f)
-(define *docroot* ".")
-
-(define *major-version* (##sys#fudge 41))
-
-(define (d fstr . args)
- (fprintf (current-error-port) "~?~%" fstr args))
-
-(define (usage code)
- (print "make-eggdoc.scm [--help] [--major-version=MAJOR] [DIR]")
- (exit code))
-
-
-(define (make-eggdoc dir)
- (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
- (eggs (gather-egg-information dir)))
-
- (for-each
- (lambda (egg)
- (let ((meta (cdr egg)))
- (d "processing meta ~s" meta)
- (cond
- ((assq 'eggdoc meta) =>
- (lambda (edoc)
- (d "edoc is ~a" edoc)
- (let ((eggname (->string (car egg))))
- (d "creating HTML from eggdoc file ~a" (cadr edoc))
- (let* ((egg-dir (locate-egg/local eggname dir))
- (eggref-dir (sprintf "~s/eggref/~a" *docroot* *major-version* ))
- (cmd (sprintf "~a -I ~a -s ~a > ~a"
- csi
- egg-dir
- (make-pathname egg-dir (->string (cadr edoc)))
- (make-pathname eggref-dir eggname "html"))))
- (d "~s" cmd)
- (system* cmd) )))))))
- eggs)
-
- ))
-
-(define (main args)
- (when *help* (usage 0))
- (match args
- ((dir) (make-eggdoc dir))
- (() (make-eggdoc "."))
- (_ (usage 1))))
-
-(main (simple-args (command-line-arguments)))
-
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
index 7fa8e935..6108a8ea 100644
--- a/scripts/makedist.scm
+++ b/scripts/makedist.scm
@@ -1,16 +1,11 @@
;;;; makedist.scm - Make distribution tarballs
-(use srfi-69 irregex)
+(use srfi-69 irregex srfi-1 setup-api)
(define *release* #f)
-
-(load-relative "tools.scm")
-
(define *help* #f)
-(set! *verbose* #t)
-
(define BUILDVERSION (with-input-from-file "buildversion" read))
(define *platform*
@@ -30,6 +25,22 @@
((string=? "mingw32" *platform*) "mingw32-make")
(else "make")))
+(define (prefix dir . files)
+ (if (null? files)
+ (pathname-directory dir)
+ (let ((files2 (map (cut make-pathname dir <>) (normalize files))))
+ (if (or (pair? (cdr files)) (pair? (car files)))
+ files2
+ (car files2) ) ) ) )
+
+(define (normalize fs)
+ (delete-duplicates
+ (map ->string
+ (if (pair? fs)
+ (flatten fs)
+ (list fs) ) )
+ equal?) )
+
(define (release full?)
(let* ((files (read-lines "distribution/manifest"))
(distname (conc "chicken-" BUILDVERSION))
@@ -39,7 +50,7 @@
(create-directory distname)
(for-each
(lambda (d)
- (let ((d (path distname d)))
+ (let ((d (make-pathname distname d)))
(unless (file-exists? d)
(print "creating " d)
(create-directory d 'with-parents))))
@@ -47,8 +58,8 @@
(let ((missing '()))
(for-each
(lambda (f)
- (if (-e f)
- (run (cp -p ,(qs f) ,(qs (path distname f))))
+ (if (file-exists? f)
+ (run (cp -p ,(qs f) ,(qs (make-pathname distname f))))
(set! f (cons f missing))))
files)
(unless (null? missing)
@@ -56,16 +67,27 @@
(run (tar cfz ,(conc distname ".tar.gz") ,distname))
(run (rm -fr ,distname)) ) )
-(define (usage . _)
- (print "usage: makedist [--release] [--make=PROGRAM] [--platform=PLATFORM] MAKEOPTION ...")
- (exit 1))
+(define (usage)
+ (print "usage: makedist [-release] [-make PROGRAM] [--platform=PLATFORM] MAKEOPTION ...")
+ (exit))
(define *makeargs*
- (simple-args
- (command-line-arguments)
- usage))
-
-(when *help* (usage))
+ (let loop ((args (command-line-arguments)))
+ (if (null? args)
+ '()
+ (let ((arg (car args)))
+ (cond ((string=? "-release" arg)
+ (set! *release* #t)
+ (loop (cdr args)))
+ ((string=? "-make" arg)
+ (set! *make* (cadr args))
+ (loop (cddr args)))
+ ((string=? "-help" arg)
+ (usage))
+ ((string=? "-platform" arg)
+ (set! *platform* (cadr args))
+ (loop (cddr args)))
+ (else (cons arg (loop (cdr args)))))))))
(run (,*make* -f ,(conc "Makefile." *platform*) distfiles ,@*makeargs*))
diff --git a/scripts/tools.scm b/scripts/tools.scm
deleted file mode 100644
index da83c994..00000000
--- a/scripts/tools.scm
+++ /dev/null
@@ -1,469 +0,0 @@
-;;;; tools.scm
-
-
-(use (srfi 1 69) posix utils files regex)
-
-
-(define *verbose* (##sys#fudge 13))
-(define *dependencies* (make-hash-table string=?))
-(define *variables* (make-hash-table string=?))
-(define *actions* (make-hash-table string=?))
-(define *pseudo-targets* '())
-(define *sleep-delay* 2)
-
-(define *windows-shell*
- (memq (build-platform) '(mingw32 msvc)))
-
-
-;;; Verbosity and output
-
-(define *tty*
- (and (##sys#tty-port? (current-output-port))
- (not (feature? #:mingw32))
- (not (equal? (get-environment-variable "EMACS") "t"))
- (not (equal? (get-environment-variable "TERM") "dumb"))))
-
-(define *tty-width*
- (or (and *tty*
- (not *windows-shell*)
- (with-input-from-pipe "stty size 2>/dev/null"
- (lambda () (read) (read))))
- 72))
-
-(define *info-message-escape* (if *tty* "\x1b[0m\x1b[2m" ""))
-(define *target-message-escape* (if *tty* "\x1b[0m\x1b[32m" ""))
-(define *error-message-escape* (if *tty* "\x1b[0m\x1b[31m" ""))
-(define *command-message-escape* (if *tty* "\x1b[0m\x1b[33m" ""))
-(define *reset-escape* (if *tty* "\x1b[0m" ""))
-
-(define (format-message msg #!optional (nl #t))
- (if (or *verbose* (not *tty*))
- ((if nl print print*) msg)
- (for-each
- (lambda (ln)
- (printf "\r\x1b[K~a~!"
- (if (>= (string-length ln) (sub1 *tty-width*))
- (string-append
- (substring ln 0 (- *tty-width* 5))
- "...")
- ln) ) )
- (string-split msg "\n")) ) )
-
-(define (message fstr . args)
- (when *verbose*
- (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*)) ) )
-
-(define (message* fstr . args)
- (when *verbose*
- (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*) #f) ) )
-
-(define (target-message fstr . args)
- (format-message (sprintf "~a~?~a " *target-message-escape* fstr args *reset-escape*)))
-
-(define (command-message fstr . args)
- (when *verbose*
- (format-message (sprintf "~a ~?~a " *command-message-escape* fstr args *reset-escape*))) )
-
-(define (error-message fstr . args)
- (sprintf "~%~a~?~a~%" *error-message-escape* fstr args *reset-escape*))
-
-(define (quit fstr . args)
- (display (apply error-message fstr args) (current-error-port))
- (reset) )
-
-(define (cleanup-output)
- (when (and (not *verbose*) *tty*)
- (printf "\r\x1b[0m\x1b[K~!") ) )
-
-
-;;; make-code stolen from PLT
-
-(define (find-matching-line str spec)
- (let ([match? (lambda (s) (string=? s str))])
- (let loop ([lines spec])
- (cond
- [(null? lines) #f]
- [else (let* ([line (car lines)]
- [names (if (string? (car line))
- (list (car line))
- (car line))])
- (if (any match? names)
- line
- (loop (cdr lines))))]))))
-
-(define (form-error s p) (quit "~a: ~s" s p))
-(define (line-error s p n) (quit "~a: ~s in line ~a" s p))
-
-(define (check-spec spec)
- (and (or (list? spec) (form-error "specification is not a list" spec))
- (or (pair? spec) (form-error "specification is an empty list" spec))
- (every
- (lambda (line)
- (and (or (and (list? line) (<= 2 (length line) 3))
- (form-error "list is not a list with 2 or 3 parts" line))
- (or (or (string? (car line))
- (and (list? (car line))
- (every string? (car line))))
- (form-error "line does not start with a string or list of strings" line))
- (let ([name (car line)])
- (or (list? (cadr line))
- (line-error "second part of line is not a list" (cadr line) name)
- (every (lambda (dep)
- (or (string? dep)
- (form-error "dependency item is not a string" dep)))
- (cadr line)))
- (or (null? (cddr line))
- (procedure? (caddr line))
- (line-error "command part of line is not a thunk" (caddr line) name)))))
- spec)))
-
-(define (check-argv argv)
- (or (string? argv)
- (and (vector? argv)
- (every string? (vector->list argv)))
- (error "argument is not a string or string vector" argv)))
-
-(define (make/proc/helper spec argv)
- (check-spec spec)
- (check-argv argv)
- (letrec ([made '()]
- [exn? (condition-predicate 'exn)]
- [exn-message (condition-property-accessor 'exn 'message)]
- [make-file
- (lambda (s indent)
- (let ([line (find-matching-line s spec)]
- [date (and (not (member s *pseudo-targets*))
- (file-exists? s)
- (file-modification-time s))])
- (if line
- (let ([deps (cadr line)])
- (for-each (let ([new-indent (string-append " " indent)])
- (lambda (d) (make-file d new-indent)))
- deps)
- (let ([reason
- (or (not date)
- (any (lambda (dep)
- (unless (file-exists? dep)
- (quit "dependancy ~a was not made~%" dep))
- (and (> (file-modification-time dep) date)
- dep))
- deps))])
- (when reason
- (let ([l (cddr line)])
- (unless (null? l)
- (set! made (cons s made))
- ((car l)))))))
- (when (not date)
- (quit "don't know how to make ~a" s)))))])
- (cond
- [(string? argv) (make-file argv "")]
- [(equal? argv '#()) (make-file (caar spec) "")]
- [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) ) )
-
-(define make/proc
- (case-lambda
- [(spec) (make/proc/helper spec '#())]
- [(spec argv) (make/proc/helper spec argv)]))
-
-
-;;; Run subcommands
-
-(define (execute exps)
- (for-each
- (lambda (exp)
- (let ((cmd (string-intersperse (map ->string (flatten exps)))))
- (command-message "~A" cmd)
- (let ((s (system cmd)))
- (unless (zero? s)
- (quit (sprintf "invocation of command failed with non-zero exit-status ~a: ~a~%" s cmd) s) ) ) ) )
- exps) )
-
-(define-syntax run
- (syntax-rules ()
- ((_ exp ...)
- (execute (list `exp ...)))))
-
-
-;;; String and path helper functions
-
-(define (prefix dir . files)
- (if (null? files)
- (pathname-directory dir)
- (let ((files2 (map (cut make-pathname dir <>) (normalize files))))
- (if (or (pair? (cdr files)) (pair? (car files)))
- files2
- (car files2) ) ) ) )
-
-(define (suffix suf . files)
- (if (null? files)
- (pathname-extension suf)
- (let ((files2 (map (cut pathname-replace-extension <> suf) (normalize files))))
- (if (or (pair? (cdr files)) (pair? (car files)))
- files2
- (car files2) ) ) ) )
-
-(define (normalize fs)
- (delete-duplicates
- (map ->string
- (if (pair? fs)
- (flatten fs)
- (list fs) ) )
- equal?) )
-
-(define path make-pathname)
-
-
-;;; "Stateful" build interface
-
-(define (build-clear)
- (set! *dependencies* (make-hash-table string=?))
- (set! *actions* (make-hash-table string=?))
- (set! *variables* (make-hash-table string=?)) )
-
-(define (depends target . deps)
- (let ((deps (normalize deps)))
- (hash-table-update!
- *dependencies* target
- (lambda (old) (lset-union string=? old deps))
- (lambda () deps) ) ) )
-
-(define actions
- (let ((doaction
- (lambda (name target proc)
- (hash-table-update! *dependencies* target identity (constantly '()))
- (hash-table-set!
- *actions* target
- (lambda ()
- (target-message "~a\t~a" name target)
- (proc) ) ) ) ) )
- (case-lambda
- ((target proc) (doaction "build " target proc))
- ((name target proc) (doaction name target proc)) ) ) )
-
-(define (notfile . targets)
- (set! *pseudo-targets* (lset-union string=? *pseudo-targets* targets)))
-
-(define (clean-on-error t thunk)
- (handle-exceptions ex
- (begin
- (when (file-exists? t)
- (message "deleting ~a" t)
- (delete-file t) )
- (abort ex) )
- (thunk) ) )
-
-(define (build #!optional
- (targets "all")
- #!key
- continuous
- (verbose *verbose*) )
- (fluid-let ((*verbose* verbose))
- (let* ((deps (hash-table->alist *dependencies*))
- (wdeps (delete-duplicates (append-map cdr deps) string=?))
- (targets (list->vector (normalize targets)) )
- (ftable (and continuous (make-hash-table string=?))))
- (when continuous
- (for-each
- (lambda (dep)
- (when (file-exists? dep)
- (hash-table-set! ftable dep (file-modification-time dep))))
- wdeps))
- (let loop ()
- (make/proc
- (map (lambda (dep)
- (let ((target (car dep))
- (deps (cdr dep)))
- (list target deps
- (eval
- `(lambda ()
- (clean-on-error
- ',target
- (lambda ()
- ((hash-table-ref/default *actions* ',target noop)))))))))
- deps)
- targets)
- (when continuous
- (watch-dependencies wdeps ftable)
- (loop)))
- (cleanup-output))))
-
-(define (build-dump #!optional (port (current-output-port)))
- (with-output-to-port port
- (lambda ()
- (message "dependencies:")
- (for-each show-dependencies (hash-table-keys *dependencies*))
- (when (positive? (hash-table-size *variables*))
- (message "variables:")
- (hash-table-walk
- *variables*
- (lambda (v x)
- (message " ~s:" v)
- (for-each
- (lambda (p)
- (message " ~a\t-> ~s~%" (car p) (cadr p)))
- x))) ) ) ) )
-
-(define (show-dependencies target)
- (let ((i ""))
- (let loop ((t target))
- (message "~a~a ~a" i t (if (member t *pseudo-targets*) "(p)" ""))
- (fluid-let ((i (string-append i " ")))
- (for-each loop (hash-table-ref/default *dependencies* t '())) ) ) ) )
-
-
-;;; Command line processing
-
-(define (build* . args)
- (let ((continuous #f)
- (targets '())
- (debug #f) )
- (let-values (((procs arglists) (partition procedure? args)))
- (let loop ((args (if (null? arglists)
- (command-line-arguments)
- (concatenate arglists))) )
- (cond ((null? args)
- (when debug (build-dump))
- (for-each (lambda (p) (p)) procs)
- (build
- (if (null? targets) "all" (reverse targets))
- verbose: *verbose*
- continuous: continuous) )
- (else
- (let ((x (car args)))
- (cond ((and (> (string-length x) 0) (char=? #\- (string-ref x 0)))
- (cond ((string=? "-v" x)
- (set! *verbose* #t) )
- ((member x '("-h" "-help" "--help"))
- (usage 0) )
- ((string=? "-c" x)
- (set! continuous #t) )
- ((string=? "-d" x)
- (set! debug #t) )
- (else (usage 1)) )
- (loop (cdr args)) )
- ((irregex-match "([-_A-Za-z0-9]+)=(.*)" x) =>
- (lambda (m)
- (let* ((sym (string->symbol (irregex-match-substring m 1))))
- (if (##sys#symbol-has-toplevel-binding? sym)
- (let ((val (##sys#slot sym 0)))
- (if (or (boolean? val)
- (string? val)
- (symbol? val)
- (eq? (void) val))
- (##sys#setslot sym 0 (irregex-match-substring m 2))
- (quit "variable `~a' already has a suspicious value"
- sym) ) )
- (##sys#setslot sym 0 (irregex-match-substring m 2)) )
- (loop (cdr args)) ) ) )
- (else
- (set! targets (cons x targets))
- (loop (cdr args))))))))) ) )
-
-(define (usage code)
- (print "usage: " (car (argv)) " [ -v | -c | -d | TARGET | VARIABLE=VALUE ] ...")
- (exit code) )
-
-
-;;; Check dependencies for changes
-
-(define (watch-dependencies deps tab)
- (let loop ((f #f))
- (sleep *sleep-delay*)
- (cond ((any (lambda (dep)
- (and-let* (((file-exists? dep))
- (ft (file-modification-time dep))
- ((> ft (hash-table-ref/default tab dep 0))))
- (hash-table-set! tab dep ft)
- (message "~a changed" dep)
- #t) )
- deps))
- (f (loop #t))
- (else
- (message "waiting for changes ...")
- (loop #t)))))
-
-
-;;; Other useful procedures
-
-(define -e file-exists?)
-(define -d (conjoin file-exists? directory?))
-(define -x (conjoin file-exists? file-execute-access?))
-
-(define cwd current-directory)
-(define (cd #!optional d) (if d (current-directory d) (get-environment-variable "HOME")))
-
-(define (with-cwd dir thunk)
- (if (or (not dir) (equal? "." dir))
- (thunk)
- (let ((old #f))
- (dynamic-wind
- (lambda () (set! old (current-directory)))
- (lambda ()
- (command-message "cd ~a" dir)
- (change-directory dir)
- (thunk) )
- (lambda ()
- (change-directory old)
- (command-message "cd ~a" old) ) ) ) ) )
-
-(define (try-run code #!optional (msg "trying to compile and run some C code") (flags "") (cc "cc"))
- (let ((tmp (create-temporary-file "c")))
- (with-output-to-file tmp (lambda () (display code)))
- (message* "~a ..." msg)
- (let ((r (zero? (system (sprintf "~a ~a ~a 2>/dev/null && ./a.out" cc tmp flags)))))
- (delete-file* tmp)
- (message (if r "ok" "failed"))
- r) ) )
-
-(define (true? x)
- (and x (not (member x '("no" "false" "off" "0" "")))))
-
-(define (simple-args #!optional (args (command-line-arguments)) (error error))
- (define (assign var val)
- (##sys#setslot
- (string->symbol (string-append "*" var "*"))
- 0
- (if (string? val)
- (or (string->number val) val)
- val)))
- (let loop ((args args) (vals '()))
- (cond ((null? args) (reverse vals))
- ((irregex-match "(-{1,2})([-_A-Za-z0-9]+)(=)?\\s*(.+)?" (car args))
- =>
- (lambda (m)
- (let*-values (((next) (cdr args))
- ((var val)
- (cond ((equal? "=" (irregex-match-substring m 3))
- (let ((opt (irregex-match-substring m 2))
- (val (irregex-match-substring m 4)))
- (cond (val (values opt val))
- (else
- (when (null? next)
- (error "missing argument for option"
- (car args)) )
- (let ((x (car next)))
- (set! next (cdr next))
- (values opt x))))) )
- ((string? (irregex-match-substring m 1))
- (values (irregex-match-substring m 2) #t))
- (else (values #f #f)) ) ) )
- (cond (var
- (assign var val)
- (loop next vals) )
- (else (loop next (cons (car args) vals)))))))
- (else (loop (cdr args) (cons (car args) vals))))))
-
-(define (yes-or-no? str . default)
- (let ((def (optional default #f)))
- (let loop ()
- (printf "~%~A (yes/no) " str)
- (when def (printf "[~A] " def))
- (flush-output)
- (let ((ln (read-line)))
- (cond ((eof-object? ln) (set! ln "abort"))
- ((and def (string=? "" ln)) (set! ln def)) )
- (cond ((string-ci=? "yes" ln) #t)
- ((string-ci=? "no" ln) #f)
- (else
- (printf "~%Please enter \"yes\" or \"no\".~%")
- (loop) ) ) ) ) ) )
diff --git a/scripts/wiki2html.scm b/scripts/wiki2html.scm
deleted file mode 100644
index a34d53aa..00000000
--- a/scripts/wiki2html.scm
+++ /dev/null
@@ -1,299 +0,0 @@
-;;;; wiki2html.scm - quick-and-dirty svnwiki->HTML conversion
-
-
-(load-relative "tools.scm")
-
-(use regex srfi-1 extras utils srfi-13 posix)
-(use htmlprag matchable)
-
-
-;;; inline elements
-
-(define +code+ '(: #\{ #\{ (submatch (*? any)) #\} #\}))
-(define +bold+ '(: (= 3 #\') (submatch (* (~ #\'))) (= 3 #\')))
-(define +italic+ '(: (= 2 #\') (submatch (* (~ #\'))) (= 2 #\')))
-(define +html-tag+ '(: #\< (submatch (* (~ #\>))) #\>))
-(define +enscript-tag+ '(: "<enscript" (* (~ #\>)) #\>))
-
-(define +link+
- '(: #\[ #\[ (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
-
-(define +image-link+
- '(: #\[ #\[ (* space) "image:" (* space)
- (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
-
-(define +inline-element+
- `(or ,+code+ ,+image-link+ ,+link+ ,+html-tag+ ,+bold+ ,+italic+))
-
-(define +http-url+ '(: (* space) "http://" (* any)))
-(define +end-enscript-tag+ '(: "</enscript>"))
-
-
-;;; Block elements
-
-(define +header+ '(: (submatch (>= 2 #\=)) (* space) (submatch (* any))))
-(define +pre+ '(: (>= 1 space) (submatch (* any))))
-
-(define +d-list+
- '(: (* space) #\; (submatch (*? any)) #\space #\: #\space (submatch (* any))))
-
-(define +d-head+ '(: (* space) #\; (submatch (* any))))
-(define +u-list+ '(: (* space) (submatch (>= 1 #\*)) (* space) (submatch (* any))))
-(define +o-list+ '(: (* space) (submatch (>= 1 #\*)) #\# (* space) (submatch (* any))))
-(define +hr+ '(: (* space) (submatch (>= 3 #\-)) (* space)))
-
-(define +block-element+
- `(or ,+pre+
- ,+header+
- ,+d-list+
- ,+d-head+
- ,+u-list+
- ,+o-list+
- ,+enscript-tag+
- ,+hr+))
-
-
-;;; Global state
-
-(define *tags* '())
-(define *open* '())
-(define *manual-pages* '())
-(define *list-continuation* #f)
-
-(define (push-tag tag out)
- ;(fprintf (current-error-port) "start: tag: ~a, open: ~a~%" tag *open*)
- (unless (and (pair? *open*) (equal? tag (car *open*)))
- (when (pair? *open*)
- (cond ((not (pair? tag)) (pop-tag out))
- ((pair? (car *open*))
- ;(fprintf (current-error-port) "tag: ~a, open: ~a~%" tag *open*)
- (when (< (cdr tag) (cdar *open*))
- (do ((n (cdar *open*) (sub1 n)))
- ((= (cdr tag) n))
- (pop-tag out))))))
- (unless (and (pair? *open*) (equal? tag (car *open*)))
- (fprintf out "<~a>~%" (if (pair? tag) (car tag) tag))
- (set! *list-continuation* #f)
- ;(fprintf (current-error-port) "PUSH: ~a~%" tag)
- (set! *open* (cons tag *open*)))))
-
-(define (pop-tag out)
- (let ((tag (car *open*)))
- ;(fprintf (current-error-port) "POP: ~a~%" *open*)
- (fprintf out "</~a>~%" (if (pair? tag) (car tag) tag))
- (set! *open* (cdr *open*))))
-
-(define (pop-all out)
- (when (pair? *open*)
- (pop-tag out)
- (pop-all out)))
-
-
-;;; Helper syntax
-
-(define-syntax rx
- (syntax-rules ()
- ((_ rx) (force (delay (regexp rx))))))
-
-
-;;; Conversion entry point
-
-(define (wiki->html #!optional (in (current-input-port)) (out (current-output-port)))
- (call/cc
- (lambda (return)
- (let loop ()
- (let ((ln (read-line in)))
- (cond ((eof-object? ln) (return #f))
- ((not (string-match (rx +block-element+) ln))
- (cond ((string-null? ln)
- (set! *list-continuation* #f))
- (else
- (pop-all out)
- (fprintf out "~a~%" (inline ln)))))
- ((string-match (rx +enscript-tag+) ln) =>
- (lambda (m)
- (pop-all out)
- (fprintf out "<pre>~a~%" (substring ln (string-length (car m))))
- (copy-until-match (rx +end-enscript-tag+) in out) ;XXX doesn't parse rest of line
- (display "</pre>" out)))
- ((string-match (rx +header+) ln) =>
- (lambda (m)
- (pop-all out)
- (let ((n (sub1 (string-length (second m))))
- (name (inline (third m))))
- (fprintf out "<a name='~a' /><h~a>~a</h~a>~%"
- name n name n))))
- ((string-match (rx +pre+) ln) =>
- (lambda (m)
- (cond (*list-continuation*
- (fprintf out "~a~%" (inline (second m))))
- (else
- (push-tag 'pre out)
- (fprintf out "~a~%" (clean (car m)))))))
- ((string-match (rx +hr+) ln) =>
- (lambda (m)
- (fprintf out "<hr />~%")))
- ((string-match (rx +d-list+) ln) =>
- (lambda (m)
- (push-tag 'dl out)
- (set! *list-continuation* #t)
- (fprintf out "<dt>~a</dt><dd>~a</dd>~%"
- (inline (second m)) (inline (or (third m) "")))))
- ((string-match (rx +d-head+) ln) =>
- (lambda (m)
- (push-tag 'dl out)
- (set! *list-continuation* #t)
- (fprintf out "<dt>~a</dt>~%" (inline (second m)))))
- ((string-match (rx +u-list+) ln) =>
- (lambda (m)
- (push-tag `(ul . ,(string-length (second m))) out)
- (set! *list-continuation* #t)
- (fprintf out "<li>~a~%" (inline (third m)))))
- ((string-match (rx +o-list+) ln) =>
- (lambda (m)
- (push-tag `(ol . ,(string-length (second m))) out)
- (set! *list-continuation* #t)
- (fprintf out "<li>~a~%" (inline (third m)))))
- (else (error "unknown block match" m)))
- (loop))))))
-
-
-;;; Substitute inline elements
-
-(define (inline str)
- (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
- (string-append
- (clean (substring str 0 (caar m)))
- (let ((rest (substring str (caar m))))
- (define (continue m)
- (inline (substring rest (string-length (first m)))))
- (cond ((string-search (rx `(: bos ,+code+)) rest) =>
- (lambda (m)
- (string-append
- "<tt>" (clean (second m)) "</tt>"
- (continue m))))
- ((string-search (rx `(: bos ,+html-tag+)) rest) =>
- (lambda (m)
- (string-append
- (first m)
- (continue m))))
- ((string-search (rx `(: bos ,+image-link+)) rest) =>
- (lambda (m)
- (string-append
- "<img src='" (clean (second m)) "' />"
- (continue m))))
- ((string-search (rx `(: bos ,+link+)) rest) =>
- (lambda (m)
- (let ((m1 (string-trim-both (second m))))
- (string-append
- (cond ((or (string=? "toc:" m1)
- (string-search (rx '(: bos (* space) "tags:")) m1) )
- "")
- ((find (cut string-ci=? <> m1) *manual-pages*)
- (string-append
- "<a href='" (clean m1) ".html'>" (inline m1) "</a>"))
- (else
- (string-append
- "<a href='"
- (clean
- (let ((href (second m)))
- (if (string-match (rx +http-url+) href)
- href
- (string-append "http://wiki.call-cc.org/" href))))
- "'>"
- (clean (or (third m) (second m)))
- "</a>")))
- (continue m)))))
- ((string-search (rx `(: bos ,+bold+)) rest) =>
- (lambda (m)
- (string-append
- "<b>" (inline (second m)) "</b>"
- (continue m))))
- ((string-search (rx `(: bos ,+italic+)) rest) =>
- (lambda (m)
- (string-append
- "<i>" (inline (second m)) "</i>"
- (continue m))))
- (else (error "unknown inline match" m rest))))))
- str))
-
-(define (convert name)
- (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
- (define (walk n)
- (match n
- (('*PI* . _) "")
- (('enscript strs ...)
- `(pre ,@(match strs
- ((('@ . _) . strs) strs)
- (_ strs))))
- (('procedure strs ...)
- `(b (p) "[procedure] " ,@strs (br)))
- (('macro strs ...)
- `(b (p) "[syntax] " ,@strs (br)))
- (('parameter strs ...)
- `(b (p) "[parameter] " ,@strs (br)))
- (('scheme strs ...)
- `(pre "\n" ,@strs))
- (('nowiki content ...)
- `(div ,@content))
- (((? symbol? tag) ('@ attr ...) . body)
- `(,tag (@ ,@attr) ,@(map walk body)))
- (((? symbol? tag) . body)
- `(,tag ,@(map walk body)))
- (_ n)))
- (display
- (shtml->html
- (let ((sxml (wrap name (walk `(body ,@(cdr sxml))))))
- ;(pp sxml (current-error-port))
- sxml)))))
-
-(define (wrap name body)
- `(html (head (title ,(string-append "The CHICKEN User's Manual - " name))
- (style (@ (type "text/css"))
- "@import url('manual.css');\n"))
- ,body))
-
-
-;;; Normalize text
-
-(define (clean str)
- (string-translate* str '(("<" . "<") ("&" . "&") ("'" . "'") ("\"" . """))))
-
-
-;;; Read until rx matches
-
-(define (copy-until-match rx in out)
- (let loop ()
- (let ((ln (read-line in)))
- (cond ((string-match rx ln) =>
- (lambda (m)
- (substring ln (string-length (car m))) ) )
- (else
- (display (clean ln) out)
- (newline out)
- (loop))))))
-
-
-;;; Run it
-
-(define *outdir* ".")
-
-(define (main args)
- (let loop ((args args))
- (match args
- (()
- (print "usage: wiki2html [--outdir=DIRECTORY] PAGEFILE ...")
- (exit 1))
- ((files ...)
- (let ((dirs (delete-duplicates (map pathname-directory files) string=?)))
- (set! *manual-pages* (map pathname-strip-directory (append-map directory dirs)))
- (for-each
- (lambda (file)
- (print file)
- (with-input-from-file file
- (lambda ()
- (with-output-to-file (pathname-replace-directory (string-append file ".html") *outdir*)
- (cut convert (pathname-file file))))))
- files))))))
-
-(main (simple-args))
Trap