From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 27 Jan 2018 05:42:35 +0000 (-0800)
Subject: Disallow runtime environments in make-syntactic-environment.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~296
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=71e8113873431480d22ec715cf4238ccc2aad8ce;p=mit-scheme.git

Disallow runtime environments in make-syntactic-environment.
---

diff --git a/src/compiler/back/asmmac.scm b/src/compiler/back/asmmac.scm
index 6a86dc122..dfeb23de7 100644
--- 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 bbf25cdc0..df8efc09b 100644
--- 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 610adc15b..85d83b381 100644
--- 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 eaaeb010f..d0ae71bb7 100644
--- 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 5321c1838..da15ce629 100644
--- 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 66c041c15..e22fd41e7 100644
--- 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))))