~ chicken-core (chicken-5) 4c57d2cba9c756c7ceaeea9b38c8bc0a028dcf7c
commit 4c57d2cba9c756c7ceaeea9b38c8bc0a028dcf7c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jun 18 21:54:21 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jun 18 21:54:21 2011 +0200
use proper environment in eval/meta for compile-time evaluation, factored it out into ##sys#eval/meta
diff --git a/compiler.scm b/compiler.scm
index f1510bfa..80c426c1 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -471,25 +471,6 @@
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
- (define (eval/meta form)
- (let ((oldcm (##sys#current-module))
- (oldme (##sys#macro-environment))
- (mme (##sys#meta-macro-environment)))
- (dynamic-wind
- (lambda ()
- (##sys#current-module #f)
- (##sys#macro-environment mme))
- (lambda ()
- ((##sys#compile-to-closure
- form
- '()
- (##sys#current-meta-environment))
- '() ) )
- (lambda ()
- (##sys#current-module oldcm)
- (##sys#meta-macro-environment (##sys#macro-environment))
- (##sys#macro-environment oldme)))))
-
(define (emit-import-lib name il)
(let* ((fname (if all-import-libraries
(string-append (symbol->string name) ".import.scm")
@@ -686,7 +667,7 @@
(car b)
se
(##sys#er-transformer
- (eval/meta (cadr b)))))
+ (##sys#eval/meta (cadr b)))))
(cadr x) )
se) ) )
(walk
@@ -700,7 +681,7 @@
(car b)
#f
(##sys#er-transformer
- (eval/meta (cadr b)))))
+ (##sys#eval/meta (cadr b)))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
@@ -727,7 +708,7 @@
(##sys#extend-macro-environment
name
(##sys#current-environment)
- (##sys#er-transformer (eval/meta body)))
+ (##sys#er-transformer (##sys#eval/meta body)))
(walk
(if ##sys#enable-runtime-macros
`(##sys#extend-macro-environment
@@ -750,7 +731,7 @@
name '##compiler#compiler-syntax
(and body
(##sys#cons
- (##sys#er-transformer (eval/meta body))
+ (##sys#er-transformer (##sys#eval/meta body))
(##sys#current-environment))))
(walk
(if ##sys#enable-runtime-macros
@@ -772,7 +753,8 @@
(list
name
(and (pair? (cdr b))
- (cons (##sys#er-transformer (eval/meta (cadr b))) se))
+ (cons (##sys#er-transformer
+ (##sys#eval/meta (cadr b))) se))
(##sys#get name '##compiler#compiler-syntax) ) ) )
(cadr x))))
(dynamic-wind
@@ -979,11 +961,11 @@
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
- (eval/meta exp)
+ (##sys#eval/meta exp)
(walk exp e se dest #f h) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
- (eval/meta (cadr x))
+ (##sys#eval/meta (cadr x))
'(##core#undefined) )
((##core#begin ##core#toplevel-begin)
diff --git a/eval.scm b/eval.scm
index c296ccaf..a52d2660 100644
--- a/eval.scm
+++ b/eval.scm
@@ -231,32 +231,6 @@
(define (decorate p ll h cntr)
(##sys#eval-decorator p ll h cntr) )
- (define (eval/meta form)
- (let ((oldcm (##sys#current-module))
- (oldme (##sys#macro-environment))
- (mme (##sys#meta-macro-environment)))
- (dynamic-wind
- (lambda ()
- (##sys#current-module #f)
- (##sys#macro-environment mme))
- (lambda ()
- ((##sys#compile-to-closure
- form
- '()
- (##sys#current-meta-environment))
- '() ) )
- (lambda ()
- (##sys#current-module oldcm)
- (##sys#meta-macro-environment (##sys#macro-environment))
- (##sys#macro-environment oldme)))))
-
- (define (eval/elab form)
- ((##sys#compile-to-closure
- form
- '()
- (##sys#current-environment))
- '() ) )
-
(define (compile x e h tf cntr se)
(cond ((keyword? x) (lambda v x))
((symbol? x)
@@ -326,7 +300,7 @@
(d `(EVAL/EXPANDED: ,x2))
(if (not (eq? x2 x))
(compile x2 e h tf cntr se)
- (let ((head (rename (##sys#slot x 0) se)))
+ (let ((head (rename (##sys#slot x 0) se)))
;; here we did't resolve ##core#primitive, but that is done in compile-call (via
;; a normal walking of the operator)
(case head
@@ -580,7 +554,7 @@
(car b)
se
(##sys#er-transformer
- (eval/meta (cadr b)))))
+ (##sys#eval/meta (cadr b)))))
(cadr x) )
se) ) )
(compile
@@ -593,7 +567,7 @@
(car b)
#f
(##sys#er-transformer
- (eval/meta (cadr b)))))
+ (##sys#eval/meta (cadr b)))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
@@ -614,7 +588,7 @@
(##sys#extend-macro-environment
name
(##sys#current-environment)
- (##sys#er-transformer (eval/meta body)))
+ (##sys#er-transformer (##sys#eval/meta body)))
(compile '(##core#undefined) e #f tf cntr se) ) )
((##core#define-compiler-syntax)
@@ -693,8 +667,7 @@
(compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
[(##core#require-for-syntax)
- (let ([ids (map (lambda (x)
- (eval/meta x))
+ (let ([ids (map (lambda (x) (##sys#eval/meta x))
(cdr x))])
(apply ##sys#require ids)
(let ([rs (##sys#lookup-runtime-requirements ids)])
@@ -718,7 +691,7 @@
e #f tf cntr se) ) ]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
- (eval/meta (cadr x))
+ (##sys#eval/meta (cadr x))
(compile '(##core#undefined) e #f tf cntr se) ]
[(##core#compiletimetoo)
@@ -815,6 +788,30 @@
(compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se) ) ) )
+
+;;; evaluate in the macro-expansion/compile-time environment
+(define (##sys#eval/meta form)
+ (let ((oldcm (##sys#current-module))
+ (oldme (##sys#macro-environment))
+ (mme (##sys#meta-macro-environment))
+ (aee ##sys#active-eval-environment))
+ (dynamic-wind
+ (lambda ()
+ (##sys#current-module #f)
+ (##sys#macro-environment mme)
+ (set! ##sys#active-eval-environment ##sys#current-meta-environment))
+ (lambda ()
+ ((##sys#compile-to-closure
+ form
+ '()
+ (##sys#current-meta-environment))
+ '() ) )
+ (lambda ()
+ (set! ##sys#active-eval-environment aee)
+ (##sys#current-module oldcm)
+ (##sys#meta-macro-environment (##sys#macro-environment))
+ (##sys#macro-environment oldme)))))
+
(define ##sys#eval-handler
(make-parameter
(lambda (x . env)
diff --git a/expand.scm b/expand.scm
index fecf0c53..2a064a4b 100644
--- a/expand.scm
+++ b/expand.scm
@@ -59,6 +59,7 @@
(define ##sys#current-environment (make-parameter '()))
(define ##sys#current-meta-environment (make-parameter '()))
+(define ##sys#active-eval-environment ##sys#current-environment)
(define (lookup id se)
(cond ((##core#inline "C_u_i_assq" id se) => cdr)
diff --git a/modules.scm b/modules.scm
index 2208c35d..76532166 100644
--- a/modules.scm
+++ b/modules.scm
@@ -37,6 +37,12 @@
(define-alias dm d)
(define-alias dx d)
+#+debugbuild
+(define (map-se se)
+ (map (lambda (a)
+ (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
+ se))
+
(define-inline (getp sym prop)
(##core#inline "C_i_getprop" sym prop #f))
@@ -712,10 +718,10 @@
((getp sym '##core#aliased)
(dm "(ALIAS) marked: " sym)
sym)
- ((assq sym (##sys#current-environment)) =>
+ ((assq sym (##sys#active-eval-environment)) =>
(lambda (a)
- (dm "(ALIAS) in current environment: " sym)
(let ((sym2 (cdr a)))
+ (dm "(ALIAS) in current environment " sym " -> " sym2)
(if (pair? sym2) ; macro (*** can this be?)
(mrename sym)
(or (getp sym2 '##core#primitive) sym2)))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 83d544f0..ae364544 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -130,7 +130,7 @@ echo "======================================== syntax tests (compiled) ..."
$compile syntax-tests.scm
./a.out
-echo "======================================== syntax tests (2, compiled) ..."
+echo "======================================== syntax tests (v2, compiled) ..."
$compile syntax-tests-2.scm
./a.out
@@ -233,9 +233,6 @@ $interpret -bnq ec.so ec-tests.scm
# $compile ec-tests.scm
# ./a.out # takes ages to compile
-echo "======================================== arithmetic tests ..."
-$interpret -D check -s arithmetic-test.scm
-
echo "======================================== hash-table tests ..."
$interpret -s hash-table-tests.scm
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index ca80ec87..c3ba70fa 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -914,3 +914,18 @@
(set-cdr! a a)
`(1 ,@a))
+
+;; ##sys#alias-global-hook, when invoked via eval/meta, did resolve identifiers
+;; used during evaluation of an expander body in the wrong environment and mapped
+;; an identifier to something imported for the runtime environment
+
+(module foonumbers (+)
+ (import (except scheme +) chicken)
+ (define (+ . _) (error "failed.")))
+
+(import foonumbers)
+
+(define-syntax (foo x r c)
+ `(print ,(+ (cadr x) 1)))
+
+(foo 3)
Trap