Ticket #445: fix-canonicalize-body.patch

expand.scm

@@ -444 +444 @@
 
 (define ##sys#canonicalize-body
   (lambda (body #!optional (se (##sys#current-environment)) cs?)
+    (define (canonical-core-macro-name renamed)
+      (let ((macro (or (lookup renamed se) renamed)))
+        (if (not (pair? macro))
+            macro ; Not found in SE?  Already a canonical name or not a macro
+            (let find-macro ((handler (cadr macro))
+                             (bindings (##sys#macro-environment)))
+              (if (null? bindings)
+                  #f
+                  (if (eq? (caddar bindings) handler)
+                      (caar bindings)
+                      (find-macro handler (cdr bindings))))))))
     (define (fini vars vals mvars mvals body)
       (if (and (null? vars) (null? mvars))
           (let loop ([body2 body] [exps '()])
@@ -451 +462 @@
                 (cons 
                  '##core#begin
                  body) ; no more defines, otherwise we would have called `expand'
-                (let ([x (car body2)])
-                  (if (and (pair? x) 
-                           (let ((d (car x)))
-                             (and (symbol? d)
-                                  (or (eq? (or (lookup d se) d) 'define)
-                                      (eq? (or (lookup d se) d) 'define-values)))) )
-                      (cons
+                (let* ([x (car body2)]
+                       [m (and (pair? x) (symbol? (car x))
+                               (canonical-core-macro-name (car x)))])
+                  (if (or (eq? m 'define) (eq? m 'define-values))
+                      (cons
                        '##core#begin
                        (##sys#append (reverse exps) (list (expand body2))))
                       (loop (cdr body2) (cons x exps)) ) ) ) )
@@ -492 +501 @@
                ((and (list? (car body))
                      (>= 3 (length (car body))) 
                      (symbol? (caar body))
-                     (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
+                     (eq? 'define-syntax (canonical-core-macro-name (caar body))))
                 (let ((def (car body)))
                   (loop 
                    (cdr body) 
@@ -514 +523 @@
             (fini vars vals mvars mvals body)
             (let* ((x (car body))
                    (rest (cdr body))
-                   (exp1 (and (pair? x) (car x)))
-                   (head (and exp1
-                              (symbol? exp1)
-                              (or (lookup exp1 se) exp1))))
-              (if (not (symbol? head))
+                   (exp1 (and (pair? x) (car x))))
+              (if (not (symbol? exp1))
                   (fini vars vals mvars mvals body)
-                  (case head
+                  (case (canonical-core-macro-name exp1)
                     ((define)
                      (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
                      (let loop2 ([x x])
@@ -558 +564 @@
                     ((##core#begin)
                      (loop (##sys#append (cdr x) rest) vars vals mvars mvals) )
                     (else
-                     (if (or (memq head vars) (memq head mvars))
+                     (if (or (memq exp1 vars) (memq exp1 mvars))
                          (fini vars vals mvars mvals body)
                          (let ((x2 (##sys#expand-0 x se cs?)))
                            (if (eq? x x2)

tests/syntax-tests.scm

@@ -713 +713 @@
        (map (cute + (begin (set! a (+ a 1)) a) <>)
             '(1 2))
        a))
-(f (eval '((cute + <...> 1) 1)))
- No newline at end of file
+(f (eval '((cute + <...> 1) 1)))
+
+;; Let's internal defines properly compared to core define procedure when renamed
+(f (eval '(let-syntax ((foo (syntax-rules () ((_ x) (begin (define x 1))))))
+            (let () (foo a))
+            (print "1: " a))))
+
+(t '(a 1) (letrec-syntax ((define (syntax-rules () ((_ x y) (list 'x y))))
+                          (foo (syntax-rules () ((_ x) (define x 1)))))
+            (let () (foo a))))
+
+(t '(1) (let-syntax ((define (syntax-rules () ((_ x) (list x)))))
+          (let () (define 1))))
+
+;; Local override: not a macro
+(t '(1) (let ((define list)) (define 1)))
+
+;; Toplevel (no SE)
+(define-syntax foo (syntax-rules () ((_ x) (begin (define x 1)))))
+(foo a)
+(t 1 a)