Fix paranoia bug in list.scm (map, map*, and for-each were not

paranoid enough).

Add error handlers for environment-link-name.

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 6969d70e2e26cfd7256ef198a050b2a28147c70c..ac52dcadbd3a51cc0c0afc2de543400efc5c112d 100644 (file)
--- 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 ec09031b3dbe65df348ba15133a91ca503982db3..e56142a40319058a249964bc654e1cb168d43ea5 100644 (file)
--- 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)
+\f
+;;;; 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