From d03fbfe4eff0c52ceceaf07b2c479b1060148de9 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Mon, 19 Oct 2009 23:28:36 +0300 Subject: [PATCH] fixed bug in expanding macros in internal definitions which were incorrectly implemented as little modules (with their own little scope) that export everything. They now use the same scope as the main definitions. --- scheme/last-revision | 2 +- scheme/psyntax.expander.ss | 120 ++++++++++++++++++++++--------------- 2 files changed, 73 insertions(+), 49 deletions(-) diff --git a/scheme/last-revision b/scheme/last-revision index 86fc8f4..1c95f53 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1862 +1863 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index ca9e674..7039a45 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -413,15 +413,57 @@ (make-stx (stx-expr e) m* s* ae*)) (make-stx e m* s* ae*)))) - ;;; to add a mark, we always add a corresponding shift. - (define add-mark - (lambda (m e ae) - (mkstx e (list m) '(shift) (list ae)))) - (define add-subst (lambda (subst e) (mkstx e '() (list subst) '()))) + (define add-mark + (lambda (mark subst expr ae) + (define merge-ae* + (lambda (ls1 ls2) + (if (and (pair? ls1) (pair? ls2) (not (car ls2))) + (cancel ls1 ls2) + (append ls1 ls2)))) + (define cancel + (lambda (ls1 ls2) + (let f ((x (car ls1)) (ls1 (cdr ls1))) + (if (null? ls1) + (cdr ls2) + (cons x (f (car ls1) (cdr ls1))))))) + (define (f e m s1* ae*) + (cond + [(pair? e) + (let ([a (f (car e) m s1* ae*)] + [d (f (cdr e) m s1* ae*)]) + (if (eq? a d) e (cons a d)))] + [(vector? e) + (let ([ls1 (vector->list e)]) + (let ([ls2 (map (lambda (x) (f x m s1* ae*)) ls1)]) + (if (for-all eq? ls1 ls2) e (list->vector ls2))))] + [(stx? e) + (let ([m* (stx-mark* e)] [s2* (stx-subst* e)]) + (cond + [(null? m*) + (f (stx-expr e) m + (append s1* s2*) + (merge-ae* ae* (stx-ae* e)))] + [(eq? (car m*) anti-mark) + (make-stx (stx-expr e) (cdr m*) + (cdr (append s1* s2*)) + (merge-ae* ae* (stx-ae* e)))] + [else + (make-stx (stx-expr e) + (cons m m*) + (let ([s* (cons 'shift (append s1* s2*))]) + (if subst (cons subst s*) s*)) + (merge-ae* ae* (stx-ae* e)))]))] + [(symbol? e) + (syntax-violation #f + "raw symbol encountered in output of macro" + expr e)] + [else (make-stx e (list m) s1* ae*)])) + (mkstx (f expr mark '() '()) '() '() (list ae)))) + ;;; now are some deconstructors and predicates for syntax objects. (define syntax-kind? (lambda (x p?) @@ -2678,7 +2720,7 @@ (define (local-macro-transformer x) (car x)) - (define (do-macro-call transformer expr r) + (define (do-macro-call transformer expr r rib) (define (return x) (let f ((x x)) ;;; don't feed me cycles. @@ -2690,8 +2732,8 @@ (syntax-violation #f "raw symbol encountered in output of macro" expr x))))) - (add-mark (gen-mark) x expr)) - (let ((x (transformer (add-mark anti-mark expr #f)))) + (add-mark (gen-mark) rib x expr)) + (let ((x (transformer (add-mark anti-mark #f expr #f)))) (if (procedure? x) (return (x (lambda (id) @@ -2711,13 +2753,13 @@ (return x)))) ;;; chi procedures - (define chi-macro - (lambda (p e r) (do-macro-call (macro-transformer p) e r))) + (define (chi-macro p e r rib) + (do-macro-call (macro-transformer p) e r rib)) - (define chi-local-macro - (lambda (p e r) (do-macro-call (local-macro-transformer p) e r))) + (define (chi-local-macro p e r rib) + (do-macro-call (local-macro-transformer p) e r rib)) - (define (chi-global-macro p e r) + (define (chi-global-macro p e r rib) (let ((lib (car p)) (loc (cdr p))) (unless (eq? lib '*interaction*) @@ -2732,7 +2774,7 @@ (cdr x)) (else (assertion-violation 'chi-global-macro "BUG: not a procedure" x))))) - (do-macro-call transformer e r))))) + (do-macro-call transformer e r rib))))) (define chi-expr* (lambda (e* r mr) @@ -2752,8 +2794,6 @@ rator (chi-expr* rands r mr))))))) - - (define chi-expr (lambda (e r mr) (let-values (((type value kwd) (syntax-type e r))) @@ -2774,9 +2814,11 @@ (let ((lex (lexical-var value))) (build-lexical-reference no-source lex))) ((global-macro global-macro!) - (chi-expr (chi-global-macro value e r) r mr)) - ((local-macro local-macro!) (chi-expr (chi-local-macro value e r) r mr)) - ((macro macro!) (chi-expr (chi-macro value e r) r mr)) + (chi-expr (chi-global-macro value e r #f) r mr)) + ((local-macro local-macro!) + (chi-expr (chi-local-macro value e r #f) r mr)) + ((macro macro!) + (chi-expr (chi-macro value e r #f) r mr)) ((constant) (let ((datum value)) (build-data no-source datum))) @@ -2853,9 +2895,9 @@ ((global) (stx-error e "attempt to modify an immutable binding")) ((global-macro!) - (chi-expr (chi-global-macro value e r) r mr)) + (chi-expr (chi-global-macro value e r #f) r mr)) ((local-macro!) - (chi-expr (chi-local-macro value e r) r mr)) + (chi-expr (chi-local-macro value e r #f) r mr)) ((mutable) (if (and (pair? value) (let ((lib (car value))) (eq? lib '*interaction*))) (let ([loc (cdr value)]) @@ -3107,24 +3149,6 @@ (cons (cons lab (cons '$module iface)) mr) mod** kwd*))))))))) - (define (copy-rib-contents! from-rib to-rib sd?) - (for-each - (lambda (sym mark* label) - (let ([id (make-stx sym mark* '() '())]) - (extend-rib! to-rib id label sd?))) - (rib-sym* from-rib) (rib-mark** from-rib) (rib-label* from-rib))) - - (define chi-body*-macro - (lambda (e* r mr lex* rhs* mod** kwd* exp* rib mix? sd? e) - (let ([rib2 (make-empty-rib)]) - (let-values ([(e1* r mr lex* rhs* mod** kwd* exp*) - (chi-body* (list (add-subst rib2 e)) - r mr lex* rhs* mod** kwd* exp* rib2 mix? sd?)]) - (copy-rib-contents! rib2 rib sd?) - (if (null? e1*) - (chi-body* e* r mr lex* rhs* mod** kwd* exp* rib mix? sd?) - (values (append e1* e*) r mr lex* rhs* mod** kwd* exp*)))))) - (define chi-body* (lambda (e* r mr lex* rhs* mod** kwd* exp* rib mix? sd?) (cond @@ -3207,17 +3231,17 @@ r mr lex* rhs* mod** kwd* exp* rib mix? sd?))))) ((global-macro global-macro!) - (chi-body*-macro (cdr e*) - r mr lex* rhs* mod** kwd* exp* rib mix? sd? - (chi-global-macro value e r))) + (chi-body* + (cons (chi-global-macro value e r rib) (cdr e*)) + r mr lex* rhs* mod** kwd* exp* rib mix? sd?)) ((local-macro local-macro!) - (chi-body*-macro (cdr e*) - r mr lex* rhs* mod** kwd* exp* rib mix? sd? - (chi-local-macro value e r))) + (chi-body* + (cons (chi-local-macro value e r rib) (cdr e*)) + r mr lex* rhs* mod** kwd* exp* rib mix? sd?)) ((macro macro!) - (chi-body*-macro (cdr e*) - r mr lex* rhs* mod** kwd* exp* rib mix? sd? - (chi-macro value e r))) + (chi-body* + (cons (chi-macro value e r rib) (cdr e*)) + r mr lex* rhs* mod** kwd* exp* rib mix? sd?)) ((module) (let-values (((lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*) (chi-internal-module e r mr lex* rhs* mod** kwd*)))