(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