;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Error handling functions for Spice Lisp.
;;; these functions are part of the standard Spice Lisp environment.
;;;
;;; Written by Jim Large
;;; changes made by David McDonald and Walter van Roggen
;;;
;;; **********************************************************************
(proclaim '(ignore ignore))
;;; Condition-handler-bindings is the binding stack which associates condition
;;; names with handler functions. It is a list of forms
;;; (condition-name . handler-function) where condition name is a symbol, and
;;; handler-function is a function object.
(defvar condition-handler-bindings ()
"The binding stack where condition handlers are stored.")
;;; *Error-output* is the stream object which error messages are sent to.
(proclaim '(special *error-output*))
;;; (DILL 7/28/82) -- I put these in to make this compile with the
;;; new XC.
(proclaim '(special *query-io* *trace-output* *terminal-io*
*standard-output* *standard-input*))
;;; Break Loop
;;; All calls to this function should be through the break macro which is in
;;; Error-macros.slisp, and is known to the compiler.
;;;
;;; The first thing internal-break-loop does is evaluate the forms in
;;; *error-cleanup-forms* for side effects. *error-cleanup-forms* is bound
;;; to nil while this happens to prevent disaster.
;;;
;;; Then, we enter an REP loop which is like the top level loop except that
;;; the standard streams are rebound to *terminal-io*,
;;; + ++ & friends are bound to their present values,
;;; *evalhook is BOUND to (),
;;; *error-cleanup-forms* is bound to (),
;;; A handler that throws back to the break loop is bound for all errors,
;;; The symbols '$P and '$G and the form '(RETURN <form>) are all treated
;;; specialy if they are typed in.
(defvar *error-cleanup-forms* ()
"A list of forms which will be evaluated for side effect when break is called.")
(defvar *break-prompt* "> " "Prompt string used in breakpoint loops.")
(proclaim '(special break-level))
(proclaim '(special - + ++ +++ * ** *** / // ///))
(proclaim '(special *evalhook*))
(defun internal-break-loop ()
"Break loop. But you should be using the Break function"
(do ((*error-cleanup-forms* ())
(e-forms *error-cleanup-forms* (cdr e-forms)))
((atom e-forms))
(eval (car e-forms)))
(clear-input *terminal-io*)
(condition-bind ((() #'break-condition-handler))
(prog (This-Eval
(*standard-input* *terminal-io*)
(*standard-output* *terminal-io*)
(*error-output* *terminal-io*)
(*query-io* *terminal-io*)
(*trace-output* *terminal-io*)
(* *) (** **) (*** ***)
(+ +) (++ ++) (+++ +++)
(/ /) (// //) (/// ///)
(*evalhook* ())
(*Error-cleanup-forms* ())
(break-level (if (and (boundp 'break-level)
(numberp break-level))
(1+ break-level)
1)))
LOOP
(terpri)
(princ break-level)
(princ *break-prompt*)
(catch 'break-loop-catcher
(setq +++ ++ ++ + + - - (Read))
(cond ((and (consp -) (Eq (car -) 'Return))
(return (eval (cadr -))))
;; These guys are escapes, not real $igns.
;; but for VAX, accept dollars too (2nd case) %%%
((memq - '(G $G)) (throw 'top-level-catcher ()))
((memq - '(P $P)) (return ()))
(T (setq This-Eval (multiple-value-list (eval -)))
(Dolist (x this-eval) (print x))
(setq /// // // / / this-eval)
(setq *** ** ** * * (car This-Eval))))
)
(go loop))))
;;; Macros used by ferror & friends
;;; Find-name returns the name of a function if it is a subr or named-lambda.
;;; If the function is a regular lambda, the whole list is returned, and if
;;; the function can't be recognized, () is returned.
(defun find-name (function)
(cond ((compiled-function-p function)
(%primitive header-ref function %function-name-slot))
((not (consp function)) ())
((eq (car function) 'Named-Lambda) (nth 1 function))
((eq (car function) 'Lambda) function)
(T ())))
;;; Get-caller returns a form that returns the function which called the
;;; currently active function.
(defmacro get-caller ()
'(read-cstack
(%sp-make-fixnum
(read-cstack (%sp-make-fixnum (%sp-current-stack-frame))
%frame-prev-active-slot))
%frame-func-slot))
;;; Error-error can be called when the error system is in trouble and needs
;;; to punt fast. Prints a message without using format. If we get into
;;; this recursively, then halt.
(defvar %error-error-depth% 0)
(defun error-error (&rest messages)
(prog ((%error-error-depth% (1+ %error-error-depth%)))
(when (> %error-error-depth% 3)
(%sp-halt)
(throw 'TOP-LEVEL-CATCHER ()))
(dolist (item messages) (princ item *terminal-io*))
REPEAT
(internal-break-loop)
(princ "Can't Proceed.")
(go REPEAT)))
;;; infinite error protect is used by ferror & friends to keep lisp
;;; out of hyperspace.
(defvar *max-error-depth* 3 "The maximum number of nested errors allowed.")
(defvar *current-error-depth* 0 "The current number of nested errors.")
(defmacro infinite-error-protect (&rest forms)
`(let ((*current-error-depth* (1+ *current-error-depth*)))
(if (> *current-error-depth* *max-error-depth*)
(error-error "Help! " *current-error-depth* " nested errors.")
,@forms)))
;;; Signal
;;; (Signal condition-name args) searches for a handler which will handle
;;; the condition condition-name. Searches down the condition-handler-
;;; bindings list for the first handler which is bound to condition-name,
;;; and which will accept the call. If none accept, return ().
;;;
;;; Handler is queried by calling it with all of the args to signal. If it
;;; returns nil, then it refuses. Otherwise signal returns all of the
;;; values returned by the handler.
;;;
;;; Condition-handler-bindings is a list of forms (name . function).
;;;
;;; Any handler for the condition () will be offered the chance to handle
;;; any condition. This feature is not part of common-lisp, but is useful
;;; for the break loop which wants to catch all errors.
(defun signal (condition-name &rest args)
"Finds a handler for condition-name, and calls it with same args as signal"
;;cdr down the list. if we reach the end, return ().
(do* ((bind-list condition-handler-bindings (cdr bind-list))
(binding (car bind-list) (car bind-list)))
((null bind-list) ())
;;for each binding of the right condition, query & return values if win.
(when (or (null (car binding)) ;or the null condition.
(eq (car binding) condition-name))
(let ((result (multiple-value-list
(apply (cdr binding) condition-name args))))
(if (car result) (return (values-list result)))
))
))
;;; Do-Failed-Handler
;;; Do-failed-handler is called by error, ferror, and %sp-internal-error
;;; whenever a handler attempts to correct an uncorrectable error, or by
;;; cerror whenever the handler returns something other than :return.
;;; The args to do-failed-handler are exactly the args that were given to
;;; the handler which failed, except that ARGS is not a rest arg.
;;;
;;; The control string we pass to the :failed-handler handler is pretty
;;; hairy. There are three cases of it so that the result will look
;;; like the thing that signaled the error.
(defconstant error-style-failure-string
"A handler for, ~s, tried to correct the uncorrectable error,~%~
(error ~3g~@{ ~s~}),~%~
which was originaly signaled in the function, ~2g~s.~%")
(defconstant cerror-style-failure-string
"A handler for, ~s, failed to return, :return, while correcting the error,~%~
(cerror ~0g~s~3g~@{ ~s~}),~%~
which was originaly signaled in the function, ~2g~s.~%")
(defun do-failed-handler (condition correctablep callers-name
control-string args)
(apply #'error
(cond (correctablep cerror-style-failure-string)
(t error-style-failure-string))
condition
()
callers-name
control-string
args))
;;; %sp-internal-error
;;; %SP-internal-error is called by the microcode when an internal error
;;; occurrs. It is simply a dispatch routine which looks up a specialized
;;; function to call in the special variable, internal-error-table.
;;;
;;; Internal-error-table contains a vector, by error code, of functions which
;;; take the caller's name, PC, ARG3, and ARG4 as arguments. It is set up at
;;; system init time by the function internal-error-init.
;;;
;;; ERR-CODE -- a fixnum which identifies the specific error.
;;; PC -- the relative offset of the NEXT macro instruction to be
;;; executed in the code vector of the errorful function.
;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.
(proclaim '(special internal-error-table))
(defun %SP-internal-error (err-code PC &optional arg3 arg4)
(infinite-error-protect
(%sp-escape-return
(funcall (%sp-v-access internal-error-table err-code)
(find-name (get-caller))
PC
arg3
arg4))))
;;; Ferror (obsolete) & Error
;;; Error-body does the work of signaling a fatal error. It is called from
;;; ERROR, and %SP-INTERNAL-ERROR. It never returns.
;;;
;;; CALLERS-NAME -- Name of user function that raised the error
;;; CONDITION -- Name of condition to signal.
;;; CONTROL-STRING -- format control string.
;;; ARGS -- args for control-string.
(defun error-body (callers-name condition control-string args)
(if (apply #'signal
condition
() ;null continue-string means not correctable error.
callers-name
control-string
args)
(do-failed-handler condition () callers-name control-string args)
(if (eq condition :error)
(error-error "No handler for condition, :error.")
(error-body callers-name :error control-string args))))
;;; The common lisp ERROR function.
(defun error (control-string &rest args)
"Signals a fatal error. Control-string & args are formatted to *error-output*."
(infinite-error-protect
(error-body (find-name (get-caller)) ':error control-string args)))
;;; Cerror
(defun cerror (continue-format-string error-format-string &rest args)
"Signals a continuable error. See manual for details."
(infinite-error-protect
(let ((callers-name (find-name (get-caller))))
(cerror-body callers-name
:error
error-format-string
continue-format-string
args))))
;;; Cerror-body is an internal version of cerror which is called by CERROR,
;;; and %sp-internal-error.
(defun cerror-body (callers-name condition error-string continue-string args)
(let ((result (multiple-value-list
(apply #'signal
condition
continue-string
callers-name
error-string
args))))
(cond ((null (car result))
(if (eq condition :error)
(error-error "No handler for condition, :error.")
(cerror-body callers-name :error "Baz?" continue-string args)))
((eq (car result) ':return)
(values-list (cdr result)))
(T (do-failed-handler condition 'T callers-name continue-string args))
)))
;;; Warn & Break
(defvar *break-on-warnings* ()
"If non-NIL, then WARN will enter a break loop before returning.")
(defun warn (format-string &rest args)
"Formats format-string & args to *error-output* as a warning message."
(format *error-output*
(if *break-on-warnings*
"~%Warning-breakpoint in function ~s:~%"
"~%Warning in function ~s:~%")
(find-name (get-caller)))
(apply #'format *error-output*
format-string
args)
(when *break-on-warnings* (internal-break-loop))
())
(defun break (&optional format-string &rest args)
"Formats format-string & args to *error-output & then enters break loop."
(cond (format-string
(format *error-output* "~%Breakpoint:~%")
(apply #'format *error-output*
format-string
args))
(T (format *error-output* "~%Breakpoint")))
(internal-break-loop))
;;; Internal-error-table
;;; This function is called at init time to make the internal error table.
;;; max-internal-error is defined in the init file. The errors defined here
;;; are common to both spice lisp and vax lisp. Those errors which are
;;; implementation specific are def-internal-errored in the init file.
(proclaim '(special allocation-space))
(defun make-error-table ()
(setq internal-error-table
(make-vector (1+ max-internal-error)
:initial-element
#'(lambda (&rest ignore) (break "Undefined Error."))))
(def-internal-error 1 () system-error "Control Stack Overflow")
(def-internal-error 2 () system-error "Control Stack Underflow")
(def-internal-error 3 () system-error "Binding Stack Overflow")
(def-internal-error 4 () system-error "Binding Stack Underflow")
(def-internal-error 5 () system-error "Virtual Memory Overflow")
(def-internal-error 8 () system-error "Illegal Effective Address")
(def-internal-error 32 () system-error "Illegal Instruction")
(def-internal-error 33 () system-error "Illegal Misc OP")
(def-internal-error 42 () system-error "Null Open Frame" )
(def-internal-error 43 () system-error "Undefined Type Code")
(def-internal-error 44 () system-error "Return From Initial Function")
(def-internal-error 45 () system-error "GC Forward Not To Newspace")
(def-internal-error 46 () system-error "Attempt to Transport GC Forward")
(def-internal-error 6 :unbound-variable fatal
"Unbound symbol: ~s." arg3)
(def-internal-error 7 :undefined-function fatal
"Undefined function: ~s." arg3)
(def-internal-error 12 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'character)
(def-internal-error 13 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'System-Area-Pointer)
(def-internal-error 14 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Control-Stack-Pointer)
(def-internal-error 15 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Binding-Stack-Pointer)
(def-internal-error 16 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Values-Marker)
(def-internal-error 17 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Fixnum)
(def-internal-error 18 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like)
(def-internal-error 19 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like)
(def-internal-error 20 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol)
(def-internal-error 21 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Cons)
(def-internal-error 22 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'List)
(def-internal-error 23 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'String)
(def-internal-error 24 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Number)
(def-internal-error 25 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Misc-Type)
(def-internal-error 26 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'U-Vector)
(def-internal-error 47 :wrong-type-argument fatal
"Wrong type argument, ~s, should be of type ~s." arg3 'integer)
;;Special because handlers won't work while allocation-space is wrong.
(%sp-v-store internal-error-table
27
#'(lambda (callers-name ignore ignore ignore)
(let ((bazfaz allocation-space))
(setq allocation-space 0)
(error-body callers-name
:error
"Illegal allocation-space value: ~s."
(list bazfaz)))))
(def-internal-error 9 :error fatal
"Attempt to alter T or NIL.")
(def-internal-error 11 :error fatal
"Attempt to write to read only space. " )
(def-internal-error 28 :error fatal
"Illegal to allocate vector of size: ~s." arg3)
(def-internal-error 29 :error fatal
"Illegal immediate type code: ~s." arg3)
(def-internal-error 30 :error fatal
"Illegal control stack pointer: ~s." arg3)
(def-internal-error 31 :error fatal
"Illegal binding stack pointer: ~s." arg3)
(def-internal-error 34 :error fatal
"Attempt to divide ~s by ~s." arg4 arg3)
(def-internal-error 35 :error fatal
"Illegal u-vector access type: ~s." arg3)
(def-internal-error 36 :error fatal
"Vector index, ~s, out of bounds." arg3)
(def-internal-error 37 :error fatal
"Illegal byte pointer: (byte ~s ~s)." arg3 arg4)
(def-internal-error 38 :invalid-function fatal
"Invalid function: ~s." arg3)
(def-internal-error 39 :too-few-arguments fatal
"Too few arguments, ~s, for function, ~s." arg3 arg4)
(def-internal-error 40 :too-many-arguments fatal
"Too many arguments, ~s, for function, ~s." arg3 arg4)
(def-internal-error 41 :unseen-throw-tag fatal
"No catcher for throw tag ~s." arg3)
(def-internal-error 48 :error fatal
"Something using ~S and ~S lead to a short-float underflow." arg3 arg4)
(def-internal-error 49 :error fatal
"Something using ~S and ~S lead to a short-float overflow." arg3 arg4)
(def-internal-error 50 :error fatal
"Something using ~S and ~S lead to a long-float underflow." arg3 arg4)
(def-internal-error 51 :error fatal
"Something using ~S and ~S lead to a long-float overflow." arg3 arg4)
(def-internal-error 52 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'Flonum)
(def-internal-error 62 :wrong-type-argument fatal
"Wrong type argument, ~S, should have been a non-negative fixnum." arg3)
(def-internal-error 63 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
(def-internal-error 53 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
(def-internal-error 54 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been of type ~s." arg3 'integer-vector)
(def-internal-error 55 :wrong-type-argument fatal
"Wrong type argument, ~s, should have been a function or an array." arg3)
(def-internal-error 56 :error fatal
"The vectors ~S and ~S are not of the same length." arg3 arg4)
(def-internal-error 57 :error fatal
"The array ~S is not one dimensional." arg3)
(def-internal-error 58 :error fatal
"~S is not a stringlike thing." arg3)
(def-internal-error 59 :error fatal
"~S is not a rational number." arg3)
(def-internal-error 60 :error fatal
"BLT too hairy!")
(def-internal-error 61 :error fatal
"Attempt to execute a silly instruction."))
;;; Error-Init
;;; Error-init is called at init time to initialize the error system.
;;; it initializes the internal error table, and condition-psetq's the
;;; error conditions which should always be present in the system.
;;;
;;; Only those error conditions which are common to both vax lisp and
;;; spice lisp are condition-psetq'd here. Implementation specific
;;; conditions are done in the init file.
(defun error-init ()
(make-error-table)
(setq condition-handler-bindings ()) ;make sure it is empty.
(condition-psetq
:error #'default-condition-handler
:unbound-variable #'default-unbound-variable-handler
:undefined-function #'default-undefined-function-handler
))
;;; macros used by error handlers
;;; dont-proceed is the standard way to drop the user into a break loop
;;; when we are handling a fatal error.
(defmacro dont-proceed ()
'(prog ()
foo
(internal-break-loop)
(warn "The current error is not correctable.")
(go foo)))
;;; Error-Print formats an error message in the standard way.
(defun error-print (message args function continue-string)
(format *error-output* "~%Error in function ~s.~%" function)
(apply #'format *error-output* message args)
(when continue-string
(format *error-output* "~%If continued: ")
(apply #'format *error-output* continue-string args)))
;;; Default-Condition-Handler & Break-Condition-Handler
;;; Default-condition-handler handles most of the conditions which are defined
;;; in the Spice Lisp environment. The handler prints a message, and enters
;;; a break loop. A default message is provided for each condition which
;;; this handler will accept.
(defun default-condition-handler
(ignore continue-string function-name error-string &rest args)
(error-print error-string args function-name continue-string)
(if continue-string
(values ':return (internal-break-loop))
(dont-proceed))
)
;;; Break-condition-handler is a generic handler which will print a message,
;;; and then punt back to the most recent break loop. Break binds this to
;;; unimportant conditions.
(defun break-condition-handler
(ignore ignore ignore error-string &rest args)
(apply #'format
*error-output*
error-string
args)
(princ "
Error flushed.
" *error-output*)
(throw 'break-loop-catcher ())
)
;;; Default-Undefined-Function-Handler
;;; Default-undefined-function-handler is a handler for the :undefined-function
;;; condition. If the error is signaled correctably, then the correction
;;; value is obtained by forcing the user to define the function in a
;;; break-loop
(defun default-undefined-function-handler
(ignore continue-string function error-string &rest args)
(error-print error-string args function continue-string)
(if continue-string
(prog ()
loop
(internal-break-loop)
(if (fboundp (car args))
(return (values ':return (symbol-function (car args)))))
(format *error-output*
"~%;Warning, Can not proceed until ~S has been defun'd."
(car args))
(go loop))
;; if not continue-string
(dont-proceed)))
;;; Default-Unbound-Variable-Handler
;;; Default-unbound-variable handler is a handler for the :unbound-variable
;;; condition. If the error is signaled correctably, then the correction
;;; value is obtained by forcing the user to setq the symbol in the
;;; break loop.
(defun default-unbound-variable-handler
(ignore continue-string function error-string &rest args)
(error-print error-string args function continue-string)
(if continue-string
(prog ()
loop
(internal-break-loop)
(if (boundp (car args))
(return (values ':return (symbol-value (car args)))))
(format *error-output*
"~%;Warning, Can not proceed until ~S has been Setq'd."
(car args))
(go loop))
;; if not continue-string
(dont-proceed)))