(FILECREATED "10-Sep-86 21:45:42" {ERIS}<LISPCORE>NEWERR>CL-ERROR.;5 34893
changes to: (FUNCTIONS COLLECT-CASE-SELECTORS CCASE)
previous date: " 9-Sep-86 16:24:20" {ERIS}<LISPCORE>NEWERR>CL-ERROR.;4)
(* 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-TYPECASE CONDITION-BLOCK CONDITION-RETURN))
(COMS (* * "Internal stuff.")
(VARIABLES %%CONDITION-TYPES-REAL)
(FUNCTIONS DEFAULT-PROCEED-REPORT)
(FUNCTIONS STRIP-KEYWORDS MAKE-REPORT-FUNCTION NORMALIZE-SLOT-DESCRIPTIONS
EXTRACT-CONDITION-BINDINGS NORMALIZE-CONDITION-CLAUSES
MASSAGE-CATCH-CONDITION-CLAUSES SPLIT-PROCEED-CLAUSES PROCESS-PROCEED-KEYWORDS
CHECK-*CASE-SELECTOR COLLECT-CASE-SELECTORS NO-PROCEED-TEST ERR::WITH-LOOP-VARS
%%PREFIX-SYMBOL %%SUFFIX-SYMBOL REPORT-CONDITION))
(COMS (* * "User-visible forms.")
(FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE CL:ASSERT
CONDITION-BIND CONDITION-CASE IGNORE-ERRORS PROCEED-CASE DEFINE-PROCEED-FUNCTION
CATCH-ABORT)
(PROP PROPTYPE %%CONDITION-HANDLER %%CONDITION-REPORTER))
(PROP FILETYPE CL-ERROR)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(* * "Temporary bootstrapping stuff. Anything in here gets changed once CL starts working.")
(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))))
(* * "Internal stuff.")
(DEFPARAMETER %%CONDITION-TYPES-REAL NIL)
(DEFMACRO DEFAULT-PROCEED-REPORT (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
(QUOTE %%DEFAULT-PROCEED-REPORT)
(CL:FUNCTION DEFAULT-PROCEED-REPORTER))))
(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 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 (ECASE CCASE))))
then (COPY-LIST (CAR CLAUSE))
else (LIST (CHECK-*CASE-SELECTOR (CAR CLAUSE)
NAME)))))
CLAUSES))
(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)))))
(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)))
(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 (CL:IF STREAM (FUNCALL REPORTER
CONDITION STREAM
)
(WITH-OUTPUT-TO-STRING
(STREAM)
(FUNCALL REPORTER CONDITION
STREAM)))
(RETURN)))))
(* * "User-visible forms.")
(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 (CL:BLOCK (\, BLOCK-NAME)
(TAGBODY (\, AGAIN)
(LET (((\, VAL)
(\, KEYFORM)))
(RETURN-FROM (\, BLOCK-NAME)
(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
)))))
(PUTPROPS %%CONDITION-HANDLER PROPTYPE STRUCTURES)
(PUTPROPS %%CONDITION-REPORTER PROPTYPE STRUCTURES)
(PUTPROPS CL-ERROR FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CL-ERROR COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP