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

fix expansion problems

Browse Source 
svn: r2312
This commit is contained in:
Eli Barzilay 2006-02-24 13:14:04 +00:00
parent 305505fb05
commit 67e5151775
1 changed files with 25 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/mzlib/kw.ss
View File

@ -53,14 +53,6 @@
) )
(append formals (list #'#:rest #'rest))))] (append formals (list #'#:rest #'rest))))]
[(formal ...) (syntax->list formals)])) [(formal ...) (syntax->list formals)]))
;; is an expression simple? (=> evaluating cannot have side effects)
(define (simple-expr? expr)
(let ([expr (local-expand expr 'expression null)]) ; expand id macros
(syntax-case expr (#%datum #%top quote)
[(#%datum . _) #t]
[(#%top . _) #t]
[(quote . _) #t]
[_ (identifier? expr)])))
;; split a list of syntax objects based on syntax keywords: ;; split a list of syntax objects based on syntax keywords:
;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...) ;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...)
(define (split-by-keywords xs) (define (split-by-keywords xs)
@ -118,6 +110,19 @@
[(or forbid forbid-any) #f] [(or forbid forbid-any) #f]
[else (ormap (lambda (k) (and (assq k rests) #t)) ; suggested? [else (ormap (lambda (k) (and (assq k rests) #t)) ; suggested?
(car (cddddr processed-spec)))]))) (car (cddddr processed-spec)))])))
(define (make-keyword-get-expr key rest default known-vars)
;; expand (for id macros) and check if its a simple expression, because if
;; it is, evaluation cannot have side-effects and we can use keyword-get*
(define default*
(local-expand default 'expression (cons #'#%app known-vars)))
(define simple?
(syntax-case default* (#%datum #%top quote)
[(#%datum . _) #t] [(#%top . _) #t] [(quote . _) #t]
[_ (identifier? default*)]))
(with-syntax ([getter (if simple? #'keyword-get* #'keyword-get)]
[default (if simple? default* #`(lambda () #,default*))]
[rest rest] [key key])
#'(getter rest key default)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; test variables ;; test variables
(define (process-vars vars opts keys0 rests modes . only-vars?) (define (process-vars vars opts keys0 rests modes . only-vars?)
@ -139,15 +144,18 @@
processed-keyword-specs))] processed-keyword-specs))]
;; turn (<id> <key> <default>) keys to (<id> <default>) ;; turn (<id> <key> <default>) keys to (<id> <default>)
[(keys) [(keys)
(with-syntax ([r rest*]) (with-syntax ([rst rest*])
(map (lambda (k) (let loop ([ks keys0] [r '()]
(list [known-vars (append vars (map car opts))])
(car k) (if (null? ks)
(if (simple-expr? (caddr k)) (reverse! r)
;; simple case => no closure (let ([k (car ks)])
#`(keyword-get* r #,(cadr k) #,(caddr k)) (loop (cdr ks)
#`(keyword-get r #,(cadr k) (lambda () #,(caddr k)))))) (cons (list (car k)
keys0))] (make-keyword-get-expr
(cadr k) rest* (caddr k) known-vars))
r)
(cons (car k) known-vars))))))]
[(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