From 6f1b636e5cf1bb326d89e95d20334208680cec77 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 3 Aug 2001 20:30:02 +0000
Subject: [PATCH] Rewrite interpreter-environment abstraction to account for
 new primitive that unbinds variables.  This works with the old microcode.

---
 v7/src/runtime/runtime.pkg |  11 +-
 v7/src/runtime/uenvir.scm  | 281 +++++++++++++++++++++++--------------
 v7/src/runtime/urtrap.scm  |  83 ++++++-----
 v7/src/runtime/version.scm |   4 +-
 4 files changed, 230 insertions(+), 149 deletions(-)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index a577625a6..f29e6fb55 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.370 2001/06/15 21:20:53 cph Exp $
+$Id: runtime.pkg,v 14.371 2001/08/03 20:29:54 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -2020,15 +2020,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (files "urtrap")
   (parent ())
   (export ()
+	  cached-reference-trap-value
+	  cached-reference-trap?
 	  make-unassigned-reference-trap
 	  make-unbound-reference-trap
 	  map-reference-trap
+	  map-reference-trap-value
 	  reference-trap-kind
 	  reference-trap-kind-name
 	  reference-trap?
 	  unassigned-reference-trap?
 	  unbound-reference-trap?
-	  unmap-reference-trap))
+	  unmap-reference-trap
+	  unmapped-unassigned-reference-trap?
+	  unmapped-unbound-reference-trap?))
 
 (define-package (runtime rep)
   (files "rep")
@@ -3130,6 +3135,8 @@ 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/uenvir.scm b/v7/src/runtime/uenvir.scm
index 7bc07a5c5..841a72920 100644
--- a/v7/src/runtime/uenvir.scm
+++ b/v7/src/runtime/uenvir.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.40 1999/10/23 03:08:00 cph Exp $
+$Id: uenvir.scm,v 14.41 2001/08/03 20:29:57 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Microcode Environments
@@ -44,7 +45,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-parent environment)
   (cond ((system-global-environment? environment)
-	 (error "Global environment has no parent" environment))
+	 (error:bad-range-argument environment 'ENVIRONMENT-PARENT))
 	((ic-environment? environment)
 	 (ic-environment/parent environment))
 	((stack-ccenv? environment)
@@ -56,7 +57,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-bound-names environment)
   (cond ((system-global-environment? environment)
-	 (system-global-environment/bound-names environment))
+	 (system-global-environment/bound-names))
 	((ic-environment? environment)
 	 (ic-environment/bound-names environment))
 	((stack-ccenv? environment)
@@ -67,13 +68,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	 (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES))))
 
 (define (environment-bindings environment)
-  (map (lambda (name)
-	 (cons name
-	       (let ((value (environment-lookup environment name)))
-		 (if (unassigned-reference-trap? value)
-		     '()
-		     (list value)))))
-       (environment-bound-names environment)))
+  (cond ((system-global-environment? environment)
+	 (system-global-environment/bindings))
+	((ic-environment? environment)
+	 (ic-environment/bindings environment))
+	(else
+	 (map (lambda (name)
+		(cons name
+		      (let ((value (environment-lookup environment name)))
+			(if (unassigned-reference-trap? value)
+			    '()
+			    (list value)))))
+	      (environment-bound-names environment)))))
 
 (define (environment-arguments environment)
   (cond ((ic-environment? environment)
@@ -146,20 +152,69 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (illegal-environment object procedure)
   (error:wrong-type-argument object "environment" procedure))
 
+;;;; Global environment
+
+(define-integrable (system-global-environment? object)
+  (eq? system-global-environment object))
+
+(define (system-global-environment/bound-names)
+  (walk-global map-entry/bound-names))
+
+(define (system-global-environment/bindings)
+  (walk-global map-entry/bindings))
+
+(define (map-entry/bound-names name value)
+  value
+  name)
+
+(define (map-entry/bindings name value)
+  (cons name
+	(if (unassigned-reference-trap? value)
+	    '()
+	    (list value))))
+
+(define (walk-global map-entry)
+  (let ((obarray (fixed-objects-item 'OBARRAY)))
+    (let ((n-buckets (vector-length obarray)))
+      (let per-bucket ((index 0) (result '()))
+	(if (fix:< index n-buckets)
+	    (let per-symbol
+		((bucket (vector-ref obarray index))
+		 (result result))
+	      (if (pair? bucket)
+		  (per-symbol (cdr bucket)
+			      (let ((name (car bucket)))
+				(if (special-unbound-name? name)
+				    result
+				    (let ((value
+					   (map-reference-trap-value
+					    (lambda ()
+					      (system-pair-cdr name)))))
+				      (if (unbound-reference-trap? value)
+					  result
+					  (cons (map-entry name value)
+						result))))))
+		  (per-bucket (fix:+ index 1) result)))
+	    result)))))
+
+(define (special-unbound-name? name)
+  (or (eq? name package-name-tag)
+      (eq? name syntax-table-tag)))
+
 ;;;; Interpreter Environments
 
 (define (interpreter-environment? object)
   (or (system-global-environment? object)
       (ic-environment? object)))
 
+(define-integrable (ic-environment? object)
+  (object-type? (ucode-type environment) object))
+
 (define (guarantee-interpreter-environment object)
   (if (not (interpreter-environment? object))
       (error:wrong-type-datum object "interpreter environment"))
   object)
 
-(define-integrable (system-global-environment? object)
-  (eq? system-global-environment object))
-
 (define (interpreter-environment/bound? environment name)
   (not (lexical-unbound? environment name)))
 
@@ -172,108 +227,89 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (lexical-assignment environment name value)
   unspecific)
 
-(define (system-global-environment/bound-names environment)
-  (list-transform-negative (obarray->list (fixed-objects-item 'OBARRAY))
-    (lambda (symbol)
-      (unbound-name? environment symbol))))
-
-(define-integrable (ic-environment? object)
-  (object-type? (ucode-type environment) object))
+(define (ic-environment/bound-names environment)
+  (map-ic-environment-bindings map-entry/bound-names environment))
+
+(define (ic-environment/bindings environment)
+  (map-ic-environment-bindings map-entry/bindings environment))
+
+(define (map-ic-environment-bindings map-entry environment)
+  (let ((external (ic-external-frame environment))
+	(do-frame
+	 (lambda (frame)
+	   (let ((procedure (ic-frame-procedure frame)))
+	     (if (vector? procedure)
+		 (append! (walk-ic-frame-extension procedure map-entry)
+			  (walk-ic-procedure-args frame
+						  (vector-ref procedure 1)
+						  map-entry))
+		 (walk-ic-procedure-args frame procedure map-entry))))))
+    (if (eq? external environment)
+	(do-frame environment)
+	(append! (do-frame environment) (do-frame external)))))
+
+(define (walk-ic-procedure-args frame procedure map-entry)
+  (let ((name-vector (system-pair-cdr (procedure-lambda procedure))))
+    (let loop ((index (vector-length name-vector)) (result '()))
+      (if (fix:> index 1)
+	  (let ((index (fix:- index 1)))
+	    (loop index
+		  (let ((name (vector-ref name-vector index)))
+		    (if (special-unbound-name? name)
+			result
+			(let ((value (ic-frame-arg frame index)))
+			  (if (unbound-reference-trap? value)
+			      result
+			      (cons (map-entry name value) result)))))))
+	  result))))
+
+(define (walk-ic-frame-extension extension map-entry)
+  (let ((limit (fix:+ 3 (object-datum (vector-ref extension 2)))))
+    (let loop ((index 3) (result '()))
+      (if (fix:< index limit)
+	  (loop (fix:+ index 1)
+		(let ((p (vector-ref extension index)))
+		  (let ((name (car p)))
+		    (if (special-unbound-name? name)
+			result
+			(cons (map-entry name
+					 (map-reference-trap-value
+					  (lambda () (cdr p))))
+			      result)))))
+	  result))))
+
+(define (ic-environment/arguments environment)
+  (let ((environment (ic-external-frame environment)))
+    (walk-ic-procedure-args environment
+			    (ic-frame-procedure* environment)
+			    (lambda (name value) name value))))
 
 (define (ic-environment/has-parent? environment)
-  (not (eq? (ic-environment/parent environment) null-environment)))
+  (interpreter-environment? (ic-frame-parent environment)))
 
 (define (ic-environment/parent environment)
-  (select-parent (ic-environment->external environment)))
-
-(define (ic-environment/lambda environment)
-  (select-lambda (ic-environment->external environment)))
-
-(define (ic-environment/procedure environment)
-  (select-procedure (ic-environment->external environment)))
-
-(define (ic-environment/bound-names environment)
-  (list-transform-negative
-      (let ((external (ic-environment->external environment))
-	    (parameters (lambda-bound (ic-environment/lambda environment)))
-	    (extension-names
-	     (lambda (environment tail)
-	       (let ((extension (select-extension environment)))
-		 (if (environment-extension? extension)
-		     (map* tail car (environment-extension-aux-list extension))
-		     tail)))))
-	(extension-names environment
-			 (if (eq? environment external)
-			     parameters
-			     (extension-names external parameters))))
-    (lambda (name)
-      (unbound-name? environment name))))
+  (let ((parent (ic-frame-parent environment)))
+    (if (not (interpreter-environment? parent))
+	(error:bad-range-argument environment 'ENVIRONMENT-PARENT))
+    parent))
 
-(define (unbound-name? environment name)
-  (if (eq? name package-name-tag)
-      #t
-      (lexical-unbound? environment name)))
-
-(define (ic-environment/arguments environment)
-  (lambda-components* (ic-environment/lambda environment)
-    (lambda (name required optional rest body)
-      name body
-      (let ((lookup
-	     (lambda (name)
-	       (interpreter-environment/lookup environment name))))
-	(map* (map* (if rest (lookup rest) '())
-		    lookup
-		    optional)
-	      lookup
-	      required)))))
-
-(define (ic-environment/set-parent! environment parent)
-  (let ((extension (select-extension (ic-environment->external environment))))
-    (if (environment-extension? extension)
-	(begin
-	  (set-environment-extension-parent! extension parent)
-	  (system-pair-set-cdr! (environment-extension-procedure extension)
-				parent))
-	(system-pair-set-cdr! extension parent))))
-
-(define (ic-environment/remove-parent! environment)
-  (ic-environment/set-parent! environment null-environment))
-
-;;  This corresponds to the #defines in sdata.h
-
-(define null-environment
-  (object-new-type (object-type #F)
-		   (fix:xor (object-datum #F) 1)))
-
-;;(define null-environment
-;;  (object-new-type (ucode-type null) 1))
+(define (ic-frame-parent environment)
+  (procedure-environment (ic-environment/procedure environment)))
 
 (define (make-null-interpreter-environment)
-  (let ((environment (let () (the-environment))))
-    (ic-environment/remove-parent! environment)
+  (let ((environment (let () (the-environment)))
+	(null-environment
+	 (object-new-type (object-type #F)
+			  (fix:xor (object-datum #F) 1))))
+    (let ((procedure
+	   (ic-frame-procedure (ic-external-frame environment))))
+      (if (vector? procedure)
+	  (begin
+	    (vector-set! procedure 0 null-environment)
+	    (system-pair-set-cdr! (vector-ref procedure 1) null-environment))
+	  (system-pair-set-cdr! procedure null-environment)))
     environment))
 
-(define (ic-environment->external environment)
-  (let ((procedure (select-procedure environment)))
-    (if (internal-lambda? (procedure-lambda procedure))
-	(procedure-environment procedure)
-	environment)))
-
-(define-integrable (select-extension environment)
-  (system-vector-ref environment 0))
-
-(define (select-procedure environment)
-  (let ((object (select-extension environment)))
-    (if (environment-extension? object)
-	(environment-extension-procedure object)
-	object)))
-
-(define (select-parent environment)
-  (procedure-environment (select-procedure environment)))
-
-(define (select-lambda environment)
-  (procedure-lambda (select-procedure environment)))
-
 (define (extend-ic-environment environment)
   (if (not (or (system-global-environment? environment)
 	       (ic-environment? environment)))
@@ -283,6 +319,35 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
      environment
      (make-syntax-table (environment-syntax-table environment)))
     environment))
+
+(define (ic-environment/lambda environment)
+  (procedure-lambda (ic-environment/procedure environment)))
+
+(define (ic-environment/procedure environment)
+  (let ((procedure (ic-frame-procedure* environment)))
+    (if (internal-lambda? (procedure-lambda procedure))
+	(ic-frame-procedure* (procedure-environment procedure))
+	procedure)))
+
+(define (ic-external-frame environment)
+  (let ((procedure (ic-frame-procedure* environment)))
+    (if (internal-lambda? (procedure-lambda procedure))
+	(procedure-environment procedure)
+	environment)))
+
+(define (ic-frame-procedure* environment)
+  (let ((procedure (ic-frame-procedure environment)))
+    (if (vector? procedure)
+	(vector-ref procedure 1)
+	procedure)))
+
+(define-integrable (ic-frame-procedure environment)
+  (system-vector-ref environment 0))
+
+(define-integrable (ic-frame-arg environment index)
+  (map-reference-trap-value
+   (lambda ()
+     (system-vector-ref environment index))))
 
 ;;;; Compiled Code Environments
 
diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm
index 6266dee7e..03404646f 100644
--- a/v7/src/runtime/urtrap.scm
+++ b/v7/src/runtime/urtrap.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: urtrap.scm,v 14.5 1999/01/02 06:19:10 cph Exp $
+$Id: urtrap.scm,v 14.6 2001/08/03 20:29:59 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Reference Traps
@@ -33,8 +34,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      (lambda (trap port)
 			(write-char #\space port)
 			(write (reference-trap-kind trap) port)))))
-  (kind false read-only true)
-  (extra false read-only true))
+  (kind #f read-only #t)
+  (extra #f read-only #t))
 
 (define-primitives
   primitive-object-type?
@@ -45,7 +46,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (primitive-object-type? (ucode-type reference-trap) (getter))
       (let ((index (object-datum (getter))))
 	(if (<= index trap-max-immediate)
-	    (make-reference-trap index false)
+	    (make-reference-trap index #f)
 	    (make-reference-trap (primitive-object-ref (getter) 0)
 				 (primitive-object-ref (getter) 1))))
       (getter)))
@@ -60,46 +61,54 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		 (reference-trap-extra trap))))
       trap))
 
-(define (reference-trap-kind-name kind)
-  (or (and (< kind (vector-length trap-kind-names))
-	   (vector-ref trap-kind-names kind))
-      'UNKNOWN))
+;;; The following must agree with the microcode.
+(define-integrable trap-max-immediate 9)
 
+(define (reference-trap-kind-name kind)
+  (case kind
+    ((0) 'UNASSIGNED)
+    ((2) 'UNBOUND)
+    ((6) 'EXPENSIVE)
+    ((14) 'COMPILER-CACHED)
+    (else #f)))
+
 (define (make-unassigned-reference-trap)
-  (make-reference-trap 0 false))
+  (make-reference-trap 0 #f))
 
 (define (unassigned-reference-trap? object)
   (and (reference-trap? object)
-       (memq (reference-trap-kind-name (reference-trap-kind object))
-	     '(UNASSIGNED UNASSIGNED-DANGEROUS))))
+       (fix:= 0 (reference-trap-kind object))))
+
+(define (unmapped-unassigned-reference-trap? getter)
+  (and (primitive-object-type? (ucode-type reference-trap) (getter))
+       (fix:= 0 (object-datum (getter)))))
 
 (define (make-unbound-reference-trap)
-  (make-reference-trap 2 false))
+  (make-reference-trap 2 #f))
 
 (define (unbound-reference-trap? object)
   (and (reference-trap? object)
-       (memq (reference-trap-kind-name (reference-trap-kind object))
-	     '(UNBOUND UNBOUND-DANGEROUS))))
-      
-;;; The following must agree with the microcode.
+       (fix:= 2 (reference-trap-kind object))))
 
-(define-integrable trap-max-immediate 9)
+(define (unmapped-unbound-reference-trap? getter)
+  (and (primitive-object-type? (ucode-type reference-trap) (getter))
+       (fix:= 2 (object-datum (getter)))))
 
-(define-integrable trap-kind-names
-  '#(UNASSIGNED				;0
-     UNASSIGNED-DANGEROUS		;1
-     UNBOUND				;2
-     UNBOUND-DANGEROUS			;3
-     ILLEGAL				;4
-     ILLEGAL-DANGEROUS			;5
-     #F					;6
-     #F					;7
-     #F					;8
-     #F					;9
-     NOP				;10
-     DANGEROUS				;11
-     FLUID				;12
-     FLUID-DANGEROUS			;13
-     COMPILER-CACHED			;14
-     COMPILER-CACHED-DANGEROUS		;15
-     ))
\ No newline at end of file
+(define (cached-reference-trap? object)
+  (and (reference-trap? object)
+       (fix:= 14 (reference-trap-kind object))))
+
+(define (cached-reference-trap-value trap)
+  (if (not (cached-reference-trap? trap))
+      (error:wrong-type-argument trap "cached reference trap"
+				 'CACHED-REFERENCE-TRAP-VALUE))
+  (map-reference-trap
+   (let ((cache (reference-trap-extra trap)))
+     (lambda ()
+       (primitive-object-ref cache 0)))))
+
+(define (map-reference-trap-value getter)
+  (let ((value (map-reference-trap getter)))
+    (if (cached-reference-trap? value)
+	(cached-reference-trap-value value)
+	value)))
\ No newline at end of file
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index b22be57a1..8bd0c8146 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: version.scm,v 14.198 2001/07/19 18:27:16 cph Exp $
+$Id: version.scm,v 14.199 2001/08/03 20:30:02 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (add-subsystem-identification! "Release" '(7 5 18 "pre"))
   (snarf-microcode-version!)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-subsystem-identification! "Runtime" '(14 189)))
+  (add-subsystem-identification! "Runtime" '(14 190)))
 
 (define (snarf-microcode-version!)
   (add-subsystem-identification! "Microcode"
-- 
2.25.1