[Chicken-hackers] [PATCH] remove non-std identifiers from std environments

[Felix]

This patch fixes two bugs: 

1. Non-standard syntax is removed from standard evaluation 
environments by filtering out all extraneous entries when
building the syntactic environment that maps identifiers
to syntax and qualified value identifiers.

2. When evaluating with a standard environment
("scheme-report-environment" or "null-environment"),
"##sys#macro-environment" is temporarily changed to an empty
list. Usually this parameter holds default and imported
syntax-definitions, but is unused when using explicit environments.

>From 235294c7fcf2d258cfc0b24276d289b7107b5394 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 3 Nov 2011 14:06:07 +0100
Subject: [PATCH] strip std-envs of non-std identifiers, ignore
 ##sys#macro-environment when evaluating with an explicit
 environment

---
 eval.scm                    |   64 +++++++++++++++++++++++++++++++-----------
 modules.scm                 |   14 ++-------
 tests/environment-tests.scm |    7 +++++
 3 files changed, 57 insertions(+), 28 deletions(-)

diff --git a/eval.scm b/eval.scm
index e66462c..bc1f303 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 7d62779..9f48089 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 517254b..2d7c081 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)
-- 
1.7.6.msysgit.0