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

A lot more functionality (and tests), almost complete now.

Browse Source 
svn: r1102
This commit is contained in:
Eli Barzilay 2005-10-19 07:05:22 +00:00
parent 82df8d122d
commit 1db64d4e85
2 changed files with 306 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

307
collects/mzlib/kw.ss
View File

@ -21,6 +21,14 @@
(raise-syntax-error #f (apply format fmt args) stx sub)) (raise-syntax-error #f (apply format fmt args) stx sub))
;; contents of syntax ;; contents of syntax
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x)) (define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
;; is an expression simple? (=> evaluating cannot have side effects)
(define (simple-expr? expr)
(let ([expr (local-expand expr 'expression null)]) ; expand id macros
(syntax-case expr (#%datum #%top quote)
[(#%datum . _) #t]
[(#%top . _) #t]
[(quote . _) #t]
[_ (identifier? expr)])))
;; split a list of syntax objects based on syntax keywords: ;; split a list of syntax objects based on syntax keywords:
;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...) ;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...)
(define (split-by-keywords xs) (define (split-by-keywords xs)
@ -31,6 +39,7 @@
(if (keyword? (syntax-e* x)) (if (keyword? (syntax-e* x))
(loop (cdr xs) (list x) (cons (reverse! cur) r)) (loop (cdr xs) (list x) (cons (reverse! cur) r))
(loop (cdr xs) (cons x cur) r)))))) (loop (cdr xs) (cons x cur) r))))))
;; --------------------------------------------------------------------------
;; process an optional argument spec, returns (<id> <default-expr>) ;; process an optional argument spec, returns (<id> <default-expr>)
(define (process-opt o) (define (process-opt o)
(syntax-case o () (syntax-case o ()
@ -38,6 +47,7 @@
[(var) (identifier? #'var) (list #'var #'#f)] [(var) (identifier? #'var) (list #'var #'#f)]
[var (identifier? #'var) (list #'var #'#f)] [var (identifier? #'var) (list #'var #'#f)]
[var (serror #'var "not a valid ~a spec" #:optional)])) [var (serror #'var "not a valid ~a spec" #:optional)]))
;; --------------------------------------------------------------------------
;; process a key argument spec, returns (<id> <key-stx> <default-expr>) ;; process a key argument spec, returns (<id> <key-stx> <default-expr>)
(define (process-key k) (define (process-key k)
(define (key var) (define (key var)
@ -51,7 +61,8 @@
[(var) (identifier? #'var) (list #'var (key #'var) #'#f)] [(var) (identifier? #'var) (list #'var (key #'var) #'#f)]
[var (identifier? #'var) (list #'var (key #'var) #'#f)] [var (identifier? #'var) (list #'var (key #'var) #'#f)]
[var (serror #'var "not a valid ~a spec" #:key)])) [var (serror #'var "not a valid ~a spec" #:key)]))
;; helper for parse-formals ;; --------------------------------------------------------------------------
;; helpers for process-vars
(define (get-mode mode k k-stx formals keys) (define (get-mode mode k k-stx formals keys)
(cond [(null? keys) (cond [(null? keys)
(serror k-stx "cannot use without #:key arguments")] (serror k-stx "cannot use without #:key arguments")]
@ -60,12 +71,48 @@
[(and mode (not (eq? k mode))) [(and mode (not (eq? k mode)))
(serror k-stx "contradicting mode keywords")] (serror k-stx "contradicting mode keywords")]
[else k])) [else k]))
;; helper for parse-formals (define (process-mode mode rests allow enablers)
(define (process-mode mode rests enablers)
(if mode (if mode
(eq? mode #:allow-other-keys) (eq? mode allow)
(ormap (lambda (k) (and (assq k rests) #t)) enablers))) (ormap (lambda (k) (and (assq k rests) #t)) enablers)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; test variables
(define (process-vars vars opts keys0 rests other-keys-mode body-mode)
(let*-values
([(opts keys0) (values (map process-opt opts) (map process-key keys0))]
[(other-keys-mode body-mode)
(values (process-mode other-keys-mode
rests #:allow-other-keys other-keys-accessing)
(process-mode body-mode
rests #:allow-body body-accessing))]
[(rest body rest-keys all-keys other-keys)
(apply values
(map (lambda (k) (cond [(assq k rests) => cdr] [else #f]))
'(#:rest #:body #:rest-keys #:all-keys #:other-keys)))]
[(rest* body* other-keys*) (values (or rest #'rest) (or body #'body)
(or other-keys #'other-keys))]
;; turn (<id> <key> <default>) keys to (<id> <default>)
[(keys) (with-syntax ([r rest*])
(map (lambda (k)
(list (car k)
(if (simple-expr? (caddr k))
;; simple case => no closure
#`(getarg* r #,(cadr k) #,(caddr k))
#`(getarg r #,(cadr k)
(lambda () #,(caddr k))))))
keys0))])
(let (; use identifiers from here if none given, so the tests work
[ids `(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body*
,(or rest-keys #'rest-keys)
,(or all-keys #'all-keys) ,(or other-keys #'other-keys))])
(cond [(ormap (lambda (x) (and (not (identifier? x)) x)) ids)
=> (lambda (d) (serror d "not an identifier"))]
[(check-duplicate-identifier ids)
=> (lambda (d) (serror d "duplicate argument name"))]))
(values vars opts keys rest rest* body body*
rest-keys all-keys other-keys other-keys*
other-keys-mode body-mode (map cadr keys0))))
;; --------------------------------------------------------------------------
;; parses formals, returns list of normal vars, optional var specs, key var ;; parses formals, returns list of normal vars, optional var specs, key var
;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys ;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys
;; or not; no duplicate names ;; or not; no duplicate names
@ -86,16 +133,7 @@
[other-keys-mode #f] [other-keys-mode #f]
[body-mode #f]) [body-mode #f])
(if (null? formals) (if (null? formals)
(let ([opts (map process-opt opts)] (process-vars vars opts keys rests other-keys-mode body-mode)
[keys (map process-key keys)]
[other-keys-mode
(process-mode other-keys-mode rests other-keys-accessing)]
[body-mode (process-mode body-mode rests body-accessing)]
[getr (lambda (k) (cond [(assq k rests) => cdr] [else #f]))])
(values vars opts keys
(getr #:rest) (getr #:body) (getr #:rest-keys)
(getr #:all-keys) (getr #:other-keys)
other-keys-mode body-mode))
(let* ([k-stx (caar formals)] (let* ([k-stx (caar formals)]
[k (syntax-e* k-stx)]) [k (syntax-e* k-stx)])
(cond [(memq k '(#:optional #:key)) (cond [(memq k '(#:optional #:key))
@ -121,28 +159,8 @@
(cons (cons k (cadar formals)) rests) (cons (cons k (cadar formals)) rests)
other-keys-mode body-mode)])))))) other-keys-mode body-mode)]))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; make case-lambda clauses for a procedure with optionals
;; vars is all identifiers, each opt is (<id> <default-expr>)
(define (make-opt-clauses name vars opts rest exprs)
(let loop ([vars (reverse vars)]
[opts opts]
[clauses '()])
(if (null? opts)
;; fast order: first the all-variable section, then from vars up
(cons (with-syntax ([vars (append! (reverse vars) (or rest '()))]
[(expr ...) exprs])
#'[vars expr ...])
(reverse clauses))
(loop (cons (caar opts) vars) (cdr opts)
(cons (with-syntax ([(var ...) (reverse vars)]
[((opt default) ...) opts]
[name name])
#'[(var ...)
(let* ([opt default] ...) (name var ... opt ...))])
clauses)))))
;; --------------------------------------------------------------------------
;; generates the actual body ;; generates the actual body
(define (generate-body formals exprs) (define (generate-body formals expr)
;; relations: ;; relations:
;; rest = (append all-keys body) ;; rest = (append all-keys body)
;; rest-keys = (append other-keys body) ;; rest-keys = (append other-keys body)
@ -150,116 +168,128 @@
opts ; optionals, each is (id default) opts ; optionals, each is (id default)
keys ; keywords, each is (id key default) keys ; keywords, each is (id key default)
rest ; rest variable (no optionals) rest ; rest variable (no optionals)
rest* ; always an id
body ; rest after all keyword-vals body ; rest after all keyword-vals
body* ; always an id
rest-keys ; rest without specified keys rest-keys ; rest without specified keys
all-keys ; keyword-vals without body all-keys ; keyword-vals without body
other-keys ; unprocessed keyword-vals other-keys ; unprocessed keyword-vals
other-keys-mode ; allowing other keys? other-keys* ; always an id
body-mode) ; allowing body after keys? allow-other-keys? ; allowing other keys?
allow-body? ; allowing body after keys?
keywords) ; list of mentioned keywords
(parse-formals formals)) (parse-formals formals))
(let (; use identifiers from here if none given, so the tests work (define name
[ids `(,@vars ,@(map car opts) ,@(map car keys) ,(or rest #'rest) (or (syntax-local-infer-name stx) (quote-syntax lambda/kw-proc)))
,(or body #'body) ,(or rest-keys #'rest-keys) ;; ------------------------------------------------------------------------
,(or all-keys #'all-keys) ,(or other-keys #'other-keys))]) ;; make case-lambda clauses for a procedure with optionals
(cond [(ormap (lambda (x) (and (not (identifier? x)) x)) ids) (define (make-opt-clauses)
=> (lambda (d) (serror d "not an identifier"))] (let loop ([vars (reverse vars)]
[(check-duplicate-identifier ids) [opts opts]
=> (lambda (d) (serror d "duplicate argument name"))])) [clauses '()])
(if (null? opts)
;; fast order: first the all-variable section, then from vars up
(cons (with-syntax ([vars (append! (reverse vars) (or rest '()))]
[expr expr])
#'[vars expr])
(reverse clauses))
(loop (cons (caar opts) vars) (cdr opts)
(cons (with-syntax ([(var ...) (reverse vars)]
[((ovar default) ...) opts]
[name name])
#'[(var ...)
(let* ([ovar default] ...)
(name var ... ovar ...))])
clauses)))))
;; ------------------------------------------------------------------------
;; generates the part of the body that deals with rest-related stuff
(define (make-rest-body)
(define others? (or other-keys rest-keys))
(with-syntax ([name name]
[rest* rest*]
[body* body*]
[keywords keywords]
[expr expr]
[all-keys* all-keys]
[other-keys* other-keys*]
[rest-keys* rest-keys])
(with-syntax ([loop-vars
#`([body* rest*]
#,@(if all-keys #`([all-keys* '()]) '())
#,@(if others? #`([other-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*)))
'()))]
[expr
(if (or all-keys others?)
#`(let* (#,@(if all-keys
#'([all-keys* (reverse! all-keys*)])
'())
#,@(if others?
#'([other-keys* (reverse! other-keys*)])
'())
#,@(cond [(and other-keys rest-keys)
#'([rest-keys*
(append other-keys* body*)])]
[rest-keys ; can destroy other-keys
#'([rest-keys*
(append! other-keys* body*)])]
[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*))))])
#`(let loop loop-vars
(if (and (pair? body*) (keyword? (car body*)))
(if (pair? (cdr body*))
next-loop
(error* 'name "keyword list not balanced: ~e" rest*))
#,(if allow-body?
#'expr
#'(if (null? body*)
expr
(error* 'name "non-keywords in arguments: ~e"
body*)))))))))
;; ------------------------------------------------------------------------
;; body generation starts here
(cond (cond
;; no optionals or keys => plain lambda ;; no optionals or keys => plain lambda
[(and (null? opts) (null? keys)) [(and (null? opts) (null? keys))
(with-syntax ([vars (append! vars (or rest '()))] (with-syntax ([vars (append! vars (or rest '()))] [expr expr])
[(expr ...) exprs]) (syntax/loc stx (lambda vars expr)))]
(syntax/loc stx (lambda vars expr ...)))] ;; no keys => make a case-lambda for optionals
;; no keys => just a lambda with optionals
[(null? keys) [(null? keys)
(let* ([name (or (syntax-local-infer-name stx) (let ([clauses (make-opt-clauses)])
(quote-syntax lambda/kw-proc))]
[clauses (make-opt-clauses name vars opts rest exprs)])
(with-syntax ([name name] [clauses clauses]) (with-syntax ([name name] [clauses clauses])
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))] (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]
[else (error "BOOM")])) ;; no opts => normal processing of keywords etc
[(null? opts)
(with-syntax ([vars (append! vars rest*)]
[((kvar kexpr) ...) keys]
[body (make-rest-body)])
(syntax/loc stx (lambda vars (let* ([kvar kexpr] ...) body))))]
;; both opts and keys => combine the above two
[else
'!!!]))
(syntax-case stx () (syntax-case stx ()
[(_ (formal ... . rest) expr0 expr ...) ; dot is exactly like #:rest [(_ (formal ... . rest) expr0 expr ...) ; dot is exactly like #:rest
#'(_ (formal ... #:rest rest) expr0 expr ...)] #'(_ (formal ... #:rest rest) expr0 expr ...)]
[(_ (formal ...) expr0 expr ...) [(_ (formal ...) expr0 expr ...)
(generate-body (syntax->list #'(formal ...)) #'(expr0 expr ...)) (generate-body (syntax->list #'(formal ...)) #'(begin expr0 expr ...))]))
#;
(let ()
(when (and (or rest-keys body all-keys other-keys) (not rest))
(set! rest #'rest))
(cond
;; non-trivial case -- full processing
[(or (pair? opts) (pair? keys) rest-keys body all-keys other-keys)
(unless rest (set! rest #'rest))
;; other-keys is computed from all-keys
(when (and other-keys (not all-keys)) (set! all-keys #'all-keys))
(quasisyntax/loc stx
(lambda (#,@vars . #,rest)
(let*-values
(#,@(map (lambda (o)
#`[(#,(car o))
(if (pair? #,rest)
(begin0 (car #,rest)
(set! #,rest (cdr #,rest)))
#,(cadr o))])
opts)
#,@(map (lambda (k)
#`[(#,(car k))
(getarg #,rest #,(cadr k)
(lambda () #,(caddr k)))])
keys)
#,@(if rest-keys
#`([(#,rest-keys)
(filter-out-keys '#,(map cadr keys) #,rest)])
#'())
#,@(cond
;; At most one scan for body, all-keys, other-keys. This
;; could be much shorter by always using keys/args, but a
;; function call is not a place to spend time on.
[(and body all-keys)
#`([(#,all-keys #,body)
;; inlined keys/args
(let loop ([args #,rest] [keys '()])
(cond [(or (null? args)
(null? (cdr args))
(not (keyword? (car args))))
(values (reverse! keys) args)]
[else (loop (cddr args)
(list* (cadr args) (car args)
keys))]))])]
[body
#`([(#,body)
(let loop ([args #,rest])
(if (or (null? args)
(null? (cdr args))
(not (keyword? (car args))))
args
(loop (cddr args))))])]
[all-keys
#`([(#,all-keys)
;; inlined keys/args, not returning args
(let loop ([args #,rest] [keys '()])
(cond [(or (null? args)
(null? (cdr args))
(not (keyword? (car args))))
(reverse! keys)]
[else (loop (cddr args)
(list* (cadr args) (car args)
keys))]))])]
[else #'()])
#,@(if other-keys
#`([(#,other-keys) ; use all-keys (see above)
(filter-out-keys '#,(map cadr keys) #,all-keys)])
#'()))
expr0 expr ...)))]
;; common cases: no optional, keyword, or other fancy stuff
[(null? vars)
(quasisyntax/loc stx
(lambda #,(or rest #'()) expr0 expr ...))]
[else
(quasisyntax/loc stx
(lambda (#,@vars . #,(or rest #'())) expr0 expr ...))]))]))
(provide define/kw) (provide define/kw)
(define-syntax (define/kw stx) (define-syntax (define/kw stx)
@ -268,6 +298,13 @@
[(_ (name . args) body0 body ...) [(_ (name . args) body0 body ...)
(syntax/loc stx (_ name (lambda/kw args body0 body ...)))])) (syntax/loc stx (_ name (lambda/kw args body0 body ...)))]))
;; raise an proper exception
(define (error* who fmt . args)
(raise (make-exn:fail:contract
(string->immutable-string
(apply format (string-append "~a: " fmt) who args))
(current-continuation-marks))))
;; Keyword searching utilities (note: no errors for odd length) ;; Keyword searching utilities (note: no errors for odd length)
(provide getarg getargs keys/args filter-out-keys) (provide getarg getargs keys/args filter-out-keys)
@ -282,10 +319,18 @@
[(eq? (car args) keyword) (cadr args)] [(eq? (car args) keyword) (cadr args)]
[else (loop (cddr args))]))) [else (loop (cddr args))])))
;; a private version of getarg that is always used with simple values
(define (getarg* args keyword . not-found)
(let loop ([args args])
(cond [(or (null? args) (null? (cdr args)))
(and (pair? not-found) (car not-found))]
[(eq? (car args) keyword) (cadr args)]
[else (loop (cddr args))])))
(define (getargs initargs keyword) (define (getargs initargs keyword)
(define (scan tail) (define (scan tail)
(cond [(null? tail) '()] (cond [(null? tail) '()]
[(null? (cdr tail)) (error 'getargs "keyword list not balanced.")] [(null? (cdr tail)) (error 'getargs "keyword list not balanced")]
[(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))] [(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))]
[else (scan (cddr tail))])) [else (scan (cddr tail))]))
(scan initargs)) (scan initargs))

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

@ -6,6 +6,7 @@
(require (lib "kw.ss")) (require (lib "kw.ss"))
(let ([t test]) (let ([t test])
;; make sure that lambda/kw behaves as lambda ;; make sure that lambda/kw behaves as lambda
(t 1 (lambda/kw () 1)) (t 1 (lambda/kw () 1))
(t 1 (lambda/kw (x) 1) 0) (t 1 (lambda/kw (x) 1) 0)
@ -29,19 +30,135 @@
(t '(1 2) f 0 1 2)) (t '(1 2) f 0 1 2))
;; using only optionals ;; using only optionals
(t 0 procedure-arity (lambda/kw (#:optional) 0)) (t 0 procedure-arity (lambda/kw (#:optional) 0))
(t '(0 #f) (lambda/kw (x #:optional y) (list x y)) 0) (t '(3 1 2) procedure-arity (lambda/kw (x #:optional y z) 0))
(t '(0 1) (lambda/kw (x #:optional y) (list x y)) 0 1) (let ([f (lambda/kw (x #:optional y) (list x y))])
(t '(0 0) (lambda/kw (x #:optional [y 0]) (list x y)) 0) (t '(0 #f) f 0)
(t '(0 1) (lambda/kw (x #:optional [y 0]) (list x y)) 0 1) (t '(0 1) f 0 1))
(t '(0 0) (lambda/kw (x #:optional [y x]) (list x y)) 0) (let ([f (lambda/kw (x #:optional [y 0]) (list x y))])
(t '(0 1) (lambda/kw (x #:optional [y x]) (list x y)) 0 1) (t '(0 0) f 0)
(t '(0 0 0) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0) (t '(0 1) f 0 1))
(t '(0 1 0) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0 1) (let ([f (lambda/kw (x #:optional [y x]) (list x y))])
(t '(0 1 2) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0 1 2) (t '(0 0) f 0)
(t '(0 0 0) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0) (t '(0 1) f 0 1))
(t '(0 1 1) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0 1) (let ([f (lambda/kw (x #:optional [y x] [z x]) (list x y z))])
(t '(0 1 2) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0 1 2) (t '(0 0 0) f 0)
(t '(0 1 0) f 0 1)
(t '(0 1 2) f 0 1 2))
(let ([f (lambda/kw (x #:optional [y x] [z y]) (list x y z))])
(t '(0 0 0) f 0)
(t '(0 1 1) f 0 1)
(t '(0 1 2) f 0 1 2))
;; keywords: default-expr scope
(let ([f (lambda/kw (#:key x y) (list x y))])
(t '(#f #f) f)
(t '(1 #f) f #:x 1)
(t '(#f 2 ) f #:y 2)
(t '(1 2 ) f #:x 1 #:y 2)
(t '(1 2 ) f #:x 1 #:y 2 #:y 3 #:x 4))
(let ([f (lambda/kw (#:key x [y x]) (list x y))])
(t '(1 1 ) f #:x 1)
(t '(#f 2 ) f #:y 2)
(t '(1 2 ) f #:x 1 #:y 2))
(let ([f (lambda/kw (#:key x [y x] [z x]) (list x y z))])
(t '(1 1 1 ) f #:x 1)
(t '(#f 1 #f) f #:y 1)
(t '(#f #f 1 ) f #:z 1))
(let ([f (lambda/kw (#:key x [y x] [z y]) (list x y z))])
(t '(1 1 1 ) f #:x 1)
(t '(#f 1 1 ) f #:y 1)
(t '(#f #f 1 ) f #:z 1))
(t '(1 2) (let ([y 1]) (lambda/kw (#:key [x y] [y (add1 x)]) (list x y))))
(t '(1 2) (let ([x 1]) (lambda/kw (#:key [x x] [y (add1 x)]) (list x y))))
;; keywords: default-expr evaluation
(t 1 (lambda/kw (#:key [x 1]) x))
(t "1" (lambda/kw (#:key [x "1"]) x))
(t 1 (lambda/kw (#:key [x '1]) x))
(t ''1 (lambda/kw (#:key [x ''1]) x))
(t '(add1 1) (lambda/kw (#:key [x '(add1 1)]) x))
(t + (lambda/kw (#:key [x +]) x))
(let ([f (lambda ()
(let ([y 1]) (lambda/kw (#:key [x (begin (set! y 3) 2)]) y)))])
(t 3 (f))
(t 1 (f) #:x 1))
(let ([f (lambda ()
(let ([y 1])
(let-syntax ([z (syntax-id-rules () [_ (begin (set! y 3) 2)])])
(lambda/kw (#:key [x z]) y))))])
(t 3 (f))
(t 1 (f) #:x 1))
;; exotic extras
(let ([f (lambda/kw (#:key a b #:rest r) r)])
(t '(1 2 3) f 1 2 3)
(t '(#:a 1 1 2 3) f #:a 1 1 2 3)
(t '(#:a 1 #:a 2 1 2 3) f #:a 1 #:a 2 1 2 3)
(t '(#:b 2 1 2 3) f #:b 2 1 2 3)
(t '(#:a 1 #:b 2 1 2 3) f #:a 1 #:b 2 1 2 3)
(t '(#:a 1 #:b 2 #:c 3 1 2 3) f #:a 1 #:b 2 #:c 3 1 2 3))
(let ([f (lambda/kw (#:key a b #:body r) r)])
(t '(1 2 3) f 1 2 3)
(t '(1 2 3) f #:a 1 1 2 3)
(t '(1 2 3) f #:a 1 #:a 2 1 2 3)
(t '(1 2 3) f #:b 2 1 2 3)
(t '(1 2 3) f #:a 1 #:b 2 1 2 3))
(let ([f (lambda/kw (#:key a b #:other-keys r) r)])
(t '() f)
(t '() f #:a 1 #:b 2)
(t '() f #:a 1 #:a 2 #:b 3)
(t '(#:c 3) f #:a 1 #:b 2 #:c 3)
(t '(#:d 4 #:c 3) f #:d 4 #:a 1 #:b 2 #:c 3)
(t '(#:d 4 #:c 3 #:c 33) f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33)
(t '(#:d 4 #:c 3 #:c 33) f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33))
(let ([f (lambda/kw (#:key a b #:rest-keys r) r)])
(t '() f)
(t '(1 2) f 1 2)
(t '() f #:a 1 #:b 2)
(t '(1 2) f #:a 1 #:b 2 1 2)
(t '() f #:a 1 #:a 2 #:b 3)
(t '(1 2) f #:a 1 #:a 2 #:b 3 1 2)
(t '(#:c 3) f #:a 1 #:b 2 #:c 3)
(t '(#:c 3 1 2) f #:a 1 #:b 2 #:c 3 1 2)
(t '(#:d 4 #:c 3) f #:d 4 #:a 1 #:b 2 #:c 3)
(t '(#:d 4 #:c 3 1 2) f #:d 4 #:a 1 #:b 2 #:c 3 1 2)
(t '(#:d 4 #:c 3 #:c 33) f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33)
(t '(#:d 4 #:c 3 #:c 33 1 2) f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33 1 2)
(t '(#:d 4 #:c 3 #:c 33) f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33)
(t '(#:d 4 #:c 3 #:c 33 1 2) f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33 1 2)
)
(let ([f (lambda/kw (x #:key a b #:all-keys r) r)])
(t '() f 1)
(t '(#:a 1 #:b 2) f 1 #:a 1 #:b 2)
(t '(#:a 1 #:a 2 #:b 3) f 1 #:a 1 #:a 2 #:b 3)
(t '(#:a 1 #:b 2 #:c 3) f 1 #:a 1 #:b 2 #:c 3)
(t '(#:d 4 #:a 1 #:b 2 #:c 3) f 1 #:d 4 #:a 1 #:b 2 #:c 3)
(t '(#:d 4 #:a 1 #:b 2 #:c 3 #:c 33) f 1 #:d 4 #:a 1 #:b 2 #:c 3 #:c 33)
(t '(#:d 4 #:a 1 #:c 3 #:b 2 #:c 33) f 1 #:d 4 #:a 1 #:c 3 #:b 2 #:c 33)
(err/rt-test (f 1 #:a 2 3))
(err/rt-test (f 1 #:a 2 3 4))
)
;; check when other keys are allowed
(err/rt-test ((lambda/kw (#:key a #:body r) r) #:a 1 #:b 2))
(err/rt-test ((lambda/kw (#:key a) a) #:a 1 #:b 2))
(t 1 (lambda/kw (#:key a #:rest r) a) #:a 1 #:b 2)
(t 1 (lambda/kw (#:key a #:rest-keys r) a) #:a 1 #:b 2)
(t 1 (lambda/kw (#:key a #:allow-other-keys) a) #:a 1 #:b 2)
(err/rt-test ((lambda/kw (#:key a #:rest r #:forbid-other-keys) a) #:a 1 #:b 2))
;; check when body is allowed
(err/rt-test ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3))
(err/rt-test ((lambda/kw (#:key a #:all-keys r) r) #:a 1 #:b 2 3 4))
(err/rt-test ((lambda/kw (#:key a #:other-keys r) r) #:a 1 #:b 2 3))
(err/rt-test ((lambda/kw (#:key a #:other-keys r) r) #:a 1 #:b 2 3 4))
(t '(#:a 1 #:b 2 3) (lambda/kw (#:key a #:rest r) r) #:a 1 #:b 2 3)
(t '(#:a 1 #:b 2 3 4) (lambda/kw (#:key a #:rest r) r) #:a 1 #:b 2 3 4)
(t '(3) (lambda/kw (#:key a #:body r) r) #:a 1 3)
(t '(3 4) (lambda/kw (#:key a #:body r) r) #:a 1 3 4)
(t '(3) (lambda/kw (#:key a #:body r) r) #:a 1 #:a 2 3)
(t '(3 4) (lambda/kw (#:key a #:body r) r) #:a 1 #:a 2 3 4)
(err/rt-test ((lambda/kw (#:key a #:body r #:forbid-body) r) #:a 1 3))
(t '(#:a 1 #:b 2) (lambda/kw (#:key a #:all-keys r #:allow-body) r) #:a 1 #:b 2 3)
) )
;; test syntax errors ;; test syntax errors