Disallow runtime environments in make-syntactic-environment.

diff --git a/src/compiler/back/asmmac.scm b/src/compiler/back/asmmac.scm
index 6a86dc122da2ba19e0a080554fca7dc481a6f012..dfeb23de73701cf4576001b558b7847b1e559a5c 100644 (file)
--- a/src/compiler/back/asmmac.scm
+++ b/src/compiler/back/asmmac.scm
@@ -82,7 +82,8 @@ USA.
 
   (define (car-constant? components)
     (and (identifier=? environment (caar components)
-                      system-global-environment 'QUOTE)
+                      (->syntactic-environment system-global-environment)
+                      'quote)
         (bit-string? (cadar components))))
 
   (define-integrable (car-constant-value constant)

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index bbf25cdc0fa0c6d7b9516dda55703b54d1c61584..df8efc09ba2a880f217c35dfa5141c2c8bde6c38 100644 (file)
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -100,7 +100,9 @@ USA.
         (compile/expression self environment)
         free-names
         (compile/expression
-         `(,(close-syntax 'BEGIN system-global-environment) ,@body)
+         `(,(close-syntax 'begin
+                          (->syntactic-environment system-global-environment))
+           ,@body)
          environment)))))))
 
 (define-syntax ==>

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index 610adc15b64524bd4dbb48c155e4b826209206bf..85d83b38144e6a5843b2175cae75ab9afb94b206 100644 (file)
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -63,6 +63,11 @@ USA.
                 (vector-ref (gc-space-status) 0))
              env))
 
+    (if (unbound? env '->syntactic-environment)
+       (eval '(define (->syntactic-environment object)
+                object)
+             env))
+
     (provide-rename 'random-bytevector 'random-byte-vector)
     (provide-rename 'string-foldcase 'string-downcase)
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index eaaeb010f85d9fa913aa895085b072e8c3ed24ff..d0ae71bb78d1d0d3fb50dfed9e4760be4bc75b24 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4455,9 +4455,9 @@ USA.
   (files "syntax-environment")
   (parent (runtime syntax))
   (export ()
+         ->syntactic-environment
          syntactic-environment?)
   (export (runtime syntax)
-         ->syntactic-environment
          make-internal-syntactic-environment
          make-keyword-syntactic-environment
          make-partial-syntactic-environment

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 5321c183884d3e5d112cee7abd118fdf8b7a0259..da15ce62962781980854a88215c28905bcf58c1b 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -70,14 +70,14 @@ USA.
   (make-syntactic-closure senv '() form))
 
 (define (make-syntactic-closure senv free form)
-  (let ((senv (->syntactic-environment senv 'make-syntactic-closure)))
-    (guarantee-list-of identifier? free 'make-syntactic-closure)
-    (if (or (memq form free)   ;LOOKUP-IDENTIFIER assumes this.
-           (constant-form? form)
-           (and (syntactic-closure? form)
-                (null? (syntactic-closure-free form))))
-       form
-       (%make-syntactic-closure senv free form))))
+  (guarantee syntactic-environment? senv 'make-syntactic-closure)
+  (guarantee-list-of identifier? free 'make-syntactic-closure)
+  (if (or (memq form free)             ;LOOKUP-IDENTIFIER assumes this.
+         (constant-form? form)
+         (and (syntactic-closure? form)
+              (null? (syntactic-closure-free form))))
+      form
+      (%make-syntactic-closure senv free form)))
 
 (define (constant-form? form)
   (not (or (syntactic-closure? form)

diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 66c041c1576a2f3e6c242b0d184480f8d155ee2b..e22fd41e78597a42d884f18f8ce14bfd41b33d7c 100644 (file)
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -284,8 +284,9 @@ USA.
     (lambda ()
       (syntax* (if (null? declarations)
                   s-expressions
-                  (cons (cons (close-syntax 'DECLARE
-                                            system-global-environment)
+                  (cons (cons (close-syntax 'declare
+                                            (->syntactic-environment
+                                             system-global-environment))
                               declarations)
                         s-expressions))
               environment))))