add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
420
CLTL2/ERROR-RUNTIME
Normal file
420
CLTL2/ERROR-RUNTIME
Normal file
@@ -0,0 +1,420 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "18-Oct-93 15:37:49" "{Pele:mv:envos}<LispCore>Sources>CLTL2>ERROR-RUNTIME.;2" 23732
|
||||
|
||||
|previous| |date:| "11-Mar-92 14:19:49"
|
||||
"{Pele:mv:envos}<LispCore>Sources>CLTL2>ERROR-RUNTIME.;1")
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT ERROR-RUNTIMECOMS)
|
||||
|
||||
(RPAQQ ERROR-RUNTIMECOMS
|
||||
((COMS
|
||||
|
||||
(* |;;;| "Internal functions.")
|
||||
|
||||
(FUNCTIONS SI::CONDITION-CASE-ERROR CONDITION-HANDLER CONDITION-REPORTER
|
||||
%PRINT-CONDITION CONDITIONS::%RESTART-PRINTER
|
||||
CONDITIONS::%RESTART-DEFAULT-REPORTER REPORT-CONDITION CONDITION-PARENT)
|
||||
(VARIABLES *CONDITION-HANDLER-BINDINGS* LISP:*DEBUGGER-HOOK* *PROCEED-CASES*)
|
||||
(FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL)
|
||||
(FUNCTIONS XCL::SYMBOL-AS-PATHNAME)
|
||||
(FUNCTIONS MAKE-INTO-CONDITION RAISE-SIGNAL DEFAULT-HANDLE-CONDITION
|
||||
DEFAULT-PROCEED-REPORTER CONDITIONS::DEFAULT-RESTART-REPORTER
|
||||
DEFAULT-PROCEED-TEST TEST-PROCEED-CASE WALK-PROCEED-CASES
|
||||
SI::INVOKE-ACTUAL-RESTART))
|
||||
(COMS
|
||||
|
||||
(* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")
|
||||
|
||||
(VARIABLES CONDITIONS:*BREAK-ON-SIGNALS* *BREAK-ON-WARNINGS* XCL:*CURRENT-CONDITION*)
|
||||
(FUNCTIONS MAKE-CONDITION SIGNAL LISP:ERROR LISP:CERROR LISP:WARN LISP:BREAK
|
||||
CONDITIONS:INVOKE-DEBUGGER)
|
||||
(FUNCTIONS LISP:FIND-RESTART LISP:COMPUTE-RESTARTS LISP:INVOKE-RESTART
|
||||
CONDITIONS:INVOKE-RESTART-INTERACTIVELY))
|
||||
(PROP FILETYPE ERROR-RUNTIME)))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Internal functions.")
|
||||
|
||||
|
||||
(LISP:DEFUN SI::CONDITION-CASE-ERROR (SI::REAL-SELECTOR SI::POSSIBILITIES)
|
||||
(LISP:ERROR "Unexpected selector in ~S." 'CONDITION-CASE SI::REAL-SELECTOR SI::POSSIBILITIES))
|
||||
|
||||
(DEFMACRO CONDITION-HANDLER (XCL::CONDITION-TYPE)
|
||||
`(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-HANDLER))
|
||||
|
||||
(DEFMACRO CONDITION-REPORTER (XCL::CONDITION-TYPE)
|
||||
`(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-REPORTER))
|
||||
|
||||
(LISP:DEFUN %PRINT-CONDITION (CONDITION STREAM LEVEL)
|
||||
(DECLARE (IGNORE LEVEL))
|
||||
(LISP:IF *PRINT-ESCAPE*
|
||||
(LISP:FORMAT STREAM "#<Condition ~S @ ~O,~O>" (LISP:TYPE-OF CONDITION)
|
||||
(\\HILOC CONDITION)
|
||||
(\\LOLOC CONDITION))
|
||||
(REPORT-CONDITION CONDITION STREAM)))
|
||||
|
||||
(LISP:DEFUN CONDITIONS::%RESTART-PRINTER (CONDITIONS:RESTART STREAM CONDITIONS::LEVEL)
|
||||
(* \; "Edited 2-Mar-92 16:00 by jrb:")
|
||||
(LISP:IF *PRINT-ESCAPE*
|
||||
(LISP:FUNCALL LISP::%DEFAULT-PRINT-FUNCTION CONDITIONS:RESTART STREAM CONDITIONS::LEVEL)
|
||||
(LET ((CONDITIONS::REPORTER (OR (CONDITIONS::RESTART-REPORT CONDITIONS:RESTART)
|
||||
(CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME
|
||||
CONDITIONS:RESTART))
|
||||
(LISP:RETURN-FROM CONDITIONS::%RESTART-PRINTER
|
||||
(CONDITIONS::DEFAULT-RESTART-REPORTER
|
||||
CONDITIONS:RESTART STREAM)))))
|
||||
(LISP:IF (LISP:STRINGP CONDITIONS::REPORTER)
|
||||
(LISP:PRINC CONDITIONS::REPORTER STREAM)
|
||||
(LISP:FUNCALL CONDITIONS::REPORTER STREAM)))))
|
||||
|
||||
(LISP:DEFUN CONDITIONS::%RESTART-DEFAULT-REPORTER (CONDITIONS:RESTART STREAM)
|
||||
(LISP:FUNCALL (CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME CONDITIONS:RESTART))
|
||||
CONDITIONS:RESTART STREAM))
|
||||
|
||||
(LISP:DEFUN REPORT-CONDITION (CONDITION STREAM)
|
||||
(LISP:DO* ((TYPE (LISP:TYPE-OF CONDITION)
|
||||
(CONDITION-PARENT TYPE))
|
||||
(REPORTER (CONDITION-REPORTER TYPE)
|
||||
(CONDITION-REPORTER TYPE)))
|
||||
((NULL TYPE)
|
||||
(LISP:BREAK "No report function found for ~S." CONDITION))
|
||||
(LISP:WHEN REPORTER
|
||||
(RETURN (LISP:IF (LISP:STRINGP REPORTER)
|
||||
(LISP:PRINC REPORTER STREAM)
|
||||
(LISP:FUNCALL REPORTER CONDITION STREAM))))))
|
||||
|
||||
(LISP:DEFUN CONDITION-PARENT (TYPE)
|
||||
(LET ((PARENT (GETSUPERTYPE TYPE)))
|
||||
(LISP:IF (EQ PARENT 'LISP::STRUCTURE-OBJECT)
|
||||
NIL
|
||||
PARENT)))
|
||||
|
||||
(LISP:DEFVAR *CONDITION-HANDLER-BINDINGS* NIL
|
||||
"Condition handler binding stack")
|
||||
|
||||
(LISP:DEFVAR LISP:*DEBUGGER-HOOK* NIL)
|
||||
|
||||
(LISP:DEFVAR *PROCEED-CASES* NIL
|
||||
"Active proceed case stack")
|
||||
|
||||
(LISP:DEFUN CHECK-TYPE-FAIL (PROCEEDABLE PLACE VALUE DESIRED-TYPE MESSAGE)
|
||||
(LISP:RESTART-CASE (LISP:ERROR 'XCL:TYPE-MISMATCH :NAME PLACE :VALUE VALUE :EXPECTED-TYPE
|
||||
DESIRED-TYPE :MESSAGE MESSAGE)
|
||||
(STORE-VALUE (NEW)
|
||||
:REPORT
|
||||
(LAMBDA (STREAM)
|
||||
(LISP:FORMAT STREAM "Change the value of ~A" PLACE))
|
||||
:INTERACTIVE
|
||||
(LAMBDA NIL
|
||||
(LISP:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE)
|
||||
(LIST (LISP:EVAL (LISP:READ *QUERY-IO*))))
|
||||
:FILTER
|
||||
(LAMBDA NIL
|
||||
(AND PROCEEDABLE (TYPEP XCL:*CURRENT-CONDITION* 'XCL:TYPE-MISMATCH)))
|
||||
NEW)))
|
||||
|
||||
(LISP:DEFUN ECASE-FAIL (PROCEEDABLE PLACE VALUE SELECTORS)
|
||||
(LISP:RESTART-CASE (LISP:IF (EQL PLACE VALUE)
|
||||
(LISP:ERROR "~S is ~?." VALUE
|
||||
"~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]"
|
||||
SELECTORS)
|
||||
(LISP:ERROR "The value of ~S, ~S,~&is ~?." PLACE VALUE
|
||||
"~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]"
|
||||
SELECTORS))
|
||||
(STORE-VALUE (V)
|
||||
:FILTER
|
||||
(LAMBDA NIL PROCEEDABLE)
|
||||
:REPORT
|
||||
(LAMBDA (STREAM)
|
||||
(LISP:FORMAT STREAM "Change the value of ~A" PLACE))
|
||||
:INTERACTIVE
|
||||
(LAMBDA NIL
|
||||
(LISP:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE)
|
||||
(LIST (LISP:EVAL (LISP:READ *QUERY-IO*))))
|
||||
V)))
|
||||
|
||||
(LISP:DEFUN ASSERT-FAIL (STRING &REST ARGS)
|
||||
(PROCEED-CASE (LISP:ERROR 'XCL:ASSERTION-FAILED :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGS)
|
||||
(CONDITIONS:CONTINUE NIL :REPORT "Re-test assertion")))
|
||||
|
||||
(LISP:DEFUN XCL::SYMBOL-AS-PATHNAME (LISP:SYMBOL XCL::WHERE &OPTIONAL XCL::MESSAGE)
|
||||
(LISP:RESTART-CASE (LISP:ERROR 'XCL::SYMBOL-AS-PATHNAME :SYMBOL LISP:SYMBOL :WHERE XCL::WHERE
|
||||
:MESSAGE XCL::MESSAGE)
|
||||
(XCL::USE-PNAME NIL :REPORT (LISP:LAMBDA (STREAM)
|
||||
(LISP:PRINC "Use the symbol's pname" STREAM))
|
||||
:FILTER
|
||||
(LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION* 'XCL::SYMBOL-AS-PATHNAME)))))
|
||||
|
||||
(LISP:DEFUN MAKE-INTO-CONDITION (DATUM DESIRED-TYPE ARGS)
|
||||
(LISP:ETYPECASE DATUM
|
||||
(CONDITION DATUM)
|
||||
(LISP:SYMBOL (LISP:IF (LISP:SUBTYPEP DATUM 'CONDITION)
|
||||
(LISP:APPLY 'MAKE-CONDITION DATUM ARGS)
|
||||
(LISP:ERROR "~S is not a condition type." DATUM)))
|
||||
(STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS))))
|
||||
|
||||
(LISP:DEFUN RAISE-SIGNAL (CONDITION)
|
||||
(LISP:WHEN (TYPEP CONDITION CONDITIONS:*BREAK-ON-SIGNALS*)
|
||||
(LISP:BREAK "Condition ~S is about to be signalled." CONDITION))
|
||||
(LET ((*CONDITION-HANDLER-BINDINGS* *CONDITION-HANDLER-BINDINGS*))
|
||||
(LISP:FLET ((TRY-TO-HANDLE (CONDITION TYPE-SPEC HANDLER)
|
||||
(LISP:MACROLET ((WITHOUT-HANDLERS (&BODY BODY)
|
||||
`(LET (*CONDITION-HANDLER-BINDINGS*)
|
||||
,@BODY)))
|
||||
(LISP:WHEN (PROCEED-CASE (WITHOUT-HANDLERS (TYPEP CONDITION
|
||||
TYPE-SPEC))
|
||||
(PROCEED NIL :REPORT
|
||||
"Skip the bad handler binding" NIL))
|
||||
(LISP:FUNCALL HANDLER CONDITION)))))
|
||||
(WHILE *CONDITION-HANDLER-BINDINGS*
|
||||
DO (LET ((BINDING (LISP:POP *CONDITION-HANDLER-BINDINGS*)))
|
||||
(IF (EQ (LISP:FIRST BINDING)
|
||||
:MULTIPLE-HANDLER-BINDINGS)
|
||||
THEN (LISP:POP BINDING)
|
||||
(WHILE BINDING DO (TRY-TO-HANDLE CONDITION
|
||||
(LISP:POP BINDING)
|
||||
(LISP:POP BINDING)))
|
||||
ELSE (TRY-TO-HANDLE CONDITION (CAR BINDING)
|
||||
(CDR BINDING)))) FINALLY (
|
||||
DEFAULT-HANDLE-CONDITION
|
||||
CONDITION)))
|
||||
CONDITION))
|
||||
|
||||
(LISP:DEFUN DEFAULT-HANDLE-CONDITION (CONDITION)
|
||||
(LISP:DO ((TYPE (LISP:TYPE-OF CONDITION)
|
||||
(CONDITION-PARENT TYPE)))
|
||||
((NULL TYPE))
|
||||
(LET ((HANDLER (CONDITION-HANDLER TYPE)))
|
||||
(LISP:WHEN HANDLER (LISP:FUNCALL HANDLER CONDITION)))))
|
||||
|
||||
(LISP:DEFUN DEFAULT-PROCEED-REPORTER (PC STREAM)
|
||||
(LISP:FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME PC)))
|
||||
|
||||
(LISP:DEFUN CONDITIONS::DEFAULT-RESTART-REPORTER (CONDITIONS:RESTART STREAM)
|
||||
(LISP:FORMAT STREAM "Restart type: ~A" (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)))
|
||||
|
||||
(DEFMACRO DEFAULT-PROCEED-TEST (XCL::PROCEED-TYPE)
|
||||
`(GETPROP ,XCL::PROCEED-TYPE '%DEFAULT-PROCEED-TEST))
|
||||
|
||||
(LISP:DEFUN TEST-PROCEED-CASE (PC &AUX FILTER)
|
||||
(COND
|
||||
((LISP:SETF FILTER (CONDITIONS::RESTART-TEST PC))
|
||||
(LISP:FUNCALL FILTER))
|
||||
((CONDITIONS:RESTART-NAME PC)
|
||||
(LISP:IF (LISP:SETF FILTER (DEFAULT-PROCEED-TEST (CONDITIONS:RESTART-NAME PC)))
|
||||
(LISP:FUNCALL FILTER)
|
||||
T))
|
||||
(T (* \;
|
||||
"unnamed proceed case with no explicit test")
|
||||
T)))
|
||||
|
||||
(LISP:DEFUN WALK-PROCEED-CASES (PROCEED-CASES PRED)
|
||||
(LISP:FLET ((CONVERT-PROCEED-CASE (PC BLIP)
|
||||
(LISP:IF (NULL (CONDITIONS::RESTART-TAG PC))
|
||||
(LET ((NEW (CONDITIONS::COPY-RESTART PC)))
|
||||
(LISP:SETF (CONDITIONS::RESTART-TAG NEW)
|
||||
BLIP)
|
||||
NEW)
|
||||
PC)))
|
||||
(LISP:DO ((TAIL PROCEED-CASES (CDR TAIL)))
|
||||
((NULL TAIL)
|
||||
NIL)
|
||||
(LISP:MACROLET ((PROCESS-THING (THING BLIP)
|
||||
`(LET ((PC (CONVERT-PROCEED-CASE ,THING ,BLIP)))
|
||||
(LISP:WHEN (LISP:FUNCALL PRED PC)
|
||||
(LISP:RETURN-FROM WALK-PROCEED-CASES PC)))))
|
||||
(LET ((OBJECT (CAR TAIL)))
|
||||
(LISP:IF (LISP:CONSP OBJECT)
|
||||
(LISP:DO ((THINGS OBJECT (CDR THINGS)))
|
||||
((NULL THINGS))
|
||||
(PROCESS-THING (CAR THINGS)
|
||||
TAIL))
|
||||
(PROCESS-THING OBJECT TAIL)))))))
|
||||
|
||||
(LISP:DEFUN SI::INVOKE-ACTUAL-RESTART (SI::RESTART SI::ARGUMENTS)
|
||||
(COND
|
||||
((NULL (CONDITIONS::RESTART-FUNCTION SI::RESTART))
|
||||
(LISP:THROW (CONDITIONS::RESTART-TAG SI::RESTART)
|
||||
(CONS (CONDITIONS::RESTART-SELECTOR SI::RESTART)
|
||||
SI::ARGUMENTS)))
|
||||
((EQ (CONDITIONS::RESTART-SELECTOR SI::RESTART)
|
||||
'SI::COMPLEX-RESTART-MARKER)
|
||||
(LISP:APPLY (CONDITIONS::RESTART-FUNCTION SI::RESTART)
|
||||
SI::ARGUMENTS))
|
||||
(T (LISP:ERROR "Malformed restart object ~S." SI::RESTART))))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")
|
||||
|
||||
|
||||
(LISP:DEFVAR CONDITIONS:*BREAK-ON-SIGNALS* NIL)
|
||||
|
||||
(LISP:DEFVAR *BREAK-ON-WARNINGS* NIL
|
||||
"If true, calls to WARN will cause a break as well as logging the warning.")
|
||||
|
||||
(LISP:DEFVAR XCL:*CURRENT-CONDITION* NIL
|
||||
"The condition currently being signalled")
|
||||
|
||||
(LISP:DEFUN MAKE-CONDITION (TYPE &REST XCL::SLOT-INITIALIZATIONS)
|
||||
"Create a condition object of the specified type."
|
||||
(LISP:APPLY (LISP::STRUCTURE-CONSTRUCTOR TYPE)
|
||||
XCL::SLOT-INITIALIZATIONS))
|
||||
|
||||
(LISP:DEFUN SIGNAL (XCL::DATUM &REST XCL::ARGS)
|
||||
(LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION XCL::DATUM 'SIMPLE-CONDITION XCL::ARGS)))
|
||||
(RAISE-SIGNAL (LISP:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*))
|
||||
(LISP:RETURN-FROM SIGNAL XCL:*CURRENT-CONDITION*)))
|
||||
|
||||
(LISP:DEFUN LISP:ERROR (LISP::DATUM &REST LISP::ARGS)
|
||||
|
||||
(* |;;| "In Xerox Common Lisp, as with Interlisp, errors may not enter the debugger if they are simple, defined by ENTER-DEBUGGER-P")
|
||||
|
||||
(LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-ERROR LISP::ARGS)))
|
||||
(RAISE-SIGNAL (LISP:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*))
|
||||
(* \; "may just unwind.")
|
||||
(RESETLST
|
||||
(LET ((PRINTMSG T)
|
||||
(ERRORPOS (FIND-DEBUGGER-ENTRY-FRAME 'LISP:ERROR)))
|
||||
(DECLARE (LISP:SPECIAL PRINTMSG ERRORPOS))
|
||||
(RESETSAVE NIL (LIST 'RELSTK ERRORPOS))
|
||||
(COND
|
||||
((NULL (ENTER-DEBUGGER-P HELPDEPTH ERRORPOS XCL:*CURRENT-CONDITION*))
|
||||
|
||||
(* |;;| " says not to enter debugger")
|
||||
|
||||
(COND
|
||||
(PRINTMSG (* \;
|
||||
"print message if no break is to occur.")
|
||||
(LISP:PRINC XCL:*CURRENT-CONDITION* *ERROR-OUTPUT*)))
|
||||
(ERROR!)))
|
||||
(DEBUGGER :CONDITION XCL:*CURRENT-CONDITION* :AT (STKNAME ERRORPOS))))))
|
||||
|
||||
(LISP:DEFUN LISP:CERROR (LISP::PROCEED-FORMAT-STRING LISP::DATUM &REST LISP::ARGUMENTS)
|
||||
(LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-ERROR LISP::ARGUMENTS)
|
||||
))
|
||||
(PROCEED-CASE (LISP:ERROR XCL:*CURRENT-CONDITION*)
|
||||
(CONDITIONS:CONTINUE NIL :REPORT (LISP:APPLY (FUNCTION LISP:FORMAT)
|
||||
T LISP::PROCEED-FORMAT-STRING
|
||||
LISP::ARGUMENTS)
|
||||
(LISP:RETURN-FROM LISP:CERROR XCL:*CURRENT-CONDITION*)))))
|
||||
|
||||
(LISP:DEFUN LISP:WARN (LISP::DATUM &REST LISP::ARGUMENTS)
|
||||
(LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-WARNING
|
||||
LISP::ARGUMENTS)))
|
||||
(LISP:UNLESS (TYPEP XCL:*CURRENT-CONDITION* 'WARNING)
|
||||
(LISP:CERROR "Signal and report the condition anyway" 'XCL:TYPE-MISMATCH :NAME
|
||||
'LISP::CONDITION :VALUE XCL:*CURRENT-CONDITION* :EXPECTED-TYPE 'WARNING))
|
||||
(LISP:WHEN *BREAK-ON-WARNINGS* (LISP:BREAK "Warning: ~A" XCL:*CURRENT-CONDITION*))
|
||||
(PROCEED-CASE (PROGN (RAISE-SIGNAL XCL:*CURRENT-CONDITION*)
|
||||
(LISP:FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%" XCL:*CURRENT-CONDITION*)
|
||||
NIL)
|
||||
(CONDITIONS:MUFFLE-WARNING NIL :REPORT "Don't print the warning" NIL))))
|
||||
|
||||
(LISP:DEFUN LISP:BREAK (&OPTIONAL (LISP::FORMAT-STRING "Break.")
|
||||
&REST LISP::FORMAT-ARGUMENTS)
|
||||
|
||||
(* |;;| "Want to try and get some indication of which break you're returning from.")
|
||||
|
||||
(PROCEED-CASE (CONDITIONS:INVOKE-DEBUGGER (MAKE-CONDITION 'SIMPLE-CONDITION :FORMAT-STRING
|
||||
LISP::FORMAT-STRING :FORMAT-ARGUMENTS
|
||||
LISP::FORMAT-ARGUMENTS))
|
||||
(CONDITIONS:CONTINUE NIL :REPORT "Return from BREAK" (LISP:RETURN-FROM LISP:BREAK NIL))
|
||||
))
|
||||
|
||||
(LISP:DEFUN CONDITIONS:INVOKE-DEBUGGER (CONDITION) (* \; "Edited 19-Feb-92 20:27 by jrb:")
|
||||
|
||||
(* |;;|
|
||||
"Look at the *DEBUGGER-HOOK* and call it; if you get back, enter debugger, never to return ")
|
||||
|
||||
(LISP:WHEN LISP:*DEBUGGER-HOOK* (LISP:FUNCALL LISP:*DEBUGGER-HOOK* CONDITION LISP:*DEBUGGER-HOOK*)
|
||||
)
|
||||
(DEBUGGER :CONDITION CONDITION))
|
||||
|
||||
(LISP:DEFUN LISP:FIND-RESTART (CONDITIONS::IDENTIFIER &OPTIONAL (XCL:*CURRENT-CONDITION*
|
||||
XCL:*CURRENT-CONDITION*))
|
||||
(* \; "Edited 24-Feb-92 12:02 by jrb:")
|
||||
(LISP:FLET ((CONDITIONS::SAME-RESTART (CONDITIONS::IDENTIFIER CONDITIONS::PROTOTYPE)))
|
||||
(LISP:ETYPECASE CONDITIONS::IDENTIFIER
|
||||
(NULL (LISP:ERROR "~S is an invalid argument to ~S;~% use ~S instead" NIL
|
||||
'LISP:FIND-RESTART
|
||||
'LISP:COMPUTE-RESTARTS))
|
||||
(CONDITIONS:RESTART (WALK-PROCEED-CASES
|
||||
*PROCEED-CASES*
|
||||
#'(LISP:LAMBDA (CONDITIONS:RESTART)
|
||||
(AND (OR (EQ CONDITIONS::IDENTIFIER CONDITIONS:RESTART)
|
||||
(AND (CONDITIONS::RESTART-TAG
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(EQ (CONDITIONS:RESTART-NAME
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS:RESTART-NAME
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-TAG
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-TAG
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-SELECTOR
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-SELECTOR
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-TEST
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-TEST
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-REPORT
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-REPORT
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-INTERACTIVE-FN
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-INTERACTIVE-FN
|
||||
CONDITIONS:RESTART))
|
||||
(EQ (CONDITIONS::RESTART-FUNCTION
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(CONDITIONS::RESTART-FUNCTION
|
||||
CONDITIONS:RESTART))))
|
||||
(TEST-PROCEED-CASE CONDITIONS:RESTART)))))
|
||||
(LISP:SYMBOL (WALK-PROCEED-CASES *PROCEED-CASES*
|
||||
#'(LISP:LAMBDA (CONDITIONS:RESTART)
|
||||
(AND (EQ (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)
|
||||
CONDITIONS::IDENTIFIER)
|
||||
(TEST-PROCEED-CASE CONDITIONS:RESTART))))))))
|
||||
|
||||
(LISP:DEFUN LISP:COMPUTE-RESTARTS (&OPTIONAL (XCL:*CURRENT-CONDITION* XCL:*CURRENT-CONDITION*))
|
||||
(* \; "Edited 24-Feb-92 12:01 by jrb:")
|
||||
(LET ((CONDITIONS::FOUND NIL))
|
||||
(WALK-PROCEED-CASES *PROCEED-CASES* #'(LISP:LAMBDA (CONDITIONS:RESTART)
|
||||
(LISP:WHEN (LISP:CATCH
|
||||
'SI::SKIP-PROCEED-CASE
|
||||
(TEST-PROCEED-CASE
|
||||
CONDITIONS:RESTART))
|
||||
(LISP:PUSH CONDITIONS:RESTART
|
||||
CONDITIONS::FOUND))
|
||||
NIL))
|
||||
(LISP:NREVERSE CONDITIONS::FOUND)))
|
||||
|
||||
(LISP:DEFUN LISP:INVOKE-RESTART (CONDITIONS:RESTART &REST CONDITIONS::ARGUMENTS)
|
||||
(LET ((CONDITIONS::R (LISP:FIND-RESTART CONDITIONS:RESTART)))
|
||||
(LISP:IF (NULL CONDITIONS::R)
|
||||
(LISP:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART)
|
||||
(SI::INVOKE-ACTUAL-RESTART CONDITIONS::R CONDITIONS::ARGUMENTS))))
|
||||
|
||||
(LISP:DEFUN CONDITIONS:INVOKE-RESTART-INTERACTIVELY (CONDITIONS:RESTART)
|
||||
(LET ((CONDITIONS::R (LISP:FIND-RESTART CONDITIONS:RESTART)))
|
||||
(LISP:IF (NULL CONDITIONS::R)
|
||||
(LISP:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART)
|
||||
(LET ((CONDITIONS::I-FN (CONDITIONS::RESTART-INTERACTIVE-FN CONDITIONS:RESTART)))
|
||||
(SI::INVOKE-ACTUAL-RESTART CONDITIONS::R (LISP:IF CONDITIONS::I-FN (LISP:FUNCALL
|
||||
|
||||
CONDITIONS::I-FN
|
||||
)))))))
|
||||
|
||||
(PUTPROPS ERROR-RUNTIME FILETYPE LISP:COMPILE-FILE)
|
||||
(PUTPROPS ERROR-RUNTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Reference in New Issue
Block a user