(FILECREATED "22-Sep-86 15:43:08" {ERIS}<LISPCORE>SOURCES>ERROR-RUNTIME.;2 26427
changes to: (VARS ERROR-RUNTIMECOMS)
previous date: " 9-Sep-86 18:55:29" {ERIS}<LISPCORE>SOURCES>ERROR-RUNTIME.;1)
(* 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)
(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 REPORT-TYPE-MISMATCH)
(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))
(COMS (FUNCTIONS SIMPLE-FORMAT)
(P (MOVD? (QUOTE SIMPLE-FORMAT)
(QUOTE FORMAT))))
(PROP FILETYPE ERROR-RUNTIME)))
(* ;;; "Internal functions.")
(DEFMACRO CONDITION-TYPEP (DATUM TYPE) (BQUOTE (FAKE-TYPEP-FOR-CONDITIONS (\, DATUM)
(\, TYPE))))
(DEFMACRO CONDITION-SUBTYPEP (T1 T2) (BQUOTE (FAKE-SUBTYPEP-FOR-CONDITIONS (\, T1)
(\, T2))))
(DEFMACRO CONDITION-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 (GETPROP T1 (QUOTE
%%CONDITION-PARENT
))
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))))
(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)
(USE-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)
(USE-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 CALLER)
(if (CONDITION-TYPEP DATUM (QUOTE CONDITION))
then DATUM
else (TYPECASE DATUM (SYMBOL (CL:WHEN (CONDITION-SUBTYPEP DATUM (QUOTE CONDITION))
(CL:APPLY (FUNCTION MAKE-CONDITION)
DATUM ARGS)))
(STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS))
(T (CL:ERROR "Bad argument to ~S: ~S." CALLER DATUM)))))
(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)
(GETPROP TYPE (QUOTE %%CONDITION-PARENT))))
((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 (GET NAME (QUOTE %%CONDITION-PARENT)
)))
(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 (GET NAME (QUOTE %%CONDITION-PARENT))
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)
(DEFINE-CONDITION SIMPLE-CONDITION CONDITION :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(SIMPLE-CONDITION-FORMAT-STRING CONDITION
)
(SIMPLE-CONDITION-FORMAT-ARGUMENTS
CONDITION))
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION WARNING CONDITION)
(DEFINE-CONDITION SIMPLE-WARNING WARNING :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(SIMPLE-WARNING-FORMAT-STRING CONDITION)
(SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION))
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION OLD-BREAK1 CONDITION :REPORT (DESTRUCTURING-BIND (MESS1 MESS2 MESS3)
(OLD-BREAK1-LIST CONDITION)
(ERRORMESS1 MESS1 MESS2 MESS3))
LIST)
(DEFINE-CONDITION SERIOUS-CONDITION CONDITION)
(DEFINE-CONDITION CL:ERROR SERIOUS-CONDITION)
(DEFINE-CONDITION OLD-INTERLISP-ERROR CL:ERROR :REPORT (CL:IF (EQ (OLD-INTERLISP-ERROR-NUMBER
CONDITION)
17)
(DESTRUCTURING-BIND (MESS1 . MESS2)
(OLD-INTERLISP-ERROR-MESSAGE
CONDITION)
(ERRORMESS1 MESS1 MESS2
(QUOTE ERROR)))
(ERRORM (LIST (
OLD-INTERLISP-ERROR-NUMBER
CONDITION)
(
OLD-INTERLISP-ERROR-MESSAGE
CONDITION))))
NUMBER MESSAGE)
(DEFINE-CONDITION SIMPLE-ERROR CL:ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(SIMPLE-ERROR-FORMAT-STRING CONDITION)
(SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION))
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION ASSERTION-FAILED SIMPLE-ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(OR (ASSERTION-FAILED-FORMAT-STRING
CONDITION)
"Assertion failed.")
(ASSERTION-FAILED-FORMAT-ARGUMENTS
CONDITION)))
(DEFINE-CONDITION CELL-ERROR CL:ERROR NAME)
(DEFINE-CONDITION UNBOUND-VARIABLE CELL-ERROR :REPORT (FORMAT T "Unbound variable: ~S." (
UNBOUND-VARIABLE-NAME
CONDITION)))
(DEFINE-CONDITION UNDEFINED-FUNCTION CELL-ERROR :REPORT (FORMAT T "Undefined function: ~S."
(UNDEFINED-FUNCTION-NAME CONDITION)))
(DEFINE-CONDITION NO-PROCEED-TEST UNDEFINED-FUNCTION :REPORT (FORMAT T
"No test specified for proceed case: ~S."
(UNDEFINED-FUNCTION-NAME
CONDITION)))
(DEFINE-CONDITION INDEX-BOUNDS-ERROR CELL-ERROR :REPORT (FORMAT T "Index out of bounds: ~D."
(INDEX-BOUNDS-ERROR-INDEX CONDITION))
INDEX)
(DEFUN PRETTY-TYPE-NAME (TYPESPEC) (CONCAT "a " TYPESPEC))
(DEFUN REPORT-TYPE-MISMATCH (C S) (FORMAT S "The value of ~A, ~A, is not ~A." (TYPE-MISMATCH-NAME
C)
(TYPE-MISMATCH-VALUE C)
(if (TYPE-MISMATCH-MESSAGE C)
then (TYPE-MISMATCH-MESSAGE C)
else (PRETTY-TYPE-NAME (TYPE-MISMATCH-DESIRED-TYPE C)))))
(DEFINE-CONDITION TYPE-MISMATCH CELL-ERROR :REPORT-FUNCTION REPORT-TYPE-MISMATCH 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."
(ILLEGAL-GO-TAG CONDITION))
TAG)
(DEFINE-CONDITION ILLEGAL-RETURN CONTROL-ERROR :REPORT (FORMAT T "RETURN to non-existant block: ~S."
(ILLEGAL-RETURN-TAG CONDITION))
TAG)
(DEFINE-CONDITION ILLEGAL-THROW CONTROL-ERROR :REPORT (FORMAT T "Tag for THROW not found: ~S."
(ILLEGAL-THROW-TAG CONDITION))
TAG)
(DEFINE-CONDITION BAD-PROCEED-CASE CONTROL-ERROR)
(DEFINE-CONDITION CALL-ERROR CONTROL-ERROR CALLEE)
(DEFINE-CONDITION TOO-MANY-ARGUMENTS CALL-ERROR :REPORT (FORMAT T "Too many arguments to ~A: ~A"
(TOO-MANY-ARGUMENTS-CALLEE CONDITION)
(TOO-MANY-ARGUMENTS-EXTRA-VALUES
CONDITION))
EXTRA-VALUES)
(DEFINE-CONDITION TOO-FEW-ARGUMENTS CALL-ERROR :REPORT (FORMAT T "Too few arguments to ~A"
(TOO-FEW-ARGUMENTS-CALLEE CONDITION)))
(DEFINE-CONDITION STREAM-ERROR CL:ERROR STREAM)
(DEFINE-CONDITION READ-ERROR STREAM-ERROR)
(DEFINE-CONDITION END-OF-FILE READ-ERROR)
(DEFINE-CONDITION STORAGE-CONDITION SERIOUS-CONDITION)
(DEFINE-CONDITION STACK-OVERFLOW STORAGE-CONDITION)
(DEFINE-CONDITION STORAGE-EXHAUSTED STORAGE-CONDITION)
(* ;;; "Exported symbols.")
(DEFVAR *BREAK-ON-WARNINGS* NIL)
(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) (CL:APPLY (STRUCTURE-CONSTRUCTOR TYPE)
SLOT-INITIALIZATIONS))
(DEFUN SIGNAL (DATUM &REST ARGS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGS
(QUOTE SIGNAL))))
(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
(QUOTE CL:ERROR)))))
(DEFUN CERROR (PROCEED-FORMAT-STRING DATUM &REST ARGUMENTS)
(PROCEED-CASE (FUNCALL (FUNCTION CL:ERROR)
(MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-ERROR)
ARGUMENTS
(QUOTE CERROR)))
(PROCEED NIL :REPORT (CL:APPLY (FUNCTION FORMAT)
T PROCEED-FORMAT-STRING ARGUMENTS)
NIL)))
(DEFUN WARN (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
)
ARGUMENTS
(QUOTE WARN))))
(RAISE-SIGNAL CONDITION)
(if *BREAK-ON-WARNINGS*
then (CL:BREAK CONDITION)
else (FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%%"
(WITH-OUTPUT-TO-STRING (S)
(REPORT-CONDITION CONDITION S))))
CONDITION))
(DEFUN CL:BREAK (&OPTIONAL (DATUM "Break.")
&REST ARGUMENTS)
(DECLARE (SPECIAL NBREAKS))
(LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-BREAK)
ARGUMENTS
(QUOTE CL:BREAK)))
(HACK (BQUOTE (CL:LAMBDA (P S)
(FORMAT S "Return from break: ~D" (\, (ADD1 NBREAKS)))))))
(* * HACK UNTIL LEXICALITY WORKS...)
(COMMON-LISP (CL:EVAL (BQUOTE (PROCEED-CASE (DEBUG (QUOTE (\, CONDITION)))
(PROCEED (C)
:REPORT-FUNCTION
(CL:LAMBDA (P S)
(FUNCALL (QUOTE (\, HACK))
P S))
C)))))
(* *
"Don't just return the thing that PROCEED gave 'cause it might not be the same condition.")
CONDITION))
(DEFUN DEBUG (&OPTIONAL (DATUM "Break.")
&REST ARGS) (LOOP (ERRORX (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGS
(QUOTE DEBUG)))))
(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)
(DEFUN FIND-PROCEED-CASE (DATUM CONDITION) (TYPECASE DATUM (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 (AND (BOUNDP (QUOTE BREAKRESETVALS))
(BOUNDP (QUOTE \BREAKRESETEXPR))
(BREAKRESETFN (QUOTE LEAVING))) (* Hack until THROW and RESETLST get
along)
(THROW (PROCEED-CASE-TAG PC)
(LIST* (PROCEED-CASE-SELECTOR PC)
CONDITION VALUES))
ELSE (CL:ERROR (QUOTE BAD-PROCEED-CASE)
:NAME PROCEED-CASE))))
(DEFINE-PROCEED-FUNCTION ABORT :TEST TRUE :REPORT "Abort")
(DEFINE-PROCEED-FUNCTION PROCEED :TEST TRUE)
(DEFINE-PROCEED-FUNCTION USE-VALUE :REPORT "Use a different value" :TEST TRUE
(VALUE (PROGN (FORMAT T "Enter a new value: ")
(EVAL (READ)))))
(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