Implement EXTEND-IC-ENVIRONMENT.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index d11e92fae57d0d34290bbe808d7720773e9a9a76..cff452e014ee0932b681ee83ba6bba38c92d5dbe 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.331 1999/08/13 18:40:43 cph Exp $
+$Id: runtime.pkg,v 14.332 1999/10/23 03:01:46 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -664,6 +664,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
          environment-parent
          environment-procedure-name
          environment?
+         extend-ic-environment
          ic-environment?
          interpreter-environment?
          make-null-interpreter-environment

diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm
index 406d68e30b5590683ed0c686e5bdfeb36a43550e..c4ad415ef634db657e47af75c1f4e30cc2897b82 100644 (file)
--- a/v7/src/runtime/uenvir.scm
+++ b/v7/src/runtime/uenvir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.38 1999/01/02 06:06:43 cph Exp $
+$Id: uenvir.scm,v 14.39 1999/10/23 03:01:29 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -32,14 +32,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-has-parent? environment)
   (cond ((system-global-environment? environment)
-        false)
+        #f)
        ((ic-environment? environment)
         (ic-environment/has-parent? environment))
        ((stack-ccenv? environment)
         (stack-ccenv/has-parent? environment))
        ((closure-ccenv? environment)
         (closure-ccenv/has-parent? environment))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-HAS-PARENT?))))
 
 (define (environment-parent environment)
   (cond ((system-global-environment? environment)
@@ -50,7 +51,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (stack-ccenv/parent environment))
        ((closure-ccenv? environment)
         (closure-ccenv/parent environment))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-PARENT))))
 
 (define (environment-bound-names environment)
   (cond ((system-global-environment? environment)
@@ -61,7 +63,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (stack-ccenv/bound-names environment))
        ((closure-ccenv? environment)
         (closure-ccenv/bound-names environment))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES))))
 
 (define (environment-bindings environment)
   (map (lambda (name)
@@ -80,7 +83,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        ((or (system-global-environment? environment)
             (closure-ccenv? environment))
         'UNKNOWN)
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-ARGUMENTS))))
 
 (define (environment-procedure-name environment)
   (let ((scode-lambda (environment-lambda environment)))
@@ -89,14 +93,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-lambda environment)
   (cond ((system-global-environment? environment)
-        false)
+        #f)
        ((ic-environment? environment)
         (ic-environment/lambda environment))
        ((stack-ccenv? environment)
         (stack-ccenv/lambda environment))
        ((closure-ccenv? environment)
         (closure-ccenv/lambda environment))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-LAMBDA))))
 
 (define (environment-bound? environment name)
   (cond ((interpreter-environment? environment)
@@ -105,7 +110,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (stack-ccenv/bound? environment name))
        ((closure-ccenv? environment)
         (closure-ccenv/bound? environment name))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-BOUND?))))
 
 (define (environment-lookup environment name)
   (cond ((interpreter-environment? environment)
@@ -114,16 +120,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (stack-ccenv/lookup environment name))
        ((closure-ccenv? environment)
         (closure-ccenv/lookup environment name))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-LOOKUP))))
 
 (define (environment-assignable? environment name)
   (cond ((interpreter-environment? environment)
-        true)
+        #t)
        ((stack-ccenv? environment)
         (stack-ccenv/assignable? environment name))
        ((closure-ccenv? environment)
         (closure-ccenv/assignable? environment name))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?))))
 
 (define (environment-assign! environment name value)
   (cond ((interpreter-environment? environment)
@@ -132,7 +140,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (stack-ccenv/assign! environment name value))
        ((closure-ccenv? environment)
         (closure-ccenv/assign! environment name value))
-       (else (error "Illegal environment" environment))))
+       (else
+        (illegal-environment environment 'ENVIRONMENT-ASSIGN!))))
+
+(define (illegal-environment object procedure)
+  (error:wrong-type-argument object "environment" procedure))
 \f
 ;;;; Interpreter Environments
 
@@ -199,7 +211,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (unbound-name? environment name)
   (if (eq? name package-name-tag)
-      true
+      #t
       (lexical-unbound? environment name)))
 \f
 (define (ic-environment/arguments environment)
@@ -227,7 +239,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (ic-environment/remove-parent! environment)
   (ic-environment/set-parent! environment null-environment))
 
-
 ;;  This corresponds to the #defines in sdata.h
 
 (define null-environment
@@ -262,6 +273,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (select-lambda environment)
   (procedure-lambda (select-procedure environment)))
+
+(define (extend-ic-environment environment)
+  (if (not (ic-environment? environment))
+      (illegal-environment environment 'EXTEND-IC-ENVIRONMENT))
+  (let ((environment (eval '(let () (the-environment)) environment)))
+    (set-environment-syntax-table!
+     environment
+     (make-syntax-table (environment-syntax-table environment)))
+    environment))
 \f
 ;;;; Compiled Code Environments
 
@@ -270,9 +290,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                                ((ucode-primitive string->symbol)
                                 "#[(runtime environment)stack-ccenv]"))
                               (conc-name stack-ccenv/))
-  (block false read-only true)
-  (frame false read-only true)
-  (start-index false read-only true))
+  (block #f read-only #t)
+  (frame #f read-only #t)
+  (start-index #f read-only #t))
 
 (define (stack-frame/environment frame default)
   (let* ((ret-add (stack-frame/return-address frame))
@@ -343,7 +363,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 \f
 (define (stack-ccenv/has-parent? environment)
   (if (dbg-block/parent (stack-ccenv/block environment))
-      true
+      #t
       'SIMULATED))
 
 (define (stack-ccenv/parent environment)
@@ -530,9 +550,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                    ((ucode-primitive string->symbol)
                     "#[(runtime environment)closure-ccenv]"))
                   (conc-name closure-ccenv/))
-  (stack-block false read-only true)
-  (closure-block false read-only true)
-  (closure false read-only true))
+  (stack-block #f read-only #t)
+  (closure-block #f read-only #t)
+  (closure #f read-only #t))
 
 (define (closure-ccenv/bound-names environment)
   (map dbg-variable/name
@@ -594,8 +614,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (let ((parent (dbg-block/parent stack-block)))
          (and parent
               (case (dbg-block/type parent)
-                ((CLOSURE) (and (dbg-block/original-parent stack-block) true))
-                ((STACK IC) true)
+                ((CLOSURE) (and (dbg-block/original-parent stack-block) #t))
+                ((STACK IC) #t)
                 (else (error "Illegal parent block" parent))))))
       'SIMULATED))
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index aae7ea1b323783b9a155fac0052a2a5ff1954643..c3fc438d188eab40528b0ea8ba63df0a63408cb6 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.336 1999/08/13 18:40:39 cph Exp $
+$Id: runtime.pkg,v 14.337 1999/10/23 03:01:41 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -666,6 +666,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
          environment-parent
          environment-procedure-name
          environment?
+         extend-ic-environment
          ic-environment?
          interpreter-environment?
          make-null-interpreter-environment

diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm
index 73641e4b6107fecae619ab75f460fe44b4be69c7..44ccf2cbed42887d88cda1c312d26175af983d9c 100644 (file)
--- a/v8/src/runtime/uenvir.scm
+++ b/v8/src/runtime/uenvir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.41 1999/01/02 06:19:10 cph Exp $
+$Id: uenvir.scm,v 14.42 1999/10/23 03:01:24 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -31,7 +31,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-has-parent? environment)
   (cond ((system-global-environment? environment)
-        false)
+        #f)
        ((ic-environment? environment)
         (ic-environment/has-parent? environment))
        ((ccenv? environment)
@@ -81,7 +81,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-lambda environment)
   (cond ((system-global-environment? environment)
-        false)
+        #f)
        ((ic-environment? environment)
         (ic-environment/lambda environment))
        ((ccenv? environment)
@@ -104,7 +104,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (environment-assignable? environment name)
   (cond ((interpreter-environment? environment)
-        true)
+        #t)
        ((ccenv? environment)
         (ccenv/assignable? environment name))
        (else (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?))))
@@ -184,7 +184,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 \f
 (define (unbound-name? environment name)
   (if (eq? name package-name-tag)
-      true
+      #t
       (lexical-unbound? environment name)))
 
 (define (ic-environment/arguments environment)
@@ -212,7 +212,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (ic-environment/remove-parent! environment)
   (ic-environment/set-parent! environment null-environment))
 
-
 ;;  This corresponds to the `#define END_OF_CHAIN ...' in sdata.h
 
 (define null-environment
@@ -244,6 +243,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (select-lambda environment)
   (procedure-lambda (select-procedure environment)))
+
+(define (extend-ic-environment environment)
+  (if (not (ic-environment? environment))
+      (illegal-environment environment 'EXTEND-IC-ENVIRONMENT))
+  (let ((environment (eval '(let () (the-environment)) environment)))
+    (set-environment-syntax-table!
+     environment
+     (make-syntax-table (environment-syntax-table environment)))
+    environment))
 \f
 ;;;; Compiled Code Environments
 
@@ -254,10 +262,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     "#[(runtime environment)ccenv]"))
                   (conc-name ccenv/))
   ;; BLOCK is a block structure description (a DBG-BLOCK).
-  (block false read-only true)
+  (block #f read-only #t)
   ;; ROOT is the object from which to de-reference access paths, usually a
   ;; STACK-FRAME or a compiled closure.
-  (root  false read-only true))
+  (root #f read-only #t))
 
 (define (ccenv/has-parent? env)
   (let ((block  (ccenv/block env)))