From bf6ef5f1e2e82bd605cbe127312ba967c44c45c3 Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Tue, 3 May 1988 19:04:42 +0000
Subject: [PATCH] Fix paranoia bug in list.scm (map, map*, and for-each were
 not paranoid enough).

Add error handlers for environment-link-name.
---
 v7/src/runtime/boot.scm  | 45 +++++++++++++++++++++++++++++-----------
 v7/src/runtime/error.scm | 33 ++++++++++++++++++++++-------
 2 files changed, 59 insertions(+), 19 deletions(-)

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 6969d70e2..ac52dcadb 100644
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.45 1988/04/12 14:59:27 jinx Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.46 1988/05/03 19:04:10 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1988 Massachusetts Institute of Technology
 ;;;
@@ -149,16 +149,37 @@
 (define (copy-program exp)
   (if (not (primitive-type? (ucode-type COMPILED-ENTRY) exp))
       (error "copy-program: Can only copy compiled programs" exp))
-  (let ((v (vector-copy
-	    (primitive-set-type
-	     (ucode-type VECTOR)
-	     (compiled-code-address->block exp)))))
-    (with-interrupt-mask
-     interrupt-mask-none
-     (lambda (old)
-       old ;; ignored
-       (primitive-object-set-type
-	(ucode-type COMPILED-ENTRY)
-	(+ (compiled-code-address->offset exp) (primitive-datum v)))))))
+  (let* ((original (compiled-code-address->block exp))
+	 (block (primitive-set-type
+		 (ucode-type COMPILED-CODE-BLOCK)
+		 (vector-copy
+		  (primitive-set-type (ucode-type VECTOR)
+				      original))))
+	 (end (system-vector-size block)))
+
+    (define (map-entry entry)
+      (with-interrupt-mask
+       interrupt-mask-none
+       (lambda (old)
+	 old ;; ignored
+	 (primitive-object-set-type
+	  (primitive-type entry)
+	  (+ (compiled-code-address->offset entry)
+	     (primitive-datum block))))))
+
+    (let loop ((n (1+ (primitive-datum (system-vector-ref block 0)))))
+      (cond ((>= n end)
+	     (map-entry exp))
+	    ((not (lambda? (system-vector-ref block n)))
+	     (loop (1+ n)))
+	    (else
+	     (lambda-components (system-vector-ref block n)
+	       (lambda (name req opt rest aux decl body)
+		 (if (and (primitive-type? (ucode-type COMPILED-ENTRY) body)
+			  (eq? original (compiled-code-address->block body)))
+		     (system-vector-set! block n
+		      (make-lambda name req opt rest aux decl
+				   (map-entry body))))
+		 (loop (1+ n)))))))))
 
 ) ;; End of let-syntax
\ No newline at end of file
diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index ec09031b3..e56142a40 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.50 1988/02/10 17:24:43 jinx Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.51 1988/05/03 19:04:42 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -344,6 +344,10 @@ using the current read-eval-print environment."))
 	(make-primitive-procedure 'LEXICAL-ASSIGNMENT 3))
   combination-second-operand)
 
+(define-unbound-variable-error
+  (list (make-primitive-procedure 'ENVIRONMENT-LINK-NAME 3))
+  combination-third-operand)
+
 (define-unbound-variable-error
   (list (make-primitive-procedure 'ADD-FLUID-BINDING! 3))
   (lambda (obj)
@@ -484,6 +488,11 @@ using the current read-eval-print environment."))
   "Too many open files"
   combination-first-operand)
 
+(define-operation-specific-error 'BAD-ASSIGNMENT
+  (list (make-primitive-procedure 'ENVIRONMENT-LINK-NAME 3))
+  "Bound variable"
+  combination-third-operand)
+
 ;;; SCODE Syntax Errors
 
 ;;; This error gets an unevaluated combination, but it doesn't ever
@@ -510,12 +519,6 @@ using the current read-eval-print environment."))
 (define-default-error 'EXECUTE-MANIFEST-VECTOR
   "Attempt to execute Manifest Vector -- get a wizard"
   identity-procedure)
-
-(define-total-error-handler 'WRITE-INTO-PURE-SPACE
-  (lambda (error-code expression)
-    (newline)
-    (write-string "Automagically IMPURIFYing an object....")
-    (impurify (combination-first-operand expression))))
  
 (define-default-error 'UNDEFINED-USER-TYPE
   "Undefined Type Code -- get a wizard"
@@ -529,9 +532,25 @@ using the current read-eval-print environment."))
   "Compiled code error -- get a wizard"
   identity-procedure)
 
+(define-default-error 'ILLEGAL-REFERENCE-TRAP
+  "Illegal reference trap -- get a wizard"
+  identity-procedure)
+
+(define-default-error 'BROKEN-VARIABLE-CACHE
+  "Broken variable value cell"
+  identity-procedure)
+
+;;;; Harmless system errors
+
 (define-default-error 'FLOATING-OVERFLOW
   "Floating point overflow"
   identity-procedure)
 
+(define-total-error-handler 'WRITE-INTO-PURE-SPACE
+  (lambda (error-code expression)
+    (newline)
+    (write-string "Automagically IMPURIFYing an object....")
+    (impurify (combination-first-operand expression))))
+
 ;;; end ERROR-SYSTEM package.
 ))
\ No newline at end of file
-- 
2.25.1