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

allow #:body without #:keys

Browse Source 
svn: r4431

original commit: 821135354b2fec54ed11054e917c150abb7a472c
This commit is contained in:
Eli Barzilay 2006-09-25 13:00:28 +00:00
commit eaa4136d7d
2 changed files with 29 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mzlib/kw.ss
View File

@ -225,7 +225,7 @@
[(memq k mode-keywords)
(cond
#; ;(*)
;; don't throw an error here, it still fine if used with
;; don't throw an error here, it is still fine if used with
;; #:allow-other-keys (explicit or implicit), also below
[(and (null? keys) (null? flags))
(serror k-stx "cannot use without #:key/#:flag arguments")]
@ -420,24 +420,31 @@
#'(begin flag-tweaks keys-body)))))
;; ------------------------------------------------------------------------
;; more sanity tests (see commented code above -- search for "(*)")
(let ([r (or all-keys other-keys other-keys+body body rest)])
(when (and (not allow-other-keys?) (null? keys))
(when r
(serror r "cannot use without #:key, #:flag, or #:allow-other-keys"))
(when allow-duplicate-keys?
(serror #f (string-append "cannot allow duplicate keys without"
" #:key, #:flag, or #:allow-other-keys"))))
(when (and allow-other-keys? (null? keys) (not r))
(serror #f "cannout allow other keys without using them in some way")))
(when (null? keys)
(let ([r (or all-keys other-keys other-keys+body body rest)])
(if allow-other-keys?
;; allow-other-keys?
(unless r
(serror #f "cannout allow other keys ~a"
"without using them in some way"))
;; (not allow-other-keys?)
(begin
;; can use #:body with no keys to forbid all keywords
(when (and r (not (eq? r body)))
(serror r "cannot use without #:key, #:flag, or ~a"
"#:allow-other-keys"))
(when allow-duplicate-keys?
(serror #f "cannot allow duplicate keys without ~a"
"#:key, #:flag, or #:allow-other-keys"))))))
;; ------------------------------------------------------------------------
;; body generation starts here
(cond
;; no optionals or keys (or other-keys) => plain lambda
[(and (null? opts) (null? keys) (not allow-other-keys?))
;; no optionals or keys (or body or other-keys) => plain lambda
[(and (null? opts) (null? keys) (not (or body allow-other-keys?)))
(with-syntax ([vars (append! vars (or rest '()))] [expr expr])
(syntax/loc stx (lambda vars expr)))]
;; no keys => make a case-lambda for optionals
[(and (null? keys) (not allow-other-keys?))
[(and (null? keys) (not (or body allow-other-keys?)))
(let ([clauses (make-opt-clauses expr (or rest '()))])
(with-syntax ([name name] [clauses clauses])
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]

10
collects/tests/mzscheme/kw.ss
View File

@ -313,6 +313,14 @@
#:x 1 #:z))
(t '(#:z) <= ((lambda/kw (#:key x #:allow-anything #:body r) r) #:x 1 #:z))
;; #:body without #:keys forbids all keys
(let ([f1 (lambda/kw (#:body b) b)]
[f2 (lambda/kw (x #:body b) (cons x b))])
(t (f1 1 2) => '(1 2)
(f2 1 2) => '(1 2)
(f1 #:foo 1 1 2) => :rt-err:
(f2 1 #:foo 1 2) => :rt-err:))
;; make sure that internal definitions work
(let ([f (lambda/kw (#:key x) (define xx x) xx)])
(t #f <= (f)
@ -349,7 +357,7 @@
:st-err: <= (lambda/kw (x #:rest r1 #:rest r2) 1)
:st-err: <= (lambda/kw (x #:rest) 1)
:st-err: <= (lambda/kw (x #:rest r1 r2) 1)
:st-err: <= (lambda/kw (x #:body b) 1)
;; :st-err: <= (lambda/kw (x #:body b) 1) ; valid!
:st-err: <= (lambda/kw (x x) 1)
:st-err: <= (lambda/kw (x #:optional [x 1]) 1)
:st-err: <= (lambda/kw (x #:key [x 1]) 1)