From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 19 Dec 2001 01:39:52 +0000 (+0000)
Subject: Implement ENVIRONMENT-DEFINE and ENVIRONMENT-ASSIGNED?.  Change
X-Git-Tag: 20090517-FFI~2372
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8161217d742c1ea411ed862a10d4d1c97928f22;p=mit-scheme.git

Implement ENVIRONMENT-DEFINE and ENVIRONMENT-ASSIGNED?.  Change
ENVIRONMENT-LOOKUP to signal an error if the variable is unassigned.
Move ENVIRONMENT-SYNTAX-TABLE and SET-ENVIRONMENT-SYNTAX-TABLE! into
the syntax-table abstraction.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 75e9d2e33..64bd263bf 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.387 2001/12/18 20:51:05 cph Exp $
+$Id: runtime.pkg,v 14.388 2001/12/19 01:39:36 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -1321,9 +1321,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  environment-arguments
 	  environment-assign!
 	  environment-assignable?
+	  environment-assigned?
 	  environment-bindings
 	  environment-bound-names
 	  environment-bound?
+	  environment-define
 	  environment-has-parent?
 	  environment-lambda
 	  environment-lookup
@@ -3738,8 +3740,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (files "syntab")
   (parent (runtime))
   (export ()
+	  environment-syntax-table
 	  guarantee-syntax-table
 	  make-syntax-table
+	  set-environment-syntax-table!
 	  syntax-table-define
 	  syntax-table-ref
 	  syntax-table/copy
@@ -3748,20 +3752,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  syntax-table/extend
 	  syntax-table/parent
 	  syntax-table/ref
-	  syntax-table?))
+	  syntax-table?)
+  (export (runtime environment)
+	  syntax-table-tag))
 
 (define-package (runtime syntaxer)
   (files "syntax")
   (parent (runtime))
   (export ()
-	  environment-syntax-table
 	  hook/syntax-expression
 	  lambda-tag:fluid-let
 	  lambda-tag:let
 	  lambda-tag:make-environment
 	  lambda-tag:unnamed
 	  make-syntax-closure
-	  set-environment-syntax-table!
 	  syntax
 	  syntax*
 	  syntax-closure/expression
@@ -3771,8 +3775,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  user-initial-syntax-table)
   (export (runtime defstruct)
 	  parse-lambda-list)
-  (export (runtime environment)
-	  syntax-table-tag)
   (initialization (initialize-package!)))
 
 (define-package (runtime illegal-definitions)
diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm
index 182ac58e9..e27535d7e 100644
--- a/v7/src/runtime/syntab.scm
+++ b/v7/src/runtime/syntab.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntab.scm,v 14.6 2001/12/18 20:47:46 cph Exp $
+$Id: syntab.scm,v 14.7 2001/12/19 01:39:41 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -85,4 +85,17 @@ USA.
 
 (define (syntax-table/extend table alist)
   (%make-syntax-table (alist-copy alist)
-		      (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)))
\ No newline at end of file
+		      (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)))
+
+(define (environment-syntax-table environment)
+  (environment-lookup environment syntax-table-tag))
+
+(define (set-environment-syntax-table! environment table)
+  (environment-define environment
+		      syntax-table-tag
+		      (guarantee-syntax-table table
+					      'SET-ENVIRONMENT-SYNTAX-TABLE!)))
+
+(define-integrable syntax-table-tag
+  ((ucode-primitive string->symbol)
+   "#[(runtime syntax-table)syntax-table-tag]"))
\ No newline at end of file
diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index 7e2287b60..7a67ab762 100644
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntax.scm,v 14.35 2001/12/18 20:47:18 cph Exp $
+$Id: syntax.scm,v 14.36 2001/12/19 01:39:46 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -113,20 +113,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define (syntax/top-level?)
   *syntax-top-level?*)
 
-(define (environment-syntax-table environment)
-  (environment-lookup environment syntax-table-tag))
-
-(define (set-environment-syntax-table! environment table)
-  (if (not (interpreter-environment? environment))
-      (error:wrong-type-argument environment
-				 "interpreter environment"
-				 'SET-ENVIRONMENT-SYNTAX-TABLE!))
-  (local-assignment environment syntax-table-tag table))
-
-(define-integrable syntax-table-tag
-  ((ucode-primitive string->symbol)
-   "#[(runtime syntax-table)syntax-table-tag]"))
-
 (define-integrable (syntax-subsequence expressions)
   (syntax-sequence #f expressions))
 
diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm
index e0bd9073c..8657abf23 100644
--- a/v7/src/runtime/uenvir.scm
+++ b/v7/src/runtime/uenvir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.45 2001/12/18 20:50:59 cph Exp $
+$Id: uenvir.scm,v 14.46 2001/12/19 01:39:52 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -119,6 +119,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(else
 	 (illegal-environment environment 'ENVIRONMENT-BOUND?))))
 
+(define (environment-assigned? environment name)
+  (cond ((interpreter-environment? environment)
+	 (interpreter-environment/assigned? environment name))
+	((stack-ccenv? environment)
+	 (stack-ccenv/assigned? environment name))
+	((closure-ccenv? environment)
+	 (closure-ccenv/assigned? environment name))
+	(else
+	 (illegal-environment environment 'ENVIRONMENT-ASSIGNED?))))
+
 (define (environment-lookup environment name)
   (cond ((interpreter-environment? environment)
 	 (interpreter-environment/lookup environment name))
@@ -149,6 +159,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(else
 	 (illegal-environment environment 'ENVIRONMENT-ASSIGN!))))
 
+(define (environment-define environment name value)
+  (cond ((interpreter-environment? environment)
+	 (interpreter-environment/define environment name value))
+	((or (stack-ccenv? environment)
+	     (closure-ccenv? environment))
+	 (error:bad-range-argument environment 'ENVIRONMENT-DEFINE))
+	(else
+	 (illegal-environment environment 'ENVIRONMENT-DEFINE))))
+
 (define (illegal-environment object procedure)
   (error:wrong-type-argument object "environment" procedure))
 
@@ -218,15 +237,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define (interpreter-environment/bound? environment name)
   (not (lexical-unbound? environment name)))
 
+(define (interpreter-environment/assigned? environment name)
+  (not (lexical-unassigned? environment name)))
+
 (define (interpreter-environment/lookup environment name)
-  (if (lexical-unassigned? environment name)
-      (make-unassigned-reference-trap)
-      (lexical-reference environment name)))
+  (lexical-reference environment name))
 
 (define (interpreter-environment/assign! environment name value)
   (lexical-assignment environment name value)
   unspecific)
 
+(define (interpreter-environment/define environment name value)
+  (local-assignment environment name value)
+  unspecific)
+
 (define (ic-environment/bound-names environment)
   (map-ic-environment-bindings map-entry/bound-names environment))
 
@@ -528,6 +552,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(and parent
 	     (environment-bound? parent name)))))
 
+(define (stack-ccenv/assigned? environment name)
+  (and (stack-ccenv/lookup environment name) #t))
+
 (define (stack-ccenv/lookup environment name)
   (lookup-dbg-variable (stack-ccenv/block environment)
 		       name
@@ -638,6 +665,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(and parent
 	     (environment-bound? parent name)))))
 
+(define (closure-ccenv/assigned? environment name)
+  (and (closure-ccenv/lookup environment name) #t))
+
 (define (closure-ccenv/variable-bound? environment variable)
   (or (eq? (dbg-variable/type variable) 'INTEGRATED)
       (vector-find-next-element