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

...

Browse Source 
original commit: 56a403ddafeea80e869c98c96fd52d386dd7806c
This commit is contained in:
Robby Findler 2001-03-01 17:49:32 +00:00
parent 1cf77786c1
commit 08a9a0c818
1 changed files with 20 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mzlib/etc.ss
View File

@ -14,6 +14,8 @@
loop-until
opt-lambda
local
recur
rec
@ -125,7 +127,7 @@
(define-syntax opt-lambda
(lambda (stx)
(with-syntax ([loop (or (syntax-local-name)
(with-syntax ([name (or (syntax-local-name)
(quote-syntax opt-lambda-proc))])
(syntax-case stx ()
[(_ args body1 body ...)
@ -138,10 +140,14 @@
(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
(unless needs-default?
(when needs-default?
(raise-syntax-error
'opt-lambda
"default value missing"
@ -152,12 +158,12 @@
#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)))]
(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
'opt-lambda
@ -170,11 +176,12 @@
"bad identifier sequence"
stx
(syntax args))]))])
(syntax/loc stx
(letrec ([loop
(case-lambda
. clauses)])
loop)))]))))
(with-syntax ([clauses clauses])
(syntax/loc stx
(letrec ([name
(case-lambda
. clauses)])
name))))]))))
(define-syntax local
(lambda (stx)