(FILECREATED "15-Jul-86 16:02:24" {ERIS}<LISPCORE>LIBRARY>CL-ERROR.;40
 60392  

      changes to:  (FUNCTIONS DEFINE-CONDITION CCASE CONDITION-CASE PROCEED-CASE 
                          DEFINE-PROCEED-FUNCTION FIND-PROCEED-CASE DEFAULT-HANDLE-CONDITION 
                          ERR::WITH-LOOP-VARS CHECK-TYPE ETYPECASE CTYPECASE ECASE CL:ASSERT)
                   (VARS CL-ERRORCOMS)

      previous date: " 4-Jul-86 01:34:27" {ERIS}<LISPCORE>LIBRARY>CL-ERROR.;35)


(* 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-TYPEP CONDITION-TYPE-OF CONDITION-SUBTYPEP CONDITION-TYPECASE 
                     CONDITION-BLOCK CONDITION-RETURN)
              (FUNCTIONS FAKE-TYPEP-FOR-CONDITIONS FAKE-TYPE-OF-FOR-CONDITIONS 
                     FAKE-SUBTYPEP-FOR-CONDITIONS))
        (COMS (* * "Internal stuff.")
              (VARIABLES %%CONDITION-TYPES-REAL)
              (VARIABLES *CONDITION-HANDLER-BINDINGS* *PROCEED-CASES* *DEBUGGED-CONDITION*)
              (VARIABLES *DEBUG-IO* *ERROR-OUTPUT*)
              (FUNCTIONS CONDITION-REPORTER CONDITION-HANDLER DEFAULT-PROCEED-REPORT 
                     DEFAULT-PROCEED-TEST)
              (FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL STRIP-KEYWORDS MAKE-REPORT-FUNCTION 
                     NORMALIZE-SLOT-DESCRIPTIONS EXTRACT-CONDITION-BINDINGS 
                     NORMALIZE-CONDITION-CLAUSES MASSAGE-CATCH-CONDITION-CLAUSES 
                     SPLIT-PROCEED-CLAUSES PROCESS-PROCEED-KEYWORDS DEFAULT-PROCEED-REPORTER 
                     CHECK-*CASE-SELECTOR COLLECT-CASE-SELECTORS FIX-INHERITANCE-LINKS 
                     MAKE-INTO-CONDITION RAISE-SIGNAL NO-PROCEED-TEST TEST-PROCEED-CASE 
                     DEFAULT-HANDLE-CONDITION ERR::WITH-LOOP-VARS))
        (COMS (* * "User-visible forms.")
              (VARIABLES *BREAK-ON-WARNINGS*)
              (FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE CL:ASSERT 
                     CONDITION-BIND CONDITION-CASE IGNORE-ERRORS PROCEED-CASE DEFINE-PROCEED-FUNCTION 
                     CATCH-ABORT SIGNAL CERROR DEBUG CL:BREAK COMPUTE-PROCEED-CASES FIND-PROCEED-CASE 
                     INVOKE-PROCEED-CASE REPORT-CONDITION)
              (PROP PROPTYPE %%CONDITION-HANDLER %%CONDITION-REPORTER)
              (FUNCTIONS ABORT PROCEED))
        (COMS (FNS MAKE-CONDITION)
              (STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING SERIOUS-CONDITION 
                     SIMPLE-BREAK CL:ERROR SIMPLE-ERROR ASSERTION-FAILED CELL-ERROR UNBOUND-VARIABLE 
                     UNDEFINED-FUNCTION NO-PROCEED-TEST INDEX-BOUNDS-ERROR)
              (STRUCTURES CALL-ERROR PROCEED-CASE TOO-MANY-ARGUMENTS)
              (COMS (FUNCTIONS PRETTY-TYPE-NAME REPORT-TYPE-MISMATCH)
                    (STRUCTURES TYPE-MISMATCH))
              (STRUCTURES CONTROL-ERROR BAD-PROCEED-CASE ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW)
              (STRUCTURES STREAM-ERROR READ-ERROR END-OF-FILE)
              (STRUCTURES STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED)
              (FUNCTIONS USE-VALUE))
        (COMS (* * "Environment stuff.")
              (FUNCTIONS PROCEED-FROM-BREAK PROCEED-WITH-DEFAULTS CREATE-PROCEED-KEYLIST 
                     PROCEED-USING-MENU CREATE-PROCEED-MENU)
              (ADDVARS (BREAKMACROS (PR (PROCEED-FROM-BREAK)))))
        (FUNCTIONS WARN CL:ERROR)
        (PROP FILETYPE CL-ERROR)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA MAKE-CONDITION)))))
(* * "Temporary bootstrapping stuff. Anything in here gets changed once CL starts working.")


(DEFMACRO CONDITION-TYPEP
 (DATUM TYPE) (BQUOTE (FAKE-TYPEP-FOR-CONDITIONS (\, DATUM)
                                                      (\, TYPE))))

(DEFMACRO CONDITION-TYPE-OF
 (DATUM) (BQUOTE (FAKE-TYPE-OF-FOR-CONDITIONS (\, DATUM))))

(DEFMACRO CONDITION-SUBTYPEP
 (T1 T2) (BQUOTE (FAKE-SUBTYPEP-FOR-CONDITIONS (\, T1)
                                                    (\, T2))))

(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))))

(DEFUN FAKE-TYPEP-FOR-CONDITIONS
 (DATUM TYPE) 
               (* amd " 9-Apr-86 17:41")

   (AND (CONSP DATUM)
        (CONDITION-SUBTYPEP (CAR DATUM)
               TYPE)))

(DEFUN FAKE-TYPE-OF-FOR-CONDITIONS
 (DATUM) (CAR DATUM))

(DEFUN FAKE-SUBTYPEP-FOR-CONDITIONS
 (T1 T2) 
                 (* amd " 9-Apr-86 18:04")

   (VALUES (AND (for
 old
 T1 by
 (GET T1 (QUOTE %%CONDITION-PARENT)) while
 T1
                   thereis
 (EQ T1 T2))
                T)
          T))

(* * "Internal stuff.")


(DEFPARAMETER %%CONDITION-TYPES-REAL
 NIL)

(DEFVAR *CONDITION-HANDLER-BINDINGS*
 NIL "Condition handler binding stack")

(DEFVAR *PROCEED-CASES*
 NIL "Active proceed case stack")

(DEFVAR *DEBUGGED-CONDITION*
 NIL "The condition passed to the latest instance of DEBUG")

(DEFVAR *DEBUG-IO*
 T)

(DEFVAR *ERROR-OUTPUT*
 T)

(DEFMACRO CONDITION-REPORTER
 (CONDITION-TYPE) (BQUOTE (GET (\, CONDITION-TYPE)
                                                           (QUOTE %%CONDITION-REPORTER))))

(DEFMACRO CONDITION-HANDLER
 (CONDITION-TYPE) (BQUOTE (GET (\, CONDITION-TYPE)
                                                          (QUOTE %%CONDITION-HANDLER))))

(DEFMACRO DEFAULT-PROCEED-REPORT
 (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
                                                             (QUOTE %%DEFAULT-PROCEED-REPORT)
                                                             (CL:FUNCTION DEFAULT-PROCEED-REPORTER))))

(DEFMACRO DEFAULT-PROCEED-TEST
 (PROCEED-TYPE) (BQUOTE (GET (\, PROCEED-TYPE)
                                                           (QUOTE %%DEFAULT-PROCEED-TEST))))

(DEFUN CHECK-TYPE-FAIL
 (PROCEEDABLE PLACE VALUE DESIRED-TYPE MESSAGE)
   (PROCEED-CASE (CL:ERROR (QUOTE TYPE-MISMATCH)
                        :NAME PLACE :VALUE VALUE :DESIRED-TYPE DESIRED-TYPE :MESSAGE MESSAGE)
          (USE-VALUE (IGNORE NEW)
                 :REPORT
                 (FORMAT T "Change the value of ~A" PLACE)
                 :TEST
                 (CL:LAMBDA (CONDITION)
                        (AND PROCEEDABLE (CONDITION-TYPEP CONDITION (QUOTE TYPE-MISMATCH))))
                 NEW)))

(DEFUN ECASE-FAIL
 (PROCEEDABLE PLACE VALUE SELECTORS) (PROCEED-CASE (CL:ERROR 
                                                                       "The value of ~S, ~S,~&is ~?." 
                                                                           PLACE VALUE 
                                   "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" 
                                                                           SELECTORS)
                                                             (USE-VALUE (IGNORE V)
                                                                    :TEST
                                                                    (CL:LAMBDA (CONDITION)
                                                                           (CL:DECLARE (IGNORE 
                                                                                            CONDITION
                                                                                              ))
                                                                           PROCEEDABLE)
                                                                    :REPORT
                                                                    (FORMAT T 
                                                                           "Change the value of ~A" 
                                                                           PLACE)
                                                                    V)))

(DEFUN ASSERT-FAIL
 (STRING &REST ARGS) (PROCEED-CASE (CL:ERROR (QUOTE ASSERTION-FAILED)
                                                            :FORMAT-STRING STRING :FORMAT-ARGUMENTS 
                                                            ARGS)
                                              (PROCEED NIL :REPORT "Re-test assertion")))

(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 DEFAULT-PROCEED-REPORTER
 (PC STREAM) (FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME
                                                                               PC)))

(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 (CTYPECASE ETYPECASE))))
                           then
 (CL:MAPCAR (FUNCTION (LAMBDA (SELECTOR)
                                                       (CHECK-*CASE-SELECTOR SELECTOR NAME)))
                                       (CAR CLAUSE))
                         else
 (LIST (CHECK-*CASE-SELECTOR (CAR CLAUSE)
                                           NAME)))))
          CLAUSES))

(DEFUN FIX-INHERITANCE-LINKS
 (NAME NEW-PARENT) (LET ((OLD-PARENT (GET NAME (QUOTE %%CONDITION-PARENT)
                                                                      )))
                                                    (CL:UNLESS (OR (EQ NEW-PARENT OLD-PARENT)
                                                                   (NULL OLD-PARENT))
                                                           (LET ((CHILDREN (GET OLD-PARENT
                                                                                (QUOTE 
                                                                                 %%CONDITION-CHILDREN
                                                                                       ))))
                                                                (SETF (GET OLD-PARENT (QUOTE 
                                                                                 %%CONDITION-CHILDREN
                                                                                             ))
                                                                      (DREMOVE NAME CHILDREN))))
                                                    (CL:PUSHNEW NAME (GET NEW-PARENT (QUOTE 
                                                                                 %%CONDITION-CHILDREN
                                                                                            )))
                                                    (SETF (GET NAME (QUOTE %%CONDITION-PARENT))
                                                          NEW-PARENT)))

(DEFUN MAKE-INTO-CONDITION
 (DATUM DESIRED-TYPE ARGS) 
        (* amd " 9-Apr-86 19:52")

   (if
 (CONDITION-TYPEP DATUM (QUOTE CONDITION))
       then
                                                  (* work-around until conditions are 

                                                             real)

            DATUM
     else
 (TYPECASE DATUM (SYMBOL (CL:WHEN (CONDITION-SUBTYPEP DATUM (QUOTE CONDITION))
                                         (CL:APPLY (FUNCTION MAKE-CONDITION)
                                                DATUM ARGS)))
                 (STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS))
                 (T NIL))))

(DEFUN RAISE-SIGNAL
 (C) 
                                     (* amd "31-Mar-86 19:15")

   (for
 CHB-TAIL on
 *CONDITION-HANDLER-BINDINGS* bind
 BINDING eachtime
 (SETQ BINDING (CAR CHB-TAIL))
      do
 (if
 (CONDITION-TYPEP C (CAR BINDING))
             then
 (LET ((*CONDITION-HANDLER-BINDINGS* (CDR CHB-TAIL)))
                       (FUNCALL (CDR BINDING)
                              C))))
   (DEFAULT-HANDLE-CONDITION C)
   C)

(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)))))

(DEFUN TEST-PROCEED-CASE
 (PC CONDITION &AUX TEST) 
           (* amd " 4-Apr-86 15:38")

   (COND
      ((SETF TEST (PROCEED-CASE-TEST PC))
       (FUNCALL TEST CONDITION))
      ((AND (PROCEED-CASE-NAME PC)
            (SETF TEST (OR (DEFAULT-PROCEED-TEST (PROCEED-CASE-NAME PC))
                           (NO-PROCEED-TEST (PROCEED-CASE-NAME PC)))))
       (FUNCALL TEST CONDITION))
      (T                                                     (* "This case shouldn't happen")

         (PROCEED-CASE (CL:ERROR "Couldn't find test function for ~S." PC)
                (PROCEED NIL :TEST TRUE :REPORT "Assume proceed case is enabled" T)))))

(DEFUN DEFAULT-HANDLE-CONDITION
 (CONDITION) 
                 (* amd " 9-Apr-86 20:20")

   (CL:DO ((TYPE (CONDITION-TYPE-OF CONDITION)
                 (GET TYPE (QUOTE %%CONDITION-PARENT))))
          ((NULL TYPE))
          (LET ((HANDLER (CONDITION-HANDLER TYPE)))
               (CL:WHEN HANDLER (FUNCALL HANDLER CONDITION)))))

(DEFMACRO ERR::WITH-LOOP-VARS
 (PREFIX &BODY BODY) (BQUOTE (LET ((VAL (GENSYM (\, PREFIX)))
                                                                (BLOCK-NAME (GENSYM (\, PREFIX)))
                                                                (AGAIN (GENSYM (\, PREFIX))))
                                                               (\,@ BODY))))

(* * "User-visible forms.")


(DEFVAR *BREAK-ON-WARNINGS*
 NIL)

(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 (TAGBODY (\, AGAIN)
                              (LET (((\, VAL)
                                     (\, KEYFORM)))
                                   (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
                                                                                       )))))

(DEFUN SIGNAL
 (DATUM &REST ARGS) 
                            (* amd " 9-Apr-86 19:53")

   (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                           ARGS)))
        (CL:IF (NULL CONDITION)
               (CL:ERROR "Bad argument to SIGNAL ~A." DATUM))
        (RAISE-SIGNAL CONDITION)
        (if
 (CONDITION-TYPEP CONDITION (QUOTE SERIOUS-CONDITION))
            then
 (DEBUG CONDITION))
        CONDITION))

(DEFUN CERROR
 (PROCEED-FORMAT-STRING DATUM &REST ARGUMENTS) 
 (* amd " 3-Apr-86 16:46")

   (PROCEED-CASE (CL:APPLY (FUNCTION CL:ERROR)
                        DATUM ARGUMENTS)
          (PROCEED NIL :REPORT (CL:APPLY (FUNCTION FORMAT)
                                      T PROCEED-FORMAT-STRING ARGUMENTS)
                 NIL)))

(DEFUN DEBUG
 (*DEBUGGED-CONDITION*) 
                         (* amd " 9-Apr-86 20:02")

   (LET ((MESSAGE (WITH-OUTPUT-TO-STRING (S)                 (* (FORMAT S "~A" *DEBUGGED-CONDITION*))

                         (REPORT-CONDITION *DEBUGGED-CONDITION* S))))
        (FUNCALL (FUNCTION BREAK1)
               NIL T (QUOTE DEBUG)
               NIL
               (QUOTE ERRORX)
               (LIST MESSAGE ""))))

(DEFUN CL:BREAK
 (DATUM &REST ARGUMENTS) 
                     (* AMD "21-Apr-86 15:52")

   (DECLARE
 (SPECVARS NBREAKS))
   (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-BREAK)
                           ARGUMENTS))
         (HACK (BQUOTE (CL:LAMBDA (P S)
                              (FORMAT S "Return from break: ~D" (\, (ADD1 NBREAKS)))))))
        (CL:UNLESS CONDITION (CL:ERROR "Bad argument to BREAK: ~S" DATUM))
          
          (* * HACK CL:UNTIL LEXICALITY WORKS...)


        (COMMON-LISP (CL:EVAL (BQUOTE (PROCEED-CASE (DEBUG (QUOTE (\, CONDITION)))
                                             (PROCEED (C)
                                                    :REPORT-FUNCTION
                                                    (CL:LAMBDA (P S)
                                                           (FUNCALL (QUOTE (\, HACK))
                                                                  P S))
                                                    C)))))
          
          (* * 

          "Don't just return the thing that PROCEED gave 'cause it might not be the same condition.")


        CONDITION))

(DEFUN COMPUTE-PROCEED-CASES
 (CONDITION) 
                    (* AMD "31-Mar-86 16:42")

   (for
 PC in
 *PROCEED-CASES* when
 (CATCH (QUOTE SKIP-PROCEED-CASE)
                                          (TEST-PROCEED-CASE PC CONDITION)) collect
 PC))

(DEFUN FIND-PROCEED-CASE
 (DATUM CONDITION) 
                  (* amd " 4-Apr-86 15:31")

   (TYPECASE DATUM (PROCEED-CASE (AND (CL:MEMBER DATUM *PROCEED-CASES* :TEST (CL:FUNCTION EQ
))
                                      (TEST-PROCEED-CASE DATUM CONDITION)
                                      DATUM))
          (SYMBOL (for
 PC in
 *PROCEED-CASES* thereis
 (AND (EQ (PROCEED-CASE-NAME PC)
                                                              DATUM)
                                                          (TEST-PROCEED-CASE PC CONDITION)
                                                          PC)))))

(DEFUN INVOKE-PROCEED-CASE
 (PROCEED-CASE CONDITION &REST VALUES) 

                                                             (* amd "22-Apr-86 15:19")

   (LET ((PC (FIND-PROCEED-CASE PROCEED-CASE CONDITION)))
        (IF
 PC
            THEN
 (AND (BOUNDP (QUOTE BREAKRESETVALS))
                      (BOUNDP (QUOTE \BREAKRESETEXPR))
                      (BREAKRESETFN (QUOTE LEAVING)))        (* Hack until THROW and RESETLST get 

                                                             along)

                 (THROW (PROCEED-CASE-TAG PC)
                        (LIST* (PROCEED-CASE-SELECTOR PC)
                               CONDITION VALUES))
          ELSE
 (CL:ERROR (QUOTE BAD-PROCEED-CASE)
                      :NAME PROCEED-CASE))))

(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 (FUNCALL REPORTER 
                                                                                  CONDITION STREAM)
                                                                           (RETURN)))))


(PUTPROPS %%CONDITION-HANDLER PROPTYPE
 STRUCTURES)

(PUTPROPS %%CONDITION-REPORTER PROPTYPE
 STRUCTURES)
(DEFINE-PROCEED-FUNCTION ABORT
 :TEST TRUE :REPORT "Abort")

(DEFINE-PROCEED-FUNCTION PROCEED
 :TEST TRUE)

(DEFINEQ

(MAKE-CONDITION

  (CL:LAMBDA (TYPE &REST SLOT-INITIALIZATIONS)
               (* lmm " 9-May-86 15:04")

         (CL:APPLY (STRUCTURE-CONSTRUCTOR TYPE)
                SLOT-INITIALIZATIONS)))
)
(DEFINE-CONDITION CONDITION
 CONDITION)

(DEFINE-CONDITION SIMPLE-CONDITION
 CONDITION :REPORT (CL:APPLY (FUNCTION FORMAT)
                                                            T
                                                            (SIMPLE-CONDITION-FORMAT-STRING CONDITION
                                                                   )
                                                            (SIMPLE-CONDITION-FORMAT-ARGUMENTS 
                                                                   CONDITION))
                                         FORMAT-STRING FORMAT-ARGUMENTS)

(DEFINE-CONDITION WARNING
 CONDITION)

(DEFINE-CONDITION SIMPLE-WARNING
 WARNING :REPORT (CL:APPLY (FUNCTION FORMAT)
                                                        T
                                                        (SIMPLE-WARNING-FORMAT-STRING CONDITION)
                                                        (SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION))
                                       FORMAT-STRING FORMAT-ARGUMENTS)

(DEFINE-CONDITION SERIOUS-CONDITION
 CONDITION)

(DEFINE-CONDITION SIMPLE-BREAK
 SERIOUS-CONDITION :REPORT (CL:APPLY (FUNCTION FORMAT)
                                                                T
                                                                (SIMPLE-BREAK-FORMAT-STRING CONDITION
                                                                       )
                                                                (SIMPLE-BREAK-FORMAT-ARGUMENTS 
                                                                       CONDITION))
                                     FORMAT-STRING FORMAT-ARGUMENTS)

(DEFINE-CONDITION CL:ERROR
 SERIOUS-CONDITION)

(DEFINE-CONDITION SIMPLE-ERROR
 CL:ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
                                                       T
                                                       (SIMPLE-ERROR-FORMAT-STRING CONDITION)
                                                       (SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION))
                                     FORMAT-STRING FORMAT-ARGUMENTS)

(DEFINE-CONDITION ASSERTION-FAILED
 SIMPLE-ERROR :REPORT (CL:APPLY (FUNCTION FORMAT)
                                                               T
                                                               (OR (ASSERTION-FAILED-FORMAT-STRING
                                                                    CONDITION)
                                                                   "Assertion failed.")
                                                               (ASSERTION-FAILED-FORMAT-ARGUMENTS
                                                                CONDITION)))

(DEFINE-CONDITION CELL-ERROR
 CL:ERROR NAME)

(DEFINE-CONDITION UNBOUND-VARIABLE
 CELL-ERROR :REPORT (FORMAT T "Unbound variable: ~S." (
                                                                                UNBOUND-VARIABLE-NAME
                                                                                         CONDITION)))

(DEFINE-CONDITION UNDEFINED-FUNCTION
 CELL-ERROR :REPORT (FORMAT T "Undefined function: ~S."
                                                               (UNDEFINED-FUNCTION-NAME CONDITION)))

(DEFINE-CONDITION NO-PROCEED-TEST
 UNDEFINED-FUNCTION :REPORT (FORMAT T 
                                                            "No test specified for proceed case: ~S."
                                                                    (UNDEFINED-FUNCTION-NAME 
                                                                           CONDITION)))

(DEFINE-CONDITION INDEX-BOUNDS-ERROR
 CELL-ERROR :REPORT (FORMAT T "Index out of bounds: ~D."
                                                               (INDEX-BOUNDS-ERROR-INDEX CONDITION))
                                           INDEX)

(DEFINE-CONDITION CALL-ERROR
 CONTROL-ERROR CALLEE)

(DEFSTRUCT (PROCEED-CASE
 (:PRINT-FUNCTION (CL:LAMBDA (PC STREAM LEVEL)
                                                 (CL:IF *PRINT-ESCAPE* (DEFAULT-STRUCTURE-PRINTER
                                                                        PC STREAM LEVEL)
                                                        (FUNCALL (PROCEED-CASE-REPORT PC)
                                                               PC STREAM))
                                                 T))) NAME TAG SELECTOR TEST REPORT)

(DEFINE-CONDITION TOO-MANY-ARGUMENTS
 CALL-ERROR :REPORT (FORMAT T "Too many arguments to ~A: ~A"
                                                               (TOO-MANY-ARGUMENTS-CALLEE CONDITION)
                                                               (TOO-MANY-ARGUMENTS-EXTRA-VALUES
                                                                CONDITION))
                                           EXTRA-VALUES)

(DEFUN PRETTY-TYPE-NAME
 (TYPESPEC) (CONCAT "a " TYPESPEC))

(DEFUN REPORT-TYPE-MISMATCH
 (C S) (FORMAT S "The value of ~A, ~A, is not ~A." (TYPE-MISMATCH-NAME
                                                                               C)
                                         (TYPE-MISMATCH-VALUE C)
                                         (if
 (TYPE-MISMATCH-MESSAGE C)
                                             then
 (TYPE-MISMATCH-MESSAGE C)
                                           else
 (PRETTY-TYPE-NAME (TYPE-MISMATCH-DESIRED-TYPE C)))))

(DEFINE-CONDITION TYPE-MISMATCH
 CELL-ERROR :REPORT-FUNCTION REPORT-TYPE-MISMATCH VALUE DESIRED-TYPE 
                                      MESSAGE)

(DEFINE-CONDITION CONTROL-ERROR
 CL:ERROR)

(DEFINE-CONDITION BAD-PROCEED-CASE
 CONTROL-ERROR)

(DEFINE-CONDITION ILLEGAL-GO
 CONTROL-ERROR :REPORT (FORMAT T "GO to a non-existant tag: ~S."
                                                          (ILLEGAL-GO-TAG CONDITION))
                                   TAG)

(DEFINE-CONDITION ILLEGAL-RETURN
 CONTROL-ERROR :REPORT (FORMAT T "RETURN to non-existant block: ~S."
                                                              (ILLEGAL-RETURN-TAG CONDITION))
                                       TAG)

(DEFINE-CONDITION ILLEGAL-THROW
 CONTROL-ERROR :REPORT (FORMAT T "Tag for THROW not found: ~S."
                                                             (ILLEGAL-THROW-TAG CONDITION))
                                      TAG)

(DEFINE-CONDITION STREAM-ERROR
 CL:ERROR STREAM)

(DEFINE-CONDITION READ-ERROR
 STREAM-ERROR)

(DEFINE-CONDITION END-OF-FILE
 READ-ERROR)

(DEFINE-CONDITION STORAGE-CONDITION
 SERIOUS-CONDITION)

(DEFINE-CONDITION STACK-OVERFLOW
 STORAGE-CONDITION)

(DEFINE-CONDITION STORAGE-EXHAUSTED
 STORAGE-CONDITION)

(DEFINE-PROCEED-FUNCTION USE-VALUE
 :REPORT "Use a different value" :TEST TRUE
                                         (VALUE (PROGN (FORMAT T "Enter a new value: ")
                                                       (EVAL (READ)))))

(* * "Environment stuff.")


(DEFUN PROCEED-FROM-BREAK
 NIL (LET ((KEYS (CREATE-PROCEED-KEYLIST *DEBUGGED-CONDITION*)))
                                   (CL:IF KEYS (LET ((CASE (PROGN (ASKUSEREXPLAIN KEYS NIL NIL "
")
                                                                  (ASKUSER NIL NIL "Proceed how? " 
                                                                         KEYS T))))
                                                    (CL:WHEN CASE (PROCEED-WITH-DEFAULTS CASE 
                                                                         *DEBUGGED-CONDITION*)))
                                          (FORMAT *DEBUG-IO* "~&No proceed cases enabled.~%%"))))

(DEFUN PROCEED-WITH-DEFAULTS
 (CASE CONDITION) 
               (* amd "21-Apr-86 15:44")

   (LET* ((NAME (PROCEED-CASE-NAME CASE))
          (ARGS (AND NAME (FBOUNDP NAME)
                     (EVAL (BQUOTE (PROCEED-CASE ((\, NAME)
                                                  (QUOTE (\, CONDITION)))
                                          ((\, NAME)
                                           (IGNORE &REST ARGS)
                                           :TEST TRUE ARGS)))))))
         (CL:APPLY (FUNCTION INVOKE-PROCEED-CASE)
                CASE CONDITION ARGS)))

(DEFUN CREATE-PROCEED-KEYLIST
 (CONDITION) 
                   (* amd "15-Apr-86 19:06")

   (LET ((CASES (COMPUTE-PROCEED-CASES CONDITION)))
        (CL:WHEN CASES (LET ((KEYLIST (for
 CASE in
 CASES as
 I from
 1 bind
 MESSAGE
                                         eachtime
 (SETQ MESSAGE (FORMAT NIL "~A " CASE))
                                         collect
 (BQUOTE ((\, I)
                                                          (\, MESSAGE)
                                                          NOECHOFLG T EXPLAINSTRING
                                                          (\, (CONCAT I " - " MESSAGE))
                                                          CONFIRMFLG T RETURN
                                                          (PROGN (TERPRI T)
                                                                 (QUOTE (\, CASE))))))))
                            (SETF (CDR (LAST KEYLIST))
                                  (QUOTE (("N" "No - don't proceed " NOECHOFLG T CONFIRMFLG T 
                                               AUTOCONFIRMFLG T RETURN (TERPRI T)))))
                            KEYLIST))))

(DEFUN PROCEED-USING-MENU
 NIL 
                               (* amd "21-Apr-86 15:41")

                              (LET ((MENU (CREATE-PROCEED-MENU *DEBUGGED-CONDITION*)))
                                   (CL:IF MENU (LET ((CASE (MENU MENU)))
                                                    (CL:WHEN CASE (PROCEED-WITH-DEFAULTS CASE 
                                                                         *DEBUGGED-CONDITION*)))
                                          (FORMAT *DEBUG-IO* "~&No proceed cases enabled.~%%"))))

(DEFUN CREATE-PROCEED-MENU
 (CONDITION) 
                      (* amd "25-Apr-86 14:53")

   (LET ((CASES (COMPUTE-PROCEED-CASES CONDITION)))
        (CL:WHEN CASES (create
 MENU
                              TITLE _ "Ways to proceed..."
                              ITEMS _ (CL:MAPCAR (FUNCTION (LAMBDA (CASE)
                                                             (LIST (FORMAT NIL "~A" CASE)
                                                                   CASE)))
                                             CASES)))))


(ADDTOVAR BREAKMACROS
 (PR (PROCEED-FROM-BREAK)))
(DEFUN WARN
 (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
                                                                                       )
                                                            ARGUMENTS)))
                                         (CL:WHEN (NULL CONDITION)
                                                (CL:ERROR "Bad argument ~S to WARN." DATUM))
                                         (RAISE-SIGNAL CONDITION)
                                         (if
 *BREAK-ON-WARNINGS*
                                             then
 (CL:BREAK CONDITION)
                                           else
 (FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%%"
                                                       (WITH-OUTPUT-TO-STRING (S)
                                                              (REPORT-CONDITION CONDITION S))))
                                         CONDITION))

(DEFUN CL:ERROR
 (DATUM &REST ARGS) 
                          (* amd " 4-Apr-86 16:41")

   (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-ERROR)
                           ARGS)))
        (CL:IF (NULL CONDITION)
               (CL:ERROR "Bad argument to ERROR ~A." DATUM))
        (RAISE-SIGNAL CONDITION)
        (DEBUG CONDITION)))


(PUTPROPS CL-ERROR FILETYPE
 COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MAKE-CONDITION)
)
(PUTPROPS CL-ERROR COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (47972 48186 (MAKE-CONDITION 47982 . 48184)))))
STOP