~ chicken-core (chicken-5) 3d035c6c6bc90cedca2e450b4f5f1f17aa19c229
commit 3d035c6c6bc90cedca2e450b4f5f1f17aa19c229
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Nov 14 13:16:38 2023 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Wed Dec 20 15:36:31 2023 +0100
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.
Signed-off-by: Peter Bex <peter@more-magic.net>
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)))
Trap