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

* getarg' -> keyword-get'

Browse Source 
* `#:rest-keys' -> `#:other-keys+body'

svn: r1147

original commit: 9ef65a4a80d55968875c6f4460733134ed644845
This commit is contained in:
Eli Barzilay 2005-10-24 22:15:20 +00:00
parent 82f7ecb1ee
commit 1dcd4966c7
2 changed files with 40 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/mzlib/kw.ss
View File

@ -4,16 +4,17 @@
(begin-for-syntax ; -> configuration for lambda/kw (begin-for-syntax ; -> configuration for lambda/kw
;; must appear at the end, each with exactly one variable ;; must appear at the end, each with exactly one variable
(define rest-like-kwds '(#:rest #:body #:rest-keys #:all-keys #:other-keys)) (define rest-like-kwds
'(#:rest #:body #:all-keys #:other-keys #:other-keys+body))
;; mode keys are in the end, without variable, cannot have contradictions ;; mode keys are in the end, without variable, cannot have contradictions
;; each descriptor for #:allow-kwd and #:forbid-kwd is ;; each descriptor for #:allow-kwd and #:forbid-kwd is
;; (kwd-sym (forcer ...) (enabler ...)) ;; (kwd-sym (forcer ...) (enabler ...))
;; `forcer' is a rest-like keyword that forces the mode, `enabler' is a ;; `forcer' is a rest-like keyword that forces the mode, `enabler' is a
;; rest-like keyword that makes it on by default ;; rest-like keyword that makes it on by default
(define mode-keyword-specs (define mode-keyword-specs
'((other-keys (#:other-keys) (#:rest #:rest-keys #:all-keys)) '((other-keys (#:other-keys) (#:rest #:all-keys #:other-keys+body))
(duplicate-keys () (#:rest #:all-keys)) (duplicate-keys () (#:rest #:all-keys))
(body (#:body) (#:rest #:rest-keys)) (body (#:body) (#:rest #:other-keys+body))
(anything () ()))) (anything () ())))
;; precomputed mode keyword stuff ;; precomputed mode keyword stuff
(define processed-keyword-specs (define processed-keyword-specs
@ -125,7 +126,7 @@
(let*-values (let*-values
([(only-vars?) (and (pair? only-vars?) (car only-vars?))] ([(only-vars?) (and (pair? only-vars?) (car only-vars?))]
[(opts keys0) (values (map process-opt opts) (map process-key keys0))] [(opts keys0) (values (map process-opt opts) (map process-key keys0))]
[(rest body rest-keys all-keys other-keys) [(rest body all-keys other-keys other-keys+body)
(apply values (map (lambda (k) (apply values (map (lambda (k)
(cond [(assq k rests) => cdr] [else #f])) (cond [(assq k rests) => cdr] [else #f]))
rest-like-kwds))] rest-like-kwds))]
@ -140,18 +141,19 @@
[(keys) [(keys)
(with-syntax ([r rest*]) (with-syntax ([r rest*])
(map (lambda (k) (map (lambda (k)
(list (car k) (list
(if (simple-expr? (caddr k)) (car k)
;; simple case => no closure (if (simple-expr? (caddr k))
#`(getarg* r #,(cadr k) #,(caddr k)) ;; simple case => no closure
#`(getarg r #,(cadr k) (lambda () #,(caddr k)))))) #`(keyword-get* r #,(cadr k) #,(caddr k))
#`(keyword-get r #,(cadr k) (lambda () #,(caddr k))))))
keys0))] keys0))]
[(all-ids) [(all-ids)
`(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body* `(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body*
;; make up names if not specified, to make checking easy ;; make up names if not specified, to make checking easy
,(or rest-keys (gensym #'rest-keys)) ,(or all-keys (gensym #'all-keys))
,(or all-keys (gensym #'all-keys)) ,(or other-keys (gensym #'other-keys))
,(or other-keys (gensym #'other-keys)) ,(or other-keys+body (gensym #'other-keys+body))
,@(if (and body (not (identifier? body))) ,@(if (and body (not (identifier? body)))
(parse-formals body #t) '()))]) (parse-formals body #t) '()))])
(cond [only-vars? all-ids] (cond [only-vars? all-ids]
@ -159,10 +161,10 @@
=> (lambda (d) (serror d "not an identifier"))] => (lambda (d) (serror d "not an identifier"))]
[(check-duplicate-identifier all-ids) [(check-duplicate-identifier all-ids)
=> (lambda (d) (serror d "duplicate argument name"))] => (lambda (d) (serror d "duplicate argument name"))]
[else (values vars opts keys rest rest* body body* rest-keys [else (values vars opts keys rest rest* body body* all-keys
all-keys other-keys other-keys* other-keys-mode other-keys other-keys* other-keys+body
duplicate-keys-mode body-mode anything-mode other-keys-mode duplicate-keys-mode body-mode
(map cadr keys0))]))) anything-mode (map cadr keys0))])))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; parses formals, returns list of normal vars, optional var specs, key var ;; 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 ;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys
@ -211,7 +213,7 @@
(define (generate-body formals expr) (define (generate-body formals expr)
;; relations: ;; relations:
;; rest = (append all-keys body) ;; rest = (append all-keys body)
;; rest-keys = (append other-keys body) ;; other-keys+body = (append other-keys body)
(define-values (vars ; plain variables (define-values (vars ; plain variables
opts ; optionals, each is (id default) opts ; optionals, each is (id default)
keys ; keywords, each is (id key default) keys ; keywords, each is (id key default)
@ -219,10 +221,10 @@
rest* ; always an id rest* ; always an id
body ; rest after all keyword-vals (id or formals) body ; rest after all keyword-vals (id or formals)
body* ; always an id body* ; always an id
rest-keys ; rest without specified keys
all-keys ; keyword-vals without body all-keys ; keyword-vals without body
other-keys ; unprocessed keyword-vals other-keys ; unprocessed keyword-vals
other-keys* ; always an id other-keys* ; always an id
other-keys+body ; rest without specified keys
allow-other-keys? ; allowing other keys? allow-other-keys? ; allowing other keys?
allow-duplicate-keys? ; allowing duplicate keys? allow-duplicate-keys? ; allowing duplicate keys?
allow-body? ; allowing body after keys? allow-body? ; allowing body after keys?
@ -254,7 +256,7 @@
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; generates the part of the body that deals with rest-related stuff ;; generates the part of the body that deals with rest-related stuff
(define (make-rest-body expr) (define (make-rest-body expr)
(define others? (or other-keys rest-keys)) (define others? (or other-keys other-keys+body))
(with-syntax ([name name] (with-syntax ([name name]
[rest* rest*] [rest* rest*]
[body* body*] [body* body*]
@ -262,7 +264,7 @@
[expr expr] [expr expr]
[all-keys* all-keys] [all-keys* all-keys]
[other-keys* other-keys*] [other-keys* other-keys*]
[rest-keys* rest-keys] [other-keys+body* other-keys+body]
[seen-keys #'seen-keys]) [seen-keys #'seen-keys])
(with-syntax (with-syntax
([loop-vars ([loop-vars
@ -295,11 +297,11 @@
#,@(if others? #,@(if others?
#'([other-keys* (reverse! other-keys*)]) #'([other-keys* (reverse! other-keys*)])
'()) '())
#,@(cond [(and other-keys rest-keys) #,@(cond [(and other-keys other-keys+body)
#'([rest-keys* #'([other-keys+body*
(append other-keys* body*)])] (append other-keys* body*)])]
[rest-keys ; can destroy other-keys [other-keys+body ; can destroy other-keys
#'([rest-keys* #'([other-keys+body*
(append! other-keys* body*)])] (append! other-keys* body*)])]
[else '()])) [else '()]))
expr) expr)
@ -311,8 +313,8 @@
next-loop next-loop
(error* 'name "unknown keyword: ~e" (error* 'name "unknown keyword: ~e"
(car body*))))]) (car body*))))])
(if (and allow-anything? (if (and allow-anything? (not body)
(not body) (not rest-keys) (not all-keys) (not other-keys)) (not other-keys+body) (not all-keys) (not other-keys))
;; allowing anything and don't need special rests, so no loop ;; allowing anything and don't need special rests, so no loop
#'expr #'expr
;; normal code ;; normal code
@ -387,16 +389,16 @@
(current-continuation-marks)))) (current-continuation-marks))))
;; keyword searching utility (note: no errors for odd length) ;; keyword searching utility (note: no errors for odd length)
(provide getarg) (provide keyword-get)
(define (getarg args keyword . not-found) (define (keyword-get args keyword . not-found)
(let loop ([args args]) (let loop ([args args])
(cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args)))) (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args))))
(and (pair? not-found) ((car not-found)))] (and (pair? not-found) ((car not-found)))]
[(eq? (car args) keyword) (cadr args)] [(eq? (car args) keyword) (cadr args)]
[else (loop (cddr args))]))) [else (loop (cddr args))])))
;; a private version of getarg that is used with simple values ;; a private version of keyword-get that is used with simple values
(define (getarg* args keyword . not-found) (define (keyword-get* args keyword . not-found)
(let loop ([args args]) (let loop ([args args])
(cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args)))) (cond [(or (null? args) (null? (cdr args)) (not (keyword? (car args))))
(and (pair? not-found) (car not-found))] (and (pair? not-found) (car not-found))]

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

@ -129,7 +129,8 @@
(f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3) (f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3)
;; #:c is not a specified key, so it is allowed to repeat ;; #:c is not a specified key, so it is allowed to repeat
(f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33) (f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33))) (f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33)
))
(let ([f (lambda/kw (#:key a b #:other-keys r #:allow-duplicate-keys) r)]) (let ([f (lambda/kw (#:key a b #:other-keys r #:allow-duplicate-keys) r)])
(t (f) => '() (t (f) => '()
(f #:a 1 #:b 2) => '() (f #:a 1 #:b 2) => '()
@ -138,7 +139,7 @@
(f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3) (f #:d 4 #:a 1 #:b 2 #:c 3) => '(#:d 4 #:c 3)
(f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33) (f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33) => '(#:d 4 #:c 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33))) (f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33)))
(let ([f (lambda/kw (#:key a b #:rest-keys r) r)]) (let ([f (lambda/kw (#:key a b #:other-keys+body r) r)])
(t (f) => '() (t (f) => '()
(f 1 2) => '(1 2) (f 1 2) => '(1 2)
(f #:a 1 #:b 2) => '() (f #:a 1 #:b 2) => '()
@ -151,7 +152,8 @@
(f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33 1 2) => '(#:d 4 #:c 3 #:c 33 1 2) (f #:d 4 #:a 1 #:b 2 #:c 3 #:c 33 1 2) => '(#:d 4 #:c 3 #:c 33 1 2)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33) (f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33) => '(#:d 4 #:c 3 #:c 33)
(f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33 1 2) => '(#:d 4 #:c 3 #:c 33 1 2))) (f #:d 4 #:a 1 #:c 3 #:b 2 #:c 33 1 2) => '(#:d 4 #:c 3 #:c 33 1 2)))
(let ([f (lambda/kw (#:key a b #:rest-keys r #:allow-duplicate-keys) r)]) (let ([f (lambda/kw (#:key a b #:other-keys+body r #:allow-duplicate-keys)
r)])
(t (f) => '() (t (f) => '()
(f 1 2) => '(1 2) (f 1 2) => '(1 2)
(f #:a 1 #:b 2) => '() (f #:a 1 #:b 2) => '()
@ -180,14 +182,14 @@
(t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:b 2) (t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:b 2)
:rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:b 2) :rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:b 2)
1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:b 2)
1 <= ((lambda/kw (#:key a #:rest-keys r) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:b 2)
1 <= ((lambda/kw (#:key a #:allow-other-keys) a) #:a 1 #:b 2) 1 <= ((lambda/kw (#:key a #:allow-other-keys) a) #:a 1 #:b 2)
:rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-other-keys) a) #:a 1 #:b 2)) :rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-other-keys) a) #:a 1 #:b 2))
;; check when duplicate keys are allowed ;; check when duplicate keys are allowed
(t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:a 2) (t :rt-err: <= ((lambda/kw (#:key a #:body r) r) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:a 2) :rt-err: <= ((lambda/kw (#:key a) a) #:a 1 #:a 2)
1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:a 2) 1 <= ((lambda/kw (#:key a #:rest r) a) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a #:rest-keys r) a) #:a 1 #:a 2) :rt-err: <= ((lambda/kw (#:key a #:other-keys+body r) a) #:a 1 #:a 2)
1 <= ((lambda/kw (#:key a #:allow-duplicate-keys) a) #:a 1 #:a 2) 1 <= ((lambda/kw (#:key a #:allow-duplicate-keys) a) #:a 1 #:a 2)
:rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-duplicate-keys) a) #:a 1 #:a 2)) :rt-err: <= ((lambda/kw (#:key a #:rest r #:forbid-duplicate-keys) a) #:a 1 #:a 2))
;; check when body is allowed ;; check when body is allowed
@ -337,7 +339,7 @@
:st-err: <= (lambda/kw (x #:optional ()) 1) :st-err: <= (lambda/kw (x #:optional ()) 1)
:st-err: <= (lambda/kw (x #:optional (x y z)) 1) :st-err: <= (lambda/kw (x #:optional (x y z)) 1)
:st-err: <= (lambda/kw (x #:other-keys z) 1) :st-err: <= (lambda/kw (x #:other-keys z) 1)
:st-err: <= (lambda/kw (x #:rest-keys z) 1) :st-err: <= (lambda/kw (x #:other-keys+body z) 1)
:st-err: <= (lambda/kw (x #:all-keys z) 1) :st-err: <= (lambda/kw (x #:all-keys z) 1)
:st-err: <= (lambda/kw (x #:key y #:allow-other-keys z) 1) :st-err: <= (lambda/kw (x #:key y #:allow-other-keys z) 1)
:st-err: <= (lambda/kw (x #:key y #:forbid-body z) 1) :st-err: <= (lambda/kw (x #:key y #:forbid-body z) 1)