(FILECREATED " 3-Oct-86 19:19:38" {ERIS}<DANIELS>LISP>CL-ERROR.;8 37921
changes to: (FUNCTIONS MAKE-ENCAPSULATION DEFINE-CONDITION REPORT-CONDITION CONDITION-TYPECASE
DEFAULT-PROCEED-REPORT WITH-GENSYMS WITH-ERR-LOOP-VARS STRIP-KEYWORDS
NORMALIZE-SLOT-DESCRIPTIONS EXTRACT-CONDITION-BINDINGS
NORMALIZE-CONDITION-CLAUSES MASSAGE-CATCH-CONDITION-CLAUSES
PROCESS-PROCEED-KEYWORDS CHECK-*CASE-SELECTOR NO-PROCEED-TEST ETYPECASE
ECASE HANDLER-BIND CONDITION-BIND CONDITION-CASE REAL-CONDITION-CASE
PROCEED-CASE)
(VARS CL-ERRORCOMS)
(VARIABLES %%CONDITION-TYPES-REAL)
previous date: " 3-Oct-86 18:39:23" {ERIS}<DANIELS>LISP>CL-ERROR.;7)
(* "
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.")
(EXPORT (VARIABLES %%CONDITION-TYPES-REAL))
(FUNCTIONS DEFAULT-PROCEED-REPORT)
(FUNCTIONS WITH-GENSYMS WITH-ERR-LOOP-VARS STRIP-KEYWORDS MAKE-REPORT-FUNCTION
MAKE-ENCAPSULATION 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 %%PREFIX-SYMBOL %%SUFFIX-SYMBOL
PROCEED-ARG-COLLECTOR))
(COMS (* ;; "User-visible forms.")
(FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE CL:ASSERT
HANDLER-BIND CONDITION-BIND CONDITION-CASE REAL-CONDITION-CASE IGNORE-ERRORS
PROCEED-CASE DEFINE-PROCEED-FUNCTION CATCH-ABORT))
(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)))
(CL:IF
%%CONDITION-TYPES-REAL
(BQUOTE (TYPECASE (\, OBJECT)
(\,@ CLAUSES)))
(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.")
(* FOLLOWING DEFINITIONS EXPORTED)
(DEFCONSTANT %%CONDITION-TYPES-REAL NIL)
(* END EXPORTED DEFINITIONS)
(DEFMACRO DEFAULT-PROCEED-REPORT (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
(QUOTE %%DEFAULT-PROCEED-REPORT)
(QUOTE DEFAULT-PROCEED-REPORTER))))
(DEFMACRO WITH-GENSYMS (VARS PREFIX &BODY BODY)
(BQUOTE (LET (\, (MAPCAR VARS (FUNCTION (CL:LAMBDA (VAR)
(BQUOTE ((\, VAR)
(GENSYM (\, PREFIX))))))))
(\,@ BODY))))
(DEFMACRO WITH-ERR-LOOP-VARS (PREFIX &BODY BODY) (BQUOTE (WITH-GENSYMS (VAL BLOCK-NAME AGAIN)
(\, PREFIX)
(\,@ BODY))))
(DEFUN STRIP-KEYWORDS (ARGS) (VALUES (FOR OLD ARGS ON ARGS BY CDDR WHILE (KEYWORDP (CL:FIRST ARGS))
COLLECT (LIST (CL:FIRST ARGS)
(SECOND ARGS)))
ARGS))
(DEFUN MAKE-REPORT-FUNCTION (DATUM BOUND-VAR &OPTIONAL ENCAPSULATION)
(ETYPECASE DATUM (STRING (BQUOTE (LAMBDA (DATUM STREAM)
(DECLARE (IGNORE DATUM))
(WRITE-STRING (\, DATUM)
STREAM))))
(LIST (BQUOTE (LAMBDA ((\, BOUND-VAR)
*STANDARD-OUTPUT*)
(\, (CL:IF (NULL ENCAPSULATION)
DATUM
(BQUOTE (LET (\, ENCAPSULATION)
(\, DATUM))))))))))
(DEFUN MAKE-ENCAPSULATION (CONDITION-TYPE SLOT-NAMES)
(MAPCAR (CL:REMOVE (QUOTE --DUMMY-SLOT--)
SLOT-NAMES)
(CL:FUNCTION (LAMBDA (SLOT)
(BQUOTE ((\, SLOT)
((\, (%%SUFFIX-SYMBOL CONDITION-TYPE (CONCATENATE (QUOTE STRING)
"-"
(SYMBOL-NAME SLOT))))
CONDITION)))))))
(DEFUN NORMALIZE-SLOT-DESCRIPTIONS (SLOTS)
(MAPCAR SLOTS (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)))))))
(DEFUN EXTRACT-CONDITION-BINDINGS (CLAUSES) (MAPCAR CLAUSES
(FUNCTION (CL:LAMBDA
(CLAUSE)
(BQUOTE
(CONS (QUOTE (\, (CL:FIRST CLAUSE)))
(\, (SECOND CLAUSE))))))))
(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)
(MAPCAR CONDITIONS (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))))))
)
(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)
(MAPCAR CLAUSES (FUNCTION (CL:LAMBDA
(CLAUSE)
(DESTRUCTURING-BIND
(SELECTOR BVL . FORMS)
CLAUSE
(CL:IF (NULL BVL)
(CONS SELECTOR FORMS)
(LIST SELECTOR (BQUOTE (LET ((\, (LIST (CAR BVL)
INIT-VALUE))
(\,@ (CDR BVL)))
(\,@ FORMS))))))))))
(DEFUN SPLIT-PROCEED-CLAUSES (CLAUSES TAG)
(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-TEST)))
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
(\, (AND TEST (BQUOTE (CL: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)
(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) (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
(HANDLER-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 %%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)))
(DEFMACRO PROCEED-ARG-COLLECTOR (NAME) (BQUOTE (GET (\, NAME)
(QUOTE %%PROCEED-ARG-COLLECTOR))))
(* ;; "User-visible forms.")
(DEFDEFINER DEFINE-CONDITION
STRUCTURES
(NAME PARENT-TYPE &REST ARGS)
"Defines a new condition type"
(FLET
((EXTRACT-SLOT-NAME (X)
(SLOT-NAME X)))
(LET
((CLASS-OPTIONS (BQUOTE ((\,@ (CL:IF %%CONDITION-TYPES-REAL (QUOTE ((:PRINT-FUNCTION
%%PRINT-CONDITION)))
(QUOTE ((:TYPE LIST)
:NAMED))))
(:CONSTRUCTOR (\, (%%PREFIX-SYMBOL "%%MAKE-" NAME)))
(:COPIER NIL)
(:PREDICATE NIL))))
REPORTER HANDLER ENCAPSULATION)
(MULTIPLE-VALUE-BIND
(KEYS SLOT-DESCRIPTIONS)
(STRIP-KEYWORDS ARGS)
(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
(CL:FUNCTION
EXTRACT-SLOT-NAME
)) 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))))
(SETF ENCAPSULATION (MAKE-ENCAPSULATION NAME (NCONC (MAPCAR (SLOT-LIST PARENT-TYPE)
(CL:FUNCTION EXTRACT-SLOT-NAME))
(MAPCAR SLOT-DESCRIPTIONS (CL:FUNCTION
EXTRACT-SLOT-NAME
)))))
(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)
ENCAPSULATION))))
(:HANDLER-FUNCTION (IF HANDLER
THEN (CL:ERROR "Handler already specified for ~S." NAME)
ELSE (SETF HANDLER VALUE)))
(:HANDLE (IF HANDLER
THEN (CL:ERROR "Handler already specified for ~S." NAME)
ELSE (SETF HANDLER (BQUOTE (LAMBDA (CONDITION)
(\, (CL:IF (NULL ENCAPSULATION)
VALUE
(BQUOTE (LET (\, ENCAPSULATION)
(\, VALUE))))))))))
(OTHERWISE (CERROR "Skip key-value pair" "Illegal keyword ~S in ~S." KEY (QUOTE
DEFINE-CONDITION
))))))
(BQUOTE (PROGN ((\, (CL:IF %%CONDITION-TYPES-REAL (QUOTE MDEFSTRUCT)
(QUOTE DEFSTRUCT)))
((\, NAME)
(\,@ 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 " default 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 " report method")))
(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)
(WITH-ERR-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)
(WITH-GENSYMS (VALUE)
"ETYPECASE"
(LET ((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)))))
(WITH-ERR-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)
(WITH-GENSYMS (VALUE)
"ECASE"
(LET ((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."))
(WITH-ERR-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))
(WITH-ERR-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 HANDLER-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-BIND (BINDINGS &REST FORMS)
"Eval forms under temporary new condition handlers; synonym for HANDLER-BIND"
(BQUOTE (HANDLER-BIND (\, BINDINGS)
(\,@ FORMS))))
(DEFMACRO CONDITION-CASE (FORM &REST BINDINGS)
"Eval form under temporary condition handlers that return alternate values."
(WITH-GENSYMS
(CONDITION VALUES BNAME HANDLER)
"CONDITION-CASE"
(LET
((CLAUSES (NORMALIZE-CONDITION-CLAUSES BINDINGS)))
(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))))))
(HANDLER-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 REAL-CONDITION-CASE (FORM &REST CASES)
(WITH-GENSYMS
(OUTER INNER CONDITION DUMMY)
"CONDITION-CASE"
(BQUOTE
(CL:BLOCK
(\, OUTER)
(MULTIPLE-VALUE-CALL
(CL:FUNCTION FUNCALL)
(CL:BLOCK
(\, INNER)
(HANDLER-BIND
(\,
(FOR CASE IN CASES
COLLECT
(DESTRUCTURING-BIND
(TYPES BVL . BODY)
CASE
(BQUOTE
((\, TYPES)
(CL:FUNCTION
(CL:LAMBDA
((\, CONDITION))
(RETURN-FROM
(\, INNER)
(VALUES (CL:FUNCTION
(CL:LAMBDA (\,@ (CL:IF BVL (LIST BVL)
(BQUOTE (((\, DUMMY))
(DECLARE (IGNORE (\, DUMMY)))))))
(\,@ BODY)))
(\, CONDITION))))))))))
(RETURN-FROM (\, OUTER)
(\, FORM)))))))))
(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."
(WITH-GENSYMS
(SELECTOR VALUES TAG)
"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 &AUX VARS)
(MULTIPLE-VALUE-BIND
(TEST REPORT ARGLIST)
(PROCESS-PROCEED-KEYWORDS NAME TAIL)
(SETF VARS (MAPCAR ARGLIST (CL:FUNCTION (LAMBDA (X)
(CL:IF (SYMBOLP X)
X
(CAR X))))))
(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)))
(SETF (PROCEED-ARG-COLLECTOR (QUOTE (\, NAME)))
(CL:FUNCTION (CL:LAMBDA (&OPTIONAL CONDITION (\,@ ARGLIST))
(LIST (\,@ VARS)))))
(DEFUN (\, NAME) (&OPTIONAL CONDITION (\,@ ARGLIST))
(CONDITION-CASE (INVOKE-PROCEED-CASE (QUOTE (\, NAME))
CONDITION
(\,@ 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 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