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

guide and reference work; change opt-lambda to use lambda/kw and hack in keyword support for documentation purposes, along with define-opt

Browse Source 
svn: r6572

original commit: 32e91015944dc36313bd5662390d93e33967047e
This commit is contained in:
Matthew Flatt 2007-06-11 07:19:42 +00:00
parent 04662786e0
commit 0823deef6b
2 changed files with 81 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
collects/mzlib/etc.ss
View File

@ -1,7 +1,8 @@
(module etc mzscheme
(require (lib "main-collects.ss" "setup"))
(require (lib "main-collects.ss" "setup")
"kw.ss")
(require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax")
@ -23,6 +24,7 @@
loop-until
opt-lambda
define-opt
local
recur
@ -129,52 +131,82 @@
(eq? x y))
(define-syntax (opt-lambda stx)
(with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))])
(syntax-case stx ()
[(_ args body1 body ...)
(let ([clauses (let loop ([pre-args null]
[args (syntax args)]
[needs-default? #f])
(syntax-case args ()
[id
(identifier? (syntax id))
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ... . id)
body1 body ...])))]
[()
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ...)
body1 body ...])))]
[(id . rest)
(identifier? (syntax id))
(begin
(when needs-default?
(raise-syntax-error
#f "default value missing" stx (syntax id)))
(loop (append pre-args (list (syntax id)))
(syntax rest)
#f))]
[([id default] . rest)
(identifier? (syntax id))
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
(syntax rest)
#t)]
[(pre-arg ...) pre-args])
(syntax ([(pre-arg ...) (name pre-arg ... default)]
. rest)))]
[(bad . rest)
(raise-syntax-error
#f
"not an identifier or identifier with default"
stx
(syntax bad))]
[else
(raise-syntax-error
#f "bad identifier sequence" stx (syntax args))]))])
(with-syntax ([clauses clauses])
(syntax/loc stx
(letrec ([name (case-lambda . clauses)]) name))))])))
(syntax-case stx ()
[(_ args body1 body ...)
(with-syntax ([((plain ...) (opt ...) (kw ...) need-kw rest)
(let loop ([args (syntax args)]
[needs-default? #f])
(syntax-case args ()
[id
(identifier? (syntax id))
#'(() () () () (#:body id))]
[()
#'(() () () () ())]
[(id . rest)
(identifier? (syntax id))
(begin
(when needs-default?
(raise-syntax-error
#f "default value missing" stx (syntax id)))
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest #f)])
#'((id . plain) opts kws need-kw rest)))]
[([id default] . rest)
(identifier? (syntax id))
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest #t)])
#'(plain ([id default] . opts) kws need-kw rest))]
[(kw id . rest)
(and (identifier? #'id)
(keyword? (syntax-e #'kw)))
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest needs-default?)])
#'(plain opts ([id kw #f] . kws) (kw . need-kw) rest))]
[(kw [id default] . rest)
(and (identifier? #'id)
(keyword? (syntax-e #'kw)))
(with-syntax ([(plain opts kws need-kw rest) (loop #'rest needs-default?)])
#'(plain opts ([id kw default] . kws) need-kw rest))]
[(bad . rest)
(raise-syntax-error
#f
"not an identifier or identifier with default"
stx
(syntax bad))]
[else
(raise-syntax-error
#f "bad identifier sequence" stx (syntax args))]))])
(let ([kw-proc (syntax/loc stx
(lambda/kw [plain ... #:optional opt ... #:key kw ... . rest] body1 body ...))])
(if (null? (syntax-e #'(kw ...)))
kw-proc
(with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))]
[kw-proc kw-proc]
[len (length (syntax->list #'(plain ...)))])
(syntax/loc stx
(let ([name kw-proc])
(lambda all-args
(apply name (sort-kws len 'need-kw all-args)))))))))]))
(define-syntax define-opt
(syntax-rules ()
[(_ (id . args) body1 body ...)
(define id (opt-lambda args body1 body ...))]
[(_ . rest) (define . rest)]))
(define (sort-kws len need-kw l)
(for-each (lambda (kw)
(unless (memq kw l)
(error "missing required argument for" kw)))
need-kw)
(let loop ([len len][l l][kws null])
(cond
[(null? l) (append kws l)]
[(zero? len) (append kws l)]
[(and (keyword? (car l))
(pair? (cdr l)))
(loop len (cddr l) (list* (car l)
(cadr l)
kws))]
[else (cons (car l) (loop (sub1 len) (cdr l) kws))])))
(define-syntax (local stx)
(syntax-case stx ()

2
collects/mzlib/for.ss
View File

@ -8,6 +8,8 @@
for/or for*/or
for/first for*/first
for/last for*/last
for/fold/derived for*/fold/derived
(rename *in-range in-range)
(rename *in-naturals in-naturals)