diff --git a/piclib/built-in.scm b/piclib/built-in.scm index a7fcd64d..568cff08 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -583,9 +583,6 @@ (identifier=? use-env x use-env y)) (make-syntactic-closure use-env '() (f expr rename compare)))) -(define (acons key val alist) - (cons (cons key val) alist)) - (define (walk f obj) (if (pair? obj) (cons (walk f (car obj)) (walk f (cdr obj))) @@ -595,21 +592,12 @@ (define (ir-macro-transformer f) (lambda (expr use-env mac-env) - (let ((wrapped '())) - (define (inject obj) - (let ((s (make-syntactic-closure use-env '() obj))) - (set! wrapped (acons s obj wrapped)) - s)) - (define (extract obj) - (let ((t (assq obj wrapped))) - (if t (cdr t) obj))) - (define (wrap expr) - (walk inject expr)) - (define (unwrap expr) - (walk extract expr)) - (define (compare x y) - (identifier=? use-env x use-env y)) - (make-syntactic-closure mac-env '() (unwrap (f (wrap expr) inject compare)))))) + (define (inject identifier) + (make-syntactic-closure use-env '() identifier)) + (define (compare x y) + (identifier=? mac-env x mac-env y)) + (let ((expr (walk (lambda (x) (if (symbol? x) (inject x) x)) expr))) + (make-syntactic-closure mac-env '() (f expr inject compare))))) (define-syntax or (ir-macro-transformer diff --git a/src/macro.c b/src/macro.c index 213b759a..531ffb1f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -153,6 +153,20 @@ pic_identifier_p(pic_value obj) return false; } +static pic_value +strip(pic_state *pic, pic_value expr) +{ + if (pic_sc_p(expr)) { + return strip(pic, pic_sc(expr)->expr); + } + else if (pic_pair_p(expr)) { + return pic_cons(pic, + strip(pic, pic_car(pic, expr)), + strip(pic, pic_cdr(pic, expr))); + } + return expr; +} + static void pic_defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct pic_senv *mac_env) { @@ -365,7 +379,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_gc_protect(pic, v); return v; case PIC_STX_QUOTE: - v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), pic_cdr(pic, expr)); + v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), strip(pic, pic_cdr(pic, expr))); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); return v;