suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

All features complete, remove utilities that don't seem necessary,

Browse Source 
make getarg and getarg* stop at non-keyword

svn: r1103
This commit is contained in:
Eli Barzilay 2005-10-19 07:47:56 +00:00
parent 1db64d4e85
commit 3494461c98
2 changed files with 66 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/mzlib/kw.ss
View File

@ -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 (<id> <key> <default>) keys to (<id> <default>)
@ -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)))])))
)

42
collects/tests/mzscheme/kw.ss
View File

@ -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))