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

#:allow-anything can be used with any rest-like, simply treats a last

Browse Source 
imbalanced keyword as the beginning of the body

svn: r1141
This commit is contained in:
Eli Barzilay 2005-10-24 11:24:41 +00:00
parent 0b1034dcf8
commit 1cf3559d0c
2 changed files with 15 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/mzlib/kw.ss
View File

@ -311,12 +311,20 @@
next-loop next-loop
(error* 'name "unknown keyword: ~e" (error* 'name "unknown keyword: ~e"
(car body*))))]) (car body*))))])
(if (not allow-anything?) ; normal code (if (and allow-anything?
(not body) (not rest-keys) (not all-keys) (not other-keys))
;; allowing anything and don't need special rests, so no loop
#'expr
;; normal code
#`(let loop loop-vars #`(let loop loop-vars
(if (and (pair? body*) (keyword? (car body*))) (if (and (pair? body*) (keyword? (car body*))
(if (pair? (cdr body*)) #,@(if allow-anything? #'((pair? (cdr body*))) '()))
next-loop #,(if allow-anything? ; already checker pair? above
(error* 'name "keyword list not balanced: ~e" rest*)) #'next-loop
#'(if (pair? (cdr body*))
next-loop
(error* 'name "keyword list not balanced: ~e"
rest*)))
#,(if allow-body? #,(if allow-body?
(if (and body (not (identifier? body))) (if (and body (not (identifier? body)))
(with-syntax ([name (string->symbol (with-syntax ([name (string->symbol
@ -332,17 +340,7 @@
#'(if (null? body*) #'(if (null? body*)
expr expr
(error* 'name "expecting a ~s keyword got: ~e" (error* 'name "expecting a ~s keyword got: ~e"
'keywords (car body*)))))) 'keywords (car body*)))))))))))
;; allowing anything: can't use rest-like except for rest
(let ([bad (cond [body `(,body #:body)]
[rest-keys `(,rest-keys #:rest-keys)]
[all-keys `(,all-keys #:all-keys)]
[other-keys `(,other-keys #:other-keys)]
[else #f])])
(if bad
(serror (car bad) "cannot use #:allow-anything with ~a"
(cadr bad))
#'expr)))))))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; generates the part of the body that deals with rest-related stuff ;; generates the part of the body that deals with rest-related stuff
(define (make-keys-body expr) (define (make-keys-body expr)

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

@ -279,6 +279,7 @@
(f #:x 1 #:x 2 #:y) => 1)) (f #:x 1 #:x 2 #:y) => 1))
(t '(#:x 1 #:z) <= ((lambda/kw (#:key x #:allow-anything #:rest r) r) (t '(#:x 1 #:z) <= ((lambda/kw (#:key x #:allow-anything #:rest r) r)
#:x 1 #:z)) #:x 1 #:z))
(t '(#:z) <= ((lambda/kw (#:key x #:allow-anything #:body r) r) #:x 1 #:z))
;; make sure that internal definitions work ;; make sure that internal definitions work
(let ([f (lambda/kw (#:key x) (define xx x) xx)]) (let ([f (lambda/kw (#:key x) (define xx x) xx)])
@ -303,10 +304,6 @@
:st-err: <= (lambda/kw (x #:rest r #:allow-anything #:forbid-anything) 1) :st-err: <= (lambda/kw (x #:rest r #:allow-anything #:forbid-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1) :st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1) :st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:body r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:rest-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:all-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:other-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1) :st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1) :st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-body #:allow-anything) 1) :st-err: <= (lambda/kw (#:key a #:forbid-body #:allow-anything) 1)