conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add walk-symbol

This commit is contained in:
Yuichi Nishiwaki 2014-07-19 18:14:11 +09:00
parent 346494524f
commit 2c1db4472b
1 changed files with 25 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
piclib/picrin/macro.scm
View File

@ -37,20 +37,26 @@
(vector-map proc expr) (vector-map proc expr)
(proc expr))))) (proc expr)))))
(define (make-syntactic-closure env free form) (define (walk-symbol proc expr)
(define cache (make-dictionary))
(walk (walk
(lambda (atom) (lambda (atom)
(if (not (symbol? atom)) (if (symbol? atom)
atom (proc atom)
(if (memq atom free) atom))
atom expr))
(if (dictionary-has? cache atom)
(dictionary-ref cache atom) (define (make-syntactic-closure env free form)
(define cache (make-dictionary))
(walk-symbol
(lambda (sym)
(if (memq sym free)
sym
(if (dictionary-has? cache sym)
(dictionary-ref cache sym)
(begin (begin
(define id (make-identifier atom env)) (define id (make-identifier sym env))
(dictionary-set! cache atom id) (dictionary-set! cache sym id)
id))))) id))))
form)) form))
(define (close-syntax form env) (define (close-syntax form env)
@ -115,6 +121,11 @@
(dictionary-set! rcache sym id) (dictionary-set! rcache sym id)
id))) id)))
(define (uninject sym)
(if (dictionary-has? icache* sym)
(dictionary-ref icache* sym)
(rename sym)))
(define (compare x y) (define (compare x y)
(if (not (symbol? x)) (if (not (symbol? x))
#f #f
@ -123,23 +134,10 @@
(identifier=? mac-env x mac-env y)))) (identifier=? mac-env x mac-env y))))
(define (wrap expr) (define (wrap expr)
(walk (walk-symbol inject expr))
(lambda (atom)
(if (not (symbol? atom))
atom
(inject atom)))
expr))
(define (unwrap expr) (define (unwrap expr)
(define cache (make-dictionary)) (walk-symbol uninject expr))
(walk
(lambda (atom)
(if (not (symbol? atom))
atom
(if (dictionary-has? icache* atom)
(dictionary-ref icache* atom)
(rename atom))))
expr))
(unwrap (f (wrap expr) inject compare)))) (unwrap (f (wrap expr) inject compare))))