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

Added #:allow-anything so it's possible to get extra speed

Browse Source 
svn: r1138

original commit: acfb67ec9bdab28786d9231bd46eb0957c1eb371
This commit is contained in:
Eli Barzilay 2005-10-24 10:18:31 +00:00
parent 55a73f404d
commit d50e0fc727
2 changed files with 80 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/mzlib/kw.ss
View File

@ -13,7 +13,8 @@
(define mode-keyword-specs
'((other-keys (#:other-keys) (#:rest #:rest-keys #:all-keys))
(duplicate-keys () (#:rest #:all-keys))
(body (#:body) (#:rest #:rest-keys))))
(body (#:body) (#:rest #:rest-keys))
(anything () ())))
;; precomputed mode keyword stuff
(define processed-keyword-specs
(map (lambda (ks)
@ -31,10 +32,9 @@
(define-syntax (lambda/kw stx)
;; --------------------------------------------------------------------------
;; easy syntax errors
(define original-formals #f)
(define (serror sub fmt . args)
(raise-syntax-error
#f (apply format fmt args) stx (or sub original-formals)))
(apply raise-syntax-error
#f (apply format fmt args) stx (if sub (list sub) '())))
;; contents of syntax
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
;; turns formals into a syntax list
@ -91,6 +91,8 @@
(cond
[(and allow forbid)
(serror #f "contradicting #:...-~a keywords" (car processed-spec))]
[(and forbid (memq #:allow-anything modes))
(serror #f "~a contradicts #:allow-anything" (caddr processed-spec))]
[(ormap (lambda (k) (assq k rests)) (cadddr processed-spec))
=> ; forced?
(lambda (r)
@ -112,15 +114,11 @@
(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 (gensym #'body)))]
[(rest* body* other-keys*)
(values (or rest (gensym #'rest))
(or body (gensym #'body))
(if (and body (identifier? body)) body (gensym #'body))
(or other-keys (gensym #'other-keys)))]
[(other-keys-mode duplicate-keys-mode body-mode)
[(other-keys-mode duplicate-keys-mode body-mode anything-mode)
(apply values (map (process-mode modes rests)
processed-keyword-specs))]
;; turn (<id> <key> <default>) keys to (<id> <default>)
@ -139,15 +137,16 @@
,(or rest-keys (gensym #'rest-keys))
,(or all-keys (gensym #'all-keys))
,(or other-keys (gensym #'other-keys))
,@(if body-spec (parse-formals body-spec #t) '()))])
,@(if (and body (not (identifier? body)))
(parse-formals body #t) '()))])
(cond [only-vars? all-ids]
[(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids)
=> (lambda (d) (serror d "not an identifier"))]
[(check-duplicate-identifier all-ids)
=> (lambda (d) (serror d "duplicate argument name"))]
[else (values vars opts keys rest rest* body body* body-spec
rest-keys all-keys other-keys other-keys*
other-keys-mode duplicate-keys-mode body-mode
[else (values vars opts keys rest rest* body body* rest-keys
all-keys other-keys other-keys* other-keys-mode
duplicate-keys-mode body-mode anything-mode
(map cadr keys0))])))
;; --------------------------------------------------------------------------
;; parses formals, returns list of normal vars, optional var specs, key var
@ -203,9 +202,8 @@
keys ; keywords, each is (id key default)
rest ; rest variable (no optionals)
rest* ; always an id
body ; rest after all keyword-vals
body ; rest after all keyword-vals (id or formals)
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
@ -213,6 +211,7 @@
allow-other-keys? ; allowing other keys?
allow-duplicate-keys? ; allowing duplicate keys?
allow-body? ; allowing body after keys?
allow-anything? ; allowing anything?
keywords) ; list of mentioned keywords
(parse-formals formals))
(define name
@ -293,32 +292,42 @@
(with-syntax ([next-loop
(if allow-other-keys?
#'next-loop
;;!!!
#'(if (memq (car body*) 'keywords)
next-loop
(error* 'name "unknown keyword: ~e"
(car body*))))])
#`(let loop loop-vars
(if (and (pair? body*) (keyword? (car body*)))
(if (pair? (cdr body*))
next-loop
(error* 'name "keyword list not balanced: ~e" rest*))
#,(if allow-body?
(if body-spec
(with-syntax ([name (string->symbol
(format "~a~~body"
(syntax-e* #'name)))])
(with-syntax ([subcall
(quasisyntax/loc stx
(let ([name (lambda/kw #,body-spec
expr)])
name))])
#'(apply subcall body*)))
#'expr)
#'(if (null? body*)
expr
(error* 'name "expecting a ~s keyword got: ~e"
'keywords (car body*))))))))))
(if (not allow-anything?) ; normal code
#`(let loop loop-vars
(if (and (pair? body*) (keyword? (car body*)))
(if (pair? (cdr body*))
next-loop
(error* 'name "keyword list not balanced: ~e" rest*))
#,(if allow-body?
(if (and body (not (identifier? body)))
(with-syntax ([name (string->symbol
(format "~a~~body"
(syntax-e* #'name)))])
(with-syntax ([subcall
(quasisyntax/loc stx
(let ([name (lambda/kw #,body
expr)])
name))])
#'(apply subcall body*)))
#'expr)
#'(if (null? body*)
expr
(error* 'name "expecting a ~s keyword got: ~e"
'keywords (car body*))))))
;; allowing anything: can't use rest-like except for rest
(let ([bad (cond [body `(,body #:body)]
[rest-keys `(,rest-keys #:rest-keys)]
[all-keys `(,all-keys #:all-keys)]
[other-keys `(,other-keys #:other-keys)]
[else #f])])
(if bad
(serror (car bad) "cannot use #:allow-anything with ~a"
(cadr bad))
#'expr)))))))
;; ------------------------------------------------------------------------
;; generates the part of the body that deals with rest-related stuff
(define (make-keys-body expr)
@ -348,8 +357,7 @@
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))
(syntax-case stx ()
[(_ formals expr0 expr ...)
(begin (set! original-formals #'formals)
(generate-body #'formals #'(let () expr0 expr ...)))]))
(generate-body #'formals #'(let () expr0 expr ...))]))
(provide define/kw)
(define-syntax (define/kw stx)

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

@ -262,11 +262,23 @@
:rt-err: <= (f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x #:x 33)))
(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 2 #:x 3 #:y #:x))
(t :rt-err: <= (f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x))
(t :rt-err: <= (f #:x 1 #:y #:x 2 #:x 3 #:y #:x #:x 33))
(t :rt-err: <= (f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x #:x 33)))
(t '(1 #f 2 3 #f) <= (f #:x 1 2 #:x 3)
'(1 #:x 2 3 #:x) <= (f #:x 1 #:y #:x 2 #:x 3 #:y #:x)
:rt-err: <= (f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x)
:rt-err: <= (f #:x 1 #:y #:x 2 #:x 3 #:y #:x #:x 33)
:rt-err: <= (f #:x 1 #:y #:x #:x 11 2 #:x 3 #:y #:x #:x 33)))
;; #:allow-anything does not check for imbalanced keyword-values
(let ([f (lambda/kw (#:key x #:allow-anything) x)])
(t (f #:x 1) => 1
(f #:x 1 2) => 1
(f #:x 1 #:y) => 1
(f #:x 1 #:x) => 1
(f #:x 1 #:y 1) => 1
(f #:x 1 #:x 2) => 1
(f #:x 1 #:x 2 #:y) => 1))
(t '(#:x 1 #:z) <= ((lambda/kw (#:key x #:allow-anything #:rest r) r)
#:x 1 #:z))
;; make sure that internal definitions work
(let ([f (lambda/kw (#:key x) (define xx x) xx)])
@ -282,6 +294,21 @@
:st-err: <= (lambda/kw (x #:rest r #:optional o) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:allow-other-keys #:forbid-other-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-duplicate-keys #:allow-duplicate-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:allow-duplicate-keys #:forbid-duplicate-keys) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-body #:allow-body) 1)
:st-err: <= (lambda/kw (x #:rest r #:allow-body #:forbid-body) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-anything #:allow-anything) 1)
:st-err: <= (lambda/kw (x #:rest r #:allow-anything #:forbid-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:body r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:rest-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:all-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:other-keys r #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
:st-err: <= (lambda/kw (#:key a #:forbid-body #:allow-anything) 1)
:st-err: <= (lambda/kw (x #:rest r1 #:rest r2) 1)
:st-err: <= (lambda/kw (x #:rest) 1)
:st-err: <= (lambda/kw (x #:rest r1 r2) 1)