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

Fixes bug 176207: macros cannot be redefined.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-14 03:23:47 -05:00
parent fa27b7e9cd
commit 4e66fe76e8
2 changed files with 23 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1240 1241

27
scheme/psyntax.expander.ss
View File

@ -2808,9 +2808,21 @@
(values e* r mr lex* rhs* mod** kwd*))))))))))) (values e* r mr lex* rhs* mod** kwd*)))))))))))
(define set-global-macro-binding! (define set-global-macro-binding!
(lambda (sym loc b) (lambda (id loc b)
(extend-library-subst! (interaction-library) sym loc) (let ([type
(extend-library-env! (interaction-library) loc b))) (case (binding-type b)
[(local-macro) 'global-macro]
[(local-macro!) 'global-macro!]
[else
(error 'set-global-macro-binding!
"BUG: invalid type" b)])]
[transformer (cadr b)]
[label (id->label id)]
[sym (id->sym id)])
(set-symbol-value! loc transformer)
(extend-library-subst! (interaction-library) sym label)
(extend-library-env! (interaction-library) label
(cons* type (interaction-library) loc)))))
(define gen-global-macro-binding (define gen-global-macro-binding
(lambda (id ctxt) (gen-global-var-binding id ctxt))) (lambda (id ctxt) (gen-global-var-binding id ctxt)))
@ -2820,7 +2832,7 @@
(let ((label (id->label id))) (let ((label (id->label id)))
(let ((b (imported-label->binding label))) (let ((b (imported-label->binding label)))
(case (binding-type b) (case (binding-type b)
((global) ((global global-macro global-macro!)
(let ((x (binding-value b))) (let ((x (binding-value b)))
(let ((lib (car x)) (loc (cdr x))) (let ((lib (car x)) (loc (cdr x)))
(cond (cond
@ -2840,7 +2852,12 @@
(case type (case type
((define) ((define)
(let-values (((id rhs) (parse-define e))) (let-values (((id rhs) (parse-define e)))
(extend-library-subst! (interaction-library)
(id->sym id) (id->label id))
(let ((loc (gen-global-var-binding id e))) (let ((loc (gen-global-var-binding id e)))
(extend-library-env! (interaction-library)
(id->label id)
(cons* 'global (interaction-library) loc))
(let ((rhs (chi-rhs rhs '() '()))) (let ((rhs (chi-rhs rhs '() '())))
(chi-top* (cdr e*) (cons (cons loc rhs) init*)))))) (chi-top* (cdr e*) (cons (cons loc rhs) init*))))))
((define-syntax) ((define-syntax)
@ -2848,7 +2865,7 @@
(let ((loc (gen-global-macro-binding id e))) (let ((loc (gen-global-macro-binding id e)))
(let ((expanded-rhs (expand-transformer rhs '()))) (let ((expanded-rhs (expand-transformer rhs '())))
(let ((b (make-eval-transformer expanded-rhs))) (let ((b (make-eval-transformer expanded-rhs)))
(set-global-macro-binding! (id->sym id) loc b) (set-global-macro-binding! id loc b)
(chi-top* (cdr e*) init*)))))) (chi-top* (cdr e*) init*))))))
((let-syntax letrec-syntax) ((let-syntax letrec-syntax)
(error 'chi-top* "not supported yet at top level" type)) (error 'chi-top* "not supported yet at top level" type))