> On Sun, Nov 12, 2023 at 01:45:06PM +0100, felix.winkelm...@bevuta.com wrote:
> > See commit message.
>
> Nice to make some progress on this!
>
> However, I tested the example given in the ticket:
>
> (define begin -)
> (begin 0 1) => 1 ;; expected: -1
>
> This still evaluates to 1.
>
Yes, this is admittedly all a bit ugly. Please find attached 2 patches:
the first addresses the endless expansion loop caused by our recent change
in ##sys#canonicalize-body. The second patch is a new version of the "override"
patch, with some additional changes to address the example above and a
followup problem that came up during testing.
I post the two patches together, because the latter includes the change for
the former. Please apply at least the former, if you still have doubts about
the override changes.
felix
From c30be664a4492db70d06edd17baffc3950ec6d45 Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Tue, 14 Nov 2023 13:14:46 +0100
Subject: [PATCH] Fix hygienic comparison for "begin" forms when expanding body
---
expand.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/expand.scm b/expand.scm
index ec94086a..f18838b3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -462,7 +462,7 @@
(define (comp s id)
(let ((f (or (lookup id se)
(lookup id (##sys#macro-environment)))))
- (or (eq? f id) (eq? s id))))
+ (or (eq? f s) (eq? s id))))
(define (comp-def def)
(lambda (id)
(let repeat ((id id))
--
2.40.0
From f98af2c34a59d885738c2f1ce5c3977d8f2abd6c Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Tue, 14 Nov 2023 13:16:38 +0100
Subject: [PATCH] Retain current identifier status as syntax or value binding
Currently, toplevel value- and macro-bindings for an identifier are distinctly
stored in separate places, resulting in the effect that a macro definition
will shadow a value-binding (see also #1166).
One way to address this would be to remove syntax-bindings when a toplevel
identifier is "define"d and vice versa, but this will require a lot of
searching and re-consing of (possibly large) environment a-lists.
The approach chosen here is to store a global property on the symbol
that names the identifier which specifies whether a value-binding
should override any existing syntax binding (and the other way around).
Some attempt is made to properly restore the "override" status when
processing modules.
Patch updated to address definition-binding lookup loop in bodies
and ensure toplevel identifiers are correctly checked for the override
property. Also clear override-status for all imports.
---
core.scm | 21 ++++++++++++---------
eval.scm | 2 ++
expand.scm | 31 ++++++++++++++++++++-----------
modules.scm | 36 +++++++++++++++++++++++++-----------
tests/module-tests.scm | 13 +++++++++++++
tests/syntax-tests.scm | 24 ++++++++++++++++++++++++
6 files changed, 96 insertions(+), 31 deletions(-)
diff --git a/core.scm b/core.scm
index a551204f..8f6b85bc 100644
--- a/core.scm
+++ b/core.scm
@@ -907,6 +907,7 @@
`(##core#lambda ,(cdadr x) ,@(cddr x))
(caddr x)))
(name (lookup var)))
+ (##sys#put/restore! name '##sys#override 'syntax)
(##sys#register-syntax-export name
(##sys#current-module) body)
(##sys#extend-macro-environment
name
@@ -924,6 +925,7 @@
(let* ((var (cadr x))
(body (caddr x))
(name (lookup var)))
+ (##sys#put/restore! name '##sys#override 'syntax)
(when body
(set! compiler-syntax
(alist-cons
@@ -1109,15 +1111,16 @@
`(##core#lambda ,aliases ,body) ) )
((##core#ensure-toplevel-definition)
- (unless tl?
- (let* ((var0 (cadr x))
- (var (lookup var0))
- (ln (get-line-number x)))
- (quit-compiling
- "~atoplevel definition of `~s' in non-toplevel
context"
- (if ln (sprintf "(~a) - " ln) "")
- var)))
- '(##core#undefined))
+ (let* ((var0 (cadr x))
+ (var (lookup var0)))
+ (unless tl?
+ (let ((ln (get-line-number x)))
+ (quit-compiling
+ "~atoplevel definition of `~s' in
non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ var)))
+ (##sys#put/restore! var '##sys#override 'value)
+ '(##core#undefined)))
((##core#set!)
(let* ((var0 (cadr x))
diff --git a/eval.scm b/eval.scm
index 68fba6ff..e760aad0 100644
--- a/eval.scm
+++ b/eval.scm
@@ -265,6 +265,7 @@
((##core#ensure-toplevel-definition)
(unless tl?
(##sys#error "toplevel definition in non-toplevel
context for variable" (cadr x)))
+ (##sys#put/restore! (cadr x) '##sys#override 'value)
(compile
'(##core#undefined) e #f tf cntr #f))
@@ -508,6 +509,7 @@
(name (rename var)))
(when (and static (not (assq var
(##sys#current-environment))))
(##sys#error 'eval "environment is not mutable"
evalenv var))
+ (##sys#put/restore! name '##sys#override 'syntax)
(##sys#register-syntax-export
name (##sys#current-module)
body) ; not really necessary, it only
shouldn't be #f
diff --git a/expand.scm b/expand.scm
index ec94086a..f100ce89 100644
--- a/expand.scm
+++ b/expand.scm
@@ -56,6 +56,7 @@
(include "mini-srfi-1.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
+;(define-syntax d (syntax-rules () ((_ args ...) (print args ...))))
;; Macro to avoid "unused variable map-se" when "d" is disabled
(define-syntax map-se
@@ -261,10 +262,13 @@
(let ((head2 (or (lookup head dse) head)))
(unless (pair? head2)
(set! head2 (or (lookup head2 (##sys#macro-environment))
head2)) )
- (cond [(eq? head2 '##core#let)
+ (cond ((and (pair? head2)
+ (eq? (##sys#get head '##sys#override) 'value))
+ (values exp #f))
+ ((eq? head2 '##core#let)
(##sys#check-syntax 'let body '#(_ 2) #f dse)
- (let ([bindings (car body)])
- (cond [(symbol? bindings) ; expand named let
+ (let ((bindings (car body)))
+ (cond ((symbol? bindings) ; expand named let
(##sys#check-syntax 'let body '(_ #((variable _)
0) . #(_ 1)) #f dse)
(let ([bs (cadr body)])
(values
@@ -275,8 +279,8 @@
,(map (lambda (b) (car b)) bs) ,@(cddr
body))])
,bindings)
,@(##sys#map cadr bs) )
- #t) ) ]
- [else (values exp #f)] ) ) ]
+ #t) ) )
+ (else (values exp #f)) ) ) )
((and cs? (symbol? head2) (getp head2
'##compiler#compiler-syntax)) =>
(lambda (cs)
(let ((result (call-handler head (car cs) exp (cdr cs)
#t)))
@@ -285,7 +289,7 @@
(when ##sys#compiler-syntax-hook
(##sys#compiler-syntax-hook head2 result))
(loop result))))))
- [else (expand head exp head2)] ) )
+ (else (expand head exp head2)) ) )
(values exp #f) ) )
(values exp #f) ) ) )
@@ -462,16 +466,20 @@
(define (comp s id)
(let ((f (or (lookup id se)
(lookup id (##sys#macro-environment)))))
- (or (eq? f id) (eq? s id))))
+ (and (or (not (symbol? f))
+ (not (eq? (##sys#get id '##sys#override) 'value)))
+ (or (eq? f s) (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)
- (not (eq? f id))
- (repeat f)))))))
+ (and (or (not (symbol? f))
+ (not (eq? (##sys#get id '##sys#override) 'value)))
+ (or (eq? f def)
+ (and (symbol? f)
+ (not (eq? f id))
+ (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))
@@ -569,6 +577,7 @@
;; Each #t in "mvars" indicates an MV-capable "var". Non-MV
;; vars (#f in mvars) are 1-element lambda-lists for simplicity.
(let loop ((body body) (vars '()) (vals '()) (mvars '()))
+ (d "BODY: " body)
(if (not (pair? body))
(fini vars vals mvars body)
(let* ((x (car body))
diff --git a/modules.scm b/modules.scm
index c6b77acd..ac4f0dc2 100644
--- a/modules.scm
+++ b/modules.scm
@@ -534,18 +534,27 @@
(##sys#error (get-output-string out))))
+ (define (filter-sdlist mod)
+ (let loop ((syms (module-defined-syntax-list mod)))
+ (cond ((null? syms) '())
+ ((eq? (##sys#get (caar syms) '##sys#override) 'value)
+ (loop (cdr syms)))
+ (else (cons (assq (caar syms) (##sys#macro-environment))
+ (loop (cdr syms)))))))
+
(let* ((explist (module-export-list mod))
(name (module-name mod))
(dlist (module-defined-list mod))
(elist (module-exist-list mod))
(missing #f)
- (sdlist (map (lambda (sym) (assq (car sym)
(##sys#macro-environment)))
- (module-defined-syntax-list mod)))
+ (sdlist (filter-sdlist mod))
(sexports
(if (eq? #t explist)
(merge-se (module-sexports mod) sdlist)
(let loop ((me (##sys#macro-environment)))
(cond ((null? me) '())
+ ((eq? (##sys#get (caar me) '##sys#override) 'value)
+ (loop (cdr me)))
((find-export (caar me) mod #f)
(cons (car me) (loop (cdr me))))
(else (loop (cdr me)))))))
@@ -555,7 +564,9 @@
'()
(let* ((h (car xl))
(id (if (symbol? h) h (car h))))
- (cond ((assq id sexports) (loop (cdr xl)))
+ (cond ((eq? (##sys#get id '##sys#override) 'syntax)
+ (loop (cdr xl)))
+ ((assq id sexports) (loop (cdr xl)))
(else
(cons
(cons
@@ -810,17 +821,20 @@
(dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
(for-each
(lambda (imp)
- (and-let* ((id (car imp))
- (a (assq id (import-env)))
- (aid (cdr imp))
- ((not (eq? aid (cdr a)))))
- (##sys#notice "re-importing already imported identifier" id)))
+ (let ((id (car imp)))
+ (##sys#put! id '##sys#override #f)
+ (and-let* ((a (assq id (import-env)))
+ (aid (cdr imp))
+ ((not (eq? aid (cdr a)))))
+ (##sys#notice "re-importing already imported identifier" id))))
vsv)
(for-each
(lambda (imp)
- (and-let* ((a (assq (car imp) (macro-env)))
- ((not (eq? (cdr imp) (cdr a)))))
- (##sys#notice "re-importing already imported syntax" (car imp))))
+ (let ((id (car imp)))
+ (##sys#put! id '##sys#override #f)
+ (and-let* ((a (assq (car imp) (macro-env)))
+ ((not (eq? (cdr imp) (cdr a)))))
+ (##sys#notice "re-importing already imported syntax" (car
imp)))))
vss)
(when reexp?
(unless cm
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index 4d15c88f..2105b081 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -402,6 +402,19 @@
(assert (equal? (alias) '(123)))
(assert (equal? bar 99)))
+;; corner case, found by DeeEff, actually not really a good idea,
+;; but the expander looped here endlessly
+(module m36 (xcons)
+ (import scheme)
+ (define (xcons x y) (cons y x)))
+
+(module m37 ()
+ (import (rename m36
+ (xcons m36#xcons)))
+ (import scheme (chicken base))
+ (define (xcons x y) (m36#xcons 'X x))
+ (assert (equal? '(1 . X) (xcons 1 2))))
+
(test-end "modules")
(test-exit)
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index a788469a..336707eb 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1334,3 +1334,27 @@ other-eval
;; changes, and any other imports are simply aliases.
;;(t 'old (reimported-foo reimported-foo))
(t 'new (reimported-foo reimported-foo))
+
+;; #1166
+(module val-vs-syn1 *
+ (import scheme)
+ (define-syntax bar (syntax-rules () ((_) 'bar)))
+ (define (bar) 99)
+)
+
+(module test-val-vs-syn1 ()
+ (import scheme (chicken base) val-vs-syn1)
+ (assert (eq? 99 (bar))))
+
+(module val-vs-syn2 *
+ (import scheme)
+ (define (bar) 99)
+ (define-syntax bar (syntax-rules () ((_) 'bar)))
+)
+
+(module test-val-vs-syn2 ()
+ (import scheme (chicken base) val-vs-syn2)
+ (assert (eq? 'bar (bar))))
+
+(define begin -)
+(assert (eq? -1 (begin 0 1)))
--
2.40.0
