(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "17-Oct-86 17:30:10" {ERIS}<DANIELS>LISP>CL-ERROR.;14
 34983  

      changes to%:  (FUNCTIONS DEFINE-CONDITION IGNORE-ERRORS WITH-GENSYMS CL:CHECK-TYPE HANDLER-BIND 
                           PROCEED-ARG-COLLECTOR PROCEED-CASE REAL-PROCEED-CASE CONDITION-TYPECASE 
                           WITH-ERR-LOOP-VARS MAKE-FAKE-REPORT-FUNCTION MAKE-REPORT-FUNCTION 
                           NORMALIZE-CONDITION-CLAUSES PROCEED-CASE-FROM-CLAUSE 
                           COLLECT-CASE-SELECTORS NO-PROCEED-TEST CL:ETYPECASE CONDITION-CASE 
                           REAL-CONDITION-CASE)
                    (VARS CL-ERRORCOMS)

      previous date%: "16-Oct-86 17:34:09" {ERIS}<DANIELS>LISP>CL-ERROR.;13)


(* "
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-FAKE-REPORT-FUNCTION 
                     MAKE-REPORT-FUNCTION MAKE-ENCAPSULATION NORMALIZE-SLOT-DESCRIPTIONS 
                     EXTRACT-CONDITION-BINDINGS NORMALIZE-CONDITION-CLAUSES 
                     MASSAGE-CATCH-CONDITION-CLAUSES SPLIT-PROCEED-CLAUSES PROCEED-CASE-FROM-CLAUSE 
                     PROCESS-PROCEED-KEYWORDS CHECK-*CASE-SELECTOR COLLECT-CASE-SELECTORS 
                     NO-PROCEED-TEST %%PREFIX-SYMBOL %%SUFFIX-SYMBOL PROCEED-ARG-COLLECTOR))
        (COMS (* ;; 
           "User-visible forms. These should all be external symbols. Any others should be internal."
                 )
              (FUNCTIONS DEFINE-CONDITION CL:CHECK-TYPE CL:ETYPECASE CTYPECASE CL:ECASE CL:CCASE 
                     CL:ASSERT HANDLER-BIND CONDITION-BIND CONDITION-CASE REAL-CONDITION-CASE 
                     IGNORE-ERRORS PROCEED-CASE REAL-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 (CL:GENSYM)))
    (CL:IF
     %%CONDITION-TYPES-REAL
     `(CL:TYPECASE ,OBJECT ,@CLAUSES)
     `(LET ((,VAL ,OBJECT))
           (COND
              ,@(CL:MAPCAR #'(CL:LAMBDA (CLAUSE)
                                    (DESTRUCTURING-BIND (SELECTOR . BODY)
                                           CLAUSE
                                           (CL:IF (EQ SELECTOR T)
                                                  CLAUSE
                                                  `((CONDITION-TYPEP ,VAL ',SELECTOR)
                                                    ,@BODY)))) CLAUSES))))))

(DEFMACRO CONDITION-BLOCK
 (TAG &BODY FORMS) `(CL:CATCH ',TAG ,@FORMS))

(DEFMACRO CONDITION-RETURN
 (TAG &OPTIONAL RESULT) `(CL:THROW ',TAG ,RESULT))




(* ;; "Internal stuff.")


(* FOLLOWING DEFINITIONS EXPORTED)


(CL:DEFCONSTANT %%CONDITION-TYPES-REAL
 NIL)



(* END EXPORTED DEFINITIONS)

(DEFMACRO DEFAULT-PROCEED-REPORT
 (PROCEED-TYPE) `(CL:GET ,PROCEED-TYPE '%%DEFAULT-PROCEED-REPORT
                                                        'DEFAULT-PROCEED-REPORTER))

(DEFMACRO WITH-GENSYMS
 (VARS PREFIX &BODY BODY)
   `(LET ,(MAPCAR VARS (FUNCTION (CL:LAMBDA (VAR)
                                        `(,VAR (GENSYM ,PREFIX))))) ,@BODY))

(DEFMACRO WITH-ERR-LOOP-VARS
 (PREFIX &BODY BODY) `(WITH-GENSYMS (VAL BLOCK-NAME AGAIN)
                                                         ,PREFIX
                                                         ,@BODY))

(DEFUN STRIP-KEYWORDS
 (ARGS) (CL:VALUES (FOR
 OLD
 ARGS ON
 ARGS BY
 CDDR
                                           WHILE
 (CL:KEYWORDP (CL:FIRST ARGS))
                                           COLLECT
 (LIST (CL:FIRST ARGS)
                                                         (CL:SECOND ARGS)))
                                    ARGS))

(DEFUN MAKE-FAKE-REPORT-FUNCTION
 (DATUM BOUND-VAR &OPTIONAL ENCAPSULATION)
   (CL:ETYPECASE DATUM (CL:STRING `(LAMBDA (DATUM STREAM)
                                     (DECLARE
 (IGNORE DATUM))
                                     (CL:WRITE-STRING ,DATUM STREAM)))
          (LIST `(LAMBDA (,BOUND-VAR *STANDARD-OUTPUT*)
                   ,(CL:IF (NULL ENCAPSULATION)
                           DATUM
                           `(LET ,ENCAPSULATION ,DATUM))))))

(DEFUN MAKE-REPORT-FUNCTION
 (DATUM BOUND-VAR &OPTIONAL TYPE-NAME)
   (CL:ETYPECASE DATUM (CL:STRING `(LAMBDA (DATUM STREAM)
                                     (DECLARE
 (IGNORE DATUM))
                                     (CL:WRITE-STRING ,DATUM STREAM)))
          (LIST `(LAMBDA (,BOUND-VAR *STANDARD-OUTPUT*)
                   ,(CL:IF TYPE-NAME `(WITH
 ,TYPE-NAME ,BOUND-VAR ,DATUM) DATUM)))))

(DEFUN MAKE-ENCAPSULATION
 (CONDITION-TYPE SLOT-NAMES)
   (MAPCAR (CL:REMOVE '--DUMMY-SLOT-- SLOT-NAMES)
          #'(LAMBDA (SLOT)
              `(,SLOT (,(%%SUFFIX-SYMBOL CONDITION-TYPE (CL:CONCATENATE 'CL:STRING "-" (
                                                                                       CL: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 '(NIL :READONLY T))
                                             else
 `(,(CAR SLOT) ,(CADR SLOT) :READ-ONLY T
                                                          ,@(CDDR SLOT)))
                                    else
 `(,SLOT NIL :READ-ONLY T))))))

(DEFUN EXTRACT-CONDITION-BINDINGS
 (CLAUSES) (MAPCAR CLAUSES
                                                   (FUNCTION (CL:LAMBDA
                                                              (CLAUSE)
                                                              `(CONS ',(CL:FIRST CLAUSE)
                                                                     ,(CL:SECOND CLAUSE))))))

(DEFUN NORMALIZE-CONDITION-CLAUSES
 (CLAUSES)
   (MAPCONC CLAUSES (FUNCTION (CL:LAMBDA
                               (CLAUSE)
                               (LET ((CONDITIONS (CL:FIRST CLAUSE)))
                                    (CL:TYPECASE
                                     CONDITIONS
                                     (LIST (CL:IF (EQ (CL:FIRST CONDITIONS)
                                                      'QUOTE)
                                                  (CL:ERROR 
                                                         "Bad condition spec ~s. Should be unquoted." 
                                                         CONDITIONS)
                                                  (MAPCAR CONDITIONS
                                                         (FUNCTION (CL:LAMBDA
                                                                    (C)
                                                                    (CL:IF (CL:SYMBOLP C)
                                                                           (CONS C (CDR CLAUSE))
                                                                           (CL:ERROR 
                                         "Bad condition spec ~s. Should be list of unquoted symbols." 
                                                                                  CONDITIONS)))))))
                                     (CL:SYMBOL (LIST CLAUSE))
                                     (T (CL:ERROR 
                                        "Bad condition spec ~s. Should be symbol or list of symbols." 
                                               CONDITIONS))))))))

(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 `(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
           (CL:MULTIPLE-VALUE-BIND
            (TEST REPORT TAIL)
            (PROCESS-PROCEED-KEYWORDS NAME (CDDR CLAUSE))
            (if
 (NULL NAME)
                then
 (CL:UNLESS TEST (CL:SETF TEST 'TRUE))
                     (CL:UNLESS REPORT (CL:ERROR 
                                              "Unnamed proceed cases must have a report method: ~S" 
                                              CLAUSE))
              else
 (CL:UNLESS TEST (if
 (NOT (CL:GET NAME '%%DEFAULT-PROCEED-TEST))
                                       then
 (CL:WARN 
                                           "No test specified for proceed type ~A: may be undefined." 
                                                   NAME)))
                   (CL:UNLESS REPORT (CL:SETF REPORT `(CL:LAMBDA (PC STREAM)
                                                             (CL:FUNCALL (DEFAULT-PROCEED-REPORT
                                                                          ',NAME)
                                                                    PC STREAM)))))
            (CL:PUSH `(MAKE-PROCEED-CASE :NAME ',NAME :TAG ,TAG :SELECTOR ,SELECTOR :TEST
                             ,(AND TEST `#',TEST) :REPORT #',REPORT) CASES)
            (CL:PUSH `(,SELECTOR (FUNCTION (CL:LAMBDA ,VARS ,@TAIL))) BODIES))))
    (CL:VALUES (REVERSE CASES)
           (REVERSE BODIES))))

(DEFUN PROCEED-CASE-FROM-CLAUSE
 (CLAUSE TAG DUMMY)
   (DESTRUCTURING-BIND
    (NAME VARS . TAIL)
    CLAUSE
    (CL:MULTIPLE-VALUE-BIND
     (TEST REPORT BODY)
     (PROCESS-PROCEED-KEYWORDS NAME TAIL)
     (if
 (NULL NAME)
         then
 (CL:UNLESS TEST (CL:SETF TEST 'TRUE))
              (CL:UNLESS REPORT (CL:ERROR "Unnamed proceed cases must have a report method: ~S" 
                                       CLAUSE))
       else
 (CL:UNLESS TEST (if
 (NOT (CL:GET NAME '%%DEFAULT-PROCEED-TEST))
                                then
 (CL:WARN 
                                           "No test specified for proceed type ~A: may be undefined." 
                                            NAME)))
            (CL:UNLESS REPORT (CL:SETF REPORT `(CL:LAMBDA (PC STREAM)
                                                      (CL:FUNCALL (DEFAULT-PROCEED-REPORT
                                                                   ',NAME)
                                                             PC STREAM)))))
     `(MAKE-REAL-PROCEED-CASE :NAME ',NAME :TAG ,TAG :CONTINUATION
             #'(CL:LAMBDA (&OPTIONAL ,@(OR VARS (LIST DUMMY)))
                      ,@BODY) :TEST ,(AND TEST `#',TEST) :REPORT #',REPORT))))

(DEFUN PROCESS-PROCEED-KEYWORDS
 (NAME ARG)
   (LET (TEST REPORT)
        (CL: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))
                                       (CL:SETF TEST VALUE))
                            (:CONDITION (CL:IF TEST (CL:ERROR 
                                                 "Duplicate test form specified for proceed type ~S." 
                                                           NAME))
                                   (CL:SETF TEST `(CL:LAMBDA (C)
                                                         (CONDITION-TYPEP C ',VALUE))))
                            (:REPORT-FUNCTION (CL:IF REPORT (CL:ERROR 
                                               "Duplicate report form specified for proceed type ~S." 
                                                                   NAME))
                                   (CL:SETF REPORT VALUE))
                            (:REPORT (CL:IF REPORT (CL:ERROR 
                                               "Duplicate report form specified for proceed type ~S." 
                                                          NAME))
                                   (CL:SETF REPORT (MAKE-REPORT-FUNCTION VALUE 'PROCEED-CASE)))
                            (OTHERWISE (CL:CERROR "Ignore key/value pair" 
                                              "Illegal keyword ~S in proceed case ~S." KEY NAME)))))
         (CL:VALUES TEST REPORT TAIL))))

(DEFUN CHECK-*CASE-SELECTOR
 (SELECTOR NAME) (CL:IF (OR (EQ SELECTOR 'T)
                                                       (EQ SELECTOR 'OTHERWISE))
                                                   (CL:ERROR "~A not allowed in the ~A form." 
                                                          SELECTOR NAME)
                                                   SELECTOR))

(DEFUN COLLECT-CASE-SELECTORS
 (CLAUSES NAME)
   (MAPCONC CLAUSES (FUNCTION (CL:LAMBDA (CLAUSE)
                                     (if
 (AND (CL:CONSP (CAR CLAUSE))
                                              (FMEMB NAME '(CL:ECASE CL:CCASE)))
                                         then
 (CL:COPY-LIST (CAR CLAUSE))
                                       else
 (LIST (CHECK-*CASE-SELECTOR (CAR CLAUSE)
                                                         NAME)))))))

(DEFUN NO-PROCEED-TEST
 (NAME &AUX ONCE)
   (PROCEED-CASE (HANDLER-BIND ((NO-PROCEED-TEST (FUNCTION (CL:LAMBDA
                                                            (C)
                                                            (CL:WHEN (EQ (NO-PROCEED-TEST-NAME C)
                                                                         NAME)
                                                                   (CL:IF ONCE (CL:THROW '
                                                                                    SKIP-PROCEED-CASE 
                                                                                      NIL)
                                                                          (CL:SETF ONCE T)))))))
                        (CL:ERROR '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
                 (CL:SETF (DEFAULT-PROCEED-TEST NAME)
                        #'TRUE))))

(DEFUN %%PREFIX-SYMBOL
 (PREFIX CL:SYMBOL) (CL:INTERN (CL:CONCATENATE 'CL:STRING PREFIX (
                                                                                       CL:SYMBOL-NAME
                                                                                        CL:SYMBOL))
                                                 (CL:SYMBOL-PACKAGE CL:SYMBOL)))

(DEFUN %%SUFFIX-SYMBOL
 (CL:SYMBOL SUFFIX) (CL:INTERN (CL:CONCATENATE 'CL:STRING (CL:SYMBOL-NAME
                                                                                 CL:SYMBOL)
                                                            SUFFIX)
                                                 (CL:SYMBOL-PACKAGE CL:SYMBOL)))

(DEFMACRO PROCEED-ARG-COLLECTOR
 (NAME) "Function that collects user-specified optional args (excluding the condition) for a named proceed case."
   `(CL:GET ,NAME '%%PROCEED-ARG-COLLECTOR))




(* ;; 
"User-visible forms. These should all be external symbols. Any others should be internal.")


(DEFDEFINER DEFINE-CONDITION

   STRUCTURES
   (NAME PARENT-TYPE &REST ARGS)
   "Defines a new condition type"
   (CL:FLET
    ((EXTRACT-SLOT-NAME (X)
            (SLOT-NAME X)))
    (LET
     ((CLASS-OPTIONS `(,@(CL:IF %%CONDITION-TYPES-REAL '((:PRINT-FUNCTION %%PRINT-CONDITION))
                                '((:TYPE LIST)
                                  :NAMED)) (:CONSTRUCTOR ,(%%PREFIX-SYMBOL "%%MAKE-" NAME))
                             (:COPIER NIL)
                             (:PREDICATE NIL)))
      REPORTER HANDLER ENCAPSULATION)
     (CL:MULTIPLE-VALUE-BIND
      (KEYS SLOT-DESCRIPTIONS)
      (STRIP-KEYWORDS ARGS)
      (CL: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
                                                                              #'EXTRACT-SLOT-NAME)
                                      collect
 SLOT)))
                 (CL:PUSH (LIST* :INCLUDE PARENT-TYPE REDEFINED-SLOTS)
                        CLASS-OPTIONS)
                 (CL:SETF SLOT-DESCRIPTIONS (for
 SLOT in
 SLOT-DESCRIPTIONS
                                               unless
 (CL:MEMBER SLOT REDEFINED-SLOTS) collect
 SLOT))
                 ))
      (CL:UNLESS (AND NIL %%CONDITION-TYPES-REAL)
             (CL:SETF ENCAPSULATION (MAKE-ENCAPSULATION NAME (NCONC (MAPCAR (SLOT-LIST PARENT-TYPE)
                                                                           #'EXTRACT-SLOT-NAME)
                                                                    (MAPCAR SLOT-DESCRIPTIONS
                                                                           #'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
 (CL:SETF REPORTER VALUE)))
                (:REPORT (if
 REPORTER
                             then
 (CL:ERROR "Report function already specified for ~S." NAME)
                           else
 (CL:SETF REPORTER (CL:IF (AND NIL %%CONDITION-TYPES-REAL)
                                                         (MAKE-REPORT-FUNCTION VALUE 'CONDITION NAME)
                                                         (MAKE-FAKE-REPORT-FUNCTION VALUE
                                                                'CONDITION ENCAPSULATION)))))
                (:HANDLER-FUNCTION (IF
 HANDLER
                                       THEN
 (CL:ERROR "Handler already specified for ~S." NAME)
                                     ELSE
 (CL:SETF HANDLER VALUE)))
                (:HANDLE (IF
 HANDLER
                             THEN
 (CL:ERROR "Handler already specified for ~S." NAME)
                           ELSE
 (CL:SETF HANDLER `(LAMBDA (CONDITION)
                                                    ,(CL:IF (NULL ENCAPSULATION)
                                                            VALUE
                                                            `(LET ,ENCAPSULATION ,VALUE))))))
                (OTHERWISE (CL:CERROR "Skip key-value pair" "Illegal keyword ~S in ~S." KEY
                                  'DEFINE-CONDITION)))))
      `(PROGN (DEFSTRUCT ((\, NAME)
 ,@CLASS-OPTIONS) ,@SLOT-DESCRIPTIONS )

              ,@(CL:IF (NEQ NAME PARENT-TYPE)
                       `((FIX-INHERITANCE-LINKS ',NAME ',PARENT-TYPE)))
              ,@(CL:IF (CL:CONSP HANDLER)
                       (LET ((HANDLER-NAME (%%SUFFIX-SYMBOL NAME " default handler")))
                            (PROG1 `((CL:SETF (CL:SYMBOL-FUNCTION ',HANDLER-NAME)
                                            #',HANDLER)) (SETQ HANDLER HANDLER-NAME))))
              (CL:SETF (CONDITION-HANDLER ',NAME)
                     ,(AND HANDLER `#',HANDLER))
              ,@(CL:IF (CL:CONSP REPORTER)
                       (LET ((REPORTER-NAME (%%SUFFIX-SYMBOL NAME " report method")))
                            (PROG1 `((CL:SETF (CL:SYMBOL-FUNCTION ',REPORTER-NAME)
                                            #',REPORTER)) (SETQ REPORTER REPORTER-NAME))))
              (CL:SETF (CONDITION-REPORTER ',NAME)
                     ,(AND REPORTER `#',REPORTER))
              ',NAME)))))

(DEFMACRO CL:CHECK-TYPE
 (PLACE TYPESPEC &OPTIONAL CL:STRING)
   (WITH-ERR-LOOP-VARS "CHECK-TYPE" `(CL:BLOCK ,BLOCK-NAME
                                            (CL:TAGBODY ,AGAIN
                                                   (LET ((,VAL ,PLACE))
                                                        (CL:WHEN (TYPEP ,VAL ',TYPESPEC)
                                                               (CL:RETURN-FROM ,BLOCK-NAME))
                                                        (CL:SETF ,PLACE (CHECK-TYPE-FAIL
                                                                         T
                                                                         ',PLACE
                                                                         ,VAL
                                                                         ',TYPESPEC
                                                                         ,CL:STRING))
                                                        (GO ,AGAIN))))))

(DEFMACRO CL:ETYPECASE
 (KEYFORM &BODY CLAUSES)
   (WITH-GENSYMS (VALUE)
          "ETYPECASE"
          (LET ((CASE-SELECTORS (CONS 'OR (COLLECT-CASE-SELECTORS CLAUSES 'CL:ETYPECASE))))
               `(LET ((,VALUE ,KEYFORM))
                     (CL:TYPECASE ,VALUE ,@CLAUSES (T (CHECK-TYPE-FAIL NIL ',KEYFORM ,VALUE
                                                             ',CASE-SELECTORS NIL)))))))

(DEFMACRO CTYPECASE
 (KEYPLACE &BODY CLAUSES)
   (LET ((CASE-SELECTORS (CONS 'OR (COLLECT-CASE-SELECTORS CLAUSES 'CTYPECASE))))
        (WITH-ERR-LOOP-VARS
         "CTYPECASE"
         `(CL:BLOCK ,BLOCK-NAME (CL:TAGBODY
                                 ,AGAIN
                                 (LET ((,VAL ,KEYPLACE))
                                      (CL:RETURN-FROM ,BLOCK-NAME
                                             (CL:TYPECASE ,VAL ,@CLAUSES
                                                    (T (CL:SETF ,KEYPLACE (CHECK-TYPE-FAIL
                                                                           T
                                                                           ',KEYPLACE
                                                                           ,VAL
                                                                           ',CASE-SELECTORS NIL))
                                                       (GO ,AGAIN))))))))))

(DEFMACRO CL:ECASE
 (KEYFORM &REST CLAUSES)
   (WITH-GENSYMS (VALUE)
          "ECASE"
          (LET ((CASE-SELECTORS (COLLECT-CASE-SELECTORS CLAUSES 'CL:ECASE)))
               (CL:IF CASE-SELECTORS `(LET ((,VALUE ,KEYFORM))
                                           (CASE ,VALUE ,@CLAUSES (T (ECASE-FAIL NIL
                                                                            ',KEYFORM
                                                                            ,VALUE
                                                                            ',CASE-SELECTORS))))
                      `(CL:ERROR "Empty case statement.")))))

(DEFMACRO CL:CCASE
 (KEYFORM &BODY CLAUSES)
   (LET ((CASE-SELECTORS (COLLECT-CASE-SELECTORS CLAUSES 'CL:CCASE)))
        (CL:UNLESS CASE-SELECTORS (CL:ERROR "Empty CCASE."))
        (WITH-ERR-LOOP-VARS
         "CCASE"
         `(CL:BLOCK ,BLOCK-NAME (CL:TAGBODY
                                 ,AGAIN
                                 (LET ((,VAL ,KEYFORM))
                                      (CL:RETURN-FROM ,BLOCK-NAME
                                             (CASE ,VAL ,@CLAUSES
                                                   (T (CL:SETF ,KEYFORM (ECASE-FAIL
                                                                         T
                                                                         ',KEYFORM
                                                                         ,VAL
                                                                         ',CASE-SELECTORS))
                                                      (GO ,AGAIN))))))))))

(DEFMACRO CL:ASSERT
 (TEST-FORM &OPTIONAL PLACES CL:STRING &REST ARGS)
   (CL:UNLESS (CL:LISTP PLACES)
          (CL:ERROR "~S should be a list of places." PLACES))
   (WITH-ERR-LOOP-VARS "ASSERT" `(CL:BLOCK ,BLOCK-NAME (CL:TAGBODY ,AGAIN (CL:WHEN
                                                                           ,TEST-FORM
                                                                           (CL:RETURN-FROM
                                                                            ,BLOCK-NAME
                                                                            (CL:VALUES)))
                                                              (ASSERT-FAIL ,CL:STRING ,@ARGS)
                                                              (GO ,AGAIN)))))

(DEFMACRO HANDLER-BIND
 (BINDINGS &REST FORMS) "Eval forms under temporary new condition handlers."
   `(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"
   `(HANDLER-BIND ,BINDINGS ,@FORMS))

(DEFMACRO CONDITION-CASE
 (FORM &REST BINDINGS) 
                           "Eval form under condition handlers that provide alternate continuations."
   (WITH-GENSYMS
    (CONDITION CL:VALUES BNAME HANDLER)
    "CONDITION-CASE"
    (LET
     ((CLAUSES (NORMALIZE-CONDITION-CLAUSES BINDINGS)))
     (if
 (NULL CLAUSES)
         then
 FORM
       else
 `(LET* ((,CONDITION NIL)
                    (,CL:VALUES (CONDITION-BLOCK
                                 ,BNAME
                                 (LET ((,HANDLER (FUNCTION (CL:LAMBDA (C)
                                                                  (CL:SETF ,CONDITION C)
                                                                  (CONDITION-RETURN ,BNAME)))))
                                      (HANDLER-BIND ((,(CL:MAPCAR (FUNCTION CAR)
                                                              CLAUSES) ,HANDLER))
                                             (CL:MULTIPLE-VALUE-LIST ,FORM))))))
                   (CL:IF ,CONDITION ,(if
 (EQL (LENGTH CLAUSES)
                                               1)
                                          then
 (CADR (CAR (MASSAGE-CATCH-CONDITION-CLAUSES CLAUSES 
                                                                 CONDITION)))
                                        else
 `(CONDITION-TYPECASE ,CONDITION ,@(
                                                                      MASSAGE-CATCH-CONDITION-CLAUSES
                                                                                CLAUSES CONDITION)
                                                     (T (CL:ERROR 
                                                  "Bug in condition-case!~&Unexpected condition: ~S."
                                                               ,CONDITION)))) (CL:VALUES-LIST
                                                                               ,CL:VALUES)))))))

(DEFMACRO REAL-CONDITION-CASE
 (FORM &REST CASES) 
                           "Eval form under condition handlers that provide alternate continuations."
   (WITH-GENSYMS
    (OUTER INNER CONDITION DUMMY)
    "CONDITION-CASE"
    `(CL:BLOCK
      ,OUTER
      (CL:MULTIPLE-VALUE-CALL
       'CL:FUNCALL
       (CL:BLOCK
        ,INNER
        (HANDLER-BIND
         ,(FOR
 CASE IN
 CASES
             COLLECT

             (DESTRUCTURING-BIND
              (TYPES BVL . BODY)
              CASE
              `(,TYPES
                #'(CL:LAMBDA
                   (,CONDITION)
                   (CL:RETURN-FROM
                    ,INNER
                    (CL:VALUES #'(CL:LAMBDA ,@(CL:IF BVL (LIST BVL)
                                                     `((,DUMMY)
                                                       (DECLARE
 (IGNORE ,DUMMY)))) ,@BODY)
                           ,CONDITION))))))
         (CL:RETURN-FROM ,OUTER ,FORM)))))))

(DEFMACRO IGNORE-ERRORS
 (&BODY FORMS) "Eval forms with handler for any condition of type ERROR."
   `(CONDITION-CASE (PROGN ,@FORMS)
           (ERROR (CONDITION)
                  NIL)))

(DEFMACRO PROCEED-CASE
 (FORM &REST CLAUSES) 
                                           "Eval forms, establishing a place to proceed from errors."
   (WITH-GENSYMS
    (SELECTOR CL:VALUES TAG)
    "PROCEED-CASE"
    (CL:MULTIPLE-VALUE-BIND
     (CASES BODIES)
     (SPLIT-PROCEED-CLAUSES CLAUSES TAG)
     (if
 (NULL CASES)
         then
 FORM
       else
 `(DESTRUCTURING-BIND (,SELECTOR \, CL:VALUES)
                    (LET ((,TAG (LIST NIL)))
                         (CL:CATCH ,TAG (CONS :NORMAL (LET ((*PROCEED-CASES* (LIST* ,@CASES 
                                                                                    *PROCEED-CASES*))
                                                            )
                                                           (CL:MULTIPLE-VALUE-LIST ,FORM)))))
                    (CL:IF (EQ ,SELECTOR :NORMAL)
                           (CL:VALUES-LIST ,CL:VALUES)
                           (CL:APPLY ,(if
 (EQL (LENGTH BODIES)
                                               1)
                                          then
 (CADR (CAR BODIES))
                                        else
 `(CASE ,SELECTOR ,@BODIES)) ,CL:VALUES)))))))

(DEFMACRO REAL-PROCEED-CASE
 (FORM &REST CLAUSES) 
                                           "Eval forms, establishing a place to proceed from errors."
   (WITH-GENSYMS (OUTER TAG DUMMY)
          "PROCEED-CASE"
          `(CL:BLOCK ,OUTER (LET* ((,TAG (LIST NIL))
                                   (*PROCEED-CASES* (LIST* ,@(MAPCAR CLAUSES
                                                                    #'(CL:LAMBDA (CLAUSE)
                                                                             (
                                                                             PROCEED-CASE-FROM-CLAUSE
                                                                              CLAUSE TAG DUMMY))) 
                                                           *PROCEED-CASES*)))
                                  (CL:MULTIPLE-VALUE-CALL 'CL:FUNCALL (CL:CATCH ,TAG
                                                                             (CL:RETURN-FROM
                                                                              ,OUTER
                                                                              ,FORM)))))))

(DEFDEFINER DEFINE-PROCEED-FUNCTION

   FUNCTIONS
   (NAME &REST TAIL &AUX VARS)
   (CL:MULTIPLE-VALUE-BIND
    (TEST REPORT ARGLIST)
    (PROCESS-PROCEED-KEYWORDS NAME TAIL)
    (CL:SETF VARS (MAPCAR ARGLIST #'(LAMBDA (X)
                                      (CL:IF (CL:SYMBOLP X)
                                             X
                                             (CAR X)))))
    (CL:UNLESS TEST (CL:SETF TEST 'TRUE))
    (CL:UNLESS REPORT (CL:SETF REPORT 'DEFAULT-PROCEED-REPORTER))
    `(PROGN ,@(CL:IF (CL:CONSP TEST)
                     (LET ((TESTER (%%SUFFIX-SYMBOL NAME "-proceed-test")))
                          (PROG1 `((CL:SETF (CL:SYMBOL-FUNCTION ',TESTER)
                                          #',TEST)) (SETQ TEST TESTER))))
            (CL:SETF (DEFAULT-PROCEED-TEST ',NAME)
                   ',TEST)
            ,@(CL:IF (CL:CONSP REPORT)
                     (LET ((REPORTER (%%SUFFIX-SYMBOL NAME "-proceed-reporter")))
                          (PROG1 `((CL:SETF (CL:SYMBOL-FUNCTION ',REPORTER)
                                          #',REPORT)) (SETQ REPORT REPORTER))))
            (CL:SETF (DEFAULT-PROCEED-REPORT ',NAME)
                   ',REPORT)
            (CL:SETF (PROCEED-ARG-COLLECTOR ',NAME)
                   #'(CL:LAMBDA (&OPTIONAL CONDITION ,@ARGLIST)
                            (LIST ,@VARS)))
            (DEFUN (\,
 NAME) (&OPTIONAL CONDITION ,@ARGLIST) (CONDITION-CASE
                                                              (INVOKE-PROCEED-CASE
                                                               ',NAME CONDITION ,@VARS)
                                                              (BAD-PROCEED-CASE NIL NIL)))
)))

(DEFMACRO CATCH-ABORT
 (PRINT-FORM &BODY FORMS) `(PROCEED-CASE (PROGN ,@FORMS)
                                                       (ABORT (CONDITION)
                                                              :REPORT
                                                              ,PRINT-FORM :TEST TRUE (CL:VALUES
                                                                                      NIL CONDITION))
                                                       ))


(PUTPROPS CL-ERROR FILETYPE
 CL: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