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

128
collects/mzlib/kw.ss
View File

@ -256,7 +256,8 @@
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; 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 track-seen? #`([seen-keys '()]) '()))]
#,@(if allow-duplicate-keys? '() #`([seen-keys '()])))]
[next-loop [next-loop
#`(loop (cddr body*) (let ([nl #`(loop
#,@(if all-keys (cddr body*)
#`((list* (cadr body*) (car body*) all-keys*)) #,@(if all-keys
'()) #`((list* (cadr body*) (car body*) all-keys*))
#,@(if others? '())
#`((if (memq (car body*) 'keywords) #,@(if others?
other-keys* #`((if (and in-keys? (not in-seen?))
(list* (cadr body*) (car body*) other-keys*))) other-keys*
'()) (list* (cadr body*) (car body*)
#,@(if allow-duplicate-keys? other-keys*)))
'() '())
#`((if (and (memq (car body*) seen-keys) #,@(if track-seen?
(memq (car body*) 'keywords)) #`((if (and in-seen? in-keys?)
(error* 'name "duplicate keyword: ~e" #,(if allow-duplicate-keys?
(car body*)) #`seen-keys
(cons (car body*) seen-keys)))))] #`(error* 'name "duplicate keyword: ~e"
(car body*)))
(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,43 +325,34 @@
[else '()])) [else '()]))
expr) expr)
#'expr)]) #'expr)])
(with-syntax ([next-loop (if (and allow-anything? (not body)
(if allow-other-keys? (not other-keys+body) (not all-keys) (not other-keys))
#'next-loop ;; allowing anything and don't need special rests, so no loop
#'(if (memq (car body*) 'keywords) #'expr
next-loop ;; normal code
(error* 'name "unknown keyword: ~e" #`(let loop loop-vars
(car body*))))]) (if (and (pair? body*) (keyword? (car body*))
(if (and allow-anything? (not body) #,@(if allow-anything? #'((pair? (cdr body*))) '()))
(not other-keys+body) (not all-keys) (not other-keys)) #,(if allow-anything? ; already checker pair? above
;; allowing anything and don't need special rests, so no loop #'next-loop
#'expr #'(if (pair? (cdr body*))
;; normal code next-loop
#`(let loop loop-vars (error* 'name "keyword list not balanced: ~e" rest*)))
(if (and (pair? body*) (keyword? (car body*)) #,(if allow-body?
#,@(if allow-anything? #'((pair? (cdr body*))) '())) (if (and body (not (identifier? body)))
#,(if allow-anything? ; already checker pair? above (with-syntax ([name (string->symbol
#'next-loop (format "~a~~body"
#'(if (pair? (cdr body*)) (syntax-e* #'name)))])
next-loop (with-syntax ([subcall
(error* 'name "keyword list not balanced: ~e" (quasisyntax/loc stx
rest*))) (let ([name (lambda/kw #,body expr)])
#,(if allow-body? name))])
(if (and body (not (identifier? body))) #'(apply subcall body*)))
(with-syntax ([name (string->symbol #'expr)
(format "~a~~body" #'(if (null? body*)
(syntax-e* #'name)))]) expr
(with-syntax ([subcall (error* 'name "expecting a ~s keyword got: ~e"
(quasisyntax/loc stx 'keywords (car body*))))))))))
(let ([name (lambda/kw #,body
expr)])
name))])
#'(apply subcall body*)))
#'expr)
#'(if (null? body*)
expr
(error* 'name "expecting a ~s keyword got: ~e"
'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))