microcode and a few minor bug fixes.
;;; -*-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
;;;
;;; 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
(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"))
(make-primitive-procedure 'ADD-FLUID-BINDING! true)
(make-primitive-procedure 'MAKE-FLUID-BINDING! true))
combination-second-operand)
+|#
\f
;;;; Application Errors
(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)
"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)
\f
;;;; 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)
(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)
\f
;;;; SCODE Syntax Errors
(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"
"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
;;; -*-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
;;;
(scode-quote #F)
system-global-environment)
(push-history! history)))))
- (thunk)))
+ (thunk)))
;;;; Primitive History Operations
;;; These operations mimic the actions of the microcode.
(car history))
;;; end HISTORY-PACKAGE.
+(the-environment)))
(the-environment)))
\ No newline at end of file
;;; -*-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
;;;
(define &subvector-to-list)
\f
(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))
;;; -*-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
;;;
;; ...
;; <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
(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.
))))
;;; end SYNTAXER-PACKAGE
+)
)
\ No newline at end of file
;;; -*-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
;;;
(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))))
\f
(set! full-quit
(named-lambda (full-quit)
false)
(else (beep) (query prompt)))))
+)
)
\ No newline at end of file
;;; -*-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
;;;
(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?
projects / mit-scheme.git / commitdiff