suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: a8745382a7357d03558af1556d13492abae1f996
This commit is contained in:
Matthew Flatt 2001-01-31 23:22:15 +00:00
parent 16edf0c455
commit 11fb8afb5d
8 changed files with 3828 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

238
collects/mzlib/awk.ss
View File

@ -1,13 +1,235 @@
(begin-elaboration-time
(require-library "invoke.ss"))
(module awk mzscheme
(begin-elaboration-time
(define-values/invoke-unit (awk)
(require-relative-library "awkr.ss")))
(export awk match:start match:end match:substring regexp-exec)
(define-macro awk awk)
(define-syntax awk
(lambda (stx)
(syntax-case stx ()
[(_ next-record
(record first field ...)
counter
((state-variable init-expr) ...)
continue
clause ...)
(and (identifier? (syntax counter-variable))
(identifier? (syntax continue-variable)))
(let ([clauses (syntax->list (syntax (clause ...)))]
[initvars null])
(with-syntax ([(local-state ...) (generate-temporaries
(syntax (state-variable ...)))])
(letrec ([get-after-clauses
(lambda ()
(let loop ([l clauses][afters null])
(cond
[(null? l) (if (stx-null? afters)
(syntax ((values state-variable ...)))
afters)]
[(syntax-case (car l) (after)
[(after . rest) (syntax rest)])
=> (lambda (rest)
(with-syntax ([(after ...) afters])
(loop (cdr l) (syntax (after ... . rest)))))]
[else
(loop (cdr l) afters)])))]
[wrap-state
(lambda (e)
(syntax-case e (=>)
[(=> f)
(with-syntax ([body (wrap-state (syntax ((f arg))))])
(syntax (=> (lambda (arg)
. body))))]
[else
(syntax
((call-with-values (lambda () . body)
(lambda (local-state ... . extras)
(set! else-ready? #f)
(set! state-variable local-state)
...))))]))]
[make-range
(lambda (include-on? include-off? body rest)
(syntax-case body ()
[(t1 t2 . body)
(with-syntax ([on? (car (generate-temporaries '(1)))]
[t1 (make-test (syntax-e (syntax t1)) (syntax t1))]
[t2 (make-test (syntax-e (syntax t2)) (syntax t2))]
[body (wrap-state (syntax body))])
(with-syntax ([check (if include-on?
(if include-off?
(syntax post-on-on?)
(syntax on?))
(if include-off?
(syntax orig-on?)
(syntax (and orig-on? on?))))])
(set! initvars (cons (syntax (on? #f)) initvars))
(syntax
((let ([orig-on? on?])
(unless on?
(set! on? t1))
(let ([post-on-on? on?])
(when on?
(set! on? (not t2))))
(when check
. body))
. rest))))]))]
[make-test
(lambda (test expr)
(cond
[(string? test)
(with-syntax ([g (car (generate-temporaries '(1)))])
(set! initvars (cons (syntax (g (regexp expr))) initvars))
(syntax (regexp-exec g first)))]
[(number? test)
(syntax (= expr counter))]
[else expr]))]
[get-testing-clauses
(lambda ()
(let loop ([l clauses])
(if (null? l)
null
(syntax-case (car l) ()
[(test-expr body ...)
(with-syntax ([rest (loop (cdr l))])
(let ([test (syntax-e (syntax test-expr))]
[body (syntax (body ...))])
(cond
[(or (string? test) (number? test))
(with-syntax ([t (make-test test (syntax text-expr))]
[body (wrap-state body)])
(syntax
((cond [t . body]
[else (void)])
. rest)))]
[(eq? test 'else)
(with-syntax ([body (wrap-state body)])
(syntax
((when else-ready? . body)
(set! else-ready? #t)
. rest)))]
[(eq? test 'range)
(make-range #f #f body (syntax rest))]
[(eq? test ':range)
(make-range #t #f body (syntax rest))]
[(eq? test 'range:)
(make-range #f #t body (syntax rest))]
[(eq? test ':range:)
(make-range #t #t body (syntax rest))]
[(eq? test 'after)
(syntax rest)]
[(eq? test '/)
(with-syntax ([g (car (generate-temporaries '(1)))])
(syntax-case body (/)
[(/ re / (var ...) . body)
(and (string? (syntax-e (syntax re)))
(andmap (lambda (x) (or (identifier? x)
(not (syntax-e x))))
(syntax->list (syntax (var ...)))))
(with-syntax ([(var ...)
(for-each (lambda (x)
(if (identifier? x)
x
(car (generate-temporaries '(1)))))
(syntax->list (syntax (var ...))))]
[body (wrap-state (syntax body))])
(set! initvars (cons (syntax (g (regexp re))) initvars))
(syntax
((cond
[(regexp-match re first)
=> (lambda (arg)
(apply
(lambda (var ...) . body)
arg))]
[else (void)])
rest)))]))]
[else
(with-syntax ([body (wrap-state (syntax body))])
(syntax
((cond [test-expr . body]
[else (void)])
. rest)))])))]))))])
(with-syntax ([testing-clauses (get-testing-clauses)]
[after-clauses (get-after-clauses)]
[initvars initvars])
(syntax
(let ((state-variable init-expr) ...
. initvars)
(let loop ([counter 1])
(call-with-values (lambda () get-next-record)
(lambda (first field ...)
(if (eof-object? first)
(begin
. after-clauses)
(let ([else-ready? #t])
(let/ec escape
(let ([continue
(lambda (local-state ... . extras)
(set! state-variable local-state)
...
(escape))])
. testing-clauses))
(loop (add1 counter)))))))))))))]
;; Left out continue...
[(_ next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
clause ...)
(identifier? (syntax counter-variable))
(syntax
(awk next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
continue-variable
clause ...))]
;; Left out counter...
[(_ next-record
(record field-variable ...)
((state-variable init-expr) ...)
continue-variable
clause ...)
(identifier? (syntax continue-variable))
(syntax
(awk next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
continue-variable
clause ...))]
;; Left out both...
[(_ next-record
(record field-variable ...)
((state-variable init-expr) ...)
clause ...)
(syntax
(awk next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
continue-variable
clause ...))])))
(define-values/invoke-unit (match:start match:end match:substring regexp-exec)
(require-relative-library "awkr.ss"))
(define-struct match (s a))
(define match:start
(case-lambda
[(rec) (match:start rec 0)]
[(rec which) (car (list-ref (match-a rec) which))]))
(define match:end
(case-lambda
[(rec) (match:end rec 0)]
[(rec which) (cdr (list-ref (match-a rec) which))]))
(define match:substring
(case-lambda
[(rec) (match:substring rec 0)]
[(rec which) (let ([p (list-ref (match-a rec) which)])
(substring (match-s rec) (car p) (cdr p)))]))
(define regexp-exec
(lambda (re s)
(let ([r (regexp-match-positions re s)])
(if r
(make-match s r)
#f)))))

470
collects/mzlib/cmdline.ss
View File

@ -1,9 +1,469 @@
(require-library "cmdlineu.ss")
(module cmdline mzscheme
(begin-elaboration-time
(require-library "invoke.ss"))
(define-syntax command-line
(lambda (stx)
(syntax-case stx ()
[(_ program-name
argv
clause ...)
(let ([serror
(lambda (msg . detail)
(apply
raise-syntax-error
'command-line
msg
stx
detail))])
(unless (string? (syntax-e (syntax program-name)))
(serror
"program name is not a string"
(syntax program-name)))
(let ([extract (lambda (what args . detail)
(if (null? args)
(apply serror (format "missing ~a" what) detail)
(values (car args) (cdr args))))]
[formal-names
(lambda (l)
(map
(lambda (a)
(cons (syntax->datum (let ([s (symbol->string (syntax-e a))])
(if (char=? #\* (string-ref s (sub1 (string-length s))))
(substring s 0 (sub1 (string-length s)))
s))
#f (quote-syntax here))))
l))])
(let ([clauses
(let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null])
(with-syntax ([(clause ...) clauses])
(if (null? csrcs)
(syntax (clause ... (lambda (accum) (void)) null))
(let ([line (car csrcs)]
[arest (cdr csrcs)])
(syntax-case line (help-labels => args)
[(help-labels s ...)
(begin
(unless (andmap (lambda (x) (string? (syntax-e x)))
(syntax->list (syntax (s ...))))
(serror "help-labels clause must contain only strings" line))
(loop arest
(syntax (clause
...
'(help-labels s ...)))))]
[(tag . rest)
(ormap (lambda (x) (module-identifier=? (syntax tag) x))
(syntax->list (syntax (once-each once-any multi))))
(let slloop ([sublines (syntax->list (syntax rest))])
(if (null? sublines)
(syntax ())
(with-syntax ([looped (slloop (cdr sublines))]
[subline
(with-syntax ([flags (syntax-case (car sublines) ()
[((flag ...) . rest)
(begin
(unless (andmap (lambda (x) (string? (syntax-e x)))
(syntax->list (syntax (flag ...))))
(serror "flag specification is not a string or sequence of strings"
(syntax (flag ...))))
(syntax (flag ...)))]
[(flag . rest)
(string? (syntax-e (syntax flag)))
(syntax (flag))]
[else
(serror "clause does not start with flags")])])
(syntax-case (car sublines) ()
[(_ => a b)
(syntax (list 'flags a b))]
[(_ rest ...)
(let*-values ([(formals rest) (let loop ([a null][rest (syntax->list (syntax (rest ...)))])
(cond
[(null? rest) (values a null)]
[(identifier? (car rest))
(values (append a (list (car rest)))
(cdr rest))]
[else (values a rest)]))]
[(help rest) (extract "help string" rest line)]
[(_) (unless (string? (syntax-e help))
(serror "help info is not a string" help))]
[(expr1 rest) (extract "handler body expressions" rest line)])
(with-syntax ([formals formals]
[formal-names (formal-names formals)]
[help help]
[expr1 expr1]
[rest rest])
(syntax (list 'flags
(lambda (flag . formals)
expr1 . rest)
'(help . formal-names)))))]))])
(loop arest
(syntax (clause
...
(list 'tag . (subline . looped))))))))]
[(=> finish-proc arg-help help-proc unknown-proc)
(begin
(unless (null? arest)
(serror "=> must be the last clause line"))
(syntax (clause
...
finish-proc arg-help help-proc unknown-proc)))]
[(=> . _)
(serror "bad => line" line)]
[(args arg-formals body1 body ...)
(begin
(unless (null? arest)
(serror "args must be the last clause" line))
(let ([formals
(let loop ([f (syntax arg-formals)])
(syntax-case f ()
[(arg . rest)
(identifier? (syntax arg))
(cons (syntax arg) (loop (syntax rest)))]
[arg
(identifier? (syntax arg))
(list (syntax arg))]
[else
(serror "bad argument list" line)]))])
(with-syntax ([formal-names (formal-names formals)])
(syntax (clause
...
(lambda (accume . arg-formals)
body1 body ...)
'formal-names)))))]
[(args . _)
(serror "bad args line" line)]
[else (serror "not a once-each, once-any, multi, args, or => line" line)])))))])
(with-syntax ([clauses clauses])
(syntax
(parse-command-line
program-name argv
. clauses))))))])))
(define number-regexp (regexp "^[-+][0-9]*(|[.][0-9]*)$"))
(define print-args
(lambda (port l f)
(let loop ([l l][a (letrec ([a (arity f)]
[a-c (lambda (a)
(cond
[(number? a) (cons (sub1 a) (sub1 a))]
[(arity-at-least? a)
(let ([v (sub1 (arity-at-least-value a))])
(cons v v))]
[else (let ([r (map a-c a)])
(cons (apply min (map car r))
(apply max (map cdr r))))]))])
(a-c a))])
(unless (null? l)
(fprintf port " ~a<~a>~a"
(if (positive? (car a)) "" "[")
(car l)
(if (positive? (car a)) "" "]"))
(unless (positive? (cdr a))
(fprintf port " ..."))
(loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a))))))))
(define (procedure-arity-includes-at-least? p n)
(letrec ([a-c
(lambda (a)
(cond
[(number? a) (>= a n)]
[(arity-at-least? a) #t]
[else (ormap a-c a)]))])
(a-c (arity p))))
(define parse-command-line
(case-lambda
[(program arguments table finish finish-help)
(parse-command-line program arguments table finish finish-help
(lambda (s)
(display s)
(exit 0)))]
[(program arguments table finish finish-help help)
(parse-command-line program arguments table finish finish-help help
(lambda (flag)
(error (string->symbol program) "unknown flag: ~s" flag)))]
[(program arguments table finish finish-help help unknown-flag)
(unless (string? program)
(raise-type-error 'parse-command-line "program name string" program))
(unless (and (vector? arguments)
(andmap string? (vector->list arguments)))
(raise-type-error 'parse-command-line "argument vector of strings" arguments))
(unless (and (list? table)
(let ([bad-table
(lambda (reason)
(raise-type-error 'parse-command-line
(format "table as a list of flag-list/procedure pairs (~a)"
reason)
table))])
(andmap
(lambda (spec)
(and (or (and (list? spec) (pair? spec))
(bad-table (format "spec-set must be a non-empty list: ~a" spec)))
(or (memq (car spec) '(once-any once-each multi help-labels))
(bad-table (format "spec-set type must be 'once-any, 'once-each, 'multi, or 'help-labels: ~a"
(car spec))))
(andmap
(lambda (line)
(if (eq? (car spec) 'help-labels)
(or (string? line)
(bad-table (format "help-labels line must be a string: ~e" line)))
(and (or (and (list? line) (= (length line) 3))
(bad-table (format "spec-line must be a list of at three items: ~e" line)))
(or (list? (car line))
(bad-table (format "flags part of a spec-line must be a list: ~e" (car line))))
(andmap
(lambda (flag)
(or (string? flag)
(bad-table (format "flag must be a string: ~e" flag)))
(or (and (or (regexp-match "^-[^-]$" flag)
(regexp-match "^[+][^+]$" flag)
(regexp-match "^--." flag)
(regexp-match "^[+][+]." flag))
(not (or (regexp-match "^--help$" flag)
(regexp-match "^-h$" flag)
(regexp-match number-regexp flag))))
(bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
(car line))
(or (procedure? (cadr line))
(bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
(let ([a (arity (cadr line))])
(or (and (number? a)
(or (>= a 1)
(bad-table (format "flag handler procedure must take at least 1 argument: ~e"
(cadr line)))))
(arity-at-least? a)
(bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line)))))
(or (and (list? (caddr line))
(andmap string? (caddr line)))
(bad-table (format "spec-line help section must be a list of strings")))
(or (let ([l (length (caddr line))]
[a (arity (cadr line))])
(if (number? a)
(= a l)
(and (>= l 1)
(>= l (arity-at-least-value a)))))
(bad-table (format "spec-line help list strings must match procedure arguments"))))))
(cdr spec))))
table)))
(raise-type-error 'parse-command-line "table of spec sets" table))
(unless (and (procedure? finish)
(procedure-arity-includes-at-least? finish 1))
(raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish))
(unless (and (list? finish-help) (andmap string? finish-help))
(raise-type-error 'parse-command-line "argument help list of strings" finish-help))
(unless (and (procedure? help) (procedure-arity-includes? help 1))
(raise-type-error 'parse-command-line "help procedure of arity 1" help))
(unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
(let ([a (arity unknown-flag)])
(or (number? a) (arity-at-least? a))))
(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
(letrec ([a (arity finish)]
[l (length finish-help)]
[a-c (lambda (a)
(or (and (number? a) (sub1 a))
(and (arity-at-least? a)
(max 1 (arity-at-least-value a)))
(and (list? a) (apply max (map a-c a)))))])
(unless (= (a-c a) l)
(error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
(let* ([once-spec-set
(lambda (lines)
(let ([set (cons #f (apply append (map car lines)))])
(map
(lambda (line) (cons set line))
lines)))]
[table
(apply
append
(list
(list #f (list "--help" "-h")
(lambda (f)
(let* ([sp (open-output-string)])
(fprintf sp "~a~a" program
(if (null? table)
""
" [ <flag> ... ]"))
(print-args sp finish-help finish)
(fprintf sp "~n where <flag> is one of~n")
(for-each
(lambda (set)
(if (eq? (car set) 'help-labels)
(for-each
(lambda (line)
(fprintf sp " ~a~n" line))
(cdr set))
(for-each
(lambda (line)
(fprintf sp (cond
[(and (eq? (car set) 'once-any)
(pair? (cddr set)))
(cond
[(eq? line (cadr set)) "/"]
[(eq? line (let loop ([l set])
(if (pair? (cdr l))
(loop (cdr l))
(car l)))) "\\"]
[else "|"])]
[(eq? (car set) 'multi)
"*"]
[else " "]))
(let loop ([flags (car line)])
(let ([flag (car flags)])
(fprintf sp " ~a" flag)
(print-args sp (cdaddr line) (cadr line)))
(unless (null? (cdr flags))
(fprintf sp ",")
(loop (cdr flags))))
(fprintf sp " : ~a~n" (caaddr line)))
(cdr set))))
table) ; the original table
(fprintf sp " --help, -h : Show this help~n")
(fprintf sp " -- : Do not treat any remaining argument as a flag (at this level)~n")
(when (assq 'multi table)
(fprintf sp " * Asterisks indicate flags allowed multiple times.~n"))
(when (assq 'once-any table)
(fprintf sp " /|\\ Brackets indicate mutually exclusive flags.~n"))
(fprintf sp " Multiple single-letter flags can be combined after one `-'; for~n")
(fprintf sp " example: `-h-' is the same as `-h --'~n")
(help (get-output-string sp))))
(list "Help")))
(map
(lambda (spec)
(cond
[(eq? (car spec) 'once-each)
(apply
append
(map
(lambda (line) (once-spec-set (list line)))
(cdr spec)))]
[(eq? (car spec) 'once-any)
(once-spec-set (cdr spec))]
[(eq? (car spec) 'help-labels)
null]
[(eq? (car spec) 'multi)
(map
(lambda (line) (cons #f line))
(cdr spec))]))
table))]
[done
(lambda (args r-acc)
(let ([options (reverse r-acc)]
[c (length args)])
(if (procedure-arity-includes? finish (add1 c))
(apply finish options args)
(error (string->symbol program)
(format "expects~a on the command line, given ~a argument~a~a"
(if (null? finish-help)
" no arguments"
(let ([s (open-output-string)])
(parameterize ([current-output-port s])
(print-args s finish-help finish))
(let ([s (get-output-string s)])
(if (equal? 2 (arity finish))
(format " 1~a" s)
s))))
c
(cond
[(zero? c) "s"]
[(= c 1) ": "]
[else "s: "])
(let loop ([args args])
(if (null? args)
""
(string-append (car args) " " (loop (cdr args))))))))))]
[call-handler
(lambda (handler flag args r-acc k)
(let* ([a (arity handler)]
[remaining (length args)]
[needed (if (number? a)
(sub1 a)
(sub1 (arity-at-least-value a)))]
[use (if (number? a)
(sub1 a)
remaining)])
(if (< remaining needed)
(error (string->symbol program)
"the ~s flag needs ~a argument~a, but only ~a provided"
flag needed (if (> needed 1) "s" "")
remaining)
(let ([v (apply handler
flag
(let loop ([n use][args args])
(if (zero? n)
null
(cons (car args)
(loop (sub1 n) (cdr args))))))])
(k (list-tail args use)
(if (void? v)
r-acc
(cons v r-acc)))))))]
[handle-flag
(lambda (flag args r-acc orig-multi k)
(let loop ([table table])
(cond
[(null? table)
(call-handler unknown-flag flag args r-acc k)]
[(member flag (cadar table))
(when (caar table)
(let ([set (caar table)])
(if (car set)
(let ([flags (cdr set)])
(error (string->symbol program)
(let ([s (if (= 1 (length flags))
(format "the ~a flag can only be specified once" (car flags))
(format "only one instance of one flag from ~a is allowed" flags))])
(if orig-multi
(format "~a; note that ~s is shorthand for ~s, in contrast to ~s"
s
orig-multi
(let loop ([prefix (string-ref orig-multi 0)]
[flags (string->list (substring orig-multi 1 (string-length orig-multi)))]
[sep ""])
(if (null? flags)
""
(format "~a~a~a~a" sep prefix (car flags)
(loop prefix (cdr flags) " "))))
(string-append (substring orig-multi 0 1) orig-multi))
s))))
(set-car! set #t))))
(call-handler (caddar table) flag args r-acc k)]
[else (loop (cdr table))])))])
(let loop ([args (vector->list arguments)][r-acc null])
(if (null? args)
(done args r-acc)
(let ([arg (car args)]
[rest (cdr args)])
(cond
[(regexp-match number-regexp arg)
(done args r-acc)]
[(regexp-match "^--$" arg)
(done (cdr args) r-acc)]
[(regexp-match "^[-+][-+]" arg)
(handle-flag arg rest r-acc #f loop)]
[(regexp-match "^[-+]." arg)
(let a-loop ([s (string->list (substring arg 1 (string-length arg)))]
[rest rest]
[r-acc r-acc])
(if (null? s)
(loop rest r-acc)
(handle-flag (string (string-ref arg 0) (car s))
rest r-acc
arg
(lambda (args r-acc)
(a-loop (cdr s) args r-acc)))))]
[else
(done args r-acc)])))))]))
(export command-line parse-command-line))
(define-values/invoke-unit/sig mzlib:command-line^ mzlib:command-line@ #f)
(require-library "cmdlinem.ss")

86
collects/mzlib/compat.ss
View File

@ -1,11 +1,81 @@
(require-library "compatu.ss")
(require-library "functio.ss")
(module compat mzscheme
(import "list.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(export real-time
1+ 1-
>=? <=? >? <? =?
flush-output-port
bound?
sort
gentemp
atom?
putprop getprop
new-cafe)
(define 1+ add1)
(define 1- sub1)
(define =? =)
(define <? <)
(define >? >)
(define <=? <)
(define >=? >)
(define-values/invoke-unit/sig mzlib:compat^
mzlib:compat@
#f
mzlib:function^)
(define atom? (lambda (v) (not (pair? v))))
(define gentemp gensym)
(define sort ; Chez argument order
(lambda (less-than? l)
(mergesort l less-than?)))
(define bound? defined?)
(define flush-output-port flush-output)
(define real-time current-milliseconds)
(define getprop (void))
(define putprop (void))
(let ([table (make-hash-table)])
(letrec ([gp
(case-lambda
[(k prop) (gp k prop #f)]
[(k prop def)
(let ([al (hash-table-get table k (lambda () #f))])
(if al
(let ([v (assq prop al)])
(if v
(cdr v)
def))
def))])]
[pp
(lambda (k prop nv)
(let ([al (hash-table-get table k (lambda () '()))])
(let ([v (assq prop al)])
(if v
(set-cdr! v nv)
(hash-table-put! table k (cons (cons prop nv) al))))))])
(set! getprop gp)
(set! putprop pp)))
;; Chez's new-cafe
(define new-cafe
(letrec ([nc
(case-lambda
[() (nc (current-eval))]
[(eval)
(let/ec escape
(let ([orig-exit (exit-handler)]
[orig-eval (current-eval)])
(dynamic-wind
(lambda ()
(current-eval eval)
(exit-handler
(lambda (v) (escape v))))
read-eval-print-loop
(lambda ()
(current-eval orig-eval)
(exit-handler orig-exit)))))])])
nc)))

367
collects/mzlib/date.ss
View File

@ -1,11 +1,362 @@
(require-library "dateu.ss")
(require-library "functio.ss")
(module date mzscheme
(begin-elaboration-time
(require-library "invoke.ss"))
(import "list.ss")
(export date->string
date-display-format
find-seconds
date->julian/scalinger
julian/scalinger->string)
;; Support for Julian calendar added by Shriram;
;; current version only works until 2099 CE Gregorian
#|
(define-primitive seconds->date (num -> structure:date))
(define-primitive current-seconds (-> num))
(define-primitive date-second (structure:date -> num))
(define-primitive date-minute (structure:date -> num))
(define-primitive date-hour (structure:date -> num))
(define-primitive date-day (structure:date -> num))
(define-primitive date-month (structure:date -> num))
(define-primitive date-year (structure:date -> num))
(define-primitive date-week-day (structure:date -> num))
(define-primitive date-year-day (structure:date -> num))
(define-primitive date-dst? (structure:date -> bool))
(define-primitive make-date (num num num num num num num num bool ->
structure:date))
(define-primitive expr->string (a -> string))
(define-primitive foldl (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
(define-primitive foldr (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
|#
(define legal-formats
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601))
(define date-display-format
(make-parameter 'american
(lambda (s)
(unless (memq s legal-formats)
(raise-type-error 'date-display-format
(format "symbol in ~a" legal-formats)
s))
s)))
(define month/number->string
(lambda (x)
(case x
[(12) "December"] [(1) "January"] [(2) "February"]
[(3) "March"] [(4) "April"] [(5) "May"]
[(6) "June"] [(7) "July"] [(8) "August"]
[(9) "September"] [(10) "October"] [(11) "November"]
[else ""])))
(define day/number->string
(lambda (x)
(case x
[(0) "Sunday"]
[(1) "Monday"]
[(2) "Tuesday"]
[(3) "Wednesday"]
[(4) "Thursday"]
[(5) "Friday"]
[(6) "Saturday"]
[else ""])))
(define date->string
(case-lambda
[(date) (date->string date #f)]
[(date time?)
(let* ((add-zero (lambda (n) (if (< n 10)
(string-append "0" (number->string n))
(number->string n))))
(year (number->string (date-year date)))
(num-month (number->string (date-month date)))
(week-day (day/number->string (date-week-day date)))
(week-day-num (date-week-day date))
(month (month/number->string (date-month date)))
(day (number->string (date-day date)))
(day-th (if (<= 11 (date-day date) 13)
"th"
(case (modulo (date-day date) 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[(0 4 5 6 7 8 9) "th"])))
(hour (date-hour date))
(am-pm (if (> hour 12) "pm" "am"))
(hour24 (add-zero hour))
(hour12 (if (> hour 12)
(number->string (- hour 12))
(number->string hour)))
(minute (add-zero (date-minute date)))
(second (add-zero (date-second date))))
(let-values
([(day time)
(case (date-display-format)
[(american)
(values (list week-day ", " month " " day day-th ", " year)
(list " " hour12 ":" minute ":" second am-pm))]
[(chinese)
(values
(list year "/" num-month "/" day
" libai" (case (date-week-day date)
[(0) "tian"]
[(1) "yi"]
[(2) "er"]
[(3) "san"]
[(4) "si"]
[(5) "wu"]
[(6) "liu"]
[else ""]))
(list " " hour24 ":" minute ":" second))]
[(indian)
(values (list day "-" num-month "-" year)
(list " " hour12 ":" minute ":" second am-pm))]
[(german)
(values (list day ". " month " " year)
(list ", " hour24 "." minute))]
[(irish)
(values (list week-day ", " day day-th " " month " " year)
(list ", " hour12 ":" minute am-pm))]
[(julian)
(values (list (julian/scalinger->string
(date->julian/scalinger date)))
(list ", " hour24 ":" minute ":" second))]
[(iso-8601)
(values
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
(list " " hour24 ":" minute ":" second))]
[else (error 'date->string "unknown date-display-format: ~s"
(date-display-format))])])
(apply string-append (if time?
(append day time)
day))))]))
(define leap-year?
(lambda (year)
(or (= 0 (modulo year 400))
(and (= 0 (modulo year 4))
(not (= 0 (modulo year 100)))))))
;; it's not clear what months mean in this context -- use days
(define-struct date-offset (second minute hour day year))
(define date-
(lambda (date1 date2)
(let* ((second (- (date-second date1) (date-second date2)))
(minute (+ (- (date-minute date1) (date-minute date2))
(if (< second 0) -1 0)))
(hour (+ (- (date-hour date1) (date-hour date2))
(if (< minute 0) -1 0)
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
[(date-dst? date1) -1]
[(date-dst? date2) 1])))
(day (+ (- (date-year-day date1) (date-year-day date2))
(if (< hour 0) -1 0)))
(year (+ (- (date-year date1) (date-year date2))
(if (< day 0) -1 0)))
(fixup (lambda (s x) (if (< s 0) (+ s x) s))))
(make-date-offset (fixup second 60)
(fixup minute 60)
(fixup hour 24)
(fixup day (if (leap-year? (date-year date1)) 366 365))
year))))
(define date-offset->string
(let ((first car)
(second cadr))
(case-lambda
[(date) (date-offset->string date #f)]
[(date seconds?)
(let* ((fields (list (list (date-offset-year date) "year")
(list (date-offset-day date) "day")
(list (date-offset-hour date) "hour")
(list (date-offset-minute date) "minute")
(list (if seconds? (date-offset-second date) 0) "second")))
(non-zero-fields (foldl (lambda (x l)
(if (= 0 (first x))
l
(cons x l)))
null
fields))
(one-entry (lambda (b)
(string-append
(number->string (first b))
" "
(second b)
(if (= 1 (first b)) "" "s")))))
(cond
[(null? non-zero-fields) ""]
[(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
[else (foldl (lambda (b string)
(cond
[(= 0 (first b)) string]
[(string=? string "")
(string-append "and "
(one-entry b)
string)]
[else (string-append (one-entry b) ", " string)]))
""
non-zero-fields)]))])))
(define days-per-month
(lambda (year month)
(cond
[(and (= month 2) (leap-year? year)) 29]
[(= month 2) 28]
[(<= month 7) (+ 30 (modulo month 2))]
[else (+ 30 (- 1 (modulo month 2)))])))
(define find-extreme-date-seconds
(lambda (start offset)
(let/ec found
(letrec ([find-between
(lambda (lo hi)
(let ([mid (floor (/ (+ lo hi) 2))])
(if (or (and (positive? offset) (= lo mid))
(and (negative? offset) (= hi mid)))
(found lo)
(let ([mid-ok?
(with-handlers ([not-break-exn? (lambda (exn) #f)])
(seconds->date mid)
#t)])
(if mid-ok?
(find-between mid hi)
(find-between lo mid))))))])
(let loop ([lo start][offset offset])
(let ([hi (+ lo offset)])
(with-handlers ([not-break-exn?
(lambda (exn)
; failed - must be between lo & hi
(find-between lo hi))])
(seconds->date hi))
; succeeded; double offset again
(loop hi (* 2 offset))))))))
(define get-min-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
(lambda ()
(force d))))
(define get-max-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
(lambda ()
(force d))))
(define find-seconds
(lambda (sec min hour day month year)
(let ([signal-error
(lambda (msg)
(error 'find-secs (string-append
msg
" (inputs: ~a ~a ~a ~a ~a ~a)")
sec min hour day month year))])
(let loop ([below-secs (get-min-seconds)]
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
[above-secs (get-max-seconds)])
(let* ([date (seconds->date secs)]
[compare
(let loop ([inputs (list year month day
hour min sec)]
[tests (list (date-year date)
(date-month date)
(date-day date)
(date-hour date)
(date-minute date)
(date-second date))])
(cond
[(null? inputs) 'equal]
[else (let ([input (car inputs)]
[test (car tests)])
(if (= input test)
(loop (cdr inputs) (cdr tests))
(if (<= input test)
'input-smaller
'test-smaller)))]))])
; (printf "~a ~a ~a~n" compare secs (date->string date))
(cond
[(eq? compare 'equal) secs]
[(or (= secs below-secs) (= secs above-secs))
(signal-error "non-existant date")]
[(eq? compare 'input-smaller)
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
[(eq? compare 'test-smaller)
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
;; date->julian/scalinger :
;; date -> number [julian-day]
;; Note: This code is correct until 2099 CE Gregorian
(define (date->julian/scalinger date)
(let ((day (date-day date))
(month (date-month date))
(year (date-year date)))
(let ((year (+ 4712 year)))
(let ((year (if (< month 3) (sub1 year) year)))
(let ((cycle-number (quotient year 4))
(cycle-position (remainder year 4)))
(let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
(let ((month-day-number (case month
((3) 0)
((4) 31)
((5) 61)
((6) 92)
((7) 122)
((8) 153)
((9) 184)
((10) 214)
((11) 245)
((12) 275)
((1) 306)
((2) 337))))
(let ((total-days (+ base-day month-day-number day)))
(let ((total-days/march-adjustment (+ total-days 59)))
(let ((gregorian-adjustment (cond
((< year 1700) 11)
((< year 1800) 12)
(else 13))))
(let ((final-date (- total-days/march-adjustment
gregorian-adjustment)))
final-date)))))))))))
;; julian/scalinger->string :
;; number [julian-day] -> string [julian-day-format]
(define (julian/scalinger->string julian-day)
(apply string-append
(cons "JD "
(reverse
(let loop ((reversed-digits (map number->string
(let loop ((jd julian-day))
(if (zero? jd) null
(cons (remainder jd 10)
(loop (quotient jd 10))))))))
(cond
((or (null? reversed-digits)
(null? (cdr reversed-digits))
(null? (cdr (cdr reversed-digits))))
(list (apply string-append reversed-digits)))
(else (cons (apply string-append
(list " "
(caddr reversed-digits)
(cadr reversed-digits)
(car reversed-digits)))
(loop (cdr (cdr (cdr reversed-digits))))))))))))
)
(define-values/invoke-unit/sig mzlib:date^
mzlib:date@
#f
mzlib:function^)

2296
collects/mzlib/deflate.ss
View File

File diff suppressed because it is too large Load Diff

121
collects/mzlib/etc.ss Normal file
View File

@ -0,0 +1,121 @@
(module etc mzscheme
(import "spidey.ss")
(export true false
boolean=? symbol=?
char->string
identity
compose
build-string
build-vector
build-list
loop-until)
(define true #t)
(define false #f)
(define identity (polymorphic (lambda (x) x)))
(define compose
(polymorphic
(case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g)
(let ([f (compose f)]
[g (compose g)])
(if (eqv? 1 (arity f)) ; optimize: don't use call-w-values
(if (eqv? 1 (arity g)) ; optimize: single arity everywhere
(lambda (x) (f (g x)))
(lambda args (f (apply g args))))
(if (eqv? 1 (arity g)) ; optimize: single input
(lambda (a)
(call-with-values
(lambda () (g a))
f))
(lambda args
(call-with-values
(lambda () (apply g args))
f)))))]
[(f . more)
(let ([m (apply compose more)])
(compose f m))])))
(define build-string
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-string "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-string "~s must be a procedure" fcn))
(let ((str (make-string n)))
(let loop ((i 0))
(if (= i n)
str
(begin
(string-set! str i (fcn i))
(loop (add1 i))))))))
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
(define build-vector
(polymorphic
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-vector "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-vector "~s must be a procedure" fcn))
(let ((vec (make-vector n)))
(let loop ((i 0))
(if (= i n) vec
(begin
(vector-set! vec i (fcn i))
(loop (add1 i)))))))))
(define build-list
(polymorphic
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-list "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-list "~s must be a procedure" fcn))
(if (zero? n) '()
(let ([head (list (fcn 0))])
(let loop ([i 1] [p head])
(if (= i n) head
(begin
(set-cdr! p (list (fcn i)))
(loop (add1 i) (cdr p))))))))))
(define loop-until
(polymorphic
(lambda (start done? next body)
(let loop ([i start])
(unless (done? i)
(body i)
(loop (next i)))))))
(define boolean=?
(lambda (x y)
(unless (and (boolean? x)
(boolean? y))
(raise-type-error 'boolean=?
"boolean"
(if (boolean? x) y x)))
(eq? x y)))
(define (symbol=? x y)
(unless (and (symbol? x)
(symbol? y))
(raise-type-error 'symbol=? "symbol"
(if (symbol? x) y x)))
(eq? x y))
(define (char->string c)
(unless (char? c)
(raise-type-error 'char->string "character" c))
(string c)))

294
collects/mzlib/file.ss
View File

@ -1,13 +1,287 @@
(module file mzscheme
(export find-relative-path
explode-path
normalize-path
build-absolute-path
build-relative-path
filename-extension
file-name-from-path
path-only
delete-directory/files
make-directory*
make-temporary-file
find-library
(require-library "fileu.ss")
(require-library "functio.ss")
(require-library "string.ss")
with-input-from-file*
call-with-input-file*
with-output-to-file*
call-with-output-file*)
(begin-elaboration-time
(require-library "invoke.ss"))
(import "list.ss")
(define-values/invoke-unit/sig mzlib:file^
mzlib:file@
#f
mzlib:string^
mzlib:function^)
(define build-relative-path
(lambda (p . args)
(if (relative-path? p)
(apply build-path p args)
(error 'build-relative-path "base path ~s is absolute" p))))
(define build-absolute-path
(lambda (p . args)
(if (relative-path? p)
(error 'build-absolute-path "base path ~s is relative" p)
(apply build-path p args))))
; Note that normalize-path does not normalize the case
(define normalize-path
(letrec ([resolve-all
(lambda (path wrt)
(let ([orig-path (if (and wrt (not (complete-path? path)))
(path->complete-path path wrt)
path)])
(let loop ([full-path orig-path][seen-paths (list orig-path)])
(let ([resolved (resolve-path full-path)])
(if (string=? resolved full-path)
(do-normalize-path resolved #f)
(let ([path (if (relative-path? resolved)
(build-path
(let-values ([(base name dir?) (split-path full-path)])
base)
resolved)
resolved)])
(if (member path seen-paths)
(error 'normalize-path "circular reference at ~s" path)
(let ([spath
;; Use simplify-path to get rid of ..s, which can
;; allow the path to grow indefinitely in a cycle.
;; An exception must mean a cycle of links.
(with-handlers ([not-break-exn?
(lambda (x)
(error 'normalize-path "circular reference at ~s" path))])
(simplify-path path))])
(loop spath (cons path seen-paths))))))))))]
[resolve
(lambda (path)
(if (string=? path (resolve-path path))
path
(resolve-all path #f)))]
[normalize-path
(case-lambda
[(orig-path) (do-normalize-path orig-path (current-directory))]
[(orig-path wrt)
(unless (complete-path? wrt)
(raise-type-error 'normalize-path "complete path" wrt))
(do-normalize-path orig-path wrt)])]
[error-not-a-dir
(lambda (path)
(error 'normalize-path
"~s (within the input path) is not a directory or does not exist"
path))]
[do-normalize-path
(lambda (orig-path wrt)
(let normalize ([path (expand-path orig-path)])
(let-values ([(base name dir?) (split-path path)])
(cond
[(eq? name 'up)
(let up ([base (if (eq? base 'relative)
wrt
(resolve-all base wrt))])
(if (directory-exists? base)
(let-values ([(prev name dir?) (split-path base)])
(cond
[(not prev)
(error 'normalize-path
"root has no parent directory: ~s"
orig-path)]
[else
(let ([prev
(if (eq? prev 'relative)
wrt
(normalize prev))])
(cond
[(eq? name 'same) (up prev)]
[(eq? name 'up) (up (up prev))]
[else prev]))]))
(error-not-a-dir base)))]
[(eq? name 'same)
(cond
[(eq? base 'relative) wrt]
[else (let ([n (normalize base)])
(if (directory-exists? n)
n
(error-not-a-dir n)))])]
[else
(cond
[(not base) (path->complete-path path)]
[else (let* ([base (if (eq? base 'relative)
(normalize wrt)
(normalize base))]
[path (if (directory-exists? base)
(build-path base name)
(error-not-a-dir base))]
[resolved (expand-path (resolve path))])
(cond
[(relative-path? resolved)
(normalize (build-path base resolved))]
[(complete-path? resolved)
resolved]
[else (path->complete-path resolved base)]))])]))))])
normalize-path))
; Argument must be in normal form
(define explode-path
(lambda (orig-path)
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(if (or (and base
(not (string? base)))
(not (string? name)))
(error 'explode-path "input was not in normal form: ~s" orig-path))
(if base
(loop base (cons name rest))
(cons name rest))))))
; Arguments must be in normal form
(define find-relative-path
(lambda (directory filename)
(let ([dir (explode-path directory)]
[file (explode-path filename)])
(if (string=? (normal-case-path (car dir))
(normal-case-path (car file)))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond
[(null? dir) (if (null? file) filename (apply build-path file))]
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(string=? (normal-case-path (car dir))
(normal-case-path (car file)))
(loop (cdr dir) (cdr file))]
[else
(apply build-path
(append (map (lambda (x) 'up) dir)
file))]))
filename))))
(define file-name-from-path
(lambda (name)
(let-values ([(base file dir?) (split-path name)])
(if (and (not dir?) (string? file))
file
#f))))
(define path-only
(lambda (name)
(let-values ([(base file dir?) (split-path name)])
(cond
[dir? name]
[(string? base) base]
[else #f]))))
;; name can be any string; we just look for a dot
(define filename-extension
(lambda (name)
(let* ([len (string-length name)]
[extension
(let loop ([p (sub1 len)])
(cond
[(negative? p) #f]
[(char=? (string-ref name p) #\.)
(substring name (add1 p) len)]
[else (loop (sub1 p))]))])
extension)))
(define (delete-directory/files path)
(cond
[(or (link-exists? path) (file-exists? path))
(unless (delete-file path)
(error 'delete-directory/files
"error deleting file or link: ~a" path))]
[(directory-exists? path)
(for-each (lambda (e) (delete-directory/files (build-path path e)))
(directory-list path))
(unless (delete-directory path)
(error 'delete-directory/files
"error deleting a directory: ~a" path))]
[else (error 'delete-directory/files
"encountered ~a, neither a file nor a directory"
path)]))
(define (make-directory* dir)
(let-values ([(base name dir?) (split-path dir)])
(when (and (string? base)
(not (directory-exists? base)))
(make-directory* base))
(make-directory dir)))
(define make-temporary-file
(case-lambda
[(template)
(with-handlers ([not-break-exn?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
template))])
(format template void))
(let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)][ms (current-milliseconds)])
(let ([name (build-path tmpdir (format template (format "~a~a" s ms)))])
(with-handlers ([exn:i/o:filesystem? (lambda (x)
(if (eq? (exn:i/o:filesystem-detail x)
'already-exists)
;; try again with a new name
(loop (- s (random 10))
(+ ms (random 10)))
;; It's something else; give up
(raise x)))])
(close-output-port (open-output-file name))
name))))]
[() (make-temporary-file "mztmp~a")]))
(define find-library
(case-lambda
[(name) (find-library name "mzlib")]
[(name collection . cp)
(let ([dir (with-handlers ([not-break-exn? (lambda (exn) #f)])
(apply collection-path collection cp))])
(if dir
(let ([file (build-path dir name)])
(if (file-exists? file)
file
#f))
#f))]))
(define with-input-from-file*
(lambda (file thunk . flags)
(let ([p (apply open-input-file file flags)])
(parameterize ([current-input-port p])
(dynamic-wind
void
thunk
(lambda () (close-input-port p)))))))
(define with-output-to-file*
(lambda (file thunk . flags)
(let ([p (apply open-output-file file flags)])
(parameterize ([current-output-port p])
(dynamic-wind
void
thunk
(lambda () (close-output-port p)))))))
(define call-with-input-file*
(lambda (file thunk . flags)
(let ([p (apply open-input-file file flags)])
(dynamic-wind
void
(lambda () (thunk p))
(lambda () (close-input-port p))))))
(define call-with-output-file*
(lambda (file thunk . flags)
(let ([p (apply open-output-file file flags)])
(dynamic-wind
void
(lambda () (thunk p))
(lambda () (close-output-port p)))))))

76
collects/mzlib/functior.ss
View File

@ -2,35 +2,6 @@
mzlib:function^
(import)
(define true #t)
(define false #f)
(define identity (polymorphic (lambda (x) x)))
(define compose
(polymorphic
(case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g)
(let ([f (compose f)]
[g (compose g)])
(if (eqv? 1 (arity f)) ; optimize: don't use call-w-values
(if (eqv? 1 (arity g)) ; optimize: single arity everywhere
(lambda (x) (f (g x)))
(lambda args (f (apply g args))))
(if (eqv? 1 (arity g)) ; optimize: single input
(lambda (a)
(call-with-values
(lambda () (g a))
f))
(lambda args
(call-with-values
(lambda () (apply g args))
f)))))]
[(f . more)
(let ([m (apply compose more)])
(compose f m))])))
(define quicksort
(polymorphic
(lambda (l less-than)
@ -290,53 +261,6 @@
(raise-type-error 'set-rest! "second argument must be a list" v))
(set-cdr! x v))))
(define build-string
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-string "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-string "~s must be a procedure" fcn))
(let ((str (make-string n)))
(let loop ((i 0))
(if (= i n)
str
(begin
(string-set! str i (fcn i))
(loop (add1 i))))))))
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
(define build-vector
(polymorphic
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-vector "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-vector "~s must be a procedure" fcn))
(let ((vec (make-vector n)))
(let loop ((i 0))
(if (= i n) vec
(begin
(vector-set! vec i (fcn i))
(loop (add1 i)))))))))
(define build-list
(polymorphic
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-list "~s must be an exact integer >= 0" n))
(unless (procedure? fcn)
(error 'build-list "~s must be a procedure" fcn))
(if (zero? n) '()
(let ([head (list (fcn 0))])
(let loop ([i 1] [p head])
(if (= i n) head
(begin
(set-cdr! p (list (fcn i)))
(loop (add1 i) (cdr p))))))))))
(define loop-until
(polymorphic
(lambda (start done? next body)