(FILECREATED " 5-Oct-86 18:20:52" {ERIS}<LISPCORE>SOURCES>CL-ERROR.;5
 37258  

      changes to:  (FUNCTIONS IGNORE-ERRORS)

      previous date: " 3-Oct-86 19:19:38" {ERIS}<LISPCORE>SOURCES>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.")
              (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)
                         NIL))))

(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