From 3494461c98ca509ce46ac7240cc2b714a8275fa4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 19 Oct 2005 07:47:56 +0000 Subject: [PATCH] All features complete, remove utilities that don't seem necessary, make getarg and getarg* stop at non-keyword svn: r1103 --- collects/mzlib/kw.ss | 62 ++++++++++++++--------------------- collects/tests/mzscheme/kw.ss | 42 +++++++++++++++++++++++- 2 files changed, 66 insertions(+), 38 deletions(-) diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss index 297ce9cdb3..d76596b67c 100644 --- a/collects/mzlib/kw.ss +++ b/collects/mzlib/kw.ss @@ -89,6 +89,8 @@ (apply values (map (lambda (k) (cond [(assq k rests) => cdr] [else #f])) '(#:rest #:body #:rest-keys #:all-keys #:other-keys)))] + [(body-spec body) + (if (identifier? body) (values #f body) (values body #'body))] [(rest* body* other-keys*) (values (or rest #'rest) (or body #'body) (or other-keys #'other-keys))] ;; turn ( ) keys to ( ) @@ -109,7 +111,7 @@ => (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* + (values vars opts keys rest rest* body body* body-spec rest-keys all-keys other-keys other-keys* other-keys-mode body-mode (map cadr keys0)))) ;; -------------------------------------------------------------------------- @@ -171,6 +173,7 @@ rest* ; always an id body ; rest after all keyword-vals body* ; always an id + body-spec ; syntax of body with sub-formals rest-keys ; rest without specified keys all-keys ; keyword-vals without body other-keys ; unprocessed keyword-vals @@ -183,13 +186,13 @@ (or (syntax-local-infer-name stx) (quote-syntax lambda/kw-proc))) ;; ------------------------------------------------------------------------ ;; make case-lambda clauses for a procedure with optionals - (define (make-opt-clauses) + (define (make-opt-clauses expr rest) (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 '()))] + (cons (with-syntax ([vars (append! (reverse vars) rest)] [expr expr]) #'[vars expr]) (reverse clauses)) @@ -203,7 +206,7 @@ clauses))))) ;; ------------------------------------------------------------------------ ;; generates the part of the body that deals with rest-related stuff - (define (make-rest-body) + (define (make-rest-body expr) (define others? (or other-keys rest-keys)) (with-syntax ([name name] [rest* rest*] @@ -259,12 +262,19 @@ next-loop (error* 'name "keyword list not balanced: ~e" rest*)) #,(if allow-body? - #'expr + (if body-spec + #`(apply (lambda/kw #,body-spec expr) body*) + #'expr) #'(if (null? body*) expr (error* 'name "non-keywords in arguments: ~e" body*))))))))) ;; ------------------------------------------------------------------------ + ;; generates the part of the body that deals with rest-related stuff + (define (make-keys-body expr) + (with-syntax ([body (make-rest-body expr)] [keys keys]) + #'(let* keys body))) + ;; ------------------------------------------------------------------------ ;; body generation starts here (cond ;; no optionals or keys => plain lambda @@ -273,18 +283,19 @@ (syntax/loc stx (lambda vars expr)))] ;; no keys => make a case-lambda for optionals [(null? keys) - (let ([clauses (make-opt-clauses)]) + (let ([clauses (make-opt-clauses expr (or rest '()))]) (with-syntax ([name name] [clauses clauses]) (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))] ;; 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))))] + [body (make-keys-body expr)]) + (syntax/loc stx (lambda vars body)))] ;; both opts and keys => combine the above two [else - '!!!])) + (let ([clauses (make-opt-clauses (make-keys-body expr) rest*)]) + (with-syntax ([name name] [clauses clauses]) + (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))])) (syntax-case stx () [(_ (formal ... . rest) expr0 expr ...) ; dot is exactly like #:rest #'(_ (formal ... #:rest rest) expr0 expr ...)] @@ -305,12 +316,11 @@ (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) - +;; Keyword searching utility (note: no errors for odd length) +(provide getarg) (define (getarg args keyword . not-found) (let loop ([args args]) - (cond [(or (null? args) (null? (cdr args))) + (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args)))) (and (pair? not-found) (let ([x (car not-found)]) (cond [(procedure? x) (x)] @@ -322,31 +332,9 @@ ;; 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))) + (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car 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")] - [(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))] - [else (scan (cddr tail))])) - (scan initargs)) - -(define (keys/args args) - (let loop ([args args] [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))]))) - -(define (filter-out-keys outs args) - (let loop ([as args] [r '()]) - (cond [(null? as) (reverse! r)] - [(null? (cdr as)) (reverse! (cons (car as) r))] - [else - (loop (cddr as) - (if (memq (car as) outs) r (list* (cadr as) (car as) r)))]))) - ) diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index 0982384cc9..3473d4fe31 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -50,6 +50,10 @@ (t '(0 1 1) f 0 1) (t '(0 1 2) f 0 1 2)) + ;; keywords: basic stuff + (let ([f (lambda/kw (#:key x [y 1] [z #:zz #:z]) (list x y z))]) + (t '(#f 1 #:z) f) + (t '(#:zz 1 #:zzz) f #:zz #:zzz #:zz 123 #:x #:zz)) ;; keywords: default-expr scope (let ([f (lambda/kw (#:key x y) (list x y))]) (t '(#f #f) f) @@ -88,6 +92,10 @@ (lambda/kw (#:key [x z]) y))))]) (t 3 (f)) (t 1 (f) #:x 1)) + ;; keywords: make sure that getarg stops at end of keyword part + (let ([f (lambda/kw (#:key x y #:body b) (list x y b))]) + (t '(#f #f (2 #:x 1)) f 2 #:x 1) + (t '(#f #f (2 3 #:x 1)) f 2 3 #:x 1)) ;; exotic extras (let ([f (lambda/kw (#:key a b #:rest r) r)]) @@ -159,6 +167,33 @@ (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) + ;; optionals and keys + (let ([f (lambda/kw (#:optional a b #:key c d) (list a b c d))]) + (t '(#f #f #f #f) f) + (t '(1 #f #f #f) f 1) + (t '(1 2 #f #f) f 1 2) + (t '(#:c #:d #f #f) f #:c #:d) + (t '(#:c 1 #f #f) f #:c 1) + (t '(1 2 #:d #f) f 1 2 #:c #:d) + (t '(#:c #:d #:d #f) f #:c #:d #:c #:d) + (t '(#:c 1 #:d #f) f #:c 1 #:c #:d)) + + ;; multi-level arg lists with #:body specs + (let ([f (lambda/kw (#:key x y #:body (z)) (list x y z))]) + (t '(#f #f 3) f 3) + (t '(#f 2 3) f #:y 2 3) + (err/rt-test (f #:y 2)) + (err/rt-test (f #:y 2 3 4))) + (let ([f (lambda/kw (#:key x y #:body (z . r)) (list x y z r))]) + (t '(#f #f 3 ()) f 3) + (t '(#f 2 3 ()) f #:y 2 3) + (err/rt-test (f #:y 2)) + (t '(#f 2 3 (4)) f #:y 2 3 4)) + (let ([f (lambda/kw (#:key x y #:body (a #:key (xx #:x #f) (yy #:y #f))) + (list x y a xx yy))]) + (t '(1 #f 2 3 #f) f #:x 1 2 #:x 3) + (t '(1 #:x 2 3 #:x) f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x #:x 33)) + ) ;; test syntax errors @@ -185,12 +220,17 @@ (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 #:key [(y) 3]) 1)) + (st #'(lambda/kw (x #:key [x]) 1)) + (st #'(lambda/kw (x #:key [y 1 2]) 1)) + (st #'(lambda/kw (x #:key [y #:y 1 2]) 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 #:key y #:body 3) 1)) (st #'(lambda/kw (x #:body "3") 1)) + (st #'(lambda/kw (x #:key y #: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))