~ chicken-core (chicken-5) 75c0461c8b541a3b03e337e7546ce3b0ea4e6931
commit 75c0461c8b541a3b03e337e7546ce3b0ea4e6931
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Nov 8 12:26:38 2023 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Fri Nov 10 14:57:29 2023 +0100
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.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index 32650079..f8d0f085 100644
--- a/NEWS
+++ b/NEWS
@@ -58,6 +58,7 @@
- Syntax expander
- When passing a module as an environment to eval, correctly resolve
identifiers in macro expansions (#1295 reported by Caolan McMahon).
+ - Internal definitions honor rebindings of core special forms (#1132).
- Compiler
- When emitting types files, the output list is now sorted, to ensure
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..e9b8e8a3 100644
--- a/tests/module-tests-2.scm
+++ b/tests/module-tests-2.scm
@@ -86,18 +86,20 @@
(import m1)
((lambda () (f1)))) ; should use new lambda (but should be folded by compiler)
-
-;;; local define should work even with redefined define
-
+;; #1132 - internal definitions honor redefinitions of defining forms
(module m3 ()
(import (rename scheme (define s:define)))
(import (only (chicken base) assert))
(define-syntax define
(syntax-rules ()
- ((_) (display 'oink))))
+ ((_) (display 'oink))
+ ((_ var value) (s:define var (+ value 1)))))
(define)
+ ;; Internal definition uses new "define"
(let ()
(define a 1)
- (assert (= a 1)))
- (define)
- (newline))
+ (assert (= a 2)))
+
+ ;; Toplevel definition also uses new "define"
+ (define b 5)
+ (assert (= b 6)))
Trap