diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss index 6b0669cecc..e2cef22c83 100644 --- a/collects/mzlib/kw.ss +++ b/collects/mzlib/kw.ss @@ -256,7 +256,8 @@ ;; ------------------------------------------------------------------------ ;; generates the part of the body that deals with rest-related stuff (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] [rest* rest*] [body* body*] @@ -267,28 +268,46 @@ [other-keys+body* other-keys+body] [seen-keys #'seen-keys]) (with-syntax - ([loop-vars - #`([body* rest*] - #,@(if all-keys #`([all-keys* '()]) '()) - #,@(if others? #`([other-keys* '()]) '()) - #,@(if allow-duplicate-keys? '() #`([seen-keys '()])))] + ([loop-vars #`([body* rest*] + #,@(if all-keys #`([all-keys* '()]) '()) + #,@(if others? #`([other-keys* '()]) '()) + #,@(if track-seen? #`([seen-keys '()]) '()))] [next-loop - #`(loop (cddr body*) - #,@(if all-keys - #`((list* (cadr body*) (car body*) all-keys*)) - '()) - #,@(if others? - #`((if (memq (car body*) 'keywords) - other-keys* - (list* (cadr body*) (car body*) other-keys*))) - '()) - #,@(if allow-duplicate-keys? - '() - #`((if (and (memq (car body*) seen-keys) - (memq (car body*) 'keywords)) - (error* 'name "duplicate keyword: ~e" - (car body*)) - (cons (car body*) seen-keys)))))] + (let ([nl #`(loop + (cddr body*) + #,@(if all-keys + #`((list* (cadr body*) (car body*) all-keys*)) + '()) + #,@(if others? + #`((if (and in-keys? (not in-seen?)) + other-keys* + (list* (cadr body*) (car body*) + other-keys*))) + '()) + #,@(if track-seen? + #`((if (and in-seen? in-keys?) + #,(if allow-duplicate-keys? + #`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 (if (or all-keys others?) #`(let* (#,@(if all-keys @@ -306,43 +325,34 @@ [else '()])) 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) - (not other-keys+body) (not all-keys) (not other-keys)) - ;; allowing anything and don't need special rests, so no loop - #'expr - ;; normal code - #`(let loop loop-vars - (if (and (pair? body*) (keyword? (car body*)) - #,@(if allow-anything? #'((pair? (cdr body*))) '())) - #,(if allow-anything? ; already checker pair? above - #'next-loop - #'(if (pair? (cdr body*)) - next-loop - (error* 'name "keyword list not balanced: ~e" - rest*))) - #,(if allow-body? - (if (and body (not (identifier? body))) - (with-syntax ([name (string->symbol - (format "~a~~body" - (syntax-e* #'name)))]) - (with-syntax ([subcall - (quasisyntax/loc stx - (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*))))))))))) + (if (and allow-anything? (not body) + (not other-keys+body) (not all-keys) (not other-keys)) + ;; allowing anything and don't need special rests, so no loop + #'expr + ;; normal code + #`(let loop loop-vars + (if (and (pair? body*) (keyword? (car body*)) + #,@(if allow-anything? #'((pair? (cdr body*))) '())) + #,(if allow-anything? ; already checker pair? above + #'next-loop + #'(if (pair? (cdr body*)) + next-loop + (error* 'name "keyword list not balanced: ~e" rest*))) + #,(if allow-body? + (if (and body (not (identifier? body))) + (with-syntax ([name (string->symbol + (format "~a~~body" + (syntax-e* #'name)))]) + (with-syntax ([subcall + (quasisyntax/loc stx + (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 (define (make-keys-body expr) diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index 0f310c098e..2e60656633 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -134,11 +134,19 @@ (let ([f (lambda/kw (#:key a b #:other-keys r #:allow-duplicate-keys) r)]) (t (f) => '() (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 #: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 #: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)]) (t (f) => '() (f 1 2) => '(1 2) @@ -158,8 +166,8 @@ (f 1 2) => '(1 2) (f #:a 1 #:b 2) => '() (f #:a 1 #:b 2 1 2) => '(1 2) - (f #:a 1 #:a 2 #:b 3) => '() - (f #:a 1 #:a 2 #:b 3 1 2) => '(1 2) + (f #:a 1 #:a 2 #:b 3) => '(#:a 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 1 2) => '(#:c 3 1 2) (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 #:other-keys+body r) 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 (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) 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) 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 (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) @@ -296,19 +306,26 @@ :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 #:rest r #:optional o) 1) - :st-err: <= (lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 1) - :st-err: <= (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-other-keys #:allow-other-keys) 1) + :st-err: <= + (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 #:allow-body #:forbid-body) 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 (#: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-duplicate-keys #:allow-anything) 1) - :st-err: <= (lambda/kw (#:key a #:forbid-body #: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 (x #:rest r1 #:rest r2) 1) :st-err: <= (lambda/kw (x #:rest) 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 #: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 #: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 (#:key a #:body r #:forbid-body) r) :st-err: <= (lambda/kw (#:key a #:other-keys r #:forbid-other-keys) r))