feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
54
stex/src/dsm.ss
Normal file
54
stex/src/dsm.ss
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
;;; dsm.ss
|
||||
;;;
|
||||
;;; Copyright (c) 1998-2016 R. Kent Dybvig and Oscar Waddell
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
||||
;;; copy of this software and associated documentation files (the "Software"),
|
||||
;;; to deal in the Software without restriction, including without limitation
|
||||
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||
;;; and/or sell copies of the Software, and to permit persons to whom the
|
||||
;;; Software is furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be included in
|
||||
;;; all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
|
||||
;;; authors: R. Kent Dybvig and Oscar Waddell
|
||||
|
||||
(library (dsm) (export define-syntactic-monad) (import (chezscheme))
|
||||
(define-syntax define-syntactic-monad
|
||||
(syntax-rules ()
|
||||
[(_ name formal ...)
|
||||
(andmap identifier? #'(name formal ...))
|
||||
(define-syntax name
|
||||
(lambda (x)
|
||||
(syntax-case x (lambda case-lambda)
|
||||
[(key lambda more-formals . body)
|
||||
(with-implicit (key formal ...)
|
||||
#'(lambda (formal ... . more-formals) . body))]
|
||||
[(key case-lambda (more-formals . body) (... ...))
|
||||
(with-implicit (key formal ...)
|
||||
#'(case-lambda ((formal ... . more-formals) . body) (... ...)))]
|
||||
[(key proc ((x e) (... ...)) arg (... ...))
|
||||
(andmap identifier? #'(x (... ...)))
|
||||
(with-implicit (key formal ...)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (let mem ((ls #'(formal ...)))
|
||||
(and (not (null? ls))
|
||||
(or (free-identifier=? x (car ls))
|
||||
(mem (cdr ls)))))
|
||||
(syntax-error x (format "in syntactic monad ~s, unrecognized identifier" 'name))))
|
||||
#'(x (... ...)))
|
||||
(with-syntax ([(t (... ...)) (generate-temporaries #'(arg (... ...)))])
|
||||
#'(let ((p proc) (x e) (... ...) (t arg) (... ...))
|
||||
(p formal ... t (... ...)))))]
|
||||
[(key proc) #'(key proc ())])))]))
|
||||
)
|
||||
34
stex/src/fixbibtex.ss
Executable file
34
stex/src/fixbibtex.ss
Executable file
|
|
@ -0,0 +1,34 @@
|
|||
#! /usr/bin/scheme --program
|
||||
|
||||
;;; fixbibtex.ss
|
||||
|
||||
;;; fixbibtex removes the line breaks inserted by bibtex, sometimes
|
||||
;;; in the middle of tex commands or urls.
|
||||
|
||||
(import (chezscheme))
|
||||
(unless (= (length (command-line-arguments)) 1)
|
||||
(printf "usage: fixbibtex <filename>\n")
|
||||
(exit 1))
|
||||
(define fn (car (command-line-arguments)))
|
||||
|
||||
(let ([s (call-with-port (open-input-file fn) get-string-all)])
|
||||
(with-input-from-string s
|
||||
(lambda ()
|
||||
(with-output-to-file fn
|
||||
(lambda ()
|
||||
(define (s0 c)
|
||||
(unless (eof-object? c)
|
||||
(case c
|
||||
[(#\\) (write-char c) (s1 (read-char))]
|
||||
[(#\%) (s2 (read-char))]
|
||||
[else (write-char c) (s0 (read-char))])))
|
||||
(define (s1 c) ; seen \
|
||||
(unless (eof-object? c)
|
||||
(write-char c)
|
||||
(s0 (read-char))))
|
||||
(define (s2 c) ; seen %
|
||||
(case c
|
||||
[(#\newline) (s0 (read-char))]
|
||||
[else (write-char #\%) (s0 c)]))
|
||||
(s0 (read-char)))
|
||||
'replace))))
|
||||
1942
stex/src/html-prep.ss
Executable file
1942
stex/src/html-prep.ss
Executable file
File diff suppressed because it is too large
Load diff
469
stex/src/preplib.ss
Normal file
469
stex/src/preplib.ss
Normal file
|
|
@ -0,0 +1,469 @@
|
|||
;;; preplib.ss
|
||||
;;;
|
||||
;;; Copyright (c) 1998-2016 R. Kent Dybvig and Oscar Waddell
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
||||
;;; copy of this software and associated documentation files (the "Software"),
|
||||
;;; to deal in the Software without restriction, including without limitation
|
||||
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||
;;; and/or sell copies of the Software, and to permit persons to whom the
|
||||
;;; Software is furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be included in
|
||||
;;; all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#!chezscheme
|
||||
(library (preplib)
|
||||
(export current-ifile genlab-prefix genlab-counters
|
||||
state-case read-alpha-command read-command
|
||||
command-symbol? read-back-slash read-open-brace read-close-brace
|
||||
read-bracketed-text read-optional-arg push-ifile pop-ifile input-error
|
||||
unexpected-eof unexpected-command genlab read-integer read-def-pattern
|
||||
read-args expand-template suppress-white-space parse-index global-def
|
||||
set-def! get-def conditional? populate-source-directories anchored-filename? find-filename
|
||||
open-input-file)
|
||||
|
||||
(import (except (chezscheme) open-input-file))
|
||||
|
||||
(define current-ifile (make-parameter #f))
|
||||
(define genlab-prefix (make-parameter #f))
|
||||
(define genlab-counters (make-parameter #f))
|
||||
|
||||
(define-syntax state-case
|
||||
(syntax-rules ()
|
||||
[(_ (var exp) c1 c2 ...)
|
||||
(identifier? (syntax var))
|
||||
(let ([var exp]) (state-case-help var c1 c2 ...))]))
|
||||
|
||||
(define-syntax state-case-help
|
||||
(syntax-rules (else)
|
||||
[(_ var (else e1 e2 ...)) (begin e1 e2 ...)]
|
||||
[(_ var ((k ...) e1 e2 ...) c ...)
|
||||
(if (or (state-case-test var k) ...)
|
||||
(begin e1 e2 ...)
|
||||
(state-case-help var c ...))]))
|
||||
|
||||
(define-syntax state-case-test
|
||||
(syntax-rules (eof -)
|
||||
[(_ var eof)
|
||||
(eof-object? var)]
|
||||
[(_ var (char1 - char2))
|
||||
(and (char? var) (char<=? char1 var char2))]
|
||||
[(_ var char)
|
||||
(and (char? var) (char=? var char))]))
|
||||
|
||||
; doesn't allow @ even in document class or style files. this won't
|
||||
; work for us anyway because we use character-based rather than
|
||||
; token-based substitution, so macros that insert @ symbols into
|
||||
; their output won't work outside of the original context
|
||||
(define read-alpha-command
|
||||
; return symbol representing command; assume \ already seen and scan
|
||||
; maximal string of alphabetic chars, e.g., \scheme => symbol scheme
|
||||
; returns || when no command is recognized
|
||||
(let ([buf (open-output-string)])
|
||||
(lambda (ip)
|
||||
(state-case (c (peek-char ip))
|
||||
[((#\a - #\z) (#\A - #\Z))
|
||||
(let loop ()
|
||||
(write-char (read-char ip) buf)
|
||||
(state-case (c (peek-char ip))
|
||||
[((#\a - #\z) (#\A - #\Z)) (loop)]
|
||||
[else (string->symbol (get-output-string buf))]))]
|
||||
[else '||]))))
|
||||
|
||||
(define read-command
|
||||
; like read-alpha-command, but allows single nonalphabetic char
|
||||
; commands, e.g., \' => |'|
|
||||
(let ([buf (open-output-string)])
|
||||
(lambda (ip)
|
||||
(state-case (c (peek-char ip))
|
||||
[((#\a - #\z) (#\A - #\Z))
|
||||
(let loop ()
|
||||
(write-char (read-char ip) buf)
|
||||
(state-case (c (peek-char ip))
|
||||
[((#\a - #\z) (#\A - #\Z)) (loop)]
|
||||
[else (string->symbol (get-output-string buf))]))]
|
||||
[(eof) '||]
|
||||
[else (read-char ip) (string->symbol (string c))]))))
|
||||
|
||||
(define command-symbol?
|
||||
(lambda (cmd) ; true iff command is one character, nonalpabetic
|
||||
(let ([s (symbol->string cmd)])
|
||||
(and (fx= (string-length s) 1)
|
||||
(state-case (c (string-ref s 0))
|
||||
[((#\a - #\z) (#\A - #\Z)) #f]
|
||||
[else #t])))))
|
||||
|
||||
(define read-back-slash
|
||||
(lambda (ip)
|
||||
(if (eqv? (peek-char ip) #\\)
|
||||
(read-char ip)
|
||||
(input-error "back slash expected"))))
|
||||
|
||||
(define read-open-brace
|
||||
(lambda (ip)
|
||||
(if (eqv? (peek-char ip) #\{)
|
||||
(read-char ip)
|
||||
(input-error "open brace expected"))))
|
||||
|
||||
(define read-close-brace
|
||||
(lambda (ip)
|
||||
(if (eqv? (peek-char ip) #\})
|
||||
(read-char ip)
|
||||
(input-error "close brace expected"))))
|
||||
|
||||
(define read-bracketed-text
|
||||
(let ([buf (open-output-string)])
|
||||
(case-lambda
|
||||
[(ip) (read-open-brace ip) (read-bracketed-text ip 1)]
|
||||
[(ip depth)
|
||||
(state-case (c (read-char ip))
|
||||
[(#\}) (if (= depth 1)
|
||||
(get-output-string buf)
|
||||
(begin (write-char #\} buf)
|
||||
(read-bracketed-text ip (- depth 1))))]
|
||||
[(#\{) (write-char #\{ buf) (read-bracketed-text ip (+ depth 1))]
|
||||
[(eof) (input-error "file ended within bracketed text")]
|
||||
[else (write-char c buf) (read-bracketed-text ip depth)])])))
|
||||
|
||||
(define read-optional-arg
|
||||
(let ([buf (open-output-string)])
|
||||
(lambda (ip)
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\[)
|
||||
(read-char ip)
|
||||
(let loop ([depth 0])
|
||||
(state-case (c (read-char ip))
|
||||
[(#\]) (if (= depth 0)
|
||||
(get-output-string buf)
|
||||
(begin (write-char c buf) (loop depth)))]
|
||||
[(#\{) (write-char c buf) (loop (+ depth 1))]
|
||||
[(#\}) (write-char c buf) (loop (- depth 1))]
|
||||
[(eof) (input-error "file ended within optional argument")]
|
||||
[else (write-char c buf) (loop depth)]))]
|
||||
[else #f]))))
|
||||
|
||||
(define push-ifile
|
||||
(lambda (ip ifiles)
|
||||
(current-ifile ip)
|
||||
(cons ip ifiles)))
|
||||
|
||||
(define pop-ifile
|
||||
(lambda (ifiles)
|
||||
(let ([ifiles (cdr ifiles)])
|
||||
(current-ifile (and (not (null? ifiles)) (car ifiles)))
|
||||
ifiles)))
|
||||
|
||||
(define input-error
|
||||
(lambda (msg . args)
|
||||
(define file-coordinates
|
||||
(lambda (ip)
|
||||
(let ([n (file-position ip)])
|
||||
(file-position ip 0)
|
||||
(let f ([n n] [line 1] [char 1] [return? #f])
|
||||
(if (= n 0)
|
||||
(values line char)
|
||||
(state-case (c (read-char ip))
|
||||
[(#\newline) (f (- n 1) (if return? line (+ line 1)) 1 #f)]
|
||||
[(#\return) (f (- n 1) (+ line 1) 1 #t)]
|
||||
[(eof) (values line char)]
|
||||
[else (f (- n 1) line (+ char 1) #f)]))))))
|
||||
(let ([ip (current-ifile)])
|
||||
(call-with-values (lambda () (file-coordinates ip))
|
||||
(lambda (line char)
|
||||
(errorf #f "~a on line ~d, character ~d of ~s"
|
||||
(apply format msg args)
|
||||
line char
|
||||
(port-name ip)))))))
|
||||
|
||||
(define unexpected-eof
|
||||
(lambda (where)
|
||||
(input-error "unexpected end-of-input ~a" where)))
|
||||
|
||||
(define unexpected-command
|
||||
(lambda (cmd)
|
||||
(input-error "unexpected command '\\~a'" cmd)))
|
||||
|
||||
(define genlab
|
||||
(lambda ()
|
||||
(define next-count
|
||||
(lambda (fn)
|
||||
(cond
|
||||
[(assoc fn (genlab-counters)) =>
|
||||
(lambda (a)
|
||||
(let ([n (+ (cdr a) 1)])
|
||||
(set-cdr! a n)
|
||||
n))]
|
||||
[else
|
||||
(genlab-counters (cons (cons fn 0) (genlab-counters)))
|
||||
0])))
|
||||
(let ([name (path-root (port-name (current-ifile)))])
|
||||
(string->symbol
|
||||
(format "~a:~a~d" name (genlab-prefix) (next-count name))))))
|
||||
|
||||
(define read-integer ; return integer or #f if none found
|
||||
(lambda (ip)
|
||||
(string->number
|
||||
(list->string
|
||||
(let loop ()
|
||||
(state-case (c (peek-char ip))
|
||||
[((#\0 - #\9)) (read-char ip) (cons c (loop))]
|
||||
[else '()]))))))
|
||||
|
||||
(define read-def-pattern
|
||||
(lambda (ip)
|
||||
(let loop ([i 1])
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\{) '()]
|
||||
[(#\#)
|
||||
(read-char ip)
|
||||
(state-case (c1 (peek-char ip))
|
||||
[(#\#) (read-char ip) (list* c1 c (loop i))]
|
||||
[else
|
||||
(let ([n (read-integer ip)])
|
||||
(if (eq? n i)
|
||||
(cons n (loop (+ i 1)))
|
||||
(input-error "invalid \\def argument specifier")))])]
|
||||
[(eof) (unexpected-eof "after \\def")]
|
||||
[else (read-char ip) (cons c (loop i))]))))
|
||||
|
||||
(define read-args
|
||||
(lambda (ip pattern cmd)
|
||||
(define read-arg
|
||||
(lambda (ip cmd)
|
||||
(state-case (c (read-char ip))
|
||||
[(#\\) (format "\\~a" (read-command ip))]
|
||||
[(#\{) (read-bracketed-text ip 1)]
|
||||
[(eof) (unexpected-eof (format "reading ~a arguments" cmd))]
|
||||
[else (string c)])))
|
||||
(let loop ([pattern pattern])
|
||||
(if (null? pattern)
|
||||
'()
|
||||
(let ([x (car pattern)])
|
||||
(cond
|
||||
[(integer? x)
|
||||
(let ([arg (read-arg ip cmd)])
|
||||
(cons arg (loop (cdr pattern))))]
|
||||
[(string? x)
|
||||
(let ([arg (read-optional-arg ip)])
|
||||
(cons (or arg x) (loop (cdr pattern))))]
|
||||
[(eqv? x #\space)
|
||||
(suppress-white-space ip)
|
||||
(loop (cdr pattern))]
|
||||
[(eqv? (read-char ip) x) (loop (cdr pattern))]
|
||||
[else (input-error "~a use does not match pattern" cmd)]))))))
|
||||
|
||||
(define expand-template
|
||||
(let ([buf (open-output-string)])
|
||||
(lambda (template args cmd)
|
||||
(let ([sip (open-input-string template)])
|
||||
(let loop ()
|
||||
(state-case (c (read-char sip))
|
||||
[(#\\)
|
||||
(write-char c buf)
|
||||
(state-case (c (peek-char sip))
|
||||
[(#\#) (read-char sip) (write-char c buf)]
|
||||
[else (void)])
|
||||
(loop)]
|
||||
[(#\#)
|
||||
(state-case (c (peek-char sip))
|
||||
[(#\#) (read-char sip) (write-char #\# buf)]
|
||||
[else (let ([n (read-integer sip)])
|
||||
(let ([n (and n (- n 1))])
|
||||
(unless (and n (< -1 n (length args)))
|
||||
(input-error "invalid argument specifier in ~a template" cmd))
|
||||
(display (list-ref args n) buf)))])
|
||||
(loop)]
|
||||
[(eof) (get-output-string buf)]
|
||||
[else (write-char c buf) (loop)]))))))
|
||||
|
||||
(define (suppress-white-space ip)
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\space #\tab #\newline) (read-char ip) (suppress-white-space ip)]
|
||||
[(#\%)
|
||||
(read-char ip)
|
||||
(let loop ()
|
||||
(state-case (c (read-char ip))
|
||||
[(eof #\newline) (void)]
|
||||
[else (loop)]))]
|
||||
[else (void)]))
|
||||
|
||||
(define parse-index
|
||||
(let ([buf (open-output-string)])
|
||||
; if proper-nesting? is true, the characters ", @, !, and | lose their
|
||||
; special meaning within nested groups.
|
||||
(lambda (ip proper-nesting?)
|
||||
(define nested-group
|
||||
(lambda (depth)
|
||||
(state-case (c (read-char ip))
|
||||
[(#\{)
|
||||
(write-char c buf)
|
||||
(nested-group (+ depth 1))]
|
||||
[(#\})
|
||||
(write-char c buf)
|
||||
(unless (= depth 0) (nested-group (- depth 1)))]
|
||||
[(#\@ #\! #\|)
|
||||
(if proper-nesting?
|
||||
(write-char c buf)
|
||||
(input-error "unquoted ~c within nested group in index entry" c))
|
||||
(nested-group depth)]
|
||||
[(#\")
|
||||
(if proper-nesting?
|
||||
(write-char c buf)
|
||||
(state-case (c (read-char ip))
|
||||
[(eof) (input-error "file ended within \\index{}")]
|
||||
[else (write-char c buf)]))
|
||||
(nested-group depth)]
|
||||
[(#\")
|
||||
(write-char c buf)
|
||||
(unless proper-nesting?
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\") (read-char ip) (write-char c buf)]
|
||||
[else (void)]))
|
||||
(nested-group depth)]
|
||||
[else (write-char c buf) (nested-group depth)])))
|
||||
(define before@
|
||||
(lambda (ls)
|
||||
; ls is list of levels seen so far
|
||||
(state-case (c (read-char ip))
|
||||
[(#\})
|
||||
(let ([s (get-output-string buf)])
|
||||
(values (reverse (cons (cons #f s) ls)) ""))]
|
||||
[(#\{)
|
||||
(write-char c buf)
|
||||
(nested-group 0)
|
||||
(before@ ls)]
|
||||
[(#\|)
|
||||
(let ([s (get-output-string buf)])
|
||||
(values (reverse (cons (cons #f s) ls))
|
||||
(read-bracketed-text ip 1)))]
|
||||
[(#\@) (after@ ls (get-output-string buf))]
|
||||
[(#\!)
|
||||
(let ([s (get-output-string buf)])
|
||||
(before@ (cons (cons #f s) ls)))]
|
||||
[(#\")
|
||||
(state-case (c (read-char ip))
|
||||
[(eof) (input-error "file ended within \\index{}")]
|
||||
[else
|
||||
(write-char c buf)
|
||||
(before@ ls)])]
|
||||
[(#\\)
|
||||
(write-char c buf)
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\") (read-char ip) (write-char c buf)]
|
||||
[else (void)])
|
||||
(before@ ls)]
|
||||
[(eof) (input-error "file ended within \\index{}")]
|
||||
[else (write-char c buf) (before@ ls)])))
|
||||
(define after@
|
||||
(lambda (ls sort-key)
|
||||
; ls is list of levels seen so far
|
||||
; sort-key is sort key part of current level
|
||||
(state-case (c (read-char ip))
|
||||
[(#\})
|
||||
(let ([s (get-output-string buf)])
|
||||
(values (reverse (cons (cons sort-key s) ls)) ""))]
|
||||
[(#\{)
|
||||
(write-char c buf)
|
||||
(nested-group 0)
|
||||
(after@ ls sort-key)]
|
||||
[(#\|)
|
||||
(let ([s (get-output-string buf)])
|
||||
(values (reverse (cons (cons sort-key s) ls))
|
||||
(read-bracketed-text ip 1)))]
|
||||
[(#\@) (input-error "at sign seen after at sign in \\index{}")]
|
||||
[(#\!)
|
||||
(let ([s (get-output-string buf)])
|
||||
(before@ (cons (cons sort-key s) ls)))]
|
||||
[(#\")
|
||||
(state-case (c (read-char ip))
|
||||
[(eof) (input-error "file ended within \\index{}")]
|
||||
[else
|
||||
; leave out quote; reinsert later
|
||||
(write-char c buf)
|
||||
(after@ ls sort-key)])]
|
||||
[(#\\)
|
||||
(write-char c buf)
|
||||
(state-case (c (peek-char ip))
|
||||
[(#\") (read-char ip) (write-char c buf)]
|
||||
[else (void)])
|
||||
(after@ ls sort-key)]
|
||||
[(eof) (input-error "file ended within \\index{}")]
|
||||
[else (write-char c buf) (after@ ls sort-key)])))
|
||||
(before@ '()))))
|
||||
|
||||
;; support for definitions
|
||||
(define-syntax global-def
|
||||
(syntax-rules ()
|
||||
[(_ name expr)
|
||||
(set-def! 'name '() #f expr)]))
|
||||
|
||||
(define set-def!
|
||||
(lambda (cmd env conditional? proc)
|
||||
(if (null? env)
|
||||
(putprop cmd 'def (cons conditional? proc))
|
||||
(set-car! env (cons (list* cmd conditional? proc) (car env))))))
|
||||
|
||||
(module (get-def conditional?)
|
||||
(define lookup-env
|
||||
(lambda (cmd env)
|
||||
(cond
|
||||
[(null? env) (getprop cmd 'def '(#f . #f))]
|
||||
[(assq cmd (car env)) => cdr]
|
||||
[else (lookup-env cmd (cdr env))])))
|
||||
|
||||
(define get-def
|
||||
(lambda (cmd env)
|
||||
(cdr (lookup-env cmd env))))
|
||||
|
||||
(define conditional?
|
||||
(lambda (cmd env)
|
||||
(car (lookup-env cmd env)))))
|
||||
|
||||
(define (populate-source-directories)
|
||||
(let ([inputs (or (getenv "TEXINPUTS") "")])
|
||||
(unless (equal? inputs "")
|
||||
(let ([ip (open-input-string inputs)] [op (open-output-string)])
|
||||
(source-directories
|
||||
(let loop ([ls '()])
|
||||
(let ([c (read-char ip)])
|
||||
(case c
|
||||
[(#\:) (loop (cons (get-output-string op) ls))]
|
||||
[(#!eof) (append (reverse ls) (source-directories))]
|
||||
[else (write-char c op) (loop ls)]))))))))
|
||||
|
||||
(define anchored-filename?
|
||||
(lambda (s)
|
||||
(and (> (string-length s) 0)
|
||||
(memv (string-ref s 0) '(#\/ #\.)))))
|
||||
|
||||
(define find-filename
|
||||
(lambda (fn)
|
||||
(if (anchored-filename? fn)
|
||||
fn
|
||||
(ormap
|
||||
(lambda (p)
|
||||
(let ([path (string-append p "/" fn)])
|
||||
(and (file-exists? path) path)))
|
||||
(source-directories)))))
|
||||
|
||||
(define open-input-file
|
||||
(lambda (fn . flags)
|
||||
(import scheme)
|
||||
(let ([path (find-filename fn)])
|
||||
(unless path
|
||||
(errorf #f
|
||||
(if (anchored-filename? fn)
|
||||
"unable to find file ~a"
|
||||
"unable to find file ~a in search path")
|
||||
fn))
|
||||
(apply open-input-file path flags))))
|
||||
)
|
||||
1166
stex/src/scheme-prep.ss
Executable file
1166
stex/src/scheme-prep.ss
Executable file
File diff suppressed because it is too large
Load diff
710
stex/src/script.ss
Normal file
710
stex/src/script.ss
Normal file
|
|
@ -0,0 +1,710 @@
|
|||
;;; script.ss
|
||||
;;;
|
||||
;;; Copyright (c) 2005 R. Kent Dybvig
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
||||
;;; copy of this software and associated documentation files (the "Software"),
|
||||
;;; to deal in the Software without restriction, including without limitation
|
||||
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||
;;; and/or sell copies of the Software, and to permit persons to whom the
|
||||
;;; Software is furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be included in
|
||||
;;; all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#!chezscheme
|
||||
(library (script)
|
||||
(export command-line-case run-script)
|
||||
(import (chezscheme))
|
||||
|
||||
#|
|
||||
|
||||
(command-line-case command-line [(<cmdspec>) <body>]*)
|
||||
|
||||
<cmdspec> -> (keyword <kwd> <required-arg>* <possible-action>]) <cmdspec>
|
||||
| (flags [<kwd> <flag-arg>* <possible-action>]*) <cmdspec>
|
||||
| <argspec>
|
||||
<possible-action> -> <empty> | $ <action>
|
||||
<flag-arg> -> <var> | (<type> <var>) | (<type> <var> <default>)
|
||||
<argspec> -> <required-arg>* <optional-arg>*
|
||||
| <required-arg>* <optional-arg>* <required-arg> ...
|
||||
<required-arg> -> <var> | (<type> <var>)
|
||||
<optional-arg> -> (optional <var>)
|
||||
| (optional <type> <var>)
|
||||
| (optional <type> <var> <default>)
|
||||
<kwd> -> <id> | (<id>+)
|
||||
<var> -> <id>
|
||||
<type> -> <id>
|
||||
<action> -> <expr>
|
||||
<default> -> <expr>
|
||||
|
||||
Each <var> must be unique.
|
||||
|
||||
If any <type> is not specified, it defaults to string.
|
||||
|
||||
If any <default> is not specified, it defaults to #f. Each <default>
|
||||
is scoped outside of the command-line-case form.
|
||||
|
||||
Command-line arguments are processed from left to right.
|
||||
|
||||
Command-line elements must appear in the order specified by <cmdspec>,
|
||||
except that each the flags in a single flags section may appear in
|
||||
any order and any flag may occur more than once.
|
||||
|
||||
For kewyword and flag clauses, the value of the <action>, if specified,
|
||||
is evaluated for effect. Each <action> is scoped where each of the <var>s
|
||||
is visible and each <var>'s current value is based on the specified or
|
||||
implicit defaults and the arguments seen so far.
|
||||
|
||||
If a flag occurs more than once on a command line, the final value of
|
||||
each corresponding <var> is its last specified value.
|
||||
|
||||
If <type> is not string, the procedure string-><type> is applied to the
|
||||
string argument to cast the string argument the actual value; it should
|
||||
return #f if the cast fails, in which case the clause doesn't match.
|
||||
A string-><type> routine should not cause side effects since it may be
|
||||
called even for clauses that don't match.
|
||||
|
||||
For flag clauses, variable ?id, where <kwd> = id or <kwd> = (id id1 ...),
|
||||
is bound to #t if the argument is specified at least once, otherwise #f.
|
||||
|
||||
Within each <body>, the variable usage is bound to a thunk that prints
|
||||
usage information. usage information is also printed if a command
|
||||
line cannot be parsed to fit any of the clauses.
|
||||
|
||||
consider:
|
||||
* instead of one keyword, have multiple keywords ALL of which must be
|
||||
provided in some order. use syntax (all (keyword ...) ...), and use
|
||||
(some (keyword ...) ...) instead of current "flags" syntax.
|
||||
|
||||
* add a prefix before <kwd> in flags section to allow multiple
|
||||
occurrences of the given flag and listification of the flag
|
||||
arguments
|
||||
|
||||
* option to print more verbose information when certain matches fail,
|
||||
for example, when a keyword or flag argument requires more additional
|
||||
arguments than are provided.
|
||||
|
||||
* allowing optional arguments after keywords and flags. leads to
|
||||
ambiguity in some cases.
|
||||
|
||||
Testing:
|
||||
|
||||
scheme
|
||||
(import (script))
|
||||
(define (exit . args) (void))
|
||||
|
||||
> (command-line-case '("a" "-q" "-v" "-v" "-b" "c")
|
||||
[((flags [-b c] [-q $ (write-char #\q)] [-v $ (write-char #\v)]))
|
||||
(list ?-b c)])
|
||||
qvv(#t "c")
|
||||
|
||||
> (let ()
|
||||
(define (bar cl)
|
||||
(command-line-case cl
|
||||
[((keyword --foo (number n))
|
||||
(flags [-b (number b)] [-q $ (write-char #\q)] [-v $ (write-char #\v)]))
|
||||
(pretty-print (list ?-b b))]))
|
||||
(bar '("a" "--foo" "32" "-q" "-v" "-v" "-b" "45"))
|
||||
(bar '("a" "--foo" "foo" "-q" "-v" "-v" "-b" "45"))
|
||||
(bar '("a" "--foo" "32" "-q" "-v" "-v" "-b" "b")))
|
||||
qvv(#t 45)
|
||||
usage: a --foo n [ -b b ] [ -q ] [ -v ]
|
||||
usage: a --foo n [ -b b ] [ -q ] [ -v ]
|
||||
|
||||
(define (foo cl)
|
||||
(define compact? #t)
|
||||
(define (register-boot-file x) (printf "registering boot file ~s\n" x))
|
||||
(define (register-heap-file x) (printf "registering boot file ~s\n" x))
|
||||
(command-line-case cl
|
||||
[((keyword --version))
|
||||
(print-version)]
|
||||
[((keyword --help (number helplevel)))
|
||||
(printf "here's your help: ~s\n" helplevel)]
|
||||
[((keyword --help))
|
||||
(print-help)]
|
||||
[((flags [(--boot -b) bootpath $ (register-boot-file bootpath)]
|
||||
[(--compact -c) $ (set! compact? (not compact?))]
|
||||
[(--heap -h) heappath $ (register-heap-file heappath)]
|
||||
[(--quiet -q)]
|
||||
[(--saveheap -s) (number level 0) savepath]
|
||||
[--verbose])
|
||||
(flags [--])
|
||||
a (optional b) (optional number c 666) (number d) ...)
|
||||
(let-syntax ([pr (syntax-rules ()
|
||||
[(_ x ...) (begin (printf " ~s = ~s\n" 'x x) ...)])])
|
||||
(pr ?--boot bootpath ?--compact ?--heap heappath ?--quiet
|
||||
?--saveheap level savepath ?--verbose ?--
|
||||
compact?
|
||||
a b c d))]))
|
||||
|
||||
> (foo '("/usr/local/bin/foo" "--help" "3"))
|
||||
here's your help: 3
|
||||
> (foo '("/usr/local/bin/foo" "aaa"))
|
||||
?--boot = #f
|
||||
bootpath = #f
|
||||
?--compact = #f
|
||||
?--heap = #f
|
||||
heappath = #f
|
||||
?--quiet = #f
|
||||
?--saveheap = #f
|
||||
level = 0
|
||||
savepath = #f
|
||||
?--verbose = #f
|
||||
?-- = #f
|
||||
compact? = #t
|
||||
a = "aaa"
|
||||
b = #f
|
||||
c = 666
|
||||
d = ()
|
||||
> (foo '("/usr/local/bin/foo" "aaa" "bbb"))
|
||||
?--boot = #f
|
||||
bootpath = #f
|
||||
?--compact = #f
|
||||
?--heap = #f
|
||||
heappath = #f
|
||||
?--quiet = #f
|
||||
?--saveheap = #f
|
||||
level = 0
|
||||
savepath = #f
|
||||
?--verbose = #f
|
||||
?-- = #f
|
||||
compact? = #t
|
||||
a = "aaa"
|
||||
b = "bbb"
|
||||
c = 666
|
||||
d = ()
|
||||
> (foo '("/usr/local/bin/foo" "aaa" "bbb" "#xccc"))
|
||||
?--boot = #f
|
||||
bootpath = #f
|
||||
?--compact = #f
|
||||
?--heap = #f
|
||||
heappath = #f
|
||||
?--quiet = #f
|
||||
?--saveheap = #f
|
||||
level = 0
|
||||
savepath = #f
|
||||
?--verbose = #f
|
||||
?-- = #f
|
||||
compact? = #t
|
||||
a = "aaa"
|
||||
b = "bbb"
|
||||
c = 3276
|
||||
d = ()
|
||||
> (foo '("/usr/local/bin/foo" "aaa" "bbb" "#xccc" "3" "4" "5"))
|
||||
?--boot = #f
|
||||
bootpath = #f
|
||||
?--compact = #f
|
||||
?--heap = #f
|
||||
heappath = #f
|
||||
?--quiet = #f
|
||||
?--saveheap = #f
|
||||
level = 0
|
||||
savepath = #f
|
||||
?--verbose = #f
|
||||
?-- = #f
|
||||
compact? = #t
|
||||
a = "aaa"
|
||||
b = "bbb"
|
||||
c = 3276
|
||||
d = (3 4 5)
|
||||
> (foo '("/usr/local/bin/foo" "aaa" "bbb" "ccc"))
|
||||
usage: foo --version
|
||||
foo --help helplevel
|
||||
foo --help
|
||||
foo [ --boot|-b bootpath ] [ --compact|-c ] [ --heap|-h heappath ] [ --quiet|-q ] [ --saveheap|-s level savepath ] [ --verbose ] [ -- ] a [ b ] [ c ] d ...
|
||||
> (foo '("/usr/local/bin/foo" "aaa" "bbb" "#xccc" "3" "4" "5" "ddd"))
|
||||
usage: foo --version
|
||||
foo --help helplevel
|
||||
foo --help
|
||||
foo [ --boot|-b bootpath ] [ --compact|-c ] [ --heap|-h heappath ] [ --quiet|-q ] [ --saveheap|-s level savepath ] [ --verbose ] [ -- ] a [ b ] [ c ] d ...
|
||||
> (foo '("/usr/local/bin/foo" "-q" "--boot" "foo.boot" "aaa"))
|
||||
registering boot file "foo.boot"
|
||||
?--boot = #t
|
||||
bootpath = "foo.boot"
|
||||
?--compact = #f
|
||||
?--heap = #f
|
||||
heappath = #f
|
||||
?--quiet = #t
|
||||
?--saveheap = #f
|
||||
level = 0
|
||||
savepath = #f
|
||||
?--verbose = #f
|
||||
?-- = #f
|
||||
compact? = #t
|
||||
a = "aaa"
|
||||
b = #f
|
||||
c = 666
|
||||
d = ()
|
||||
> (foo '("/usr/local/bin/foo" "-q" "--boot" "foo.boot" "-b"
|
||||
"--heap" "-h" "foo.heap" "-s" "7" "foo7.heap" "-c" "-c" "-c"
|
||||
"--verbose" "aaa"))
|
||||
registering boot file "foo.boot"
|
||||
registering boot file "--heap"
|
||||
registering boot file "foo.heap"
|
||||
?--boot = #t
|
||||
bootpath = "--heap"
|
||||
?--compact = #t
|
||||
?--heap = #t
|
||||
heappath = "foo.heap"
|
||||
?--quiet = #t
|
||||
?--saveheap = #t
|
||||
level = 7
|
||||
savepath = "foo7.heap"
|
||||
?--verbose = #t
|
||||
?-- = #f
|
||||
compact? = #f
|
||||
a = "aaa"
|
||||
b = #f
|
||||
c = 666
|
||||
d = ()
|
||||
|
||||
(command-line-case (cons "/usr/local/bin/foo" (command-line-arguments))
|
||||
[((keyword --build ifn)
|
||||
(flags [--verify] [(--output -o) (string ofn "a.out")])
|
||||
lib* ...)
|
||||
---]
|
||||
[((keyword (--query -q) ifn))
|
||||
---]
|
||||
[((flags [(--verify -v)] [(--output -o) (string ofn "a.out")])
|
||||
(string x*) ...)
|
||||
---]
|
||||
[((flags [(--verify -v)] [(--output -o) ofn])
|
||||
(flags [--])
|
||||
x* ...)
|
||||
---]
|
||||
[(x (optional integer y 0))
|
||||
---]
|
||||
[(x (optional integer y) x* ...)
|
||||
---]
|
||||
)
|
||||
|
||||
|#
|
||||
|
||||
(define-syntax command-line-case
|
||||
(lambda (x)
|
||||
;; Internal representation:
|
||||
;; ({ keyword | flags }* reqarg* optarg* restarg?)
|
||||
;; kwd's are strings
|
||||
;; vars's are syntax objects (identifiers)
|
||||
;; defaults are syntax objects
|
||||
;; actions are syntax objects or #f
|
||||
(define-record pkeyword ((immutable kwd*)
|
||||
(immutable reqarg*)
|
||||
(immutable action)))
|
||||
(define-record pflags ((immutable flag*)))
|
||||
(define-record pflag ((immutable kwd*)
|
||||
(immutable ?var)
|
||||
(immutable optarg*)
|
||||
(immutable action)))
|
||||
(define-record preqarg ((immutable type)
|
||||
(immutable var)))
|
||||
(define-record poptarg ((immutable type)
|
||||
(immutable var)
|
||||
(immutable default)))
|
||||
(define-record prestarg ((immutable reqarg)))
|
||||
(define-record pend ())
|
||||
|
||||
(module (parse-cmdspec)
|
||||
(define (parse-cmdspec cmdspec)
|
||||
(unless (syntax-case cmdspec () [(x ...) #t] [_ #f])
|
||||
(syntax-error cmdspec "improper argument declaration list"))
|
||||
(let parse-cmdspec ([cmdspec cmdspec])
|
||||
(syntax-case cmdspec (keyword flags $)
|
||||
[((keyword kwd reqarg ... $ actionexpr) . cmdspec)
|
||||
(cons (make-pkeyword
|
||||
(map id->string (parse-kwd #'kwd))
|
||||
(map parse-reqarg
|
||||
(syntax->list
|
||||
#'(reqarg ...)))
|
||||
#'actionexpr)
|
||||
(parse-cmdspec #'cmdspec))]
|
||||
[((keyword kwd reqarg ...) . cmdspec)
|
||||
(cons (make-pkeyword
|
||||
(map id->string (parse-kwd #'kwd))
|
||||
(map parse-reqarg
|
||||
(syntax->list
|
||||
#'(reqarg ...)))
|
||||
#f)
|
||||
(parse-cmdspec #'cmdspec))]
|
||||
[((keyword . ignore1) . ignore2)
|
||||
(syntax-error (syntax-case cmdspec () [(x . r) #'x])
|
||||
"invalid keyword declaration")]
|
||||
[((flags flagdecl ...) . cmdspec)
|
||||
(cons (make-pflags
|
||||
(map (lambda (flagdecl)
|
||||
(syntax-case flagdecl ($)
|
||||
[(kwd flagarg ... $ actionexpr)
|
||||
(let ([kwd* (parse-kwd #'kwd)])
|
||||
(make-pflag
|
||||
(map id->string kwd*)
|
||||
(make-?var (car kwd*))
|
||||
(map parse-flagarg
|
||||
(syntax->list #'(flagarg ...)))
|
||||
#'actionexpr))]
|
||||
[(kwd flagarg ...)
|
||||
(let ([kwd* (parse-kwd #'kwd)])
|
||||
(make-pflag
|
||||
(map id->string kwd*)
|
||||
(make-?var (car kwd*))
|
||||
(map parse-flagarg
|
||||
(syntax->list #'(flagarg ...)))
|
||||
#f))]
|
||||
[_ (syntax-error flagdecl
|
||||
"invalid flag declaration")]))
|
||||
(syntax->list #'(flagdecl ...))))
|
||||
(parse-cmdspec #'cmdspec))]
|
||||
[((flags . ignore1) . ignore2)
|
||||
(syntax-error (syntax-case cmdspec () [(x . r) #'x])
|
||||
"invalid flags declaration")]
|
||||
[argspec (parse-argspec #'argspec)])))
|
||||
(define (parse-kwd kwd)
|
||||
(syntax-case kwd ()
|
||||
[id (identifier? #'id) (list #'id)]
|
||||
[(id1 id2 ...) (syntax->list #'(id1 id2 ...))]
|
||||
[_ (syntax-error kwd "invalid kwd specifier")]))
|
||||
(define (parse-argspec argspec)
|
||||
(define (dots? x)
|
||||
(and (identifier? x)
|
||||
(literal-identifier=? x #'(... ...))))
|
||||
(syntax-case argspec ()
|
||||
[() (list (make-pend))]
|
||||
[(reqarg dots)
|
||||
(dots? #'dots)
|
||||
(list (make-prestarg (parse-reqarg #'reqarg)))]
|
||||
[(arg . argspec)
|
||||
(cons (parse-arg #'arg) (parse-argspec #'argspec))]
|
||||
[(x . r) (syntax-error #'x "invalid argument declaration")]))
|
||||
(define (parse-arg arg)
|
||||
(syntax-case arg (optional)
|
||||
[(optional . stuff) (parse-optarg arg)]
|
||||
[_ (parse-reqarg arg)]))
|
||||
(define (parse-reqarg reqarg)
|
||||
(syntax-case reqarg ()
|
||||
[var (identifier? #'var) (make-preqarg #'string #'var)]
|
||||
[(type var)
|
||||
(and (identifier? #'type) (identifier? #'var))
|
||||
(make-preqarg #'type #'var)]
|
||||
[x (syntax-error reqarg "invalid argument specifier")]))
|
||||
(define (parse-optarg optarg)
|
||||
(syntax-case optarg (optional)
|
||||
[(optional var)
|
||||
(identifier? #'var)
|
||||
(make-poptarg #'string #'var #'#f)]
|
||||
[(optional type var)
|
||||
(and (identifier? #'type) (identifier? #'var))
|
||||
(make-poptarg #'type #'var #'#f)]
|
||||
[(optional type var default)
|
||||
(and (identifier? #'type) (identifier? #'var))
|
||||
(make-poptarg #'type #'var #'default)]
|
||||
[x (syntax-error optarg "invalid optional argument specifier")]))
|
||||
(define (parse-flagarg flagarg)
|
||||
(syntax-case flagarg ()
|
||||
[var (identifier? #'var) (make-poptarg #'string #'var #'#f)]
|
||||
[(type var)
|
||||
(and (identifier? #'type) (identifier? #'var))
|
||||
(make-poptarg #'type #'var #'#f)]
|
||||
[(type var default)
|
||||
(and (identifier? #'type) (identifier? #'var))
|
||||
(make-poptarg #'type #'var #'default)]
|
||||
[x (syntax-error flagarg "invalid flag argument specifier")]))
|
||||
(define (id->string x) (symbol->string (syntax-object->datum x)))
|
||||
(define (make-?var x)
|
||||
(datum->syntax-object x
|
||||
(string->symbol (format "?~a" (id->string x))))))
|
||||
|
||||
(module (usage-printer)
|
||||
(define (usage-printer cmdspec+)
|
||||
#`(lambda (cl)
|
||||
(let ([who (path-last (car cl))])
|
||||
#,(usage-cmdspec "usage:" (car cmdspec+))
|
||||
#,@(map (lambda (cmdspec) (usage-cmdspec " " cmdspec)) (cdr cmdspec+)))))
|
||||
(define (usage-cmdspec leader cmdspec)
|
||||
(define cmdspec-printer
|
||||
(lambda (s*)
|
||||
#`(printf #,(format "~a ~~a~~a\n" leader) who #,(apply string-append s*))))
|
||||
(let-values ([(s* flag**) (usage-cmdspec-helper #t cmdspec)])
|
||||
(assert (null? flag**))
|
||||
(if (< (apply + (string-length leader) (map string-length s*)) 80)
|
||||
(cmdspec-printer s*)
|
||||
(let-values ([(s* flag**) (usage-cmdspec-helper #f cmdspec)])
|
||||
(fold-left
|
||||
(lambda (expr flag*)
|
||||
(let ([flag-header (car flag*)] [flag* (cdr flag*)])
|
||||
#`(begin
|
||||
#,expr
|
||||
(display-string #,(format " where each ~a is one of:\n~{ ~a\n~}"
|
||||
flag-header
|
||||
(map (lambda (kwd* optarg*)
|
||||
(format " ~a~{~a~}"
|
||||
(usage-kwd* kwd*)
|
||||
(map usage-optarg optarg*)))
|
||||
(map pflag-kwd* flag*)
|
||||
(map pflag-optarg* flag*)))))))
|
||||
(cmdspec-printer s*)
|
||||
flag**)))))
|
||||
(define (usage-cmdspec-helper inline-flags? cmdspec)
|
||||
(let loop ([cmdspec cmdspec]
|
||||
[rs* '()]
|
||||
[rflag** '()]
|
||||
[flagsno (and (not inline-flags?)
|
||||
(cond [(memp pflags? cmdspec) => (lambda (cmdspec) (memp pflags? (cdr cmdspec)))] [else #f])
|
||||
1)])
|
||||
(if (null? cmdspec)
|
||||
(values (reverse rs*) (reverse rflag**))
|
||||
(let ([x (car cmdspec)])
|
||||
(if (pflags? x)
|
||||
(if inline-flags?
|
||||
(loop (cdr cmdspec)
|
||||
(cons (let ([flag* (pflags-flag* x)])
|
||||
(format "~{~a~}"
|
||||
(map (lambda (kwd* optarg*)
|
||||
(format " [ ~a~{~a~} ]"
|
||||
(usage-kwd* kwd*)
|
||||
(map usage-optarg optarg*)))
|
||||
(map pflag-kwd* flag*)
|
||||
(map pflag-optarg* flag*))))
|
||||
rs*)
|
||||
rflag**
|
||||
flagsno)
|
||||
(let ([flag-header (if flagsno (format "flag~s" flagsno) "flag")])
|
||||
(loop (cdr cmdspec)
|
||||
(cons (format " ~a ..." flag-header) rs*)
|
||||
(cons (cons flag-header (pflags-flag* x)) rflag**)
|
||||
(and flagsno (+ flagsno 1)))))
|
||||
(loop (cdr cmdspec)
|
||||
(cons (cond
|
||||
[(pkeyword? x)
|
||||
(format " ~a~{~a~}"
|
||||
(usage-kwd* (pkeyword-kwd* x))
|
||||
(map usage-reqarg (pkeyword-reqarg* x)))]
|
||||
[(preqarg? x) (usage-reqarg x)]
|
||||
[(poptarg? x) (format " [~a ]" (usage-optarg x))]
|
||||
[(prestarg? x) (format "~a ..." (usage-reqarg (prestarg-reqarg x)))]
|
||||
[(pend? x) ""]
|
||||
[else (errorf 'usage-cmdspec "unrecognized cmdspec ~s" x)])
|
||||
rs*)
|
||||
rflag**
|
||||
flagsno))))))
|
||||
(define (usage-kwd* kwd*) (format "~a~{|~a~}" (car kwd*) (cdr kwd*)))
|
||||
(define (usage-reqarg x)
|
||||
(format " ~a" (syntax-object->datum (preqarg-var x))))
|
||||
(define (usage-optarg x)
|
||||
(format " ~a" (syntax-object->datum (poptarg-var x)))))
|
||||
|
||||
(define (xmap p ls tail)
|
||||
(if (null? ls)
|
||||
tail
|
||||
(p (car ls) (xmap p (cdr ls) tail))))
|
||||
|
||||
(module (findvars)
|
||||
(define (findvars cmdspec)
|
||||
(findvars-cmdspec cmdspec '()))
|
||||
(define (findvars-cmdspec cmdspec tail)
|
||||
(xmap
|
||||
(lambda (x tail)
|
||||
(cond
|
||||
[(pkeyword? x) (xmap findvars-reqarg (pkeyword-reqarg* x) tail)]
|
||||
[(pflags? x)
|
||||
(xmap (lambda (flag tail)
|
||||
(cons (pflag-?var flag)
|
||||
(xmap findvars-optarg (pflag-optarg* flag) tail)))
|
||||
(pflags-flag* x)
|
||||
tail)]
|
||||
[(preqarg? x) (findvars-reqarg x tail)]
|
||||
[(poptarg? x) (findvars-optarg x tail)]
|
||||
[(prestarg? x) (findvars-reqarg (prestarg-reqarg x) tail)]
|
||||
[(pend? x) tail]
|
||||
[else (errorf 'findvars-cmdspec "unrecognized cmdspec ~s" x)]))
|
||||
cmdspec
|
||||
tail))
|
||||
(define (findvars-reqarg x tail)
|
||||
(cons (preqarg-var x) tail))
|
||||
(define (findvars-optarg x tail)
|
||||
(cons (poptarg-var x) tail)))
|
||||
|
||||
(module (finddefaults)
|
||||
(define (finddefaults cmdspec)
|
||||
(finddefaults-cmdspec cmdspec '()))
|
||||
(define (finddefaults-cmdspec cmdspec tail)
|
||||
(xmap
|
||||
(lambda (x tail)
|
||||
(cond
|
||||
[(pkeyword? x)
|
||||
(xmap finddefaults-reqarg (pkeyword-reqarg* x) tail)]
|
||||
[(pflags? x)
|
||||
(xmap (lambda (flag tail)
|
||||
(cons #'#f
|
||||
(xmap finddefaults-optarg (pflag-optarg* flag) tail)))
|
||||
(pflags-flag* x)
|
||||
tail)]
|
||||
[(preqarg? x) (finddefaults-reqarg x tail)]
|
||||
[(poptarg? x) (finddefaults-optarg x tail)]
|
||||
[(prestarg? x) (cons #''() tail)]
|
||||
[(pend? x) tail]
|
||||
[else (errorf 'finddefaults-cmdspec "unrecognized cmdspec ~s" x)]))
|
||||
cmdspec
|
||||
tail))
|
||||
(define (finddefaults-reqarg x tail)
|
||||
(cons #'(void) tail))
|
||||
(define (finddefaults-optarg x tail)
|
||||
(cons (poptarg-default x) tail)))
|
||||
|
||||
(module (build-clause)
|
||||
(define (type->converter x)
|
||||
(if (and x (not (literal-identifier=? x #'string)))
|
||||
(datum->syntax-object x
|
||||
(string->symbol
|
||||
(format "string->~a" (syntax-object->datum x))))
|
||||
#'values))
|
||||
(define (build-clause-body var* cmdspec body)
|
||||
(with-syntax ([(var ...) var*])
|
||||
(let ([x (car cmdspec)])
|
||||
(cond
|
||||
[(pkeyword? x)
|
||||
(let ([reqarg* (pkeyword-reqarg* x)])
|
||||
(with-syntax ([(kwd ...) (pkeyword-kwd* x)]
|
||||
[(reqvar ...) (map preqarg-var reqarg*)]
|
||||
[(convert ...)
|
||||
(map type->converter (map preqarg-type reqarg*))]
|
||||
[action (or (pkeyword-action x) #'(#2%void))]
|
||||
[finish (build-clause-body var* (cdr cmdspec) body)]
|
||||
[n (length reqarg*)])
|
||||
#'(cond
|
||||
[(and (> (length cl) n) (member (car cl) '(kwd ...)))
|
||||
(let ([cl (cdr cl)])
|
||||
(apply (lambda (reqvar ... . ignore)
|
||||
; performs unnecessary tests if convert
|
||||
; is values; doesn't shortcut out as
|
||||
; soon as one convert returns false
|
||||
(let ([reqvar (convert reqvar)] ...)
|
||||
(if (and reqvar ...)
|
||||
(let ([cl (list-tail cl n)]
|
||||
[act! (lambda () (act!) action)])
|
||||
finish)
|
||||
(next orig-cl))))
|
||||
cl))]
|
||||
[else (next orig-cl)])))]
|
||||
[(pflags? x)
|
||||
(let* ([flag* (pflags-flag* x)]
|
||||
[optarg** (map pflag-optarg* flag*)])
|
||||
(with-syntax ([((kwd ...) ...) (map pflag-kwd* flag*)]
|
||||
[(?var ...) (map pflag-?var flag*)]
|
||||
[((optvar ...) ...)
|
||||
(map (lambda (optarg*)
|
||||
(map poptarg-var optarg*))
|
||||
optarg**)]
|
||||
[((convert ...) ...)
|
||||
(map (lambda (optarg*)
|
||||
(map type->converter
|
||||
(map poptarg-type optarg*)))
|
||||
optarg**)]
|
||||
[(action ...)
|
||||
(map (lambda (flag)
|
||||
(or (pflag-action flag) #'(#2%void)))
|
||||
flag*)]
|
||||
[finish (build-clause-body var* (cdr cmdspec) body)]
|
||||
[(n ...) (map length optarg**)])
|
||||
#'(let ([t (lambda (cl act! ?var ... optvar ... ...) finish)])
|
||||
(let f ([cl cl]
|
||||
[act! act!]
|
||||
[?var ?var] ...
|
||||
[optvar optvar] ... ...)
|
||||
(cond
|
||||
[(null? cl) (t cl act! ?var ... optvar ... ...)]
|
||||
[(and (> (length cl) n) (member (car cl) '(kwd ...)))
|
||||
(let ([cl (cdr cl)])
|
||||
(apply (lambda (optvar ... . ignore)
|
||||
; performs unnecessary tests if convert
|
||||
; is values; doesn't shortcut out as
|
||||
; soon as one convert returns false
|
||||
(let ([optvar (convert optvar)] ...)
|
||||
(if (and optvar ...)
|
||||
(let ([?var #t])
|
||||
(f (list-tail cl n)
|
||||
(lambda () (act!) action)
|
||||
?var ...
|
||||
optvar ... ...))
|
||||
(next orig-cl))))
|
||||
cl))]
|
||||
...
|
||||
[else (t cl act! ?var ... optvar ... ...)])))))]
|
||||
[(preqarg? x)
|
||||
(with-syntax ([reqvar (preqarg-var x)]
|
||||
[convert (type->converter (preqarg-type x))]
|
||||
[finish (build-clause-body var* (cdr cmdspec) body)])
|
||||
#'(cond
|
||||
; performs unnecessary test if convert is values
|
||||
[(and (not (null? cl)) (convert (car cl))) =>
|
||||
(lambda (reqvar) (let ([cl (cdr cl)]) finish))]
|
||||
[else (next orig-cl)]))]
|
||||
[(poptarg? x)
|
||||
(with-syntax ([optvar (poptarg-var x)]
|
||||
[convert (type->converter (poptarg-type x))]
|
||||
[finish (build-clause-body var* (cdr cmdspec) body)])
|
||||
#'(let ([t (lambda (optvar cl) finish)])
|
||||
(cond
|
||||
[(null? cl) (t optvar cl)]
|
||||
; performs unnecessary test if convert is values
|
||||
[(convert (car cl)) => (lambda (optvar) (t optvar (cdr cl)))]
|
||||
[else (next orig-cl)])))]
|
||||
[(prestarg? x)
|
||||
(let ([reqarg (prestarg-reqarg x)])
|
||||
(with-syntax ([restvar (preqarg-var reqarg)]
|
||||
[convert (type->converter (preqarg-type reqarg))]
|
||||
[body body])
|
||||
#'(let f ([cl cl] [rrestvar '()])
|
||||
(cond
|
||||
[(null? cl)
|
||||
(let ([restvar (reverse rrestvar)])
|
||||
(let () (act!) . body))]
|
||||
; performs unnecessary test if convert is values
|
||||
[(convert (car cl)) =>
|
||||
(lambda (x) (f (cdr cl) (cons x rrestvar)))]
|
||||
[else (next orig-cl)]))))]
|
||||
[(pend? x)
|
||||
(with-syntax ([body body])
|
||||
#'(if (null? cl)
|
||||
(let () (act!) . body)
|
||||
(next orig-cl)))]
|
||||
[else (errorf 'build-clause-body "unrecognized cmdspec ~s" x)]))))
|
||||
(define (build-clause cmdspec body next-expr)
|
||||
(let ([var* (findvars cmdspec)])
|
||||
(with-syntax ([next-expr next-expr]
|
||||
[(var ...) var*]
|
||||
[(default ...) (finddefaults cmdspec)]
|
||||
[clause-body (build-clause-body var* cmdspec body)])
|
||||
#'(let ([next next-expr])
|
||||
(lambda (orig-cl)
|
||||
(let ([cl (cdr orig-cl)] [act! #2%void] [var default] ...)
|
||||
clause-body)))))))
|
||||
|
||||
(syntax-case x ()
|
||||
[(k clexpr [cmdspeca b1a b2a ...] [cmdspec b1 b2 ...] ...)
|
||||
(let ([all-cmdspec* (map parse-cmdspec
|
||||
(cons #'cmdspeca
|
||||
(syntax->list #'(cmdspec ...))))]
|
||||
[body* #'((b1a b2a ...) (b1 b2 ...) ...)])
|
||||
(with-implicit (k usage)
|
||||
#`(let ([usage-proc #,(usage-printer all-cmdspec*)] [cl clexpr])
|
||||
(let ([usage (lambda () (usage-proc cl))])
|
||||
#,(with-syntax ([p (let f ([cmdspec* all-cmdspec*] [body* body*])
|
||||
(if (null? cmdspec*)
|
||||
#'(lambda (cl) (usage-proc cl) (exit 1))
|
||||
(build-clause (car cmdspec*) (car body*)
|
||||
(f (cdr cmdspec*) (cdr body*)))))])
|
||||
#'(p cl))))))])))
|
||||
|
||||
;;; (run-script script arg ...) runs named script in same process
|
||||
(define (run-script script . arg*)
|
||||
(command-line-arguments arg*)
|
||||
(load script))
|
||||
)
|
||||
Reference in a new issue