From aec61ded4b562d63bccd63ec7f0b5a647cc33386 Mon Sep 17 00:00:00 2001 From: Peter Bex 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