other-keys now includes duplicates of specified keys
(if duplicates are allowed) svn: r1149
This commit is contained in:
Eli Barzilay
parent
9ef65a4a80
commit
8a425d27a6
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user