suzanne.soy/racket
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
This commit is contained in:
Eli Barzilay 2005-10-24 10:18:31 +00:00
parent 2415956597
commit acfb67ec9b
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 (define mode-keyword-specs
'((other-keys (#:other-keys) (#:rest #:rest-keys #:all-keys)) '((other-keys (#:other-keys) (#:rest #:rest-keys #:all-keys))
(duplicate-keys () (#:rest #:all-keys)) (duplicate-keys () (#:rest #:all-keys))
(body (#:body) (#:rest #:rest-keys)))) (body (#:body) (#:rest #:rest-keys))
(anything () ())))
;; precomputed mode keyword stuff ;; precomputed mode keyword stuff
(define processed-keyword-specs (define processed-keyword-specs
(map (lambda (ks) (map (lambda (ks)
@ -31,10 +32,9 @@
(define-syntax (lambda/kw stx) (define-syntax (lambda/kw stx)
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; easy syntax errors ;; easy syntax errors
(define original-formals #f)
(define (serror sub fmt . args) (define (serror sub fmt . args)
(raise-syntax-error (apply raise-syntax-error
#f (apply format fmt args) stx (or sub original-formals))) #f (apply format fmt args) stx (if sub (list sub) '())))
;; contents of syntax ;; contents of syntax
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x)) (define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
;; turns formals into a syntax list ;; turns formals into a syntax list
@ -91,6 +91,8 @@
(cond (cond
[(and allow forbid) [(and allow forbid)
(serror #f "contradicting #:...-~a keywords" (car processed-spec))] (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)) [(ormap (lambda (k) (assq k rests)) (cadddr processed-spec))
=> ; forced? => ; forced?
(lambda (r) (lambda (r)
@ -112,15 +114,11 @@
(apply values (apply values
(map (lambda (k) (cond [(assq k rests) => cdr] [else #f])) (map (lambda (k) (cond [(assq k rests) => cdr] [else #f]))
'(#:rest #:body #:rest-keys #:all-keys #:other-keys)))] '(#: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*) [(rest* body* other-keys*)
(values (or rest (gensym #'rest)) (values (or rest (gensym #'rest))
(or body (gensym #'body)) (if (and body (identifier? body)) body (gensym #'body))
(or other-keys (gensym #'other-keys)))] (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) (apply values (map (process-mode modes rests)
processed-keyword-specs))] processed-keyword-specs))]
;; turn (<id> <key> <default>) keys to (<id> <default>) ;; turn (<id> <key> <default>) keys to (<id> <default>)
@ -139,15 +137,16 @@
,(or rest-keys (gensym #'rest-keys)) ,(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))
,@(if body-spec (parse-formals body-spec #t) '()))]) ,@(if (and body (not (identifier? body)))
(parse-formals body #t) '()))])
(cond [only-vars? all-ids] (cond [only-vars? all-ids]
[(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids) [(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids)
=> (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* body-spec [else (values vars opts keys rest rest* body body* rest-keys
rest-keys all-keys other-keys other-keys* all-keys other-keys other-keys* other-keys-mode
other-keys-mode duplicate-keys-mode body-mode duplicate-keys-mode body-mode anything-mode
(map cadr keys0))]))) (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
@ -203,9 +202,8 @@
keys ; keywords, each is (id key default) keys ; keywords, each is (id key default)
rest ; rest variable (no optionals) rest ; rest variable (no optionals)
rest* ; always an id rest* ; always an id
body ; rest after all keyword-vals body ; rest after all keyword-vals (id or formals)
body* ; always an id body* ; always an id
body-spec ; syntax of body with sub-formals
rest-keys ; rest without specified keys 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
@ -213,6 +211,7 @@
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?
allow-anything? ; allowing anything?
keywords) ; list of mentioned keywords keywords) ; list of mentioned keywords
(parse-formals formals)) (parse-formals formals))
(define name (define name
@ -293,32 +292,42 @@
(with-syntax ([next-loop (with-syntax ([next-loop
(if allow-other-keys? (if allow-other-keys?
#'next-loop #'next-loop
;;!!!
#'(if (memq (car body*) 'keywords) #'(if (memq (car body*) 'keywords)
next-loop next-loop
(error* 'name "unknown keyword: ~e" (error* 'name "unknown keyword: ~e"
(car body*))))]) (car body*))))])
#`(let loop loop-vars (if (not allow-anything?) ; normal code
(if (and (pair? body*) (keyword? (car body*))) #`(let loop loop-vars
(if (pair? (cdr body*)) (if (and (pair? body*) (keyword? (car body*)))
next-loop (if (pair? (cdr body*))
(error* 'name "keyword list not balanced: ~e" rest*)) next-loop
#,(if allow-body? (error* 'name "keyword list not balanced: ~e" rest*))
(if body-spec #,(if allow-body?
(with-syntax ([name (string->symbol (if (and body (not (identifier? body)))
(format "~a~~body" (with-syntax ([name (string->symbol
(syntax-e* #'name)))]) (format "~a~~body"
(with-syntax ([subcall (syntax-e* #'name)))])
(quasisyntax/loc stx (with-syntax ([subcall
(let ([name (lambda/kw #,body-spec (quasisyntax/loc stx
expr)]) (let ([name (lambda/kw #,body
name))]) expr)])
#'(apply subcall body*))) name))])
#'expr) #'(apply subcall body*)))
#'(if (null? body*) #'expr)
expr #'(if (null? body*)
(error* 'name "expecting a ~s keyword got: ~e" expr
'keywords (car body*)))))))))) (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 ;; generates the part of the body that deals with rest-related stuff
(define (make-keys-body expr) (define (make-keys-body expr)
@ -348,8 +357,7 @@
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))])) (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))
(syntax-case stx () (syntax-case stx ()
[(_ formals expr0 expr ...) [(_ formals expr0 expr ...)
(begin (set! original-formals #'formals) (generate-body #'formals #'(let () expr0 expr ...))]))
(generate-body #'formals #'(let () expr0 expr ...)))]))
(provide define/kw) (provide define/kw)
(define-syntax (define/kw stx) (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))) :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))) (let ([f (lambda/kw (#:key x y #:body (a #:key (xx #:x #f) (yy #:y #f)))
(list x y a xx yy))]) (list x y a xx yy))])
(t '(1 #f 2 3 #f) <= (f #:x 1 2 #:x 3)) (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)) '(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)) :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)) :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))) :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 ;; make sure that internal definitions work
(let ([f (lambda/kw (#:key x) (define xx x) xx)]) (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 #:optional o) 1)
:st-err: <= (lambda/kw (x #:rest r #:forbid-other-keys #:allow-other-keys) 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 #: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 r1 #:rest r2) 1)
:st-err: <= (lambda/kw (x #:rest) 1) :st-err: <= (lambda/kw (x #:rest) 1)
:st-err: <= (lambda/kw (x #:rest r1 r2) 1) :st-err: <= (lambda/kw (x #:rest r1 r2) 1)