A lot more functionality (and tests), almost complete now.
svn: r1102
This commit is contained in:
Eli Barzilay
parent
82df8d122d
commit
1db64d4e85
|
|
@ -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 (<id> <default-expr>)
|
||||
(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 (<id> <key-stx> <default-expr>)
|
||||
(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 (<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
|
||||
;; 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 (<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
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user