~ chicken-core (chicken-5) fd018dfd63f16cba2c5762bf76f5e614e2f3f956

commit fd018dfd63f16cba2c5762bf76f5e614e2f3f956
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Nov 3 14:06:07 2011 +0100
Commit:     Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sat Nov 5 23:03:27 2011 +0100

    strip std-envs of non-std identifiers, ignore ##sys#macro-environment when evaluating with an explicit environment
    
    Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>

diff --git a/eval.scm b/eval.scm
index e66462cb..bc1f303e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -818,11 +818,16 @@
   (make-parameter
    (lambda (x #!optional env)
      (let ((se (##sys#current-environment)))
-       (when env
-	 (##sys#check-structure env 'environment 'eval)
-	 (set! se (or (##sys#slot env 2) se)))
-       ((##sys#compile-to-closure x '() se #f env (and env (##sys#slot env 3)))
-	'() ) ) ) ) )
+       (cond (env
+	      (##sys#check-structure env 'environment 'eval)
+	      (let ((se2 (##sys#slot env 2)))
+		((if se2		; not interaction-environment?
+		     (parameterize ((##sys#macro-environment '()))
+		       (##sys#compile-to-closure x '() se2 #f env (##sys#slot env 3)))
+		     (##sys#compile-to-closure x '() se #f env #f))
+		 '() ) ) )
+	     (else
+	      ((##sys#compile-to-closure x '() se #f #f #f) '() ) ) ) ) )))
 
 (define eval-handler ##sys#eval-handler)
 
@@ -1379,27 +1384,52 @@
   (##sys#print (##sys#slot e 1) #f p)
   (##sys#write-char-0 #\> p))
 
-(define scheme-report-environment
-  (let ((r4 (module-environment 'r4rs 'scheme-report-environment/4))
-	(r5 (module-environment 'scheme 'scheme-report-environment/5)))
+(define scheme-report-environment)
+(define null-environment)
+
+(let* ((r4s (module-environment 'r4rs 'scheme-report-environment/4))
+       (r5s (module-environment 'scheme 'scheme-report-environment/5))
+       (r4n (module-environment 'r4rs-null 'null-environment/4))
+       (r5n (module-environment 'r5rs-null 'null-environment/5)))
+  (define (strip se)
+    (foldr
+     (lambda (s r)
+       (if (memq (car s)
+		 '(import 
+		    require-extension 
+		    require-library 
+		    begin-for-syntax
+		    export 
+		    module
+		    cond-expand
+		    syntax
+		    reexport 
+		    import-for-syntax))
+	   r
+	   (cons s r)))
+     '()
+     se))
+  ;; Strip non-std syntax from SEs
+  (##sys#setslot r4s 2 (strip (##sys#slot r4s 2)))
+  (##sys#setslot r4n 2 (strip (##sys#slot r4n 2)))
+  (##sys#setslot r5s 2 (strip (##sys#slot r5s 2)))
+  (##sys#setslot r5n 2 (strip (##sys#slot r5n 2)))
+  (set! scheme-report-environment
     (lambda (n)
       (##sys#check-exact n 'scheme-report-environment)
       (case n
-	((4) r4)
-	((5) r5)
+	((4) r4s)
+	((5) r5s)
 	(else 
 	 (##sys#error 
 	  'scheme-report-environment
-	  "unsupported scheme report environment version" n)) ) ) ) )
-
-(define null-environment
-  (let ((r4 (module-environment 'r4rs-null 'null-environment/4))
-	(r5 (module-environment 'r5rs-null 'null-environment/5)))
+	  "unsupported scheme report environment version" n)) ) ) )
+  (set! null-environment
     (lambda (n)
       (##sys#check-exact n 'null-environment)
       (case n
-	((4) r4)
-	((5) r5)
+	((4) r4n)
+	((5) r5n)
 	(else
 	 (##sys#error
 	  'null-environment 
diff --git a/modules.scm b/modules.scm
index 7d627795..9f48089b 100644
--- a/modules.scm
+++ b/modules.scm
@@ -867,18 +867,10 @@
 	     scheme-report-environment null-environment interaction-environment
 	     else))
       (r4rs-syntax
-       ;;XXX currently disabled - better would be to move these into the "chicken"
+       ;;XXX better would be to move these into the "chicken"
        ;;    module. "import[-for-syntax]" and "reexport" are in
-       ;;    ##sys#initial-macro-environment and thus always available inside modules.
-       #;(foldr
-	(lambda (s r)
-	  (if (memq (car s)
-		    '(import require-extension require-library begin-for-syntax
-			     export module cond-expand syntax reexport import-for-syntax))
-	      r
-	      (cons s r)))
-	'()
-	##sys#default-macro-environment)
+       ;;    ##sys#initial-macro-environment and thus always available inside 
+       ;;    modules.
        ##sys#default-macro-environment))
   (##sys#register-primitive-module 'r4rs r4rs-values r4rs-syntax)
   (##sys#register-primitive-module 
diff --git a/tests/environment-tests.scm b/tests/environment-tests.scm
index 517254b2..2d7c081b 100644
--- a/tests/environment-tests.scm
+++ b/tests/environment-tests.scm
@@ -24,6 +24,13 @@
 		  (scheme-report-environment 5)))
 
 (test-error (eval 'car (null-environment 5)))
+(test-error (eval '(cond-expand (chicken 1) (else 2)) (null-environment 4)))
+(test-error (eval '(cond-expand (chicken 1) (else 2)) (null-environment 5)))
+(test-error (eval '(cond-expand (chicken 1) (else 2)) (scheme-report-environment 4)))
+(test-error (eval '(cond-expand (chicken 1) (else 2)) (scheme-report-environment 5)))
+(test-equal 1 (eval '(if #t 1 2) (scheme-report-environment 5)))
+(test-equal 1 (eval '(if #t 1 2) (null-environment 4)))
+(test-equal 1 (eval '(if #t 1 2) (null-environment 5)))
 (test-equal (eval '((lambda (x) x) 123) (null-environment 5)) 123)
 
 (define baz 100)