Replace usage of ENVIRONMENT-LINK-NAME with new LINK-VARIABLES.

This change requires microcode 14.5 or later.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index f45e2a10d0a103b2ac13cc1a0b99d72328e1fef6..0ad37fad01439373fd6b8b721f9b9c44dafb4a31 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.52 2000/01/10 03:35:47 cph Exp $
+$Id: global.scm,v 14.53 2001/08/09 03:04:44 cph Exp $
 
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-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.
 |#
 
 ;;;; Miscellaneous Global Definitions
@@ -225,11 +226,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define user-initial-prompt
   "]=>")
 
-(define (environment-link-name to from name)
-  ((ucode-primitive environment-link-name)
-   (->environment to)
-   (->environment from)
-   name))
+(define (link-variables target-environment target-name
+                       source-environment source-name)
+  ((ucode-primitive link-variables 4) (->environment target-environment)
+                                     target-name
+                                     (->environment source-environment)
+                                     source-name))
+
+(define (environment-link-name target-environment source-environment name)
+  ;; Obsolete; for backwards compatibility.
+  (link-variables target-environment name source-environment name))
 \f
 (define-integrable (object-non-pointer? object)
   (zero? (object-gc-type object)))

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index c0e1427f1873ffce2b50c3ab13aefad0845577ca..00593bee086acfe92ca8678c8fd1b3e9ea77043d 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.69 2001/05/22 03:09:52 cph Exp $
+$Id: make.scm,v 14.70 2001/08/09 03:04:46 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -87,7 +87,6 @@ USA.
   (< integer-less?)
   binary-fasload
   (channel-write 4)
-  environment-link-name
   exit-with-value
   (file-exists? 1)
   garbage-collect
@@ -97,6 +96,7 @@ USA.
   get-primitive-name
   lexical-reference
   lexical-unreferenceable?
+  (link-variables 4)
   microcode-identify
   scode-eval
   set-fixed-objects-vector!
@@ -312,11 +312,10 @@ USA.
              PACKAGE/SYSTEM-LOADER
              PACKAGE?
              SYSTEM-GLOBAL-PACKAGE)))
-  (if (not (null? names))
+  (if (pair? names)
       (begin
-       (environment-link-name system-global-environment
-                              environment-for-package
-                              (car names))
+       (link-variables system-global-environment (car names)
+                       environment-for-package (car names))
        (loop (cdr names)))))
 (package/add-child! system-global-package 'PACKAGE environment-for-package)
 (eval (fasload "runtime.bco" #f) system-global-environment)
@@ -495,9 +494,8 @@ USA.
   (if obj
       (eval obj system-global-environment)))
 
-(environment-link-name (->environment '(RUNTIME ENVIRONMENT))
-                      (->environment '(PACKAGE))
-                      'PACKAGE-NAME-TAG)
+(link-variables (->environment '(RUNTIME ENVIRONMENT)) 'PACKAGE-NAME-TAG
+               (->environment '(PACKAGE)) 'PACKAGE-NAME-TAG)
 
 (let ((roots
        (list->vector

diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm
index b776caedb1a646f6736aa8301c3dab5c7801d3b0..661175387d1dd301ed3540cb97cd2258fde5c6ff 100644 (file)
--- a/v7/src/runtime/uerror.scm
+++ b/v7/src/runtime/uerror.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uerror.scm,v 14.47 2001/03/21 19:15:22 cph Exp $
+$Id: uerror.scm,v 14.48 2001/08/09 03:04:49 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -493,15 +493,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
                   ((eq? (ucode-primitive lexical-assignment) operator)
                    (signal-other (apply-frame/operand frame 0)
                                  (apply-frame/operand frame 1)))
-                  ((eq? (ucode-primitive add-fluid-binding! 3) operator)
+                  ((eq? (ucode-primitive link-variables 4) operator)
                    (signal-other (apply-frame/operand frame 0)
-                                 (let ((name (apply-frame/operand frame 1)))
-                                   (if (variable? name)
-                                       (variable-name name)
-                                       name))))
-                  ((eq? (ucode-primitive environment-link-name) operator)
-                   (signal-other (apply-frame/operand frame 0)
-                                 (apply-frame/operand frame 2)))
+                                 (apply-frame/operand frame 1)))
                   ((eq? (ucode-primitive lexical-unassigned?) operator)
                    (signal-other (apply-frame/operand frame 0)
                                  (apply-frame/operand frame 1))))))
@@ -546,26 +540,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
            COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
           (signal (reference-trap-frame/environment frame)
                   (reference-trap-frame/name frame))))))))
-
-(set! condition-type:unlinkable-variable
-  (make-condition-type 'UNLINKABLE-VARIABLE condition-type:variable-error '()
-    (lambda (condition port)
-      (write-string "The variable " port)
-      (write (access-condition condition 'LOCATION) port)
-      (write-string " is already bound; it cannot be linked to." port))))
-
-(define-error-handler 'BAD-ASSIGNMENT
-  (let ((signal
-        (condition-signaller condition-type:unlinkable-variable
-                             '(ENVIRONMENT LOCATION))))
-    (lambda (continuation)
-      (let ((frame (continuation/first-subproblem continuation)))
-       (if (and (apply-frame? frame)
-                (eq? (ucode-primitive environment-link-name)
-                     (apply-frame/operator frame)))
-           (signal continuation
-                   (apply-frame/operand frame 0)
-                   (apply-frame/operand frame 2)))))))
 \f
 ;;;; Argument Errors