(FILECREATED " 3-Oct-86 20:07:45" {ERIS}<DANIELS>LISP>ERROR-RUNTIME.;8 29492
changes to: (FUNCTIONS WARN)
previous date: " 3-Oct-86 19:28:40" {ERIS}<DANIELS>LISP>ERROR-RUNTIME.;7)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT ERROR-RUNTIMECOMS)
(RPAQQ ERROR-RUNTIMECOMS
((COMS (* ;;; "Internal functions.")
(FUNCTIONS CONDITION-TYPEP CONDITION-SUBTYPEP CONDITION-TYPE-OF
FAKE-TYPEP-FOR-CONDITIONS FAKE-SUBTYPEP-FOR-CONDITIONS
FAKE-TYPE-OF-FOR-CONDITIONS)
(FUNCTIONS CONDITION-HANDLER CONDITION-REPORTER %%PRINT-CONDITION REPORT-CONDITION
CONDITION-PARENT)
(VARIABLES *CONDITION-HANDLER-BINDINGS* *PROCEED-CASES*)
(FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL)
(FUNCTIONS MAKE-INTO-CONDITION RAISE-SIGNAL DEFAULT-HANDLE-CONDITION
DEFAULT-PROCEED-REPORTER FIX-INHERITANCE-LINKS DEFAULT-PROCEED-TEST
TEST-PROCEED-CASE))
(COMS (* ;;; "Pre-defined condition types.")
(STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING OLD-BREAK1
SERIOUS-CONDITION CL:ERROR OLD-INTERLISP-ERROR SIMPLE-ERROR ASSERTION-FAILED
CELL-ERROR UNBOUND-VARIABLE UNDEFINED-FUNCTION NO-PROCEED-TEST
INDEX-BOUNDS-ERROR)
(COMS (FUNCTIONS PRETTY-TYPE-NAME)
(STRUCTURES TYPE-MISMATCH))
(STRUCTURES CONTROL-ERROR ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW BAD-PROCEED-CASE)
(STRUCTURES CALL-ERROR TOO-MANY-ARGUMENTS TOO-FEW-ARGUMENTS)
(STRUCTURES STREAM-ERROR READ-ERROR END-OF-FILE)
(STRUCTURES STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED))
(COMS (* ;;; "Exported symbols.")
(VARIABLES *BREAK-ON-WARNINGS*)
(FUNCTIONS MAKE-CONDITION SIGNAL CL:ERROR CERROR WARN CL:BREAK DEBUG)
(STRUCTURES PROCEED-CASE)
(FUNCTIONS FIND-PROCEED-CASE COMPUTE-PROCEED-CASES INVOKE-PROCEED-CASE)
(FUNCTIONS ABORT PROCEED USE-VALUE STORE-VALUE))
(COMS (FUNCTIONS SIMPLE-FORMAT)
(P (MOVD? (QUOTE SIMPLE-FORMAT)
(QUOTE FORMAT))))
(PROP FILETYPE ERROR-RUNTIME)))
(* ;;; "Internal functions.")
(DEFMACRO CONDITION-TYPEP (DATUM TYPE) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (TYPEP (\, DATUM)
(\, TYPE)))
(BQUOTE (FAKE-TYPEP-FOR-CONDITIONS (\, DATUM)
(\, TYPE)))))
(DEFMACRO CONDITION-SUBTYPEP (T1 T2) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (SUBTYPEP (\, T1)
(\, T2)))
(BQUOTE (FAKE-SUBTYPEP-FOR-CONDITIONS (\, T1)
(\, T2)))))
(DEFMACRO CONDITION-TYPE-OF (DATUM) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (TYPE-OF (\, DATUM)))
(BQUOTE (FAKE-TYPE-OF-FOR-CONDITIONS (\, DATUM)))))
(DEFUN FAKE-TYPEP-FOR-CONDITIONS (DATUM TYPE) (* amd " 9-Apr-86 17:41")
(AND (CONSP DATUM)
(SYMBOLP (CAR DATUM))
(CONDITION-SUBTYPEP (CAR DATUM)
TYPE)))
(DEFUN FAKE-SUBTYPEP-FOR-CONDITIONS (T1 T2) (VALUES (AND (for old T1 by (CONDITION-PARENT T1)
while T1 thereis (EQ T1 T2))
T)
T))
(DEFUN FAKE-TYPE-OF-FOR-CONDITIONS (DATUM) (CAR DATUM))
(DEFMACRO CONDITION-HANDLER (CONDITION-TYPE) (BQUOTE (GETPROP (\, CONDITION-TYPE)
(QUOTE %%CONDITION-HANDLER))))
(DEFMACRO CONDITION-REPORTER (CONDITION-TYPE) (BQUOTE (GETPROP (\, CONDITION-TYPE)
(QUOTE %%CONDITION-REPORTER))))
(DEFUN %%PRINT-CONDITION (CONDITION STREAM LEVEL) (DECLARE (IGNORE LEVEL))
(CL:IF *PRINT-ESCAPE*
(FORMAT STREAM "~c<Condition ~S @ ~O,~O>"
(CODE-CHAR (fetch (READTABLEP
HASHMACROCHAR
)
of *READTABLE*))
(TYPE-OF CONDITION)
(\HILOC CONDITION)
(\LOLOC CONDITION))
(REPORT-CONDITION CONDITION STREAM)))
(DEFUN REPORT-CONDITION (CONDITION STREAM) (CL:DO* ((TYPE (CONDITION-TYPE-OF CONDITION)
(CONDITION-PARENT TYPE))
(REPORTER (CONDITION-REPORTER TYPE)
(CONDITION-REPORTER TYPE)))
((NULL TYPE)
(CL:BREAK "No report function found for ~S."
CONDITION))
(CL:WHEN REPORTER
(RETURN (CL:IF STREAM (FUNCALL REPORTER
CONDITION
STREAM)
(WITH-OUTPUT-TO-STRING
(STREAM)
(FUNCALL REPORTER CONDITION
STREAM)))))))
(DEFMACRO CONDITION-PARENT (TYPE) (BQUOTE (GETPROP (\, TYPE)
(QUOTE %%CONDITION-PARENT))))
(DEFVAR *CONDITION-HANDLER-BINDINGS* NIL "Condition handler binding stack")
(DEFVAR *PROCEED-CASES* NIL "Active proceed case stack")
(DEFUN CHECK-TYPE-FAIL (PROCEEDABLE PLACE VALUE DESIRED-TYPE MESSAGE)
(PROCEED-CASE (CL:ERROR (QUOTE TYPE-MISMATCH)
:NAME PLACE :VALUE VALUE :DESIRED-TYPE DESIRED-TYPE :MESSAGE MESSAGE)
(STORE-VALUE (IGNORE NEW)
:REPORT
(FORMAT T "Change the value of ~A" PLACE)
:TEST
(CL:LAMBDA (CONDITION)
(AND PROCEEDABLE (CONDITION-TYPEP CONDITION (QUOTE TYPE-MISMATCH))))
NEW)))
(DEFUN ECASE-FAIL (PROCEEDABLE PLACE VALUE SELECTORS) (PROCEED-CASE (CL:ERROR
"The value of ~S, ~S,~&is ~?."
PLACE VALUE
"~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~↑,~}~]"
SELECTORS)
(STORE-VALUE (IGNORE V)
:TEST
(CL:LAMBDA (CONDITION)
(CL:DECLARE (IGNORE
CONDITION
))
PROCEEDABLE)
:REPORT
(FORMAT T
"Change the value of ~A"
PLACE)
V)))
(DEFUN ASSERT-FAIL (STRING &REST ARGS) (PROCEED-CASE (CL:ERROR (QUOTE ASSERTION-FAILED)
:FORMAT-STRING STRING :FORMAT-ARGUMENTS
ARGS)
(PROCEED NIL :REPORT "Re-test assertion")))
(DEFUN MAKE-INTO-CONDITION (DATUM DESIRED-TYPE ARGS) (* ;; "The entire thing should be a typecase.")
(CL:IF (CONDITION-TYPEP DATUM (QUOTE CONDITION))
DATUM
(ETYPECASE DATUM (SYMBOL (CL:IF (CONDITION-SUBTYPEP DATUM (QUOTE CONDITION))
(CL:APPLY (FUNCTION MAKE-CONDITION)
DATUM ARGS)
(CL:ERROR "~S is not a condition type." DATUM)))
(STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS)))))
(DEFUN RAISE-SIGNAL (C) (for CHB-TAIL on *CONDITION-HANDLER-BINDINGS* bind BINDING
eachtime (SETQ BINDING (CAR CHB-TAIL))
do (if (CONDITION-TYPEP C (CAR BINDING))
then (LET ((*CONDITION-HANDLER-BINDINGS* (CDR CHB-TAIL)))
(FUNCALL (CDR BINDING)
C))))
(DEFAULT-HANDLE-CONDITION C)
C)
(DEFUN DEFAULT-HANDLE-CONDITION (CONDITION) (CL:DO ((TYPE (CONDITION-TYPE-OF CONDITION)
(CONDITION-PARENT TYPE)))
((NULL TYPE))
(LET ((HANDLER (CONDITION-HANDLER TYPE)))
(CL:WHEN HANDLER (FUNCALL HANDLER CONDITION))
)))
(DEFUN DEFAULT-PROCEED-REPORTER (PC STREAM) (FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME
PC)))
(DEFUN FIX-INHERITANCE-LINKS (NAME NEW-PARENT) (LET ((OLD-PARENT (CONDITION-PARENT NAME)))
(CL:UNLESS (OR (EQ NEW-PARENT OLD-PARENT)
(NULL OLD-PARENT))
(LET ((CHILDREN (GET OLD-PARENT
(QUOTE
%%CONDITION-CHILDREN
))))
(SETF (GET OLD-PARENT (QUOTE
%%CONDITION-CHILDREN
))
(DREMOVE NAME CHILDREN))))
(CL:PUSHNEW NAME (GETPROP NEW-PARENT (QUOTE
%%CONDITION-CHILDREN
)))
(SETF (CONDITION-PARENT NAME)
NEW-PARENT)))
(DEFMACRO DEFAULT-PROCEED-TEST (PROCEED-TYPE) (BQUOTE (GETPROP (\, PROCEED-TYPE)
(QUOTE %%DEFAULT-PROCEED-TEST))))
(DEFUN TEST-PROCEED-CASE (PC CONDITION &AUX TEST) (COND
((SETF TEST (PROCEED-CASE-TEST PC))
(FUNCALL TEST CONDITION))
((AND (PROCEED-CASE-NAME PC)
(SETF TEST (OR (DEFAULT-PROCEED-TEST
(PROCEED-CASE-NAME PC))
(NO-PROCEED-TEST
(PROCEED-CASE-NAME PC)))))
(FUNCALL TEST CONDITION))
(T (* ; "This case shouldn't happen")
(PROCEED-CASE (CL:ERROR
"Couldn't find test function for ~S."
PC)
(PROCEED NIL :TEST TRUE :REPORT
"Assume proceed case is enabled"
T)))))
(* ;;; "Pre-defined condition types.")
(DEFINE-CONDITION CONDITION CONDITION :REPORT "Condition ~S occurred." --DUMMY-SLOT--)
(DEFINE-CONDITION SIMPLE-CONDITION CONDITION :REPORT (CL:APPLY (FUNCTION FORMAT)
T FORMAT-STRING FORMAT-ARGUMENTS)
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION WARNING CONDITION)
(DEFINE-CONDITION SIMPLE-WARNING WARNING :REPORT (CL:APPLY (FUNCTION FORMAT)
T FORMAT-STRING FORMAT-ARGUMENTS)
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION OLD-BREAK1 CONDITION :REPORT (DESTRUCTURING-BIND (MESS1 MESS2 MESS3)
LIST
(ERRORMESS1 MESS1 MESS2 MESS3))
LIST)
(DEFINE-CONDITION SERIOUS-CONDITION CONDITION :REPORT (FORMAT T "Serious condition ~S occurred."
(CONDITION-TYPE-OF CONDITION)))
(DEFINE-CONDITION CL:ERROR SERIOUS-CONDITION)
(DEFINE-CONDITION OLD-INTERLISP-ERROR CL:ERROR :REPORT (CL:IF (EQ NUMBER 17)
(DESTRUCTURING-BIND (MESS1 . MESS2)
MESSAGE
(ERRORMESS1 MESS1 MESS2
(QUOTE ERROR)))
(ERRORM (LIST NUMBER MESSAGE)))
NUMBER MESSAGE)
(DEFINE-CONDITION SIMPLE-ERROR CL:ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
T FORMAT-STRING FORMAT-ARGUMENTS)
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION ASSERTION-FAILED SIMPLE-ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(OR FORMAT-STRING "Assertion failed.")
FORMAT-ARGUMENTS))
(DEFINE-CONDITION CELL-ERROR CL:ERROR NAME)
(DEFINE-CONDITION UNBOUND-VARIABLE CELL-ERROR :REPORT (FORMAT T "Unbound variable: ~S." NAME))
(DEFINE-CONDITION UNDEFINED-FUNCTION CELL-ERROR :REPORT (FORMAT T "Undefined function: ~S." NAME))
(DEFINE-CONDITION NO-PROCEED-TEST UNDEFINED-FUNCTION :REPORT (FORMAT T
"No test specified for proceed case: ~S."
NAME))
(DEFINE-CONDITION INDEX-BOUNDS-ERROR CELL-ERROR :REPORT (FORMAT T "Index out of bounds: ~D." INDEX)
INDEX)
(DEFUN PRETTY-TYPE-NAME (TYPESPEC) (CONCAT "a " TYPESPEC))
(DEFINE-CONDITION TYPE-MISMATCH CELL-ERROR :REPORT (FORMAT T "The value of ~A, ~A, is not ~A." NAME
VALUE (OR MESSAGE (PRETTY-TYPE-NAME
DESIRED-TYPE)))
VALUE DESIRED-TYPE MESSAGE)
(DEFINE-CONDITION CONTROL-ERROR CL:ERROR)
(DEFINE-CONDITION ILLEGAL-GO CONTROL-ERROR :REPORT (FORMAT T "GO to a non-existant tag: ~S." TAG)
TAG)
(DEFINE-CONDITION ILLEGAL-RETURN CONTROL-ERROR :REPORT (FORMAT T "RETURN to non-existant block: ~S."
TAG)
TAG)
(DEFINE-CONDITION ILLEGAL-THROW CONTROL-ERROR :REPORT (FORMAT T "Tag for THROW not found: ~S." TAG)
TAG)
(DEFINE-CONDITION BAD-PROCEED-CASE CONTROL-ERROR :REPORT (FORMAT T
"Proceed case ~S is not currently active."
NAME)
NAME)
(DEFINE-CONDITION CALL-ERROR CONTROL-ERROR CALLEE)
(DEFINE-CONDITION TOO-MANY-ARGUMENTS CALL-ERROR :REPORT (CL:IF (AND MAXIMUM ACTUAL)
(FORMAT T
"Too many arguments to ~A:~%% ~D were given but at most ~D are accepted"
CALLEE ACTUAL MAXIMUM)
(FORMAT T "Too many arguments to ~A"
CALLEE))
MAXIMUM ACTUAL)
(DEFINE-CONDITION TOO-FEW-ARGUMENTS CALL-ERROR :REPORT (CL:IF (AND MINIMUM ACTUAL)
(FORMAT T
"Too few arguments to ~A:~%% ~D were given but at least ~D are necessary"
CALLEE ACTUAL MINIMUM)
(FORMAT T "Too few arguments to ~A"
CALLEE))
MINIMUM ACTUAL)
(DEFINE-CONDITION STREAM-ERROR CL:ERROR :REPORT (FORMAT T "Stream error on ~S." STREAM)
STREAM)
(DEFINE-CONDITION READ-ERROR STREAM-ERROR)
(DEFINE-CONDITION END-OF-FILE READ-ERROR :REPORT "End of file:~%% ~S" STREAM)
(DEFINE-CONDITION STORAGE-CONDITION SERIOUS-CONDITION)
(DEFINE-CONDITION STACK-OVERFLOW STORAGE-CONDITION :REPORT "Stack overflow")
(DEFINE-CONDITION STORAGE-EXHAUSTED STORAGE-CONDITION)
(* ;;; "Exported symbols.")
(DEFVAR *BREAK-ON-WARNINGS* NIL
"If true, calls to WARN will cause a break as well as logging the warning.")
(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
(* ;; "(cl:apply 'make type slot-initializations)")
(CL:APPLY (STRUCTURE-CONSTRUCTOR TYPE)
SLOT-INITIALIZATIONS))
(DEFUN SIGNAL (DATUM &REST ARGS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGS)))
(RAISE-SIGNAL CONDITION)
(CL:IF (CONDITION-TYPEP CONDITION (QUOTE SERIOUS-CONDITION))
(DEBUG CONDITION)
(RETURN-FROM SIGNAL CONDITION))))
(DEFUN CL:ERROR (DATUM &REST ARGS) (DEBUG (RAISE-SIGNAL (MAKE-INTO-CONDITION DATUM (QUOTE
SIMPLE-ERROR
)
ARGS))))
(DEFUN CERROR (PROCEED-FORMAT-STRING DATUM &REST ARGUMENTS &AUX CONDITION)
(PROCEED-CASE (DEBUG (RAISE-SIGNAL (SETF CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-ERROR)
ARGUMENTS))))
(PROCEED NIL :REPORT (CL:APPLY (FUNCTION FORMAT)
T PROCEED-FORMAT-STRING ARGUMENTS)
CONDITION)))
(DEFUN WARN (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
)
ARGUMENTS)))
(CL:UNLESS (CONDITION-TYPEP CONDITION (QUOTE WARNING))
(CERROR "Signal and report the condition anyway"
(QUOTE TYPE-MISMATCH)
:NAME
(QUOTE CONDITION)
:VALUE CONDITION :DESIRED-TYPE (QUOTE WARNING)
))
(RAISE-SIGNAL CONDITION)
(CL:IF %%CONDITION-TYPES-REAL (FORMAT *ERROR-OUTPUT*
"~&Warning: ~A~%%"
CONDITION)
(FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%%"
(REPORT-CONDITION CONDITION NIL)))
(CL:WHEN *BREAK-ON-WARNINGS* (CL:BREAK CONDITION))
CONDITION))
(DEFUN CL:BREAK (&OPTIONAL (DATUM "Break")
&REST ARGUMENTS &AUX CONDITION)
(* ;;
"Want to try and get some indication of which break you're returning from.")
(PROCEED-CASE (DEBUG (SETF CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGUMENTS)))
(PROCEED NIL :REPORT "Return from BREAK" CONDITION)))
(DEFUN DEBUG (&OPTIONAL (DATUM "Break")
&REST ARGS) (LOOP (ERRORX (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGS))))
(DEFSTRUCT (PROCEED-CASE (:PRINT-FUNCTION (CL:LAMBDA (PC STREAM LEVEL)
(CL:IF *PRINT-ESCAPE* (DEFAULT-STRUCTURE-PRINTER
PC STREAM LEVEL)
(FUNCALL (PROCEED-CASE-REPORT PC)
PC STREAM))
T))) NAME TAG SELECTOR TEST
(REPORT
(CL:FUNCTION (LAMBDA (PC STREAM)
(FUNCALL
(DEFAULT-PROCEED-REPORT
(PROCEED-CASE-NAME
PC))
PC STREAM)))))
(DEFUN FIND-PROCEED-CASE (DATUM CONDITION) (ETYPECASE DATUM (NULL (CL:ERROR
"~S is an invalid argument to ~S;~%% use ~S instead"
NIL (QUOTE FIND-PROCEED-CASE
)
(QUOTE COMPUTE-PROCEED-CASES
)))
(PROCEED-CASE (AND (FMEMB DATUM *PROCEED-CASES*)
(TEST-PROCEED-CASE DATUM
CONDITION)
DATUM))
(SYMBOL (for PC in *PROCEED-CASES*
thereis (AND (EQ (PROCEED-CASE-NAME
PC)
DATUM)
(TEST-PROCEED-CASE PC
CONDITION)
PC)))))
(DEFUN COMPUTE-PROCEED-CASES (CONDITION) (for PC in *PROCEED-CASES*
when (CATCH (QUOTE SKIP-PROCEED-CASE)
(TEST-PROCEED-CASE PC CONDITION))
collect PC))
(DEFUN INVOKE-PROCEED-CASE (PROCEED-CASE CONDITION &REST VALUES)
(LET ((PC (FIND-PROCEED-CASE PROCEED-CASE CONDITION)))
(IF PC
THEN (* ;; "Hack until real unwinder is in. ")
(AND (BOUNDP (QUOTE BREAKRESETVALS))
(BOUNDP (QUOTE \BREAKRESETEXPR))
(BREAKRESETFN (QUOTE LEAVING)))
(THROW (PROCEED-CASE-TAG PC)
(LIST* (PROCEED-CASE-SELECTOR PC)
CONDITION
(COND
((SYMBOLP PROCEED-CASE)
VALUES)
((FBOUNDP (PROCEED-CASE-NAME PC))
(CL:APPLY (PROCEED-ARG-COLLECTOR (PROCEED-CASE-NAME PC))
CONDITION VALUES))
(T VALUES))))
ELSE (CL:ERROR (QUOTE BAD-PROCEED-CASE)
:NAME PROCEED-CASE))))
(DEFINE-PROCEED-FUNCTION ABORT :TEST TRUE :REPORT "Abort")
(DEFINE-PROCEED-FUNCTION PROCEED :REPORT "Proceed with no special action" :TEST TRUE)
(DEFINE-PROCEED-FUNCTION USE-VALUE :REPORT "Use a different value" :TEST TRUE
(VALUE (PROGN (FORMAT *QUERY-IO* "Enter a new value: ")
(EVAL (CL:READ *QUERY-IO*)))))
(DEFINE-PROCEED-FUNCTION STORE-VALUE :REPORT "Store a new value and use it" :TEST TRUE
(VALUE (PROGN (FORMAT *QUERY-IO*
"Enter a value to store: ")
(CL:EVAL (CL:READ *QUERY-IO*)))))
(DEFUN SIMPLE-FORMAT (STREAM &REST ARGS) (CL:WHEN (EQ STREAM T)
(SETF STREAM *STANDARD-OUTPUT*))
(DOLIST (X ARGS)
(CL:PRINT X STREAM)))
(MOVD? (QUOTE SIMPLE-FORMAT)
(QUOTE FORMAT))
(PUTPROPS ERROR-RUNTIME FILETYPE COMPILE-FILE)
(PUTPROPS ERROR-RUNTIME COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP