From 2f8b94388ee7a940a311cea831f7bcdc79472686 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 9 Aug 2001 03:04:49 +0000 Subject: [PATCH] Replace usage of ENVIRONMENT-LINK-NAME with new LINK-VARIABLES. This change requires microcode 14.5 or later. --- v7/src/runtime/global.scm | 22 ++++++++++++++-------- v7/src/runtime/make.scm | 16 +++++++--------- v7/src/runtime/uerror.scm | 32 +++----------------------------- 3 files changed, 24 insertions(+), 46 deletions(-) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index f45e2a10d..0ad37fad0 100644 --- 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)) (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 c0e1427f1..00593bee0 100644 --- 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 b776caedb..661175387 100644 --- 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))))))) ;;;; Argument Errors -- 2.25.1