(FILECREATED "17-Jul-86 03:34:41" {ERIS}<LISPCORE>EVAL>CL-ERROR.;1
changes to: (STRUCTURES TOO-FEW-ARGUMENTS)
(VARS CL-ERRORCOMS)
previous date: "15-Jul-86 18:18:52" {ERIS}<LISPCORE>LIBRARY>CL-ERROR.;42)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CL-ERRORCOMS)
(RPAQQ CL-ERRORCOMS
[(COMS (* *
"Temporary bootstrapping stuff. Anything in here gets changed once CL starts working."
)
(FUNCTIONS CONDITION-TYPEP CONDITION-TYPE-OF CONDITION-SUBTYPEP CONDITION-TYPECASE
CONDITION-BLOCK CONDITION-RETURN)
(FUNCTIONS FAKE-TYPEP-FOR-CONDITIONS FAKE-TYPE-OF-FOR-CONDITIONS
FAKE-SUBTYPEP-FOR-CONDITIONS))
(COMS (* * "Internal stuff.")
(VARIABLES %%CONDITION-TYPES-REAL)
(VARIABLES *CONDITION-HANDLER-BINDINGS* *PROCEED-CASES* *DEBUGGED-CONDITION*)
(VARIABLES *DEBUG-IO* *ERROR-OUTPUT*)
(FUNCTIONS CONDITION-REPORTER CONDITION-HANDLER DEFAULT-PROCEED-REPORT
DEFAULT-PROCEED-TEST)
(FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL STRIP-KEYWORDS MAKE-REPORT-FUNCTION
NORMALIZE-SLOT-DESCRIPTIONS EXTRACT-CONDITION-BINDINGS
NORMALIZE-CONDITION-CLAUSES MASSAGE-CATCH-CONDITION-CLAUSES
SPLIT-PROCEED-CLAUSES PROCESS-PROCEED-KEYWORDS DEFAULT-PROCEED-REPORTER
CHECK-*CASE-SELECTOR COLLECT-CASE-SELECTORS FIX-INHERITANCE-LINKS
MAKE-INTO-CONDITION RAISE-SIGNAL NO-PROCEED-TEST TEST-PROCEED-CASE
DEFAULT-HANDLE-CONDITION ERR::WITH-LOOP-VARS %%PREFIX-SYMBOL %%SUFFIX-SYMBOL))
(COMS (* * "User-visible forms.")
(VARIABLES *BREAK-ON-WARNINGS*)
(FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE CL:ASSERT
CONDITION-BIND CONDITION-CASE IGNORE-ERRORS PROCEED-CASE DEFINE-PROCEED-FUNCTION
CATCH-ABORT SIGNAL CERROR DEBUG CL:BREAK COMPUTE-PROCEED-CASES FIND-PROCEED-CASE
INVOKE-PROCEED-CASE REPORT-CONDITION)
(PROP PROPTYPE %%CONDITION-HANDLER %%CONDITION-REPORTER)
(FUNCTIONS ABORT PROCEED))
(COMS (FNS MAKE-CONDITION)
(STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING SERIOUS-CONDITION
SIMPLE-BREAK CL:ERROR SIMPLE-ERROR ASSERTION-FAILED CELL-ERROR UNBOUND-VARIABLE
UNDEFINED-FUNCTION NO-PROCEED-TEST INDEX-BOUNDS-ERROR)
(STRUCTURES CALL-ERROR PROCEED-CASE TOO-MANY-ARGUMENTS TOO-FEW-ARGUMENTS)
(COMS (FUNCTIONS PRETTY-TYPE-NAME REPORT-TYPE-MISMATCH)
(STRUCTURES TYPE-MISMATCH))
(STRUCTURES CONTROL-ERROR BAD-PROCEED-CASE ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW)
(STRUCTURES STREAM-ERROR READ-ERROR END-OF-FILE)
(STRUCTURES STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED)
(FUNCTIONS USE-VALUE))
[COMS (* * "Environment stuff.")
(FUNCTIONS PROCEED-FROM-BREAK PROCEED-WITH-DEFAULTS CREATE-PROCEED-KEYLIST
PROCEED-USING-MENU CREATE-PROCEED-MENU)
(ADDVARS (BREAKMACROS (PR (PROCEED-FROM-BREAK]
(FUNCTIONS WARN CL:ERROR)
(PROP FILETYPE CL-ERROR)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA MAKE-CONDITION])
(* * "Temporary bootstrapping stuff. Anything in here gets changed once CL starts working.")
(DEFMACRO CONDITION-TYPEP (DATUM TYPE) (BQUOTE (FAKE-TYPEP-FOR-CONDITIONS (\, DATUM)
(\, TYPE))))
(DEFMACRO CONDITION-TYPE-OF (DATUM) (BQUOTE (FAKE-TYPE-OF-FOR-CONDITIONS (\, DATUM))))
(DEFMACRO CONDITION-SUBTYPEP (T1 T2) (BQUOTE (FAKE-SUBTYPEP-FOR-CONDITIONS (\, T1)
(\, T2))))
(DEFMACRO CONDITION-TYPECASE (OBJECT &REST CLAUSES)
(LET ((VAL (GENTEMP)))
(BQUOTE
(LET (((\, VAL)
(\, OBJECT)))
(COND
(\,@ (CL:MAPCAR (CL:FUNCTION
(CL:LAMBDA (CLAUSE)
(DESTRUCTURING-BIND
(SELECTOR . BODY)
CLAUSE
(CL:IF (EQ SELECTOR T)
CLAUSE
(BQUOTE ((CONDITION-TYPEP (\, VAL)
(QUOTE (\, SELECTOR)))
(\,@ BODY)))))))
CLAUSES)))))))
(DEFMACRO CONDITION-BLOCK (TAG &BODY FORMS) (BQUOTE (CATCH (QUOTE (\, TAG))
(\,@ FORMS))))
(DEFMACRO CONDITION-RETURN (TAG &OPTIONAL RESULT) (BQUOTE (THROW (QUOTE (\, TAG))
(\, RESULT))))
(DEFUN FAKE-TYPEP-FOR-CONDITIONS (DATUM TYPE) (* amd " 9-Apr-86 17:41")
(AND (CONSP DATUM)
(CONDITION-SUBTYPEP (CAR DATUM)
TYPE)))
(DEFUN FAKE-TYPE-OF-FOR-CONDITIONS (DATUM) (CAR DATUM))
(DEFUN FAKE-SUBTYPEP-FOR-CONDITIONS (T1 T2) (* amd " 9-Apr-86 18:04")
(VALUES (AND (for old T1 by (GET T1 (QUOTE %%CONDITION-PARENT)) while T1
thereis (EQ T1 T2))
T)
T))
(* * "Internal stuff.")
(DEFPARAMETER %%CONDITION-TYPES-REAL NIL)
(DEFVAR *CONDITION-HANDLER-BINDINGS* NIL "Condition handler binding stack")
(DEFVAR *PROCEED-CASES* NIL "Active proceed case stack")
(DEFVAR *DEBUGGED-CONDITION* NIL "The condition passed to the latest instance of DEBUG")
(DEFVAR *DEBUG-IO* T)
(DEFVAR *ERROR-OUTPUT* T)
(DEFMACRO CONDITION-REPORTER (CONDITION-TYPE) (BQUOTE (GET (\, CONDITION-TYPE)
(QUOTE %%CONDITION-REPORTER))))
(DEFMACRO CONDITION-HANDLER (CONDITION-TYPE) (BQUOTE (GET (\, CONDITION-TYPE)
(QUOTE %%CONDITION-HANDLER))))
(DEFMACRO DEFAULT-PROCEED-REPORT (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
(QUOTE %%DEFAULT-PROCEED-REPORT)
(CL:FUNCTION DEFAULT-PROCEED-REPORTER))))
(DEFMACRO DEFAULT-PROCEED-TEST (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
(QUOTE %%DEFAULT-PROCEED-TEST))))
(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 STRIP-KEYWORDS (ARGS) (* amd "27-Mar-86 17:06")
(LET ((KEYWORDS NIL))
(while (KEYWORDP (CAR ARGS)) do (CL:PUSH (LIST (CAR ARGS)
(CADR ARGS))
KEYWORDS)
(SETF ARGS (CDDR ARGS)))
(VALUES KEYWORDS ARGS)))
(DEFUN MAKE-REPORT-FUNCTION (DATUM BOUND-VAR) (* amd " 1-Apr-86 17:44")
(TYPECASE DATUM (STRING (BQUOTE (CL:LAMBDA (DATUM STREAM)
(DECLARE (IGNORE DATUM))
(FORMAT STREAM (\, DATUM)))))
(T (BQUOTE (CL:LAMBDA ((\, BOUND-VAR)
*STANDARD-OUTPUT*)
(\, DATUM))))))
(DEFUN NORMALIZE-SLOT-DESCRIPTIONS (SLOTS) (* amd "27-Mar-86 17:41")
(CL:MAPCAR (FUNCTION (CL:LAMBDA (SLOT)
(if (LISTP SLOT)
then (if (EQUAL (LENGTH SLOT)
1)
then (APPEND SLOT (QUOTE (NIL :READONLY T)))
else (BQUOTE ((\, (CAR SLOT))
(\, (CADR SLOT))
:READ-ONLY T (\,@ (CDDR SLOT)))))
else (BQUOTE ((\, SLOT)
NIL :READ-ONLY T)))))
SLOTS))
(DEFUN EXTRACT-CONDITION-BINDINGS (CLAUSES) (CL:MAPCAR
(FUNCTION (CL:LAMBDA
(CLAUSE)
(BQUOTE (CONS (QUOTE (\, (CL:FIRST CLAUSE)))
(\, (SECOND CLAUSE))))))
CLAUSES))
(DEFUN NORMALIZE-CONDITION-CLAUSES (CLAUSES)
(MAPCAN (FUNCTION (CL:LAMBDA
(CLAUSE)
(LET ((CONDITIONS (CL:FIRST CLAUSE)))
(TYPECASE CONDITIONS
(LIST (CL:IF (EQ (CL:FIRST CONDITIONS)
(QUOTE QUOTE))
(CL:ERROR "Bad condition spec ~s. Should be unquoted."
CONDITIONS)
(CL:MAPCAR (FUNCTION (CL:LAMBDA
(C)
(CL:IF (SYMBOLP C)
(CONS C (CDR CLAUSE))
(CL:ERROR
"Bad condition spec ~s. Should be list of unquoted symbols."
CONDITIONS))))
CONDITIONS)))
(SYMBOL (LIST CLAUSE))
(T (CL:ERROR
"Bad condition spec ~s. Should be symbol or list of symbols."
CONDITIONS))))))
CLAUSES))
(DEFUN MASSAGE-CATCH-CONDITION-CLAUSES (CLAUSES INIT-VALUE)
(CL:MAPCAR (FUNCTION (CL:LAMBDA (CLAUSE)
(LET ((SELECTOR (CL:FIRST CLAUSE))
(BVL (SECOND CLAUSE))
(FORMS (NTHCDR 2 CLAUSE)))
(CL:IF (NULL BVL)
(CONS SELECTOR FORMS)
(LIST SELECTOR (BQUOTE (LET ((\, (LIST (CAR BVL)
INIT-VALUE))
(\,@ (CDR BVL)))
(\,@ FORMS))))))))
CLAUSES))
(DEFUN SPLIT-PROCEED-CLAUSES (CLAUSES TAG) (* amd "21-Apr-86 16:02")
(LET
(CASES BODIES)
(for CLAUSE in CLAUSES as SELECTOR from 0
do (DESTRUCTURING-BIND
(NAME VARS)
CLAUSE
(MULTIPLE-VALUE-BIND
(TEST REPORT TAIL)
(PROCESS-PROCEED-KEYWORDS NAME (CDDR CLAUSE))
(if (NULL NAME)
then (CL:UNLESS TEST (SETF TEST (QUOTE TRUE)))
(CL:UNLESS REPORT (CL:ERROR
"Unnamed proceed cases must have a report method: ~S"
CLAUSE))
else (* (CL:UNLESS TEST (if
(NOT (GET NAME (QUOTE
%%DEFAULT-PROCEED-REPORT))) then
(WARN
"No test specified for proceed type ~A: may be undefined."
NAME))))
(CL:UNLESS REPORT (SETF REPORT (BQUOTE (CL:LAMBDA
(PC STREAM)
(FUNCALL (DEFAULT-PROCEED-REPORT
(QUOTE (\, NAME)))
PC STREAM))))))
(CL:PUSH (BQUOTE (MAKE-PROCEED-CASE :NAME (QUOTE (\, NAME))
:TAG
(\, TAG)
:SELECTOR
(\, SELECTOR)
:TEST
(FUNCTION (\, TEST))
:REPORT
(FUNCTION (\, REPORT))))
CASES)
(CL:PUSH (BQUOTE ((\, SELECTOR)
(FUNCTION (CL:LAMBDA (\, VARS)
(\,@ TAIL)))))
BODIES))))
(VALUES (REVERSE CASES)
(REVERSE BODIES))))
(DEFUN PROCESS-PROCEED-KEYWORDS (NAME ARG) (* amd " 4-Apr-86 14:49")
(LET (TEST REPORT)
(MULTIPLE-VALUE-BIND
(KEYS TAIL)
(STRIP-KEYWORDS ARG)
(for PAIR in KEYS
do (DESTRUCTURING-BIND (KEY VALUE)
PAIR
(CASE KEY (:TEST (CL:IF TEST (CL:ERROR
"Duplicate test form specified for proceed type ~S."
NAME))
(SETF TEST VALUE))
(:CONDITION (CL:IF TEST (CL:ERROR
"Duplicate test form specified for proceed type ~S."
NAME))
(SETF TEST (BQUOTE (CL:LAMBDA (C)
(CONDITION-TYPEP C (QUOTE (\, VALUE)))))
))
(:REPORT-FUNCTION (CL:IF REPORT (CL:ERROR
"Duplicate report form specified for proceed type ~S."
NAME))
(SETF REPORT VALUE))
(:REPORT (CL:IF REPORT (CL:ERROR
"Duplicate report form specified for proceed type ~S."
NAME))
(SETF REPORT (MAKE-REPORT-FUNCTION VALUE (QUOTE PROCEED-CASE))))
(OTHERWISE (CERROR "Ignore key/value pair"
"Illegal keyword ~S in proceed case ~S." KEY NAME)))))
(VALUES TEST REPORT TAIL))))
(DEFUN DEFAULT-PROCEED-REPORTER (PC STREAM) (FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME
PC)))
(DEFUN CHECK-*CASE-SELECTOR (SELECTOR NAME) (* amd "15-Apr-86 18:30")
(CL:IF (OR (EQ SELECTOR (QUOTE T))
(EQ SELECTOR (QUOTE OTHERWISE)))
(CL:ERROR "~A not allowed in the ~A form." SELECTOR NAME)
SELECTOR))
(DEFUN COLLECT-CASE-SELECTORS (CLAUSES NAME)
(MAPCAN (FUNCTION (LAMBDA (CLAUSE)
(if (AND (CONSP (CAR CLAUSE))
(FMEMB NAME (QUOTE (CTYPECASE ETYPECASE))))
then (CL:MAPCAR (FUNCTION (LAMBDA (SELECTOR)
(CHECK-*CASE-SELECTOR SELECTOR NAME)))
(CAR CLAUSE))
else (LIST (CHECK-*CASE-SELECTOR (CAR CLAUSE)
NAME)))))
CLAUSES))
(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 (GET NEW-PARENT (QUOTE
%%CONDITION-CHILDREN
)))
(SETF (GET NAME (QUOTE %%CONDITION-PARENT))
NEW-PARENT)))
(DEFUN MAKE-INTO-CONDITION (DATUM DESIRED-TYPE ARGS) (* amd " 9-Apr-86 19:52")
(if (CONDITION-TYPEP DATUM (QUOTE CONDITION))
then (* work-around until conditions are
real)
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 NIL))))
(DEFUN RAISE-SIGNAL (C) (* amd "31-Mar-86 19:15")
(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 NO-PROCEED-TEST (NAME &AUX ONCE) (PROCEED-CASE
(CONDITION-BIND
((NO-PROCEED-TEST (FUNCTION (LAMBDA (C)
(CL:WHEN
(EQ (NO-PROCEED-TEST-NAME
C)
NAME)
(CL:IF ONCE
(THROW (QUOTE
SKIP-PROCEED-CASE
)
NIL)
(SETF ONCE T)))))))
(CL:ERROR (QUOTE NO-PROCEED-TEST)
:NAME NAME))
(NIL NIL :REPORT "Use FALSE for the test" :CONDITION
NO-PROCEED-TEST (FUNCTION FALSE))
(PROCEED NIL :REPORT "Make TRUE the default test" :CONDITION
NO-PROCEED-TEST (SETF (DEFAULT-PROCEED-TEST NAME)
(CL:FUNCTION TRUE)))))
(DEFUN TEST-PROCEED-CASE (PC CONDITION &AUX TEST) (* amd " 4-Apr-86 15:38")
(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)))))
(DEFUN DEFAULT-HANDLE-CONDITION (CONDITION) (* amd " 9-Apr-86 20:20")
(CL:DO ((TYPE (CONDITION-TYPE-OF CONDITION)
(GET TYPE (QUOTE %%CONDITION-PARENT))))
((NULL TYPE))
(LET ((HANDLER (CONDITION-HANDLER TYPE)))
(CL:WHEN HANDLER (FUNCALL HANDLER CONDITION)))))
(DEFMACRO ERR::WITH-LOOP-VARS (PREFIX &BODY BODY) (BQUOTE (LET ((VAL (GENSYM (\, PREFIX)))
(BLOCK-NAME (GENSYM (\, PREFIX)))
(AGAIN (GENSYM (\, PREFIX))))
(\,@ BODY))))
(DEFUN %%PREFIX-SYMBOL (PREFIX SYMBOL) (INTERN (CONCATENATE (QUOTE STRING)
PREFIX
(SYMBOL-NAME SYMBOL))
(SYMBOL-PACKAGE SYMBOL)))
(DEFUN %%SUFFIX-SYMBOL (SYMBOL SUFFIX) (INTERN (CONCATENATE (QUOTE STRING)
(SYMBOL-NAME SYMBOL)
SUFFIX)
(SYMBOL-PACKAGE SYMBOL)))
(* * "User-visible forms.")
(DEFVAR *BREAK-ON-WARNINGS* NIL)
(DEFDEFINER DEFINE-CONDITION
STRUCTURES
(NAME PARENT-TYPE &REST ARGS)
"Defines a new condition type"
(LET ((CLASS-OPTIONS (BQUOTE ((:CONSTRUCTOR (\, (%%PREFIX-SYMBOL "%%MAKE-" NAME)))
(:COPIER NIL)
(:PREDICATE NIL))))
REPORTER HANDLER)
(MULTIPLE-VALUE-BIND
(KEYS SLOT-DESCRIPTIONS)
(STRIP-KEYWORDS ARGS)
(for PAIR in KEYS do (DESTRUCTURING-BIND
(KEY VALUE)
PAIR
(CASE KEY (:CONC-NAME (CL:PUSH PAIR CLASS-OPTIONS))
(:REPORT-FUNCTION (if REPORTER
then (CL:ERROR
"Report function already specified for ~S."
NAME)
else (SETF REPORTER VALUE)))
(:REPORT (if REPORTER
then (CL:ERROR
"Report function already specified for ~S."
NAME)
else (SETF REPORTER (MAKE-REPORT-FUNCTION
VALUE
(QUOTE CONDITION)))))
(:HANDLE (CL:UNLESS HANDLER (SETF HANDLER VALUE)))
(OTHERWISE (CERROR "Skip key-value pair"
"Illegal keyword ~S in DEFINE-CONDITION." KEY)
))))
(SETF SLOT-DESCRIPTIONS (NORMALIZE-SLOT-DESCRIPTIONS SLOT-DESCRIPTIONS))
(AND (NEQ PARENT-TYPE NAME)
(LET* ((ALL-SUPER-SLOTS (SLOT-LIST PARENT-TYPE))
(REDEFINED-SLOTS (for SLOT in SLOT-DESCRIPTIONS
when (CL:MEMBER (CAR SLOT)
ALL-SUPER-SLOTS :KEY (FUNCTION (CL:LAMBDA
(X)
(SLOT-NAME
X))))
collect SLOT)))
(CL:PUSH (LIST* :INCLUDE PARENT-TYPE REDEFINED-SLOTS)
CLASS-OPTIONS)
(SETF SLOT-DESCRIPTIONS (for SLOT in SLOT-DESCRIPTIONS
unless (CL:MEMBER SLOT REDEFINED-SLOTS) collect SLOT))
))
(BQUOTE (PROGN (DEFSTRUCT ((\, NAME) (:TYPE LIST)
:NAMED
(\,@ CLASS-OPTIONS)) (\,@ SLOT-DESCRIPTIONS) )
(\,@ (CL:IF (NEQ NAME PARENT-TYPE)
(BQUOTE ((FIX-INHERITANCE-LINKS (QUOTE (\, NAME))
(QUOTE (\, PARENT-TYPE)))))))
(\,@ (CL:IF (CONSP HANDLER)
(LET ((HANDLER-NAME (%%SUFFIX-SYMBOL NAME "-condition-handler")))
(PROG1 (BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (\,
HANDLER-NAME
)))
(CL:FUNCTION (\, HANDLER)))))
(SETQ HANDLER HANDLER-NAME)))))
(SETF (CONDITION-HANDLER (QUOTE (\, NAME)))
(QUOTE (\, HANDLER)))
(\,@ (CL:IF (CONSP REPORTER)
(LET ((REPORTER-NAME (%%SUFFIX-SYMBOL NAME "-condition-reporter")
))
(PROG1 (BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (\,
REPORTER-NAME
)))
(CL:FUNCTION (\, REPORTER)))))
(SETQ REPORTER REPORTER-NAME)))))
(SETF (CONDITION-REPORTER (QUOTE (\, NAME)))
(QUOTE (\, REPORTER)))
(QUOTE (\, NAME)))))))
(DEFMACRO CHECK-TYPE (PLACE TYPESPEC &OPTIONAL STRING)
(ERR::WITH-LOOP-VARS "CHECK-TYPE" (BQUOTE (CL:BLOCK
(\, BLOCK-NAME)
(TAGBODY (\, AGAIN)
(LET (((\, VAL)
(\, PLACE)))
(CL:WHEN (TYPEP (\, VAL)
(QUOTE (\, TYPESPEC)))
(RETURN-FROM (\, BLOCK-NAME)
(\, VAL)))
(SETF (\, PLACE)
(CHECK-TYPE-FAIL T
(QUOTE (\, PLACE))
(\, VAL)
(QUOTE (\, TYPESPEC))
(\, STRING)))
(GO (\, AGAIN))))))))
(DEFMACRO ETYPECASE (KEYFORM &BODY CLAUSES)
(LET ((VALUE (GENSYM "ETYPECASE"))
(CASE-SELECTORS (CONS (QUOTE OR)
(COLLECT-CASE-SELECTORS CLAUSES (QUOTE ETYPECASE)))))
(BQUOTE (LET (((\, VALUE)
(\, KEYFORM)))
(TYPECASE (\, VALUE)
(\,@ CLAUSES)
(T (CHECK-TYPE-FAIL NIL (QUOTE (\, KEYFORM))
(\, VALUE)
(QUOTE (\, CASE-SELECTORS))
NIL)))))))
(DEFMACRO CTYPECASE (KEYPLACE &BODY CLAUSES)
(LET ((CASE-SELECTORS (CONS (QUOTE OR)
(COLLECT-CASE-SELECTORS CLAUSES (QUOTE CTYPECASE)))))
(ERR::WITH-LOOP-VARS
"CTYPECASE"
(BQUOTE (CL:BLOCK (\, BLOCK-NAME)
(TAGBODY (\, AGAIN)
(LET (((\, VAL)
(\, KEYPLACE)))
(RETURN-FROM (\, BLOCK-NAME)
(TYPECASE (\, VAL)
(\,@ CLAUSES)
(T (SETF (\, KEYPLACE)
(CHECK-TYPE-FAIL T (QUOTE (\, KEYPLACE))
(\, VAL)
(QUOTE (\, CASE-SELECTORS))
NIL))
(GO (\, AGAIN))))))))))))
(DEFMACRO ECASE (KEYFORM &REST CLAUSES)
(LET ((VALUE (GENSYM "ECASE"))
(CASE-SELECTORS (COLLECT-CASE-SELECTORS CLAUSES (QUOTE ECASE))))
(CL:IF CASE-SELECTORS (BQUOTE (LET (((\, VALUE)
(\, KEYFORM)))
(CASE (\, VALUE)
(\,@ CLAUSES)
(T (ECASE-FAIL NIL (QUOTE (\, KEYFORM))
(\, VALUE)
(QUOTE (\, CASE-SELECTORS)))))))
(BQUOTE (CL:ERROR "Empty case statement.")))))
(DEFMACRO CCASE (KEYFORM &BODY CLAUSES)
(LET ((CASE-SELECTORS (COLLECT-CASE-SELECTORS CLAUSES (QUOTE CCASE))))
(CL:UNLESS CASE-SELECTORS (CL:ERROR "Empty CCASE."))
(ERR::WITH-LOOP-VARS "CCASE"
(BQUOTE (TAGBODY (\, AGAIN)
(LET (((\, VAL)
(\, KEYFORM)))
(CASE (\, VAL)
(\,@ CLAUSES)
(T (SETF (\, KEYFORM)
(ECASE-FAIL T (QUOTE (\, KEYFORM))
(\, VAL)
(QUOTE (\, CASE-SELECTORS))))
(GO (\, AGAIN))))))))))
(DEFMACRO CL:ASSERT (TEST-FORM &OPTIONAL PLACES STRING &REST ARGS)
(CL:UNLESS (CL:LISTP PLACES)
(CL:ERROR "~S should be a list of places." PLACES))
(ERR::WITH-LOOP-VARS "ASSERT" (BQUOTE (CL:BLOCK (\, BLOCK-NAME)
(TAGBODY (\, AGAIN)
(CL:WHEN (\, TEST-FORM)
(RETURN-FROM (\, BLOCK-NAME)
(VALUES)))
(ASSERT-FAIL (\, STRING)
(\,@ ARGS))
(GO (\, AGAIN)))))))
(DEFMACRO CONDITION-BIND (BINDINGS &REST FORMS) "Eval forms under temporary new condition handlers."
(BQUOTE (LET ((*CONDITION-HANDLER-BINDINGS* (LIST* (\,@ (EXTRACT-CONDITION-BINDINGS (
NORMALIZE-CONDITION-CLAUSES
BINDINGS)))
*CONDITION-HANDLER-BINDINGS*)))
(\,@ FORMS))))
(DEFMACRO CONDITION-CASE (FORM &REST BINDINGS)
"Eval form under temporary condition handlers that return alternate values."
(LET
((CLAUSES (NORMALIZE-CONDITION-CLAUSES BINDINGS))
(CONDITION (GENTEMP "CONDITION-CASE"))
(VALUES (GENTEMP "CONDITION-CASE"))
(BNAME (GENTEMP "CONDITION-CASE"))
(HANDLER (GENTEMP "CONDITION-CASE")))
(if (NULL CLAUSES)
then FORM
else (BQUOTE (LET* (((\, CONDITION)
NIL)
((\, VALUES)
(CONDITION-BLOCK (\, BNAME)
(LET (((\, HANDLER)
(FUNCTION (CL:LAMBDA (C)
(SETF (\, CONDITION)
C)
(CONDITION-RETURN (\, BNAME))))))
(CONDITION-BIND (((\, (CL:MAPCAR (FUNCTION CAR)
CLAUSES))
(\, HANDLER)))
(MULTIPLE-VALUE-LIST (\, FORM)))))))
(CL:IF (\, CONDITION)
(\, (if (EQL (LENGTH CLAUSES)
1)
then (CADR (CAR (MASSAGE-CATCH-CONDITION-CLAUSES CLAUSES
CONDITION)))
else (BQUOTE (CONDITION-TYPECASE (\, CONDITION)
(\,@ (MASSAGE-CATCH-CONDITION-CLAUSES
CLAUSES CONDITION))
(T (CL:ERROR
"Bug in condition-case!~&Unexpected condition: ~S."
(\, CONDITION)))))))
(VALUES-LIST (\, VALUES))))))))
(DEFMACRO IGNORE-ERRORS (&BODY FORMS) "Eval forms with handler for any condition of type ERROR."
(BQUOTE (CONDITION-CASE (PROGN (\,@ FORMS))
(CL:ERROR (CONDITION)
(VALUES NIL CONDITION)))))
(DEFMACRO PROCEED-CASE (FORM &REST CLAUSES)
"Eval forms, establishing a place to proceed from errors."
(LET
((SELECTOR (GENSYM "PROCEED-CASE"))
(VALUES (GENSYM "PROCEED-CASE"))
(TAG (GENSYM "PROCEED-CASE")))
(MULTIPLE-VALUE-BIND
(CASES BODIES)
(SPLIT-PROCEED-CLAUSES CLAUSES TAG)
(if (NULL CASES)
then FORM
else (BQUOTE (DESTRUCTURING-BIND ((\, SELECTOR)
\, VALUES)
(LET (((\, TAG)
(LIST NIL)))
(CATCH (\, TAG)
(CONS :NORMAL (LET ((*PROCEED-CASES* (LIST* (\,@ CASES)
*PROCEED-CASES*)))
(MULTIPLE-VALUE-LIST (\, FORM))))))
(CL:IF (EQ (\, SELECTOR)
:NORMAL)
(VALUES-LIST (\, VALUES))
(CL:APPLY (\, (if (EQL (LENGTH BODIES)
1)
then (CADR (CAR BODIES))
else (BQUOTE (CASE (\, SELECTOR)
(\,@ BODIES)))))
(\, VALUES)))))))))
(DEFDEFINER DEFINE-PROCEED-FUNCTION
FUNCTIONS
(NAME &REST TAIL)
(MULTIPLE-VALUE-BIND
(TEST REPORT VARS)
(PROCESS-PROCEED-KEYWORDS NAME TAIL)
(CL:UNLESS TEST (SETF TEST (QUOTE TRUE)))
(CL:UNLESS REPORT (SETF REPORT (QUOTE DEFAULT-PROCEED-REPORTER)))
(BQUOTE (PROGN (\,@ (CL:IF (CONSP TEST)
(LET ((TESTER (%%SUFFIX-SYMBOL NAME "-proceed-test")))
(PROG1 (BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (\, TESTER)))
(CL:FUNCTION (\, TEST)))))
(SETQ TEST TESTER)))))
(SETF (DEFAULT-PROCEED-TEST (QUOTE (\, NAME)))
(QUOTE (\, TEST)))
(\,@ (CL:IF (CONSP REPORT)
(LET ((REPORTER (%%SUFFIX-SYMBOL NAME "-proceed-reporter")))
(PROG1 (BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (\, REPORTER)))
(CL:FUNCTION (\, REPORT)))))
(SETQ REPORT REPORTER)))))
(SETF (DEFAULT-PROCEED-REPORT (QUOTE (\, NAME)))
(QUOTE (\, REPORT)))
(DEFUN (\, NAME) (&OPTIONAL CONDITION (\,@ VARS))
(CONDITION-CASE (INVOKE-PROCEED-CASE (QUOTE (\, NAME))
CONDITION
(\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (V)
(CL:IF (SYMBOLP V)
V
(CAR V))))
VARS)))
(BAD-PROCEED-CASE NIL NIL)))
))))
(DEFMACRO CATCH-ABORT (PRINT-FORM &BODY FORMS) (BQUOTE (PROCEED-CASE (PROGN (\,@ FORMS))
(ABORT (CONDITION)
:REPORT
(\, PRINT-FORM)
:TEST TRUE (VALUES NIL CONDITION
)))))
(DEFUN SIGNAL (DATUM &REST ARGS) (* amd " 9-Apr-86 19:53")
(LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
ARGS)))
(CL:IF (NULL CONDITION)
(CL:ERROR "Bad argument to SIGNAL ~A." DATUM))
(RAISE-SIGNAL CONDITION)
(if (CONDITION-TYPEP CONDITION (QUOTE SERIOUS-CONDITION))
then (DEBUG CONDITION))
CONDITION))
(DEFUN CERROR (PROCEED-FORMAT-STRING DATUM &REST ARGUMENTS) (* amd " 3-Apr-86 16:46")
(PROCEED-CASE (CL:APPLY (FUNCTION CL:ERROR)
DATUM ARGUMENTS)
(PROCEED NIL :REPORT (CL:APPLY (FUNCTION FORMAT)
T PROCEED-FORMAT-STRING ARGUMENTS)
NIL)))
(DEFUN DEBUG (*DEBUGGED-CONDITION*) (* amd " 9-Apr-86 20:02")
(LET ((MESSAGE (WITH-OUTPUT-TO-STRING (S) (* (FORMAT S "~A" *DEBUGGED-CONDITION*))
(REPORT-CONDITION *DEBUGGED-CONDITION* S))))
(FUNCALL (FUNCTION BREAK1)
NIL T (QUOTE DEBUG)
NIL
(QUOTE ERRORX)
(LIST MESSAGE ""))))
(DEFUN CL:BREAK (DATUM &REST ARGUMENTS) (* AMD "21-Apr-86 15:52")
(DECLARE (SPECVARS NBREAKS))
(LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-BREAK)
ARGUMENTS))
(HACK (BQUOTE (CL:LAMBDA (P S)
(FORMAT S "Return from break: ~D" (\, (ADD1 NBREAKS)))))))
(CL:UNLESS CONDITION (CL:ERROR "Bad argument to BREAK: ~S" DATUM))
(* * HACK CL: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 COMPUTE-PROCEED-CASES (CONDITION) (* AMD "31-Mar-86 16:42")
(for PC in *PROCEED-CASES* when (CATCH (QUOTE SKIP-PROCEED-CASE)
(TEST-PROCEED-CASE PC CONDITION)) collect PC))
(DEFUN FIND-PROCEED-CASE (DATUM CONDITION) (* amd " 4-Apr-86 15:31")
(TYPECASE DATUM (PROCEED-CASE (AND (CL:MEMBER DATUM *PROCEED-CASES* :TEST (CL:FUNCTION EQ))
(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 INVOKE-PROCEED-CASE (PROCEED-CASE CONDITION &REST VALUES)
(* amd "22-Apr-86 15:19")
(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))))
(DEFUN REPORT-CONDITION (CONDITION STREAM) (CL:DO* ((TYPE (CONDITION-TYPE-OF CONDITION)
(GET TYPE (QUOTE %%CONDITION-PARENT)))
(REPORTER (CONDITION-REPORTER TYPE)
(CONDITION-REPORTER TYPE)))
((NULL TYPE)
(CL:ERROR "No report function found for ~S."
CONDITION))
(CL:WHEN REPORTER (PROGN (FUNCALL REPORTER
CONDITION STREAM)
(RETURN)))))
(PUTPROPS %%CONDITION-HANDLER PROPTYPE STRUCTURES)
(PUTPROPS %%CONDITION-REPORTER PROPTYPE STRUCTURES)
(DEFINE-PROCEED-FUNCTION ABORT :TEST TRUE :REPORT "Abort")
(DEFINE-PROCEED-FUNCTION PROCEED :TEST TRUE)
(DEFINEQ
(MAKE-CONDITION
(CL:LAMBDA (TYPE &REST SLOT-INITIALIZATIONS) (* lmm " 9-May-86 15:04")
(CL:APPLY (STRUCTURE-CONSTRUCTOR TYPE)
SLOT-INITIALIZATIONS)))
)
(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 SERIOUS-CONDITION CONDITION)
(DEFINE-CONDITION SIMPLE-BREAK SERIOUS-CONDITION :REPORT (CL:APPLY (FUNCTION FORMAT)
T
(SIMPLE-BREAK-FORMAT-STRING CONDITION
)
(SIMPLE-BREAK-FORMAT-ARGUMENTS
CONDITION))
FORMAT-STRING FORMAT-ARGUMENTS)
(DEFINE-CONDITION CL:ERROR SERIOUS-CONDITION)
(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)
(DEFINE-CONDITION CALL-ERROR CONTROL-ERROR CALLEE)
(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)
(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)))
(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 BAD-PROCEED-CASE CONTROL-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 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)
(DEFINE-PROCEED-FUNCTION USE-VALUE :REPORT "Use a different value" :TEST TRUE
(VALUE (PROGN (FORMAT T "Enter a new value: ")
(EVAL (READ)))))
(* * "Environment stuff.")
(DEFUN PROCEED-FROM-BREAK NIL (LET ((KEYS (CREATE-PROCEED-KEYLIST *DEBUGGED-CONDITION*)))
(CL:IF KEYS (LET ((CASE (PROGN (ASKUSEREXPLAIN KEYS NIL NIL "
")
(ASKUSER NIL NIL "Proceed how? "
KEYS T))))
(CL:WHEN CASE (PROCEED-WITH-DEFAULTS CASE
*DEBUGGED-CONDITION*)))
(FORMAT *DEBUG-IO* "~&No proceed cases enabled.~%%"))))
(DEFUN PROCEED-WITH-DEFAULTS (CASE CONDITION) (* amd "21-Apr-86 15:44")
(LET* ((NAME (PROCEED-CASE-NAME CASE))
(ARGS (AND NAME (FBOUNDP NAME)
(EVAL (BQUOTE (PROCEED-CASE ((\, NAME)
(QUOTE (\, CONDITION)))
((\, NAME)
(IGNORE &REST ARGS)
:TEST TRUE ARGS)))))))
(CL:APPLY (FUNCTION INVOKE-PROCEED-CASE)
CASE CONDITION ARGS)))
(DEFUN CREATE-PROCEED-KEYLIST (CONDITION) (* amd "15-Apr-86 19:06")
(LET ((CASES (COMPUTE-PROCEED-CASES CONDITION)))
(CL:WHEN CASES (LET ((KEYLIST (for CASE in CASES as I from 1 bind MESSAGE
eachtime (SETQ MESSAGE (FORMAT NIL "~A " CASE))
collect (BQUOTE ((\, I)
(\, MESSAGE)
NOECHOFLG T EXPLAINSTRING
(\, (CONCAT I " - " MESSAGE))
CONFIRMFLG T RETURN
(PROGN (TERPRI T)
(QUOTE (\, CASE))))))))
(SETF (CDR (LAST KEYLIST))
(QUOTE (("N" "No - don't proceed " NOECHOFLG T CONFIRMFLG T
AUTOCONFIRMFLG T RETURN (TERPRI T)))))
KEYLIST))))
(DEFUN PROCEED-USING-MENU NIL (* amd "21-Apr-86 15:41")
(LET ((MENU (CREATE-PROCEED-MENU *DEBUGGED-CONDITION*)))
(CL:IF MENU (LET ((CASE (MENU MENU)))
(CL:WHEN CASE (PROCEED-WITH-DEFAULTS CASE
*DEBUGGED-CONDITION*)))
(FORMAT *DEBUG-IO* "~&No proceed cases enabled.~%%"))))
(DEFUN CREATE-PROCEED-MENU (CONDITION) (* amd "25-Apr-86 14:53")
(LET ((CASES (COMPUTE-PROCEED-CASES CONDITION)))
(CL:WHEN CASES (create MENU
TITLE ← "Ways to proceed..."
ITEMS ← (CL:MAPCAR (FUNCTION (LAMBDA (CASE)
(LIST (FORMAT NIL "~A" CASE)
CASE)))
CASES)))))
(ADDTOVAR BREAKMACROS (PR (PROCEED-FROM-BREAK)))
(DEFUN WARN (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
)
ARGUMENTS)))
(CL:WHEN (NULL CONDITION)
(CL:ERROR "Bad argument ~S to WARN." DATUM))
(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:ERROR (DATUM &REST ARGS) (* amd " 4-Apr-86 16:41")
(LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-ERROR)
ARGS)))
(CL:IF (NULL CONDITION)
(CL:ERROR "Bad argument to ERROR ~A." DATUM))
(RAISE-SIGNAL CONDITION)
(DEBUG CONDITION)))
(PUTPROPS CL-ERROR FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MAKE-CONDITION)
)
(PUTPROPS CL-ERROR COPYRIGHT ("Xerox Corporation" 1986))
STOP