From 1db64d4e850088fe32c2b5bb82b23956928bf837 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 19 Oct 2005 07:05:22 +0000 Subject: [PATCH] A lot more functionality (and tests), almost complete now. svn: r1102 --- collects/mzlib/kw.ss | 307 +++++++++++++++++++--------------- collects/tests/mzscheme/kw.ss | 143 ++++++++++++++-- 2 files changed, 306 insertions(+), 144 deletions(-) diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss index 982ce6c2ff..297ce9cdb3 100644 --- a/collects/mzlib/kw.ss +++ b/collects/mzlib/kw.ss @@ -21,6 +21,14 @@ (raise-syntax-error #f (apply format fmt args) stx sub)) ;; contents of syntax (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: ;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...) (define (split-by-keywords xs) @@ -31,6 +39,7 @@ (if (keyword? (syntax-e* x)) (loop (cdr xs) (list x) (cons (reverse! cur) r)) (loop (cdr xs) (cons x cur) r)))))) + ;; -------------------------------------------------------------------------- ;; process an optional argument spec, returns ( ) (define (process-opt o) (syntax-case o () @@ -38,6 +47,7 @@ [(var) (identifier? #'var) (list #'var #'#f)] [var (identifier? #'var) (list #'var #'#f)] [var (serror #'var "not a valid ~a spec" #:optional)])) + ;; -------------------------------------------------------------------------- ;; process a key argument spec, returns ( ) (define (process-key k) (define (key var) @@ -51,7 +61,8 @@ [(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)])) - ;; helper for parse-formals + ;; -------------------------------------------------------------------------- + ;; helpers for process-vars (define (get-mode mode k k-stx formals keys) (cond [(null? keys) (serror k-stx "cannot use without #:key arguments")] @@ -60,12 +71,48 @@ [(and mode (not (eq? k mode))) (serror k-stx "contradicting mode keywords")] [else k])) - ;; helper for parse-formals - (define (process-mode mode rests enablers) + (define (process-mode mode rests allow enablers) (if mode - (eq? mode #:allow-other-keys) + (eq? mode allow) (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 ( ) keys to ( ) + [(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 ;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys ;; or not; no duplicate names @@ -86,16 +133,7 @@ [other-keys-mode #f] [body-mode #f]) (if (null? formals) - (let ([opts (map process-opt opts)] - [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)) + (process-vars vars opts keys rests other-keys-mode body-mode) (let* ([k-stx (caar formals)] [k (syntax-e* k-stx)]) (cond [(memq k '(#:optional #:key)) @@ -121,28 +159,8 @@ (cons (cons k (cadar formals)) rests) other-keys-mode body-mode)])))))) ;; -------------------------------------------------------------------------- - ;; make case-lambda clauses for a procedure with optionals - ;; vars is all identifiers, each opt is ( ) - (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 - (define (generate-body formals exprs) + (define (generate-body formals expr) ;; relations: ;; rest = (append all-keys body) ;; rest-keys = (append other-keys body) @@ -150,116 +168,128 @@ opts ; optionals, each is (id default) keys ; keywords, each is (id key default) rest ; rest variable (no optionals) + rest* ; always an id body ; rest after all keyword-vals + body* ; always an id rest-keys ; rest without specified keys all-keys ; keyword-vals without body other-keys ; unprocessed keyword-vals - other-keys-mode ; allowing other keys? - body-mode) ; allowing body after keys? + other-keys* ; always an id + allow-other-keys? ; allowing other keys? + allow-body? ; allowing body after keys? + keywords) ; list of mentioned keywords (parse-formals formals)) - (let (; use identifiers from here if none given, so the tests work - [ids `(,@vars ,@(map car opts) ,@(map car keys) ,(or rest #'rest) - ,(or body #'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"))])) + (define name + (or (syntax-local-infer-name stx) (quote-syntax lambda/kw-proc))) + ;; ------------------------------------------------------------------------ + ;; make case-lambda clauses for a procedure with optionals + (define (make-opt-clauses) + (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 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 ;; no optionals or keys => plain lambda [(and (null? opts) (null? keys)) - (with-syntax ([vars (append! vars (or rest '()))] - [(expr ...) exprs]) - (syntax/loc stx (lambda vars expr ...)))] - ;; no keys => just a lambda with optionals + (with-syntax ([vars (append! vars (or rest '()))] [expr expr]) + (syntax/loc stx (lambda vars expr)))] + ;; no keys => make a case-lambda for optionals [(null? keys) - (let* ([name (or (syntax-local-infer-name stx) - (quote-syntax lambda/kw-proc))] - [clauses (make-opt-clauses name vars opts rest exprs)]) + (let ([clauses (make-opt-clauses)]) (with-syntax ([name name] [clauses clauses]) (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 () [(_ (formal ... . rest) expr0 expr ...) ; dot is exactly like #:rest #'(_ (formal ... #:rest rest) expr0 expr ...)] [(_ (formal ...) expr0 expr ...) - (generate-body (syntax->list #'(formal ...)) #'(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 ...))]))])) + (generate-body (syntax->list #'(formal ...)) #'(begin expr0 expr ...))])) (provide define/kw) (define-syntax (define/kw stx) @@ -268,6 +298,13 @@ [(_ (name . 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) (provide getarg getargs keys/args filter-out-keys) @@ -282,10 +319,18 @@ [(eq? (car args) keyword) (cadr 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 (scan 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)))] [else (scan (cddr tail))])) (scan initargs)) diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index f4ce78d314..0982384cc9 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -6,6 +6,7 @@ (require (lib "kw.ss")) (let ([t test]) + ;; make sure that lambda/kw behaves as lambda (t 1 (lambda/kw () 1)) (t 1 (lambda/kw (x) 1) 0) @@ -29,19 +30,135 @@ (t '(1 2) f 0 1 2)) ;; using only optionals - (t 0 procedure-arity (lambda/kw (#:optional) 0)) - (t '(0 #f) (lambda/kw (x #:optional y) (list x y)) 0) - (t '(0 1) (lambda/kw (x #:optional y) (list x y)) 0 1) - (t '(0 0) (lambda/kw (x #:optional [y 0]) (list x y)) 0) - (t '(0 1) (lambda/kw (x #:optional [y 0]) (list x y)) 0 1) - (t '(0 0) (lambda/kw (x #:optional [y x]) (list x y)) 0) - (t '(0 1) (lambda/kw (x #:optional [y x]) (list x y)) 0 1) - (t '(0 0 0) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0) - (t '(0 1 0) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0 1) - (t '(0 1 2) (lambda/kw (x #:optional [y x] [z x]) (list x y z)) 0 1 2) - (t '(0 0 0) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0) - (t '(0 1 1) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0 1) - (t '(0 1 2) (lambda/kw (x #:optional [y x] [z y]) (list x y z)) 0 1 2) + (t 0 procedure-arity (lambda/kw (#:optional) 0)) + (t '(3 1 2) procedure-arity (lambda/kw (x #:optional y z) 0)) + (let ([f (lambda/kw (x #:optional y) (list x y))]) + (t '(0 #f) f 0) + (t '(0 1) f 0 1)) + (let ([f (lambda/kw (x #:optional [y 0]) (list x y))]) + (t '(0 0) f 0) + (t '(0 1) f 0 1)) + (let ([f (lambda/kw (x #:optional [y x]) (list x y))]) + (t '(0 0) f 0) + (t '(0 1) f 0 1)) + (let ([f (lambda/kw (x #:optional [y x] [z x]) (list x y z))]) + (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