From 78c19494b7b7031c174852391f38f2e4a8c8f9f0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 17 Oct 2005 23:42:24 +0000 Subject: [PATCH] Extensive argument processing, more meta-keywords for modes, efficient optionals, test everything so far svn: r1099 --- collects/mzlib/kw.ss | 273 ++++++++++++++++++++++------------ collects/tests/mzscheme/kw.ss | 92 +++++++++--- 2 files changed, 247 insertions(+), 118 deletions(-) diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss index 58c0936c50..982ce6c2ff 100644 --- a/collects/mzlib/kw.ss +++ b/collects/mzlib/kw.ss @@ -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 ( ) + (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 ( ) + (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 ( ) + (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) '()] diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index aaaf4a0d97..f4ce78d314 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -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)))