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

@@ -1 +1 @@
-1862
+1863

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*)))