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

other-keys now includes duplicates of specified keys

Browse Source 
(if duplicates are allowed)

svn: r1149
This commit is contained in:
Eli Barzilay 2005-10-25 00:58:37 +00:00
parent 9ef65a4a80
commit 8a425d27a6
2 changed files with 101 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/mzlib/kw.ss
View File

@ -257,6 +257,7 @@
;; 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-rest-body expr) (define (make-rest-body expr)
(define others? (or other-keys other-keys+body)) (define others? (or other-keys other-keys+body))
(define track-seen? (or others? (not allow-duplicate-keys?)))
(with-syntax ([name name] (with-syntax ([name name]
[rest* rest*] [rest* rest*]
[body* body*] [body* body*]
@ -267,28 +268,46 @@
[other-keys+body* other-keys+body] [other-keys+body* other-keys+body]
[seen-keys #'seen-keys]) [seen-keys #'seen-keys])
(with-syntax (with-syntax
([loop-vars ([loop-vars #`([body* rest*]
#`([body* rest*]
#,@(if all-keys #`([all-keys* '()]) '()) #,@(if all-keys #`([all-keys* '()]) '())
#,@(if others? #`([other-keys* '()]) '()) #,@(if others? #`([other-keys* '()]) '())
#,@(if allow-duplicate-keys? '() #`([seen-keys '()])))] #,@(if track-seen? #`([seen-keys '()]) '()))]
[next-loop [next-loop
#`(loop (cddr body*) (let ([nl #`(loop
(cddr body*)
#,@(if all-keys #,@(if all-keys
#`((list* (cadr body*) (car body*) all-keys*)) #`((list* (cadr body*) (car body*) all-keys*))
'()) '())
#,@(if others? #,@(if others?
#`((if (memq (car body*) 'keywords) #`((if (and in-keys? (not in-seen?))
other-keys* other-keys*
(list* (cadr body*) (car body*) other-keys*))) (list* (cadr body*) (car body*)
other-keys*)))
'()) '())
#,@(if allow-duplicate-keys? #,@(if track-seen?
'() #`((if (and in-seen? in-keys?)
#`((if (and (memq (car body*) seen-keys) #,(if allow-duplicate-keys?
(memq (car body*) 'keywords)) #`seen-keys
(error* 'name "duplicate keyword: ~e" #`(error* 'name "duplicate keyword: ~e"
(car body*)) (car body*)))
(cons (car body*) seen-keys)))))] (cons (car body*) seen-keys)))
'()))])
(cond
[(or track-seen? others?)
#`(let ([in-keys? (memq (car body*) 'keywords)]
[in-seen? (memq (car body*) seen-keys)])
#,(if allow-other-keys?
nl
#`(if in-keys?
#,nl
(error* 'name "unknown keyword: ~e"
(car body*)))))]
[(not allow-other-keys?)
#`(if (memq (car body*) 'keywords)
#,nl
(error* 'name "unknown keyword: ~e"
(car body*)))]
[else nl]))]
[expr [expr
(if (or all-keys others?) (if (or all-keys others?)
#`(let* (#,@(if all-keys #`(let* (#,@(if all-keys
@ -306,13 +325,6 @@
[else '()])) [else '()]))
expr) expr)
#'expr)]) #'expr)])
(with-syntax ([next-loop
(if allow-other-keys?
#'next-loop
#'(if (memq (car body*) 'keywords)
next-loop
(error* 'name "unknown keyword: ~e"
(car body*))))])
(if (and allow-anything? (not body) (if (and allow-anything? (not body)
(not other-keys+body) (not all-keys) (not other-keys)) (not other-keys+body) (not all-keys) (not other-keys))
;; allowing anything and don't need special rests, so no loop ;; allowing anything and don't need special rests, so no loop
@ -325,8 +337,7 @@
#'next-loop #'next-loop
#'(if (pair? (cdr body*)) #'(if (pair? (cdr body*))
next-loop next-loop
(error* 'name "keyword list not balanced: ~e" (error* 'name "keyword list not balanced: ~e" rest*)))
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
@ -334,15 +345,14 @@
(syntax-e* #'name)))]) (syntax-e* #'name)))])
(with-syntax ([subcall (with-syntax ([subcall
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([name (lambda/kw #,body (let ([name (lambda/kw #,body expr)])
expr)])
name))]) name))])
#'(apply subcall body*))) #'(apply subcall body*)))
#'expr) #'expr)
#'(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*))))))))))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; 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)

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

@ -134,11 +134,19 @@
(let ([f (lambda/kw (#:key a b #:other-keys r #:allow-duplicate-keys) r)]) (let ([f (lambda/kw (#:key a b #:other-keys r #:allow-duplicate-keys) r)])
(t (f) => '() (t (f) => '()
(f #:a 1 #:b 2) => '() (f #:a 1 #:b 2) => '()
(f #:a 1 #:a 2 #:b 3) => '() (f #:b 1 #:a 2) => '()
(f #:a 1 #:b 2 #:c 3) => '(#:c 3) (f #:a 1 #:b 2 #:c 3) => '(#:c 3)
(f #:a 1 #:c 2 #:b 3) => '(#:c 2)
(f #:c 1 #:a 2 #:b 3) => '(#:c 1)
(f #:a 1 #:a 2 #:b 3) => '(#:a 2)
(f #:a 1 #:b 2 #:c 3) => '(#:c 3)
(f #:a 1 #:a 2 #:b 3 #:a 4) => '(#:a 2 #:a 4)
(f #:a 1 #:a 2 #:b 3 #:b 4 #:a 5) => '(#:a 2 #:b 4 #:a 5)
(f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3) (f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3)
(f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33) (f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33))) (f #:d 4 #:a 1 #:b 2 #:a 3 #:c 33) => '(#:d 4 #:a 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:a 2 #:c 33) => '(#:d 4 #:c 3 #:a 2 #:c 33)))
(let ([f (lambda/kw (#:key a b #:other-keys+body r) r)]) (let ([f (lambda/kw (#:key a b #:other-keys+body r) r)])
(t (f) => '() (t (f) => '()
(f 1 2) => '(1 2) (f 1 2) => '(1 2)
@ -158,8 +166,8 @@
(f 1 2) => '(1 2) (f 1 2) => '(1 2)
(f #:a 1 #:b 2) => '() (f #:a 1 #:b 2) => '()
(f #:a 1 #:b 2 1 2) => '(1 2) (f #:a 1 #:b 2 1 2) => '(1 2)
(f #:a 1 #:a 2 #:b 3) => '() (f #:a 1 #:a 2 #:b 3) => '(#:a 2)
(f #:a 1 #:a 2 #:b 3 1 2) => '(1 2) (f #:a 1 #:a 2 #:b 3 1 2) => '(#:a 2 1 2)
(f #:a 1 #:b 2 #:c 3) => '(#:c 3) (f #:a 1 #:b 2 #:c 3) => '(#:c 3)
(f #:a 1 #:b 2 #:c 3 1 2) => '(#:c 3 1 2) (f #:a 1 #:b 2 #:c 3 1 2) => '(#:c 3 1 2)
(f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3) (f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3)
@ -184,14 +192,16 @@
1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:b 2)
1 <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:b 2)
1 <= ((lambda/kw (#:key a #:allow-other-keys) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:allow-other-keys) a) #:a 1 #:b 2)
:rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-other-keys) a) #:a 1 #:b 2)) :rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-other-keys) a)
#:a 1 #:b 2))
;; check when duplicate keys are allowed ;; check when duplicate keys are allowed
(t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:a 2) (t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:a 2) :rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:a 2)
1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:a 2) 1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:a 2) :rt-err: <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:a 2)
1 <= ((lambda/kw (#:key a #:allow-duplicate-keys) a) #:a 1 #:a 2) 1 <= ((lambda/kw (#:key a #:allow-duplicate-keys) a) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-duplicate-keys) a) #:a 1 #:a 2)) :rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-duplicate-keys) a)
#:a 1 #:a 2))
;; check when body is allowed ;; check when body is allowed
(t :rt-err: <= ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3) (t :rt-err: <= ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3)
:rt-err: <= ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3 4) :rt-err: <= ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3 4)
@ -296,19 +306,26 @@
:st-err: <= (lambda/kw (x #:key k #:optional o) 1) :st-err: <= (lambda/kw (x #:key k #:optional o) 1)
:st-err: <= (lambda/kw (x #:optional k #:optional o) 1) :st-err: <= (lambda/kw (x #:optional k #:optional o) 1)
:st-err: <= (lambda/kw (x #:rest r #:optional o) 1) :st-err: <= (lambda/kw (x #:rest r #:optional o) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 1) :st-err: <=
:st-err: <= (lambda/kw (x #:rest r #:allow-other-keys #:forbid-other-keys) 1) (lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-duplicate-keys #:allow-duplicate-keys) 1) :st-err: <=
:st-err: <= (lambda/kw (x #:rest r #:allow-duplicate-keys #:forbid-duplicate-keys) 1) (lambda/kw (x #:rest r #:allow-other-keys #:forbid-other-keys) 1)
:st-err: <=
(lambda/kw (x #:rest r #:forbid-duplicate-keys #:allow-duplicate-keys) 1)
:st-err: <=
(lambda/kw (x #:rest r #:allow-duplicate-keys #:forbid-duplicate-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-body #:allow-body) 1) :st-err: <= (lambda/kw (x #:rest r #:forbid-body #:allow-body) 1)
:st-err: <= (lambda/kw (x #:rest r #:allow-body #:forbid-body) 1) :st-err: <= (lambda/kw (x #:rest r #:allow-body #:forbid-body) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-anything #:allow-anything) 1) :st-err: <= (lambda/kw (x #:rest r #:forbid-anything #:allow-anything) 1)
: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 #: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: <=
:st-err: <= (lambda/kw (#:key a #:forbid-body #:allow-anything) 1) (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 (x #:rest r1 #:rest r2) 1) :st-err: <= (lambda/kw (x #:rest r1 #:rest r2) 1)
:st-err: <= (lambda/kw (x #:rest) 1) :st-err: <= (lambda/kw (x #:rest) 1)
:st-err: <= (lambda/kw (x #:rest r1 r2) 1) :st-err: <= (lambda/kw (x #:rest r1 r2) 1)
@ -344,7 +361,8 @@
:st-err: <= (lambda/kw (x #:key y #:allow-other-keys z) 1) :st-err: <= (lambda/kw (x #:key y #:allow-other-keys z) 1)
:st-err: <= (lambda/kw (x #:key y #:forbid-body z) 1) :st-err: <= (lambda/kw (x #:key y #:forbid-body z) 1)
:st-err: <= (lambda/kw (x #:key y #:allow-body #:rest r #:forbid-body) 1) :st-err: <= (lambda/kw (x #:key y #:allow-body #:rest r #:forbid-body) 1)
:st-err: <= (lambda/kw (x #:key y #:forbid-other-keys #:rest r #:allow-other-keys) 1) :st-err: <=
(lambda/kw (x #:key y #:forbid-other-keys #:rest r #:allow-other-keys) 1)
:st-err: <= (lambda/kw (x #:key y z #:body (x)) x) :st-err: <= (lambda/kw (x #:key y z #:body (x)) x)
:st-err: <= (lambda/kw (#:key a #:body r #:forbid-body) r) :st-err: <= (lambda/kw (#:key a #:body r #:forbid-body) r)
:st-err: <= (lambda/kw (#:key a #:other-keys r #:forbid-other-keys) r)) :st-err: <= (lambda/kw (#:key a #:other-keys r #:forbid-other-keys) r))