From bd0f5bc81207a3ec82995e13c8a470fc3ab9e1a0 Mon Sep 17 00:00:00 2001
From: felix <felix@call-with-current-continuation.org>
Date: Wed, 8 Nov 2023 12:26:38 +0100
Subject: [PATCH] Detect redefinitions of defining forms correctly (#1132)

The scanning for local definitions in ##sys#canonicalize-body used
what I think is incorrect logic to detect whether references to
local "define-*" forms need to be expanded.

The two problems where: ##sys#macro-environment was not consulted,
so the global (default) definition would never be found to be compared
with the stored meaning in "define-definition", etc., resulting in
the fallback mode of merely testing for eq? to be used in all cases.

Second, after looking up the entry in the syntactic environment, the
value could result in a reference to another definition, so the
lookup operation needs to be repeated.

I have added test cases, as given in #1132 and removed an existing
test that seems to be wrong.
---
 expand.scm               | 42 +++++++++++++++++++++++-----------------
 tests/module-tests-2.scm | 16 ---------------
 2 files changed, 24 insertions(+), 34 deletions(-)

diff --git a/expand.scm b/expand.scm
index ba4737b5..67ddf228 100644
--- a/expand.scm
+++ b/expand.scm
@@ -460,14 +460,20 @@
 (define ##sys#canonicalize-body
   (lambda (body #!optional (se (##sys#current-environment)) cs?)
     (define (comp s id)
-      (let ((f (lookup id se)))
-	(or (eq? s f)
-	    (case s
-	      ((define) (if f (eq? f define-definition) (eq? s id)))
-	      ((define-syntax) (if f (eq? f define-syntax-definition) (eq? s id)))
-	      ((define-values) (if f (eq? f define-values-definition) (eq? s id)))
-	      ((import) (if f (eq? f import-definition) (eq? s id)))
-	      (else (eq? s id))))))
+      (let ((f (or (lookup id se)
+                   (lookup id (##sys#macro-environment)))))
+        (or (eq? f id) (eq? s id))))
+    (define (comp-def def)
+      (lambda (id)
+        (let repeat ((id id))
+          (let ((f (or (lookup id se)
+                       (lookup id (##sys#macro-environment)))))
+            (or (eq? f def)
+                (and (symbol? f) (repeat f)))))))
+    (define comp-define (comp-def define-definition))
+    (define comp-define-syntax (comp-def define-syntax-definition))
+    (define comp-define-values (comp-def define-values-definition))
+    (define comp-import (comp-def import-definition))
     (define (fini vars vals mvars body)
       (if (and (null? vars) (null? mvars))
 	  ;; Macro-expand body, and restart when defines are found.
@@ -482,13 +488,13 @@
 		    (if (and (pair? x)
 			     (let ((d (car x)))
 			       (and (symbol? d)
-				    (or (comp 'define d)
-					(comp 'define-values d)
-					(comp 'define-syntax d)
-					(comp '##core#begin d)
-					(comp 'import d)))))
+				    (or (comp '##core#begin d)
+                                        (comp-define d)
+					(comp-define-values d)
+					(comp-define-syntax d)
+					(comp-import d)))))
 			;; Stupid hack to avoid expanding imports
-			(if (comp 'import (car x))
+			(if (comp-import (car x))
 			    (loop rest (cons x exps))
 			    (cons
 			     '##core#begin
@@ -547,7 +553,7 @@
 	       ((and (list? (car body))
 		     (>= 3 (length (car body))) 
 		     (symbol? (caar body))
-		     (comp 'define-syntax (caar body)))
+		     (comp-define-syntax (caar body)))
 		(let ((def (car body)))
 		  ;; This check is insufficient, if introduced by
 		  ;; different expansions, but better than nothing:
@@ -570,7 +576,7 @@
 	      (if (not (symbol? head))
 		  (fini vars vals mvars body)
 		  (cond
-		   ((comp 'define head)
+		   ((comp-define head)
 		     (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
 		     (let loop2 ((x x))
 		       (let ((head (cadr x)))
@@ -597,10 +603,10 @@
 				      (cons (list (car head)) vars)
 				      (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
 				      (cons #f mvars)))))))
-		    ((comp 'define-syntax head)
+		    ((comp-define-syntax head)
 		     (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)
 		     (fini/syntax vars vals mvars body))
-		    ((comp 'define-values head)
+		    ((comp-define-values head)
 		     ;;XXX check for any of the variables being `define-values'
 		     (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)
 		     (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))
diff --git a/tests/module-tests-2.scm b/tests/module-tests-2.scm
index 2fc33f23..d975bce8 100644
--- a/tests/module-tests-2.scm
+++ b/tests/module-tests-2.scm
@@ -85,19 +85,3 @@
 (module m2 ()
   (import m1)
   ((lambda () (f1)))) ; should use new lambda (but should be folded by compiler)
-
-
-;;; local define should work even with redefined define
-
-(module m3 ()
-  (import (rename scheme (define s:define)))
-  (import (only (chicken base) assert))
-  (define-syntax define
-    (syntax-rules ()
-      ((_) (display 'oink))))
-  (define)
-  (let ()
-    (define a 1)
-    (assert (= a 1)))
-  (define)
-  (newline))
-- 
2.40.0