Extensive argument processing, more meta-keywords for modes,
efficient optionals, test everything so far svn: r1099
This commit is contained in:
Eli Barzilay
parent
26988c0b5d
commit
78c19494b7
|
|
@ -1,21 +1,45 @@
|
|||
(module kw mzscheme
|
||||
|
||||
(require-for-syntax (lib "define.ss" "syntax"))
|
||||
(require-for-syntax (lib "name.ss" "syntax"))
|
||||
|
||||
(provide define/kw)
|
||||
(define-syntax (define/kw stx)
|
||||
(let-values ([(id val) (normalize-definition stx #'lambda/kw)])
|
||||
(with-syntax ([id id] [val val]) #'(define id val))))
|
||||
(begin-for-syntax ; -> configuration for lambda/kw
|
||||
;; must appear at the end, each with exactly one variable
|
||||
(define rest-like-kwds '(#:rest #:body #:rest-keys #:all-keys #:other-keys))
|
||||
;; also in the end, without variable, cannot have contradictions
|
||||
(define allow-other-keys-kwds '(#:allow-other-keys #:forbid-other-keys))
|
||||
(define allow-body-kwds '(#:allow-body #:forbid-body))
|
||||
;; using any of these allows access to additional keys or to body, making the
|
||||
;; default be to allow other keys or body
|
||||
(define other-keys-accessing '(#:rest #:rest-keys #:all-keys #:other-keys))
|
||||
(define body-accessing '(#:rest #:body #:rest-keys)))
|
||||
|
||||
(provide lambda/kw)
|
||||
(define-syntax (lambda/kw stx)
|
||||
(define (process-optional-arg o)
|
||||
;; --------------------------------------------------------------------------
|
||||
;; easy syntax errors
|
||||
(define (serror sub fmt . args)
|
||||
(raise-syntax-error #f (apply format fmt args) stx sub))
|
||||
;; contents of syntax
|
||||
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
|
||||
;; split a list of syntax objects based on syntax keywords:
|
||||
;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...)
|
||||
(define (split-by-keywords xs)
|
||||
(let loop ([xs xs] [cur '()] [r '()])
|
||||
(if (null? xs)
|
||||
(reverse! (cons (reverse! cur) r))
|
||||
(let ([x (car xs)])
|
||||
(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 ()
|
||||
[(var default) (identifier? #'var) (list #'var #'default)]
|
||||
[(var) (identifier? #'var) (list #'var #'#f)]
|
||||
[var (identifier? #'var) (list #'var #'#f)]
|
||||
[var (raise-syntax-error #f "not a valid #:optional spec" stx #'var)]))
|
||||
(define (process-keyword-arg k)
|
||||
[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)
|
||||
(datum->syntax-object
|
||||
k (string->keyword (symbol->string (syntax-e var))) k k))
|
||||
|
|
@ -26,84 +50,142 @@
|
|||
[(var default) (identifier? #'var) (list #'var (key #'var) #'default)]
|
||||
[(var) (identifier? #'var) (list #'var (key #'var) #'#f)]
|
||||
[var (identifier? #'var) (list #'var (key #'var) #'#f)]
|
||||
[var (raise-syntax-error #f "not a valid #:key spec" stx #'var)]))
|
||||
[var (serror #'var "not a valid ~a spec" #:key)]))
|
||||
;; helper for parse-formals
|
||||
(define (get-mode mode k k-stx formals keys)
|
||||
(cond [(null? keys)
|
||||
(serror k-stx "cannot use without #:key arguments")]
|
||||
[(pair? (cdar formals))
|
||||
(serror (cadar formals) "identifier following mode keyword ~a" k)]
|
||||
[(and mode (not (eq? k mode)))
|
||||
(serror k-stx "contradicting mode keywords")]
|
||||
[else k]))
|
||||
;; helper for parse-formals
|
||||
(define (process-mode mode rests enablers)
|
||||
(if mode
|
||||
(eq? mode #:allow-other-keys)
|
||||
(ormap (lambda (k) (and (assq k rests) #t)) enablers)))
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 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
|
||||
(define (parse-formals formals)
|
||||
(let* ([formals (split-by-keywords formals)]
|
||||
[vars (car formals)]
|
||||
[formals (cdr formals)]
|
||||
[pop-formals
|
||||
(lambda (key)
|
||||
(if (and (pair? formals) (eq? key (syntax-e* (caar formals))))
|
||||
(begin0 (cdar formals) (set! formals (cdr formals)))
|
||||
'()))]
|
||||
[opts (pop-formals #:optional)]
|
||||
[keys (pop-formals #:key)])
|
||||
;; now get all rest-like vars
|
||||
(let loop ([formals formals]
|
||||
[rests '()]
|
||||
[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))
|
||||
(let* ([k-stx (caar formals)]
|
||||
[k (syntax-e* k-stx)])
|
||||
(cond [(memq k '(#:optional #:key))
|
||||
(serror k-stx "misplaced ~a" k)]
|
||||
[(memq k allow-other-keys-kwds)
|
||||
(loop (cdr formals) rests
|
||||
(get-mode other-keys-mode k k-stx formals keys)
|
||||
body-mode)]
|
||||
[(memq k allow-body-kwds)
|
||||
(loop (cdr formals) rests other-keys-mode
|
||||
(get-mode body-mode k k-stx formals keys))]
|
||||
[(not (memq k rest-like-kwds))
|
||||
(serror k-stx "unknown meta keyword")]
|
||||
[(assq k rests)
|
||||
(serror k-stx "duplicate ~a" k)]
|
||||
[(null? (cdar formals))
|
||||
(serror k-stx "missing variable name")]
|
||||
[(not (null? (cddar formals)))
|
||||
(serror k-stx "too many variable names")]
|
||||
[(and (null? keys) (not (eq? #:rest k)))
|
||||
(serror k-stx "cannot use without #:key arguments")]
|
||||
[else (loop (cdr formals)
|
||||
(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)
|
||||
;; relations:
|
||||
;; rest = (append all-keys body)
|
||||
;; rest-keys = (append other-keys body)
|
||||
(define-values (vars ; plain variables
|
||||
opts ; optionals, each is (id default)
|
||||
keys ; keywords, each is (id key default)
|
||||
rest ; rest variable (no optionals)
|
||||
body ; rest after all keyword-vals
|
||||
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?
|
||||
(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"))]))
|
||||
(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
|
||||
[(null? keys)
|
||||
(let* ([name (or (syntax-local-infer-name stx)
|
||||
(quote-syntax lambda/kw-proc))]
|
||||
[clauses (make-opt-clauses name vars opts rest exprs)])
|
||||
(with-syntax ([name name] [clauses clauses])
|
||||
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]
|
||||
[else (error "BOOM")]))
|
||||
(syntax-case stx ()
|
||||
[(_ formals expr0 expr ...)
|
||||
(let ([vars '()]
|
||||
[opts '()]
|
||||
[keys '()]
|
||||
[rest #f] ; keys and all (no optionals)
|
||||
[rest-keys #f] ; like the above, minus specified keys
|
||||
[body #f] ; stuff that follows all keywords
|
||||
[all-keys #f] ; all keys, excluding body
|
||||
[other-keys #f]) ; unprocessed keys, excluding body
|
||||
;; relations:
|
||||
;; rest = (append all-keys body)
|
||||
;; rest-keys = (append other-keys body)
|
||||
(let loop ([state #f] [args #'formals])
|
||||
(syntax-case args ()
|
||||
[() #f]
|
||||
[(v . xs)
|
||||
(let* ([v #'v]
|
||||
[k (if (syntax? v) (syntax-e v) v)]
|
||||
[k (and (keyword? k) k)])
|
||||
(define (serror sub fmt . args)
|
||||
(raise-syntax-error #f (apply format fmt args) stx sub))
|
||||
(cond
|
||||
[k (case k
|
||||
[(#:optional)
|
||||
(if state
|
||||
(serror #'formals "misplaced ~a argument" k)
|
||||
(loop 'o #'xs))]
|
||||
[(#:key)
|
||||
(if (memq state '(#f o r!))
|
||||
(loop 'k #'xs)
|
||||
(serror #'formals "misplaced ~a argument" k))]
|
||||
[(#:rest)
|
||||
(if (pair? (syntax-e #'xs))
|
||||
(loop 'r #'xs)
|
||||
(serror #'formals "no name for ~a argument" k))]
|
||||
[(#:rest-keys)
|
||||
(if (pair? (syntax-e #'xs))
|
||||
(loop 'rk #'xs)
|
||||
(serror #'formals "no name for ~a argument" k))]
|
||||
[(#:body)
|
||||
(if (pair? (syntax-e #'xs))
|
||||
(loop 'b #'xs)
|
||||
(serror #'formals "no name for ~a argument" k))]
|
||||
[(#:all-keys)
|
||||
(if (pair? (syntax-e #'xs))
|
||||
(loop 'ak #'xs)
|
||||
(serror #'formals "no name for ~a argument" k))]
|
||||
[(#:other-keys)
|
||||
(if (pair? (syntax-e #'xs))
|
||||
(loop 'ok #'xs)
|
||||
(serror #'formals "no name for ~a argument" k))]
|
||||
[else (serror v "unknown lambda meta-keyword")])]
|
||||
[(not (or (identifier? #'v) (memq state '(o k))))
|
||||
(serror v "not an identifier")]
|
||||
[else
|
||||
(let ([test (lambda (var name)
|
||||
(if var
|
||||
(serror #'formals "too many ~a arguments" name)
|
||||
(set! state 'r!)))])
|
||||
(case state
|
||||
[(#f) (set! vars (cons v vars))]
|
||||
[(o) (set! opts (cons v opts))]
|
||||
[(k) (set! keys (cons v keys))]
|
||||
[(r!) (serror v "second identifier after a ~a or similar"
|
||||
#:rest)]
|
||||
[(r) (test rest #:rest ) (set! rest v)]
|
||||
[(rk) (test rest-keys #:rest-keys ) (set! rest-keys v)]
|
||||
[(b) (test body #:body ) (set! body v)]
|
||||
[(ak) (test all-keys #:all-keys ) (set! all-keys v)]
|
||||
[(ok) (test other-keys #:other-keys) (set! other-keys v)]
|
||||
[else (serror v "bad lambda formals")])
|
||||
(loop state #'xs))]))]
|
||||
[v (loop state #'(#:rest v))]))
|
||||
(set! vars (reverse! vars))
|
||||
(set! opts (map process-optional-arg (reverse! opts)))
|
||||
(set! keys (map process-keyword-arg (reverse! keys)))
|
||||
[(_ (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
|
||||
|
|
@ -179,8 +261,15 @@
|
|||
(quasisyntax/loc stx
|
||||
(lambda (#,@vars . #,(or rest #'())) expr0 expr ...))]))]))
|
||||
|
||||
(provide define/kw)
|
||||
(define-syntax (define/kw stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name val) (identifier? #'name) #'(define name val)]
|
||||
[(_ (name . args) body0 body ...)
|
||||
(syntax/loc stx (_ name (lambda/kw args body0 body ...)))]))
|
||||
|
||||
;; Keyword searching utilities (note: no errors for odd length)
|
||||
(provide getarg syntax-getarg getargs keys/args filter-out-keys)
|
||||
(provide getarg getargs keys/args filter-out-keys)
|
||||
|
||||
(define (getarg args keyword . not-found)
|
||||
(let loop ([args args])
|
||||
|
|
@ -193,18 +282,6 @@
|
|||
[(eq? (car args) keyword) (cadr args)]
|
||||
[else (loop (cddr args))])))
|
||||
|
||||
(define (syntax-getarg syntax-args keyword . not-found)
|
||||
(when (syntax? keyword) (set! keyword (syntax-e keyword)))
|
||||
(let loop ([args syntax-args])
|
||||
(syntax-case args ()
|
||||
[(key arg . more)
|
||||
(if (eq? (syntax-e #'key) keyword) #'arg (loop #'more))]
|
||||
[_ (and (pair? not-found)
|
||||
(let ([x (car not-found)])
|
||||
(cond [(procedure? x) (x)]
|
||||
[(promise? x) (force x)]
|
||||
[else x])))])))
|
||||
|
||||
(define (getargs initargs keyword)
|
||||
(define (scan tail)
|
||||
(cond [(null? tail) '()]
|
||||
|
|
|
|||
|
|
@ -5,24 +5,76 @@
|
|||
|
||||
(require (lib "kw.ss"))
|
||||
|
||||
;; make sure that lambda/kw behaves as lambda
|
||||
(test 1 (lambda/kw () 1))
|
||||
(test 1 (lambda/kw (x) 1) 0)
|
||||
(test '() (lambda/kw x x))
|
||||
(test '(1 2) (lambda/kw x x) 1 2)
|
||||
(test '(1 2) (lambda/kw (x . xs) xs) 0 1 2)
|
||||
;; even with keywords
|
||||
(test #:x (lambda/kw () #:x))
|
||||
(test #:x (lambda/kw (x) #:x) #:y)
|
||||
(test '(#:x #:y) (lambda/kw x x) #:x #:y)
|
||||
(test '(#:x #:y) (lambda/kw (x . xs) xs) #:z #:x #:y)
|
||||
(let ([t test])
|
||||
;; make sure that lambda/kw behaves as lambda
|
||||
(t 1 (lambda/kw () 1))
|
||||
(t 1 (lambda/kw (x) 1) 0)
|
||||
(t '() (lambda/kw x x))
|
||||
(t '(1 2) (lambda/kw x x) 1 2)
|
||||
(t '(1 2) (lambda/kw (x . xs) xs) 0 1 2)
|
||||
;; even with keywords
|
||||
(t #:x (lambda/kw () #:x))
|
||||
(t #:x (lambda/kw (x) #:x) #:y)
|
||||
(t '(#:x #:y) (lambda/kw x x) #:x #:y)
|
||||
(t '(#:x #:y) (lambda/kw (x . xs) xs) #:z #:x #:y)
|
||||
|
||||
;; just using #:rest is the same as a dot
|
||||
(let ([f (lambda/kw (#:rest r) r)])
|
||||
(test '() f)
|
||||
(test '(1) f 1)
|
||||
(test '(1 2) f 1 2))
|
||||
(let ([f (lambda/kw (x #:rest r) r)])
|
||||
(test '() f 0)
|
||||
(test '(1) f 0 1)
|
||||
(test '(1 2) f 0 1 2))
|
||||
;; just using #:rest is the same as a dot
|
||||
(let ([f (lambda/kw (#:rest r) r)])
|
||||
(t '() f)
|
||||
(t '(1) f 1)
|
||||
(t '(1 2) f 1 2))
|
||||
(let ([f (lambda/kw (x #:rest r) r)])
|
||||
(t '() f 0)
|
||||
(t '(1) f 0 1)
|
||||
(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)
|
||||
)
|
||||
|
||||
;; test syntax errors
|
||||
(let ([st syntax-test])
|
||||
(st #'(lambda/kw (x #:blah y) 1))
|
||||
(st #'(lambda/kw (x #:rest) 1))
|
||||
(st #'(lambda/kw (x #:key k #:key o) 1))
|
||||
(st #'(lambda/kw (x #:key k #:optional o) 1))
|
||||
(st #'(lambda/kw (x #:optional k #:optional o) 1))
|
||||
(st #'(lambda/kw (x #:rest r #:optional o) 1))
|
||||
(st #'(lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 1))
|
||||
(st #'(lambda/kw (x #:rest r #:allow-other-keys #:forbid-other-keys) 1))
|
||||
(st #'(lambda/kw (x #:rest r1 #:rest r2) 1))
|
||||
(st #'(lambda/kw (x #:rest) 1))
|
||||
(st #'(lambda/kw (x #:rest r1 r2) 1))
|
||||
(st #'(lambda/kw (x #:body b) 1))
|
||||
(st #'(lambda/kw (x x) 1))
|
||||
(st #'(lambda/kw (x #:optional [x 1]) 1))
|
||||
(st #'(lambda/kw (x #:key [x 1]) 1))
|
||||
(st #'(lambda/kw (x #:rest x) 1))
|
||||
(st #'(lambda/kw (x #:body x) 1))
|
||||
(st #'(lambda/kw (x #:optional 3) 1))
|
||||
(st #'(lambda/kw (x #:optional "3") 1))
|
||||
(st #'(lambda/kw (x #:optional [(x) 3]) 1))
|
||||
(st #'(lambda/kw (x #:key 3) 1))
|
||||
(st #'(lambda/kw (x #:key "3") 1))
|
||||
(st #'(lambda/kw (x #:key [(x) 3]) 1))
|
||||
(st #'(lambda/kw (x #:rest 3) 1))
|
||||
(st #'(lambda/kw (x #:rest "3") 1))
|
||||
(st #'(lambda/kw (x #:rest (x)) 1))
|
||||
(st #'(lambda/kw (x #:body 3) 1))
|
||||
(st #'(lambda/kw (x #:body "3") 1))
|
||||
(st #'(lambda/kw (x #:body (x)) 1))
|
||||
(st #'(lambda/kw (x #:body x #:allow-other-keys) 1))
|
||||
(st #'(lambda/kw (x #:optional ()) 1))
|
||||
(st #'(lambda/kw (x #:optional (x y z)) 1)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user