From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Fri, 3 Apr 1987 00:53:27 +0000 (+0000)
Subject: Changes to match the rewrite of the variable lookup code in the
X-Git-Tag: 20090517-FFI~13651
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=47229c38c52d8b228f2c00669425892abff049ef;p=mit-scheme.git

Changes to match the rewrite of the variable lookup code in the
microcode and a few minor bug fixes.
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 38cd8c633..ddd9be876 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.44 1987/03/17 18:49:27 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.45 1987/04/03 00:51:34 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -196,8 +196,17 @@ using the current read-eval-print environment."))
 
 ;;; Initialize the error vector to the default state:
 
+(define (error-code-or-name code)
+  (let ((v (vector-ref (get-fixed-objects-vector)
+		       (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))))
+    (if (or (>= code (vector-length v))
+	    (null? (vector-ref v code)))
+	code
+	(vector-ref v code))))	
+
 (define (default-error-handler expression)
-  (start-error-rep "Anomalous error -- get a wizard" *error-code*))
+  (start-error-rep "Anomalous error -- get a wizard"
+		   (error-code-or-name *error-code*)))
 
 (define system-error-vector
   (make-initialized-vector number-of-microcode-errors
@@ -352,6 +361,7 @@ using the current read-eval-print environment."))
 (define-bad-frame-error access? access-environment)
 (define-bad-frame-error in-package? in-package-environment)
 
+#|
 (define define-assignment-to-procedure-error
   (define-specific-error 'ASSIGN-LAMBDA-NAME
     "Attempt to assign procedure's name"))
@@ -364,6 +374,7 @@ using the current read-eval-print environment."))
 	(make-primitive-procedure 'ADD-FLUID-BINDING! true)
 	(make-primitive-procedure 'MAKE-FLUID-BINDING! true))
   combination-second-operand)
+|#
 
 ;;;; Application Errors
 
@@ -373,6 +384,9 @@ using the current read-eval-print environment."))
 (define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION
   "Undefined Primitive Procedure")
 
+(define-operator-error 'UNIMPLEMENTED-PRIMITIVE
+  "Unimplemented Primitive Procedure")
+
 (define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS
   "Wrong Number of Arguments"
   (lambda (combination)
@@ -401,18 +415,24 @@ using the current read-eval-print environment."))
 	"ninth" (lambda (list) (general-car-cdr list #x1400)))
   (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9
 	"tenth" (lambda (list) (general-car-cdr list #x3000))))
+
+(define-operand-error 'FAILED-ARG-1-COERCION
+  "Argument 1 cannot be coerced to floating point"
+  combination-first-operand)
+
+(define-operand-error 'FAILED-ARG-2-COERCION
+  "Argument 2 cannot be coerced to floating point"
+  combination-second-operand)
 
 ;;;; Primitive Operator Errors
 
 (define-operation-specific-error 'FASL-FILE-TOO-BIG
-  (list (make-primitive-procedure 'PRIMITIVE-FASLOAD)
-	(make-primitive-procedure 'BINARY-FASLOAD))
+  (list (make-primitive-procedure 'BINARY-FASLOAD))
   "Not enough room to Fasload"
   combination-first-operand)
 
 (define-operation-specific-error 'FASL-FILE-BAD-DATA
-  (list (make-primitive-procedure 'PRIMITIVE-FASLOAD)
-	(make-primitive-procedure 'BINARY-FASLOAD))
+  (list (make-primitive-procedure 'BINARY-FASLOAD))
   "Fasload file would not relocate correctly"
   combination-first-operand)
 
@@ -433,6 +453,11 @@ using the current read-eval-print environment."))
   (list (make-primitive-procedure 'FILE-OPEN-CHANNEL))
   "Unable to open file"
   combination-first-operand)
+
+(define-operation-specific-error 'OUT-OF-FILE-HANDLES
+  (list (make-primitive-procedure 'FILE-OPEN-CHANNEL))
+  "Too many open files"
+  combination-first-operand)
 
 ;;;; SCODE Syntax Errors
 
@@ -450,7 +475,8 @@ using the current read-eval-print environment."))
 
 (define-total-error-handler 'BAD-ERROR-CODE
   (lambda (error-code)
-    (start-error-rep "Bad Error Code -- get a wizard" error-code)))
+    (start-error-rep "Bad Error Code -- get a wizard"
+		     (error-code-or-name error-code))))
 
 (define-default-error 'BAD-INTERRUPT-CODE
   "Illegal Interrupt Code -- get a wizard"
@@ -471,5 +497,18 @@ using the current read-eval-print environment."))
   "Undefined Type Code -- get a wizard"
   identity-procedure)
 
+(define-default-error 'INAPPLICABLE-CONTINUATION
+  "Inapplicable continuation -- get a wizard"
+  identity-procedure)
+
+(define-default-error 'COMPILED-CODE-ERROR
+  "Compiled code error -- get a wizard"
+  identity-procedure)
+
+(define-default-error 'FLOATING-OVERFLOW
+  "Floating point overflow"
+  identity-procedure)
+
 ;;; end ERROR-SYSTEM package.
+))
 ))
\ No newline at end of file
diff --git a/v7/src/runtime/histry.scm b/v7/src/runtime/histry.scm
index 9d7be55ab..b4c1a3d13 100644
--- a/v7/src/runtime/histry.scm
+++ b/v7/src/runtime/histry.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.43 1987/03/17 18:50:22 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.44 1987/04/03 00:51:49 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -167,7 +167,7 @@
 					   (scode-quote #F)
 					   system-global-environment)
 	    (push-history! history)))))
-	(thunk)))
+    (thunk)))
 
 ;;;; Primitive History Operations
 ;;;  These operations mimic the actions of the microcode.
@@ -247,4 +247,5 @@
   (car history))
 
 ;;; end HISTORY-PACKAGE.
+(the-environment)))
 (the-environment)))
\ No newline at end of file
diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm
index 5c318fd1d..b0e1d36af 100644
--- a/v7/src/runtime/sdata.scm
+++ b/v7/src/runtime/sdata.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.41 1987/01/23 00:19:30 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.42 1987/04/03 00:52:12 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -73,19 +73,23 @@
 (define &subvector-to-list)
 
 (let ((&unbound-object '(&UNBOUND-OBJECT))
+      (&unbound-datum 2)
       (&unassigned-object '(&UNASSIGNED-OBJECT))
+      (&unassigned-datum 0)
       (&unassigned-type (microcode-type 'UNASSIGNED))
+      (&make-object (make-primitive-procedure '&MAKE-OBJECT))
       (hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
 
   (define (map-unassigned object)
-    (if (eq? object &unbound-object)
-	(primitive-set-type &unassigned-type 1)
-	(if (eq? object &unassigned-object)
-	    (primitive-set-type &unassigned-type 0)
-	    object)))
+    (cond ((eq? object &unbound-object)
+	   (&make-object &unassigned-type &unbound-datum))
+	  ((eq? object &unassigned-object)
+	   (&make-object &unassigned-type &unassigned-datum))
+	  (else object)))
 
+  ;; This is no longer really right, given the other traps.
   (define (map-from-unassigned datum)
-    (if (eq? datum 0)					;**** cheat for speed.
+    (if (eq? datum &unassigned-datum)				;**** cheat for speed.
 	&unassigned-object
 	&unbound-object))
 
diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index 03009167b..c37fcef09 100644
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.43 1987/03/17 18:53:27 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.44 1987/04/03 00:52:43 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -614,7 +614,7 @@
   ;;        ...
   ;;        <body>))
   (let ((with-saved-fluid-bindings
-	 (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS)))
+	 (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS #t)))
     (spread-arguments
      (lambda (bindings . body)
        (syntax-fluid-bindings bindings
@@ -666,12 +666,12 @@
 	       (syntax-error "Binding not a pair" binding)))))))
 
 (set! syntax-FLUID-LET-form-deep
-      (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING!)
+      (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! #t)
 		      lambda-tag:deep-fluid-let))
 
 (set! syntax-FLUID-LET-form-common-lisp
       ;; This -- groan -- is for Common Lisp support
-      (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING!)
+      (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! #t)
 		      lambda-tag:common-lisp-fluid-let))
 
 ;;; end special FLUID-LETs.
@@ -1011,4 +1011,5 @@
 	       ))))
 
 ;;; end SYNTAXER-PACKAGE
+)
 )
\ No newline at end of file
diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm
index a13d04e8a..e44244a78 100644
--- a/v7/src/runtime/system.scm
+++ b/v7/src/runtime/system.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.43 1987/03/17 18:53:48 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.44 1987/04/03 00:53:06 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -128,6 +128,13 @@
 				    (home-directory-pathname))))))
 	 (if (not (null? file))
 	     (load file user-initial-environment))))))
+
+;; This is not the right place for this, but I don't know what is.
+
+(add-event-receiver!
+ event:after-restore
+ (lambda ()
+   ((access reset! continuation-package))))
 
 (set! full-quit
 (named-lambda (full-quit)
@@ -270,4 +277,5 @@
 	   false)
 	  (else (beep) (query prompt)))))
 
+)
 )
\ No newline at end of file
diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm
index 7fa53fec1..d787deb36 100644
--- a/v7/src/runtime/utabs.scm
+++ b/v7/src/runtime/utabs.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.42 1987/03/09 15:00:25 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.43 1987/04/03 00:53:27 jinx Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -234,7 +234,7 @@
   (let ((code (name->code primitives-slot 'PRIMITIVE name)))
     (if code
 	(map-code-to-machine-address primitive-type-code code)
-	(or (get-external-number name force?)
+	(or (get-external-number name (if (unassigned? force?) #f force?))
 	    (error "Unknown name" make-primitive-procedure name))))))
 
 (set! implemented-primitive-procedure?