Hi all, While figuring out what was causing the remaining issue in #1437, I found out that a proper fix would be to change the code walker to always dereference ##sys#current-environment for every lookup. Attached is a pretty large, but straightforward patch to do this.
The patch basically drops the "se" argument of "walk" in both the
compiler and the interpreter. Any procedure that requires a syntax
environment argument is now called with (##sys#current-environment),
and anywhere the syntax environment is (functionally) modified, we
parameterize (##sys#current-environment) before calling walk recursively.
As a cool side effect, the fix accidentally adds a new feature: (import)
is now lexically scoped (like Python's import, but better).
For instance,
(begin
(let ()
(import (rename scheme (- +)))
(print (+ 1 2)))
(print (+ 1 2)))
will now print "-1", followed by "3".
Cheers,
Peter
From aec61ded4b562d63bccd63ec7f0b5a647cc33386 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 28 Apr 2018 18:09:13 +0200
Subject: [PATCH] Change module imports to be lexically scoped.
Instead of carrying around a syntactic environment in the code walker,
we delay lookups by re-invoking the ##sys#current-environment
parameter to get its current value (which is mutated by import).
This is the final fix for the remaining issue in #1437
---
NEWS | 2 +
core.scm | 329 +++++++++++++++++++++-------------------
eval.scm | 264 ++++++++++++++++----------------
tests/module-tests-compiled.scm | 31 ++++
4 files changed, 339 insertions(+), 287 deletions(-)
diff --git a/NEWS b/NEWS
index e88c2150..835e20f1 100644
--- a/NEWS
+++ b/NEWS
@@ -103,6 +103,8 @@
- Added support for list-style library names.
- The "use" and "use-for-syntax" special forms have been removed
in favor of "import" and "import-for-syntax" to reduce confusion.
+ - Module imports are now lexically scoped: identifiers provided by
+ an (import ...) inside (let ...) won't be visible outside that let.
- Syntax expander
- Removed support for (define-syntax (foo e r c) ...), which was
diff --git a/core.scm b/core.scm
index ac35785f..b60e44b2 100644
--- a/core.scm
+++ b/core.scm
@@ -504,21 +504,25 @@
;;; Expand macros and canonicalize expressions:
(define (canonicalize-expression exp)
- (let ((compiler-syntax '()))
+ (let ((compiler-syntax '())
+ ;; Not sure this is correct, given that subsequent expressions
+ ;; to be canonicalized will mutate the current environment.
+ ;; Used to reset the environment for ##core#module forms.
+ (initial-environment (##sys#current-environment)))
(define (find-id id se) ; ignores macro bindings
(cond ((null? se) #f)
((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
(else (find-id id (cdr se)))))
- (define (lookup id se)
- (cond ((find-id id se))
+ (define (lookup id)
+ (cond ((find-id id (##sys#current-environment)))
((##sys#get id '##core#macro-alias))
(else id)))
- (define (macro-alias var se)
+ (define (macro-alias var)
(let ((alias (gensym var)))
- (##sys#put! alias '##core#macro-alias (lookup var se))
+ (##sys#put! alias '##core#macro-alias (lookup var))
alias) )
(define (handle-expansion-result outer-ln)
@@ -528,10 +532,10 @@
(update-line-number-database! output ln))
output))
- (define (canonicalize-body/ln ln body se cs?)
+ (define (canonicalize-body/ln ln body cs?)
(fluid-let ((chicken.syntax#expansion-result-hook
(handle-expansion-result ln)))
- (##sys#canonicalize-body body se cs?)))
+ (##sys#canonicalize-body body (##sys#current-environment) cs?)))
(define (set-real-names! as ns)
(for-each (lambda (a n) (set-real-name! a n)) as ns) )
@@ -541,22 +545,22 @@
(write x out)
(get-output-string out) ) )
- (define (unquotify x se)
+ (define (unquotify x)
(if (and (list? x)
(= 2 (length x))
(symbol? (car x))
- (eq? 'quote (lookup (car x) se)))
+ (eq? 'quote (lookup (car x))))
(cadr x)
x) )
- (define (resolve-variable x0 e se dest ldest h)
- (let ((x (lookup x0 se)))
- (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se)))
+ (define (resolve-variable x0 e dest ldest h)
+ (let ((x (lookup x0)))
+ (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) (##sys#current-environment))))
(cond ((not (symbol? x)) x0) ; syntax?
((hash-table-ref constant-table x)
- => (lambda (val) (walk val e se dest ldest h #f #f)))
+ => (lambda (val) (walk val e dest ldest h #f #f)))
((hash-table-ref inline-table x)
- => (lambda (val) (walk val e se dest ldest h #f #f)))
+ => (lambda (val) (walk val e dest ldest h #f #f)))
((assq x foreign-variables)
=> (lambda (fv)
(let* ((t (second fv))
@@ -566,7 +570,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h #f #f))))
+ e dest ldest h #f #f))))
((assq x location-pointer-map)
=> (lambda (a)
(let* ((t (third a))
@@ -576,7 +580,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h #f #f))))
+ e dest ldest h #f #f))))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
@@ -603,13 +607,13 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
- (define (walk x e se dest ldest h outer-ln tl?)
+ (define (walk x e dest ldest h outer-ln tl?)
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
(warning
(sprintf "reference to variable `~s' possibly unintended" x) )))
- (resolve-variable x e se dest ldest h))
+ (resolve-variable x e dest ldest h))
((not (pair? x))
(if (constant? x)
`(quote ,x)
@@ -622,28 +626,28 @@
(##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
(##sys#syntax-error/context "malformed expression" x)))
(set! ##sys#syntax-error-culprit x)
- (let* ((name (lookup (car x) se))
+ (let* ((name (lookup (car x)))
(xexpanded
(fluid-let ((chicken.syntax#expansion-result-hook
(handle-expansion-result ln)))
- (expand x se compiler-syntax-enabled))))
+ (expand x (##sys#current-environment) compiler-syntax-enabled))))
(cond ((not (eq? x xexpanded))
- (walk xexpanded e se dest ldest h ln tl?))
+ (walk xexpanded e dest ldest h ln tl?))
((hash-table-ref inline-table name)
=> (lambda (val)
- (walk (cons val (cdr x)) e se dest ldest h ln #f)))
+ (walk (cons val (cdr x)) e dest ldest h ln #f)))
(else
(case name
((##core#if)
`(if
- ,(walk (cadr x) e se #f #f h ln #f)
- ,(walk (caddr x) e se #f #f h ln #f)
+ ,(walk (cadr x) e #f #f h ln #f)
+ ,(walk (caddr x) e #f #f h ln #f)
,(if (null? (cdddr x))
'(##core#undefined)
- (walk (cadddr x) e se #f #f h ln #f) ) ) )
+ (walk (cadddr x) e #f #f h ln #f) ) ) )
((##core#syntax ##core#quote)
`(quote ,(strip-syntax (cadr x))))
@@ -651,21 +655,21 @@
((##core#check)
(if unsafe
''#t
- (walk (cadr x) e se dest ldest h ln tl?) ) )
+ (walk (cadr x) e dest ldest h ln tl?) ) )
((##core#the)
`(##core#the
,(strip-syntax (cadr x))
,(caddr x)
- ,(walk (cadddr x) e se dest ldest h ln tl?)))
+ ,(walk (cadddr x) e dest ldest h ln tl?)))
((##core#typecase)
`(##core#typecase
,(or ln (cadr x))
- ,(walk (caddr x) e se #f #f h ln tl?)
+ ,(walk (caddr x) e #f #f h ln tl?)
,@(map (lambda (cl)
(list (strip-syntax (car cl))
- (walk (cadr cl) e se dest ldest h ln tl?)))
+ (walk (cadr cl) e dest ldest h ln tl?)))
(cdddr x))))
((##core#immutable)
@@ -692,7 +696,7 @@
((##core#inline_loc_ref)
`(##core#inline_loc_ref
,(strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest h ln #f)))
+ ,(walk (caddr x) e dest ldest h ln #f)))
((##core#require-for-syntax)
(chicken.load#load-extension (cadr x) '() 'require)
@@ -712,23 +716,24 @@
file-requirements type
(cut lset-adjoin/eq? <> id)
(cut list id)))
- (walk exp e se dest ldest h ln #f))))
+ (walk exp e dest ldest h ln #f))))
((##core#let)
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
(aliases (map gensym vars))
- (se2 (##sys#extend-se se vars aliases))
+ (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
(ln (or (get-line x) outer-ln)))
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
- (list alias (walk (cadr b) e se (car b) #t h ln #f)) )
+ (list alias (walk (cadr b) e (car b) #t h ln #f)) )
aliases bindings)
- ,(walk (canonicalize-body/ln
- ln (cddr x) se2 compiler-syntax-enabled)
- (append aliases e)
- se2 dest ldest h ln #f) ) ) )
+ ,(parameterize ((##sys#current-environment se2))
+ (walk (canonicalize-body/ln
+ ln (cddr x) compiler-syntax-enabled)
+ (append aliases e)
+ dest ldest h ln #f)) ) ) )
((##core#letrec*)
(let ((bindings (cadr x))
@@ -742,7 +747,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e se dest ldest h ln #f)))
+ e dest ldest h ln #f)))
((##core#letrec)
(let* ((bindings (cadr x))
@@ -760,7 +765,7 @@
`(##core#set! ,v ,t))
vars tmps)
(##core#let () ,@body) ) )
- e se dest ldest h ln #f)))
+ e dest ldest h ln #f)))
((##core#lambda)
(let ((llist (cadr x))
@@ -769,22 +774,23 @@
(set!-values
(llist obody)
(##sys#expand-extended-lambda-list
- llist obody ##sys#error se) ) )
+ llist obody ##sys#error (##sys#current-environment)) ) )
(##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
(ln (or (get-line x) outer-ln))
- (se2 (##sys#extend-se se vars aliases))
- (body0 (canonicalize-body/ln
- ln obody se2 compiler-syntax-enabled))
- (body (walk
- (if emit-debug-info
- `(##core#begin
- (##core#debug-event "C_DEBUG_ENTRY" ',dest)
- ,body0)
- body0)
- (append aliases e) se2 #f #f dest ln #f))
+ (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
+ (body (parameterize ((##sys#current-environment se2))
+ (let ((body0 (canonicalize-body/ln
+ ln obody compiler-syntax-enabled)))
+ (walk
+ (if emit-debug-info
+ `(##core#begin
+ (##core#debug-event "C_DEBUG_ENTRY" ',dest)
+ ,body0)
+ body0)
+ (append aliases e) #f #f dest ln #f))))
(llist2
(build-lambda-list
aliases argc
@@ -793,7 +799,7 @@
(set-real-names! aliases vars)
(cond ((or (not dest)
ldest
- (assq dest se)) ; not global?
+ (assq dest (##sys#current-environment))) ; not global?
l)
((and emit-profile
(or (eq? profiled-procedures 'all)
@@ -808,21 +814,23 @@
(else l)))))))
((##core#let-syntax)
- (let ((se2 (append
- (map (lambda (b)
- (list
- (car b)
- se
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (car b))))
- (cadr x) )
- se) )
- (ln (or (get-line x) outer-ln)))
- (walk
- (canonicalize-body/ln
- ln (cddr x) se2 compiler-syntax-enabled)
- e se2 dest ldest h ln #f) ) )
+ (parameterize
+ ((##sys#current-environment
+ (append
+ (map (lambda (b)
+ (list
+ (car b)
+ (##sys#current-environment)
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (car b))))
+ (cadr x) )
+ (##sys#current-environment)) ))
+ (let ((ln (or (get-line x) outer-ln)))
+ (walk
+ (canonicalize-body/ln
+ ln (cddr x) compiler-syntax-enabled)
+ e dest ldest h ln #f)) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -833,16 +841,17 @@
(##sys#eval/meta (cadr b))
(car b))))
(cadr x) ) )
- (se2 (append ms se))
+ (se2 (append ms (##sys#current-environment)))
(ln (or (get-line x) outer-ln)) )
(for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
ms)
- (walk
- (canonicalize-body/ln
- ln (cddr x) se2 compiler-syntax-enabled)
- e se2 dest ldest h ln #f)))
+ (parameterize ((##sys#current-environment se2))
+ (walk
+ (canonicalize-body/ln
+ ln (cddr x) compiler-syntax-enabled)
+ e dest ldest h ln #f))))
((##core#define-syntax)
(##sys#check-syntax
@@ -850,12 +859,12 @@
(if (pair? (cadr x))
'(_ (variable . lambda-list) . #(_ 1))
'(_ variable _) )
- #f se)
+ #f (##sys#current-environment))
(let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
(body (if (pair? (cadr x))
`(##core#lambda ,(cdadr x) ,@(cddr x))
(caddr x)))
- (name (lookup var se)))
+ (name (lookup var)))
(##sys#register-syntax-export name (##sys#current-module) body)
(##sys#extend-macro-environment
name
@@ -867,12 +876,12 @@
',var
(##sys#current-environment) ,body) ;XXX possibly wrong se?
'(##core#undefined) )
- e se dest ldest h ln #f)) )
+ e dest ldest h ln #f)) )
((##core#define-compiler-syntax)
(let* ((var (cadr x))
(body (caddr x))
- (name (lookup var se)))
+ (name (lookup var)))
(when body
(set! compiler-syntax
(alist-cons
@@ -899,21 +908,21 @@
',var)
(##sys#current-environment))))
'(##core#undefined) )
- e se dest ldest h ln #f)))
+ e dest ldest h ln #f)))
((##core#let-compiler-syntax)
(let ((bs (map
(lambda (b)
(##sys#check-syntax
'let-compiler-syntax b '(symbol . #(_ 0 1)))
- (let ((name (lookup (car b) se)))
+ (let ((name (lookup (car b))))
(list
name
(and (pair? (cdr b))
(cons (##sys#ensure-transformer
(##sys#eval/meta (cadr b))
(car b))
- se))
+ (##sys#current-environment)))
(##sys#get name '##compiler#compiler-syntax) ) ) )
(cadr x)))
(ln (or (get-line x) outer-ln)))
@@ -926,8 +935,8 @@
(lambda ()
(walk
(canonicalize-body/ln
- ln (cddr x) se compiler-syntax-enabled)
- e se dest ldest h ln tl?) )
+ ln (cddr x) compiler-syntax-enabled)
+ e dest ldest h ln tl?) )
(lambda ()
(for-each
(lambda (b)
@@ -942,7 +951,7 @@
(cadr x)
(caddr x)
(lambda (forms)
- (walk `(##core#begin ,@forms) e se dest ldest h ln tl?)))))
+ (walk `(##core#begin ,@forms) e dest ldest h ln tl?)))))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -951,7 +960,7 @@
(strip-syntax b))
(cadr x))
(lambda ()
- (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln #t))))
+ (walk `(##core#begin ,@(cddr x)) e dest ldest h ln #t))))
((##core#module)
(let* ((name (strip-syntax (cadr x)))
@@ -1016,7 +1025,6 @@
(cons (walk
(car body)
e ;?
- (##sys#current-environment)
#f #f h ln #t) ; reset to toplevel!
xs))))))))))
(let ((body
@@ -1024,13 +1032,15 @@
(append
(parameterize ((##sys#current-module #f)
(##sys#macro-environment
- (##sys#meta-macro-environment)))
+ (##sys#meta-macro-environment))
+ (##sys#current-environment ; ???
+ (##sys#current-meta-environment)))
(map
(lambda (x)
(walk
x
e ;?
- (##sys#current-meta-environment) #f #f h ln tl?) )
+ #f #f h ln tl?) )
(cons `(##core#provide ,req) module-registration)))
body))))
(do ((cs compiler-syntax (cdr cs)))
@@ -1043,20 +1053,21 @@
(let* ((vars (cadr x))
(obody (cddr x))
(aliases (map gensym vars))
- (se2 (##sys#extend-se se vars aliases))
+ (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
(ln (or (get-line x) outer-ln))
(body
- (walk
- (canonicalize-body/ln ln obody se2 compiler-syntax-enabled)
- (append aliases e)
- se2 #f #f dest ln #f) ) )
+ (parameterize ((##sys#current-environment se2))
+ (walk
+ (canonicalize-body/ln ln obody compiler-syntax-enabled)
+ (append aliases e)
+ #f #f dest ln #f)) ) )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
((##core#ensure-toplevel-definition)
(unless tl?
(let* ((var0 (cadr x))
- (var (lookup var0 se))
+ (var (lookup var0))
(ln (get-line x)))
(quit-compiling
"~atoplevel definition of `~s' in non-toplevel context"
@@ -1066,7 +1077,7 @@
((##core#set!)
(let* ((var0 (cadr x))
- (var (lookup var0 se))
+ (var (lookup var0))
(ln (get-line x))
(val (caddr x)))
(when (memq var unlikely-variables)
@@ -1083,7 +1094,7 @@
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type)))
- e se #f #f h ln #f))))
+ e #f #f h ln #f))))
((assq var location-pointer-map)
=> (lambda (a)
(let* ((type (third a))
@@ -1094,7 +1105,7 @@
(,type)
,(second a)
,(foreign-type-check tmp type)))
- e se #f #f h ln #f))))
+ e #f #f h ln #f))))
(else
(unless (memq var e) ; global?
(set! var (##sys#alias-global-hook var #t dest))
@@ -1108,7 +1119,7 @@
,var)))
;; We use `var0` instead of `var` because the {macro,current}-environment
;; are keyed by the raw and unqualified name
- (cond ((##sys#macro? var0 se)
+ (cond ((##sys#macro? var0 (##sys#current-environment))
(warning
(sprintf "~aassignment to syntax `~S'"
(if ln (sprintf "(~a) - " ln) "") var0))
@@ -1123,38 +1134,38 @@
(warning
(sprintf "~aassignment to keyword `~S'"
(if ln (sprintf "(~a) - " ln) "") var0)))))
- `(set! ,var ,(walk val e se var0 (memq var e) h ln #f))))))
+ `(set! ,var ,(walk val e var0 (memq var e) h ln #f))))))
((##core#debug-event)
`(##core#debug-event
- ,(unquotify (cadr x) se)
+ ,(unquotify (cadr x))
,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
,@(map (lambda (arg)
- (unquotify (walk arg e se #f #f h ln tl?) se))
+ (unquotify (walk arg e #f #f h ln tl?)))
(cddr x))))
((##core#inline)
`(##core#inline
- ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln #f)))
+ ,(unquotify (cadr x)) ,@(mapwalk (cddr x) e h ln #f)))
((##core#inline_allocate)
`(##core#inline_allocate
- ,(map (cut unquotify <> se) (second x))
- ,@(mapwalk (cddr x) e se h ln #f)))
+ ,(map unquotify (second x))
+ ,@(mapwalk (cddr x) e h ln #f)))
((##core#inline_update)
- `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln #f)) )
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e #f #f h ln #f)) )
((##core#inline_loc_update)
`(##core#inline_loc_update
,(cadr x)
- ,(walk (caddr x) e se #f #f h ln #f)
- ,(walk (cadddr x) e se #f #f h ln #f)) )
+ ,(walk (caddr x) e #f #f h ln #f)
+ ,(walk (cadddr x) e #f #f h ln #f)) )
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
(##sys#eval/meta exp)
- (walk exp e se dest #f h ln tl?) ) )
+ (walk exp e dest #f h ln tl?) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
(##sys#eval/meta (cadr x))
@@ -1167,24 +1178,24 @@
(let ([x (car xs)]
[r (cdr xs)] )
(if (null? r)
- (list (walk x e se dest ldest h ln tl?))
- (cons (walk x e se #f #f h ln tl?) (fold r)) ) ) ) )
+ (list (walk x e dest ldest h ln tl?))
+ (cons (walk x e #f #f h ln tl?) (fold r)) ) ) ) )
'(##core#undefined) ) )
((##core#foreign-lambda)
- (walk (expand-foreign-lambda x #f) e se dest ldest h ln #f) )
+ (walk (expand-foreign-lambda x #f) e dest ldest h ln #f) )
((##core#foreign-safe-lambda)
- (walk (expand-foreign-lambda x #t) e se dest ldest h ln #f) )
+ (walk (expand-foreign-lambda x #t) e dest ldest h ln #f) )
((##core#foreign-lambda*)
- (walk (expand-foreign-lambda* x #f) e se dest ldest h ln #f) )
+ (walk (expand-foreign-lambda* x #f) e dest ldest h ln #f) )
((##core#foreign-safe-lambda*)
- (walk (expand-foreign-lambda* x #t) e se dest ldest h ln #f) )
+ (walk (expand-foreign-lambda* x #t) e dest ldest h ln #f) )
((##core#foreign-primitive)
- (walk (expand-foreign-primitive x) e se dest ldest h ln #f) )
+ (walk (expand-foreign-primitive x) e dest ldest h ln #f) )
((##core#define-foreign-variable)
(let* ((var (strip-syntax (second x)))
@@ -1220,7 +1231,7 @@
(define
,ret
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
- e se dest ldest h ln tl?))]
+ e dest ldest h ln tl?))]
[else
(register-foreign-type! name type)
'(##core#undefined) ] ) ) )
@@ -1254,22 +1265,24 @@
(set-real-name! alias var)
(set! location-pointer-map
(cons (list alias store type) location-pointer-map) )
- (walk
- `(let (,(let ([size (bytes->words (estimate-foreign-result-location-size type))])
- ;; Add 2 words: 1 for the header, 1 for double-alignment:
- ;; Note: C_a_i_bytevector takes number of words, not bytes
- (list
- store
- `(##core#inline_allocate
- ("C_a_i_bytevector" ,(+ 2 size))
- ',size)) ) )
- (##core#begin
- ,@(if init
- `((##core#set! ,alias ,init))
- '() )
- ,(if init (fifth x) (fourth x)) ) )
- e (alist-cons var alias se)
- dest ldest h ln #f) ) )
+ (parameterize ((##sys#current-environment
+ (alist-cons var alias (##sys#current-environment))))
+ (walk
+ `(let (,(let ((size (bytes->words (estimate-foreign-result-location-size type))))
+ ;; Add 2 words: 1 for the header, 1 for double-alignment:
+ ;; Note: C_a_i_bytevector takes number of words, not bytes
+ (list
+ store
+ `(##core#inline_allocate
+ ("C_a_i_bytevector" ,(+ 2 size))
+ ',size)) ) )
+ (##core#begin
+ ,@(if init
+ `((##core#set! ,alias ,init))
+ '() )
+ ,(if init (fifth x) (fourth x)) ) )
+ e
+ dest ldest h ln #f)) ) )
((##core#define-inline)
(let* ((name (second x))
@@ -1313,7 +1326,7 @@
(hide-variable var)
(mark-variable var '##compiler#constant)
(mark-variable var '##compiler#always-bound)
- (walk `(define ,var (##core#quote ,val)) e se #f #f h ln tl?)))
+ (walk `(define ,var (##core#quote ,val)) e #f #f h ln tl?)))
(else
(quit-compiling
"~ainvalid compile-time value for named constant `~S'"
@@ -1321,15 +1334,17 @@
name)))))
((##core#declare)
- (walk
- `(##core#begin
- ,@(map (lambda (d)
- (process-declaration
- d se
- (lambda (id)
- (memq (lookup id se) e))))
- (cdr x) ) )
- e '() #f #f h ln #f) )
+ (let ((old-se (##sys#current-environment)))
+ (parameterize ((##sys#current-environment '())) ;; ??
+ (walk
+ `(##core#begin
+ ,@(map (lambda (d)
+ (process-declaration
+ d old-se
+ (lambda (id)
+ (memq (lookup id) e))))
+ (cdr x) ) )
+ e #f #f h ln #f))) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1354,7 +1369,7 @@
"non-matching or invalid argument list to foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
- ,@(mapwalk args e se h ln #f)
+ ,@(mapwalk args e h ln #f)
,(walk `(##core#lambda
,vars
(##core#let
@@ -1406,37 +1421,37 @@
(const c-string)) )
`((##core#let
((r (##core#let () ,@(cddr lam))))
- (,(macro-alias 'and se)
+ (,(macro-alias 'and)
r
(##sys#make-c-string r ',name)) ) ) )
(else (cddr lam)) ) )
rtype) ) )
- e se #f #f h ln #f) ) ) ) )
+ e #f #f h ln #f) ) ) ) )
((##core#location)
(let ([sym (cadr x)])
(if (symbol? sym)
- (cond [(assq (lookup sym se) location-pointer-map)
+ (cond ((assq (lookup sym) location-pointer-map)
=> (lambda (a)
(walk
`(##sys#make-locative ,(second a) 0 #f 'location)
- e se #f #f h ln #f) ) ]
- [(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f #f h ln #f)) ]
- [(assq sym callback-names)
- `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
- [else
+ e #f #f h ln #f) ) )
+ ((assq sym external-to-pointer)
+ => (lambda (a) (walk (cdr a) e #f #f h ln #f)) )
+ ((assq sym callback-names)
+ `(##core#inline_ref (,(symbol->string sym) c-pointer)) )
+ (else
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h ln #f) ] )
+ e #f #f h ln #f) ) )
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h ln #f) ) ) )
+ e #f #f h ln #f) ) ) )
(else
(let* ((x2 (fluid-let ((##sys#syntax-context
(cons name ##sys#syntax-context)))
- (mapwalk x e se h ln tl?)))
+ (mapwalk x e h ln tl?)))
(head2 (car x2))
(old (hash-table-ref line-number-database-2 head2)))
(when ln
@@ -1452,7 +1467,7 @@
((constant? (car x))
(emit-syntax-trace-info x #f)
(warning "literal in operator position" x)
- (mapwalk x e se h outer-ln tl?) )
+ (mapwalk x e h outer-ln tl?) )
(else
(emit-syntax-trace-info x #f)
@@ -1461,10 +1476,10 @@
`(##core#let
((,tmp ,(car x)))
(,tmp ,@(cdr x)))
- e se dest ldest h outer-ln #f)))))
+ e dest ldest h outer-ln #f)))))
- (define (mapwalk xs e se h ln tl?)
- (map (lambda (x) (walk x e se #f #f h ln tl?)) xs) )
+ (define (mapwalk xs e h ln tl?)
+ (map (lambda (x) (walk x e #f #f h ln tl?)) xs) )
(when (memq 'c debugging-chicken) (newline) (pretty-print exp))
(foreign-code "C_clear_trace_buffer();")
@@ -1477,7 +1492,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment) #f #f #f #f #t) ) )
+ '() #f #f #f #f #t) ) )
(define (process-declaration spec se local?)
diff --git a/eval.scm b/eval.scm
index 78a2c73a..1ae1f9d0 100644
--- a/eval.scm
+++ b/eval.scm
@@ -80,7 +80,7 @@
(define compile-to-closure
(let ((reverse reverse))
- (lambda (exp env se #!optional cntr evalenv static tl?)
+ (lambda (exp env #!optional cntr evalenv static tl?)
(define-syntax thread-id
(syntax-rules ()
((_ t) (##sys#slot t 14))))
@@ -90,14 +90,14 @@
((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
(else (find-id id (cdr se)))))
- (define (rename var se)
- (cond ((find-id var se))
+ (define (rename var)
+ (cond ((find-id var (##sys#current-environment)))
((##sys#get var '##core#macro-alias))
(else var)))
- (define (lookup var0 e se)
- (let ((var (rename var0 se)))
- (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map (lambda (x) (car x)) se)))
+ (define (lookup var0 e)
+ (let ((var (rename var0)))
+ (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map (lambda (x) (car x)) (##sys#current-environment))))
(let loop ((envs e) (ei 0))
(cond ((null? envs) (values #f var))
((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
@@ -128,13 +128,13 @@
(define (decorate p ll h cntr)
(eval-decorator p ll h cntr))
- (define (compile x e h tf cntr se tl?)
+ (define (compile x e h tf cntr tl?)
(cond ((keyword? x) (lambda v x))
((symbol? x)
- (receive (i j) (lookup x e se)
+ (receive (i j) (lookup x e)
(cond ((not i)
(let ((var (cond ((not (symbol? j)) x) ; syntax?
- ((assq x se) j)
+ ((assq x (##sys#current-environment)) j)
((not static)
(##sys#alias-global-hook j #f cntr))
(else #f))))
@@ -191,11 +191,11 @@
(##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
(emit-syntax-trace-info tf x cntr)
- (let ((x2 (expand x se)))
+ (let ((x2 (expand x (##sys#current-environment))))
(d `(EVAL/EXPANDED: ,x2))
(if (not (eq? x2 x))
- (compile x2 e h tf cntr se tl?)
- (let ((head (rename (##sys#slot x 0) se)))
+ (compile x2 e h tf cntr tl?)
+ (let ((head (rename (##sys#slot x 0))))
;; here we did't resolve ##core#primitive, but that is done in compile-call (via
;; a normal walking of the operator)
(case head
@@ -217,53 +217,53 @@
(lambda v c)))
[(##core#check)
- (compile (cadr x) e h tf cntr se #f) ]
+ (compile (cadr x) e h tf cntr #f) ]
[(##core#immutable)
- (compile (cadr x) e #f tf cntr se #f) ]
+ (compile (cadr x) e #f tf cntr #f) ]
[(##core#undefined) (lambda (v) (##core#undefined))]
[(##core#if)
- (let* ((test (compile (cadr x) e #f tf cntr se #f))
- (cns (compile (caddr x) e #f tf cntr se #f))
+ (let* ((test (compile (cadr x) e #f tf cntr #f))
+ (cns (compile (caddr x) e #f tf cntr #f))
(alt (if (pair? (cdddr x))
- (compile (cadddr x) e #f tf cntr se #f)
- (compile '(##core#undefined) e #f tf cntr se #f) ) ) )
+ (compile (cadddr x) e #f tf cntr #f)
+ (compile '(##core#undefined) e #f tf cntr #f) ) ) )
(lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
[(##core#begin)
(let* ((body (##sys#slot x 1))
(len (length body)) )
(case len
- ((0) (compile '(##core#undefined) e #f tf cntr se tl?))
- ((1) (compile (##sys#slot body 0) e #f tf cntr se tl?))
- ((2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
- [x2 (compile (cadr body) e #f tf cntr se tl?)] )
+ ((0) (compile '(##core#undefined) e #f tf cntr tl?))
+ ((1) (compile (##sys#slot body 0) e #f tf cntr tl?))
+ ((2) (let* ((x1 (compile (##sys#slot body 0) e #f tf cntr tl?))
+ (x2 (compile (cadr body) e #f tf cntr tl?)) )
(lambda (v) (##core#app x1 v) (##core#app x2 v)) ) )
(else
- (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
- [x2 (compile (cadr body) e #f tf cntr se tl?)]
- [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se tl?)] )
+ (let* ((x1 (compile (##sys#slot body 0) e #f tf cntr tl?))
+ (x2 (compile (cadr body) e #f tf cntr tl?))
+ (x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr tl?)) )
(lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ) ) ) ]
((##core#ensure-toplevel-definition)
(unless tl?
(##sys#error "toplevel definition in non-toplevel context for variable" (cadr x)))
(compile
- '(##core#undefined) e #f tf cntr se #f))
+ '(##core#undefined) e #f tf cntr #f))
[(##core#set!)
(let ((var (cadr x)))
- (receive (i j) (lookup var e se)
- (let ((val (compile (caddr x) e var tf cntr se #f)))
+ (receive (i j) (lookup var e)
+ (let ((val (compile (caddr x) e var tf cntr #f)))
(cond ((not i)
(when ##sys#notices-enabled
(and-let* ((a (assq var (##sys#current-environment)))
((symbol? (cdr a))))
(##sys#notice "assignment to imported value binding" var)))
(let ((var
- (cond ((assq x se) j) ;XXX this looks wrong
+ (cond ((assq x (##sys#current-environment)) j) ;XXX this looks wrong
((not static)
(##sys#alias-global-hook j #t cntr))
(else #f))))
@@ -281,36 +281,37 @@
(##core#inline "C_u_i_list_ref" v i) j (##core#app val v))))))))]
[(##core#let)
- (let* ([bindings (cadr x)]
- [n (length bindings)]
- [vars (map (lambda (x) (car x)) bindings)]
+ (let* ((bindings (cadr x))
+ (n (length bindings))
+ (vars (map (lambda (x) (car x)) bindings))
(aliases (map gensym vars))
- [e2 (cons aliases e)]
- (se2 (##sys#extend-se se vars aliases))
- [body (compile-to-closure
- (##sys#canonicalize-body (cddr x) se2 #f)
- e2 se2 cntr evalenv static #f) ] )
+ (e2 (cons aliases e))
+ (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
+ (body (parameterize ((##sys#current-environment se2))
+ (compile-to-closure
+ (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
+ e2 cntr evalenv static #f)) ) )
(case n
- [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se #f)])
+ ((1) (let ([val (compile (cadar bindings) e (car vars) tf cntr #f)])
(lambda (v)
- (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
- [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] )
+ (##core#app body (cons (vector (##core#app val v)) v)) ) ) )
+ ((2) (let ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
+ (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f)) )
(lambda (v)
- (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
- [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)]
- [t (cddr bindings)]
- [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] )
+ (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) )
+ ((3) (let* ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
+ (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f))
+ (t (cddr bindings))
+ (val3 (compile (cadar t) e (caddr vars) tf cntr #f)) )
(lambda (v)
(##core#app
body
- (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
- [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)]
- [t (cddr bindings)]
- [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)]
- [val4 (compile (cadadr t) e (cadddr vars) tf cntr se #f)] )
+ (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) )
+ ((4) (let* ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
+ (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f))
+ (t (cddr bindings))
+ (val3 (compile (cadar t) e (caddr vars) tf cntr #f))
+ (val4 (compile (cadadr t) e (cadddr vars) tf cntr #f)) )
(lambda (v)
(##core#app
body
@@ -318,9 +319,9 @@
(##core#app val2 v)
(##core#app val3 v)
(##core#app val4 v))
- v)) ) ) ]
+ v)) ) ) )
[else
- (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se #f)) bindings)))
+ (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr #f)) bindings)))
(lambda (v)
(let ([v2 (##sys#make-vector n)])
(do ([i 0 (fx+ i 1)]
@@ -341,7 +342,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e h tf cntr se #f)))
+ e h tf cntr #f)))
((##core#letrec)
(let* ((bindings (cadr x))
@@ -358,10 +359,10 @@
`(##core#set! ,v ,t))
vars tmps)
(##core#let () ,@body) ) )
- e h tf cntr se #f)))
+ e h tf cntr #f)))
[(##core#lambda)
- (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
+ (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f (##sys#current-environment))
(let* ([llist (cadr x)]
[body (cddr x)]
[info (cons (or h '?) llist)] )
@@ -369,17 +370,18 @@
(set!-values
(llist body)
(##sys#expand-extended-lambda-list
- llist body ##sys#syntax-error-hook se) ) )
+ llist body ##sys#syntax-error-hook (##sys#current-environment)) ) )
(##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
- (se2 (##sys#extend-se se vars aliases))
+ (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
(e2 (cons aliases e))
- (body
- (compile-to-closure
- (##sys#canonicalize-body body se2 #f)
- e2 se2 (or h cntr) evalenv static #f) ) )
+ (body
+ (parameterize ((##sys#current-environment se2))
+ (compile-to-closure
+ (##sys#canonicalize-body body se2 #f)
+ e2 (or h cntr) evalenv static #f)) ) )
(case argc
[(0) (if rest
(lambda (v)
@@ -454,19 +456,21 @@
info h cntr) ) ) ] ) ) ) ) ) ]
((##core#let-syntax)
- (let ((se2 (append
- (map (lambda (b)
- (list
- (car b)
- se
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (strip-syntax (car b)))))
- (cadr x) )
- se) ) )
+ (parameterize
+ ((##sys#current-environment
+ (append
+ (map (lambda (b)
+ (list
+ (car b)
+ (##sys#current-environment)
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (strip-syntax (car b)))))
+ (cadr x) )
+ (##sys#current-environment)) ) )
(compile
- (##sys#canonicalize-body (cddr x) se2 #f)
- e #f tf cntr se2 #f)))
+ (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
+ e #f tf cntr #f)))
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -477,20 +481,21 @@
(##sys#eval/meta (cadr b))
(strip-syntax (car b)))))
(cadr x) ) )
- (se2 (append ms se)) )
+ (se2 (append ms (##sys#current-environment))) )
(for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
- ms)
- (compile
- (##sys#canonicalize-body (cddr x) se2 #f)
- e #f tf cntr se2 #f)))
+ ms)
+ (parameterize ((##sys#current-environment se2))
+ (compile
+ (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
+ e #f tf cntr #f))))
((##core#define-syntax)
(let* ((var (cadr x))
(body (caddr x))
- (name (rename var se)))
- (when (and static (not (assq var se)))
+ (name (rename var)))
+ (when (and static (not (assq var (##sys#current-environment))))
(##sys#error 'eval "environment is not mutable" evalenv var))
(##sys#register-syntax-export
name (##sys#current-module)
@@ -499,22 +504,22 @@
name
(##sys#current-environment)
(##sys#eval/meta body))
- (compile '(##core#undefined) e #f tf cntr se #f) ) )
+ (compile '(##core#undefined) e #f tf cntr #f) ) )
((##core#define-compiler-syntax)
- (compile '(##core#undefined) e #f tf cntr se #f))
+ (compile '(##core#undefined) e #f tf cntr #f))
((##core#let-compiler-syntax)
(compile
- (##sys#canonicalize-body (cddr x) se #f)
- e #f tf cntr se #f))
+ (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
+ e #f tf cntr #f))
((##core#include)
(##sys#include-forms-from-file
(cadr x)
(caddr x)
(lambda (forms)
- (compile `(##core#begin ,@forms) e #f tf cntr se tl?))))
+ (compile `(##core#begin ,@forms) e #f tf cntr tl?))))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -523,7 +528,7 @@
(strip-syntax b))
(cadr x))
(lambda ()
- (compile `(##core#begin ,@(cddr x)) e #f tf cntr se tl?))))
+ (compile `(##core#begin ,@(cddr x)) e #f tf cntr tl?))))
((##core#module)
(let* ((x (strip-syntax x))
@@ -574,42 +579,41 @@
(cons (compile
(car body)
'() #f tf cntr
- (##sys#current-environment)
#t) ; reset back to toplevel!
xs))))) ) )))
[(##core#loop-lambda)
- (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se #f) ]
+ (compile `(,(rename 'lambda) ,@(cdr x)) e #f tf cntr #f) ]
[(##core#provide)
- (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se #f)]
+ (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr #f)]
[(##core#require-for-syntax)
(chicken.load#load-extension (cadr x) '() 'require)
- (compile '(##core#undefined) e #f tf cntr se #f)]
+ (compile '(##core#undefined) e #f tf cntr #f)]
[(##core#require)
(let ((id (cadr x))
(alternates (cddr x)))
(let-values (((exp _) (##sys#process-require id #f alternates)))
- (compile exp e #f tf cntr se #f)))]
+ (compile exp e #f tf cntr #f)))]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
(##sys#eval/meta (cadr x))
- (compile '(##core#undefined) e #f tf cntr se tl?) ]
+ (compile '(##core#undefined) e #f tf cntr tl?) ]
[(##core#compiletimetoo)
- (compile (cadr x) e #f tf cntr se tl?) ]
+ (compile (cadr x) e #f tf cntr tl?) ]
[(##core#compiletimeonly ##core#callunit)
- (compile '(##core#undefined) e #f tf cntr se tl?) ]
+ (compile '(##core#undefined) e #f tf cntr tl?) ]
[(##core#declare)
(##sys#notice "declarations are ignored in interpreted code" x)
- (compile '(##core#undefined) e #f tf cntr se #f) ]
+ (compile '(##core#undefined) e #f tf cntr #f) ]
[(##core#define-inline ##core#define-constant)
- (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se tl?) ]
+ (compile `(,(rename 'define) ,@(cdr x)) e #f tf cntr tl?) ]
[(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
##core#define-foreign-variable
@@ -619,16 +623,16 @@
(##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
[(##core#app)
- (compile-call (cdr x) e tf cntr se) ]
+ (compile-call (cdr x) e tf cntr (##sys#current-environment)) ]
((##core#the)
- (compile (cadddr x) e h tf cntr se tl?))
+ (compile (cadddr x) e h tf cntr tl?))
((##core#typecase)
;; drops exp and requires "else" clause
(cond ((assq 'else (strip-syntax (cdddr x))) =>
(lambda (cl)
- (compile (cadr cl) e h tf cntr se tl?)))
+ (compile (cadr cl) e h tf cntr tl?)))
(else
(##sys#syntax-error-hook
'compiler-typecase
@@ -637,11 +641,11 @@
(else
(fluid-let ((##sys#syntax-context (cons head ##sys#syntax-context)))
- (compile-call x e tf cntr se)))))))]
+ (compile-call x e tf cntr (##sys#current-environment))))))))]
[else
(emit-syntax-trace-info tf x cntr)
- (compile-call x e tf cntr se)] ) )
+ (compile-call x e tf cntr (##sys#current-environment))] ) )
(define (fudge-argument-list n alst)
(if (null? alst)
@@ -667,43 +671,43 @@
(let* ((head (##sys#slot x 0))
(fn (if (procedure? head)
(lambda _ head)
- (compile (##sys#slot x 0) e #f tf cntr se #f)))
+ (compile (##sys#slot x 0) e #f tf cntr #f)))
(args (##sys#slot x 1))
(argc (checked-length args))
(info x) )
(case argc
- [(#f) (##sys#syntax-error/context "malformed expression" x)]
- [(0) (lambda (v)
+ ((#f) (##sys#syntax-error/context "malformed expression" x))
+ ((0) (lambda (v)
(emit-trace-info tf info cntr e v)
- ((##core#app fn v)))]
- [(1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)))
+ ((##core#app fn v))))
+ ((1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr #f)))
(lambda (v)
(emit-trace-info tf info cntr e v)
- ((##core#app fn v) (##core#app a1 v))) ) ]
- [(2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
- (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) )
+ ((##core#app fn v) (##core#app a1 v))) ) )
+ ((2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
- ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
- [(3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
- (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
- (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) )
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) )
+ ((3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f))
+ (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
- ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
- [(4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
- (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
- (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f))
- (a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se #f)) )
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) )
+ ((4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f))
+ (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr #f))
+ (a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
- ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
- [else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr se #f)) args)))
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) )
+ (else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr #f)) args)))
(lambda (v)
(emit-trace-info tf info cntr e v)
- (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
+ (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ) ) ) )
- (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se tl?) ) ) )
+ (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr tl?) ) ) )
;;; evaluate in the macro-expansion/compile-time environment
@@ -724,7 +728,6 @@
((compile-to-closure
form
'()
- (##sys#current-meta-environment)
#f #f #f ;XXX evalenv? static?
#t) ; toplevel.
'()) )
@@ -748,17 +751,18 @@
((compile-to-closure
`(##core#begin (import-for-syntax ,@default-syntax-imports)
(import ,@default-imports))
- '() se #f #f #f #t) '()))
+ '() #f #f #f #t) '()))
(cond (env
(##sys#check-structure env 'environment 'eval)
(let ((se2 (##sys#slot env 2)))
((if se2 ; not interaction-environment?
- (parameterize ((##sys#macro-environment '()))
- (compile-to-closure x '() se2 #f env (##sys#slot env 3) #t))
- (compile-to-closure x '() se #f env #f #t))
+ (parameterize ((##sys#macro-environment '())
+ (##sys#current-environment se2))
+ (compile-to-closure x '() #f env (##sys#slot env 3) #t))
+ (compile-to-closure x '() #f env #f #t))
'() ) ) )
(else
- ((compile-to-closure x '() se #f #f #f #t) '())))))))
+ ((compile-to-closure x '() #f #f #f #t) '())))))))
(set! scheme#eval
(lambda (x . env)
diff --git a/tests/module-tests-compiled.scm b/tests/module-tests-compiled.scm
index 892d2a22..6a375ecb 100644
--- a/tests/module-tests-compiled.scm
+++ b/tests/module-tests-compiled.scm
@@ -39,6 +39,37 @@
(define v (vector 1 2 3))
(test-equal "unmarked primitive exports" (vector-fill! 99 v) '#(99 99 99))
+(module m3 (op)
+ (import scheme)
+ (define op -))
+
+(module m4 (op)
+ (import scheme)
+ (define op +))
+
+;; Lexically scoped import, see #1437
+
+(import m4)
+(test-equal "lexically scoped import uses imported module"
+ 3 (let () (import m3) (op 5 2)))
+
+(test-equal "After leaving scope, fall back to old import" 7 (op 5 2))
+
+(eval '(import m4))
+(test-equal "Interpreted code behaves identically on lexical import"
+ 3 (eval '(let () (import m3) (op 5 2))))
+
+(test-equal "Interpreted code behaves identically after leaving scope"
+ 7 (eval '(op 5 2)))
+
+;; This was the remaining bug: imports would be evaluated during
+;; macro expansion, mutating ##sys#current-environment, but the
+;; code walker would keep the old syntax environment.
+(begin
+ (import m3)
+ (test-equal "In begin, imports are seen immediately" 3 (op 5 2)))
+
+(test-equal "begin splices; imports still active afterwards" 3 (op 5 2))
(test-end "modules")
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
