(FILECREATED " 3-Oct-86 20:07:45" {ERIS}<DANIELS>LISP>ERROR-RUNTIME.;8
 29492  

      changes to:  (FUNCTIONS WARN)

      previous date: " 3-Oct-86 19:28:40" {ERIS}<DANIELS>LISP>ERROR-RUNTIME.;7)


(* "
Copyright (c) 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ERROR-RUNTIMECOMS)

(RPAQQ ERROR-RUNTIMECOMS
 
       ((COMS (* ;;; "Internal functions.")
              (FUNCTIONS CONDITION-TYPEP CONDITION-SUBTYPEP CONDITION-TYPE-OF 
                     FAKE-TYPEP-FOR-CONDITIONS FAKE-SUBTYPEP-FOR-CONDITIONS 
                     FAKE-TYPE-OF-FOR-CONDITIONS)
              (FUNCTIONS CONDITION-HANDLER CONDITION-REPORTER %%PRINT-CONDITION REPORT-CONDITION 
                     CONDITION-PARENT)
              (VARIABLES *CONDITION-HANDLER-BINDINGS* *PROCEED-CASES*)
              (FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL)
              (FUNCTIONS MAKE-INTO-CONDITION RAISE-SIGNAL DEFAULT-HANDLE-CONDITION 
                     DEFAULT-PROCEED-REPORTER FIX-INHERITANCE-LINKS DEFAULT-PROCEED-TEST 
                     TEST-PROCEED-CASE))
        (COMS (* ;;; "Pre-defined condition types.")
              (STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING OLD-BREAK1 
                     SERIOUS-CONDITION CL:ERROR OLD-INTERLISP-ERROR SIMPLE-ERROR ASSERTION-FAILED 
                     CELL-ERROR UNBOUND-VARIABLE UNDEFINED-FUNCTION NO-PROCEED-TEST 
                     INDEX-BOUNDS-ERROR)
              (COMS (FUNCTIONS PRETTY-TYPE-NAME)
                    (STRUCTURES TYPE-MISMATCH))
              (STRUCTURES CONTROL-ERROR ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW BAD-PROCEED-CASE)
              (STRUCTURES CALL-ERROR TOO-MANY-ARGUMENTS TOO-FEW-ARGUMENTS)
              (STRUCTURES STREAM-ERROR READ-ERROR END-OF-FILE)
              (STRUCTURES STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED))
        (COMS (* ;;; "Exported symbols.")
              (VARIABLES *BREAK-ON-WARNINGS*)
              (FUNCTIONS MAKE-CONDITION SIGNAL CL:ERROR CERROR WARN CL:BREAK DEBUG)
              (STRUCTURES PROCEED-CASE)
              (FUNCTIONS FIND-PROCEED-CASE COMPUTE-PROCEED-CASES INVOKE-PROCEED-CASE)
              (FUNCTIONS ABORT PROCEED USE-VALUE STORE-VALUE))
        (COMS (FUNCTIONS SIMPLE-FORMAT)
              (P (MOVD? (QUOTE SIMPLE-FORMAT)
                        (QUOTE FORMAT))))
        (PROP FILETYPE ERROR-RUNTIME)))



(* ;;; "Internal functions.")


(DEFMACRO CONDITION-TYPEP
 (DATUM TYPE) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (TYPEP (\, DATUM)
                                                                                    (\, TYPE)))
                                              (BQUOTE (FAKE-TYPEP-FOR-CONDITIONS (\, DATUM)
                                                             (\, TYPE)))))

(DEFMACRO CONDITION-SUBTYPEP
 (T1 T2) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (SUBTYPEP (\, T1)
                                                                                  (\, T2)))
                                            (BQUOTE (FAKE-SUBTYPEP-FOR-CONDITIONS (\, T1)
                                                           (\, T2)))))

(DEFMACRO CONDITION-TYPE-OF
 (DATUM) (CL:IF %%CONDITION-TYPES-REAL (BQUOTE (TYPE-OF (\, DATUM)))
                                           (BQUOTE (FAKE-TYPE-OF-FOR-CONDITIONS (\, DATUM)))))

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

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

(DEFUN FAKE-SUBTYPEP-FOR-CONDITIONS
 (T1 T2) (VALUES (AND (for
 old
 T1 by
 (CONDITION-PARENT T1)
                                                            while
 T1 thereis
 (EQ T1 T2))
                                                         T)
                                                   T))

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

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

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

(DEFUN %%PRINT-CONDITION
 (CONDITION STREAM LEVEL) (DECLARE
 (IGNORE LEVEL))
                                                  (CL:IF *PRINT-ESCAPE*
                                                         (FORMAT STREAM "~c<Condition ~S @ ~O,~O>"
                                                                (CODE-CHAR (fetch
 (READTABLEP 
                                                                                        HASHMACROCHAR
                                                                                         )
                                                                              of
 *READTABLE*))
                                                                (TYPE-OF CONDITION)
                                                                (\HILOC CONDITION)
                                                                (\LOLOC CONDITION))
                                                         (REPORT-CONDITION CONDITION STREAM)))

(DEFUN REPORT-CONDITION
 (CONDITION STREAM) (CL:DO* ((TYPE (CONDITION-TYPE-OF CONDITION)
                                                          (CONDITION-PARENT TYPE))
                                                    (REPORTER (CONDITION-REPORTER TYPE)
                                                           (CONDITION-REPORTER TYPE)))
                                                  ((NULL TYPE)
                                                   (CL:BREAK "No report function found for ~S." 
                                                          CONDITION))
                                                  (CL:WHEN REPORTER
                                                         (RETURN (CL:IF STREAM (FUNCALL REPORTER 
                                                                                      CONDITION 
                                                                                      STREAM)
                                                                        (WITH-OUTPUT-TO-STRING
                                                                         (STREAM)
                                                                         (FUNCALL REPORTER CONDITION 
                                                                                STREAM)))))))

(DEFMACRO CONDITION-PARENT
 (TYPE) (BQUOTE (GETPROP (\, TYPE)
                                                 (QUOTE %%CONDITION-PARENT))))

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

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

(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)
          (STORE-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)
                                                             (STORE-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 MAKE-INTO-CONDITION
 (DATUM DESIRED-TYPE ARGS) 
(* ;; "The entire thing should be a typecase.")

   (CL:IF (CONDITION-TYPEP DATUM (QUOTE CONDITION))
          DATUM
          (ETYPECASE DATUM (SYMBOL (CL:IF (CONDITION-SUBTYPEP DATUM (QUOTE CONDITION))
                                          (CL:APPLY (FUNCTION MAKE-CONDITION)
                                                 DATUM ARGS)
                                          (CL:ERROR "~S is not a condition type." DATUM)))
                 (STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS)))))

(DEFUN RAISE-SIGNAL
 (C) (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 DEFAULT-HANDLE-CONDITION
 (CONDITION) (CL:DO ((TYPE (CONDITION-TYPE-OF CONDITION)
                                                          (CONDITION-PARENT TYPE)))
                                                   ((NULL TYPE))
                                                   (LET ((HANDLER (CONDITION-HANDLER TYPE)))
                                                        (CL:WHEN HANDLER (FUNCALL HANDLER CONDITION))
                                                        )))

(DEFUN DEFAULT-PROCEED-REPORTER
 (PC STREAM) (FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME
                                                                               PC)))

(DEFUN FIX-INHERITANCE-LINKS
 (NAME NEW-PARENT) (LET ((OLD-PARENT (CONDITION-PARENT NAME)))
                                                    (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 (GETPROP NEW-PARENT (QUOTE
                                                                                          
                                                                                 %%CONDITION-CHILDREN
                                                                                          )))
                                                    (SETF (CONDITION-PARENT NAME)
                                                          NEW-PARENT)))

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

(DEFUN TEST-PROCEED-CASE
 (PC CONDITION &AUX TEST) (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)))))




(* ;;; "Pre-defined condition types.")


(DEFINE-CONDITION CONDITION
 CONDITION :REPORT "Condition ~S occurred." --DUMMY-SLOT--)

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

(DEFINE-CONDITION WARNING
 CONDITION)

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

(DEFINE-CONDITION OLD-BREAK1
 CONDITION :REPORT (DESTRUCTURING-BIND (MESS1 MESS2 MESS3)
                                                      LIST
                                                      (ERRORMESS1 MESS1 MESS2 MESS3))
                                   LIST)

(DEFINE-CONDITION SERIOUS-CONDITION
 CONDITION :REPORT (FORMAT T "Serious condition ~S occurred."
                                                             (CONDITION-TYPE-OF CONDITION)))

(DEFINE-CONDITION CL:ERROR
 SERIOUS-CONDITION)

(DEFINE-CONDITION OLD-INTERLISP-ERROR
 CL:ERROR :REPORT (CL:IF (EQ NUMBER 17)
                                                              (DESTRUCTURING-BIND (MESS1 . MESS2)
                                                                     MESSAGE
                                                                     (ERRORMESS1 MESS1 MESS2
                                                                            (QUOTE ERROR)))
                                                              (ERRORM (LIST NUMBER MESSAGE)))
                                            NUMBER MESSAGE)

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

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

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

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

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

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

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

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

(DEFINE-CONDITION TYPE-MISMATCH
 CELL-ERROR :REPORT (FORMAT T "The value of ~A, ~A, is not ~A." NAME 
                                                          VALUE (OR MESSAGE (PRETTY-TYPE-NAME 
                                                                                   DESIRED-TYPE)))
                                      VALUE DESIRED-TYPE MESSAGE)

(DEFINE-CONDITION CONTROL-ERROR
 CL:ERROR)

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

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

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

(DEFINE-CONDITION BAD-PROCEED-CASE
 CONTROL-ERROR :REPORT (FORMAT T 
                                                           "Proceed case ~S is not currently active." 
                                                                NAME)
                                         NAME)

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

(DEFINE-CONDITION TOO-MANY-ARGUMENTS
 CALL-ERROR :REPORT (CL:IF (AND MAXIMUM ACTUAL)
                                                               (FORMAT T 
                           "Too many arguments to ~A:~%%   ~D were given but at most ~D are accepted" 
                                                                      CALLEE ACTUAL MAXIMUM)
                                                               (FORMAT T "Too many arguments to ~A" 
                                                                      CALLEE))
                                           MAXIMUM ACTUAL)

(DEFINE-CONDITION TOO-FEW-ARGUMENTS
 CALL-ERROR :REPORT (CL:IF (AND MINIMUM ACTUAL)
                                                              (FORMAT T 
                          "Too few arguments to ~A:~%%   ~D were given but at least ~D are necessary" 
                                                                     CALLEE ACTUAL MINIMUM)
                                                              (FORMAT T "Too few arguments to ~A" 
                                                                     CALLEE))
                                          MINIMUM ACTUAL)

(DEFINE-CONDITION STREAM-ERROR
 CL:ERROR :REPORT (FORMAT T "Stream error on ~S." STREAM)
                                     STREAM)

(DEFINE-CONDITION READ-ERROR
 STREAM-ERROR)

(DEFINE-CONDITION END-OF-FILE
 READ-ERROR :REPORT "End of file:~%%    ~S" STREAM)

(DEFINE-CONDITION STORAGE-CONDITION
 SERIOUS-CONDITION)

(DEFINE-CONDITION STACK-OVERFLOW
 STORAGE-CONDITION :REPORT "Stack overflow")

(DEFINE-CONDITION STORAGE-EXHAUSTED
 STORAGE-CONDITION)




(* ;;; "Exported symbols.")


(DEFVAR *BREAK-ON-WARNINGS*
 NIL 
                          "If true, calls to WARN will cause a break as well as logging the warning.")

(DEFUN MAKE-CONDITION
 (TYPE &REST SLOT-INITIALIZATIONS) 

                                                  (* ;; "(cl:apply 'make type slot-initializations)")

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

(DEFUN SIGNAL
 (DATUM &REST ARGS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                                                         ARGS)))
                                      (RAISE-SIGNAL CONDITION)
                                      (CL:IF (CONDITION-TYPEP CONDITION (QUOTE SERIOUS-CONDITION))
                                             (DEBUG CONDITION)
                                             (RETURN-FROM SIGNAL CONDITION))))

(DEFUN CL:ERROR
 (DATUM &REST ARGS) (DEBUG (RAISE-SIGNAL (MAKE-INTO-CONDITION DATUM (QUOTE 
                                                                                         SIMPLE-ERROR
                                                                                          )
                                                               ARGS))))

(DEFUN CERROR
 (PROCEED-FORMAT-STRING DATUM &REST ARGUMENTS &AUX CONDITION)
   (PROCEED-CASE (DEBUG (RAISE-SIGNAL (SETF CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-ERROR)
                                                             ARGUMENTS))))
          (PROCEED NIL :REPORT (CL:APPLY (FUNCTION FORMAT)
                                      T PROCEED-FORMAT-STRING ARGUMENTS)
                 CONDITION)))

(DEFUN WARN
 (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
                                                                                       )
                                                            ARGUMENTS)))
                                         (CL:UNLESS (CONDITION-TYPEP CONDITION (QUOTE WARNING))
                                                (CERROR "Signal and report the condition anyway"
                                                       (QUOTE TYPE-MISMATCH)
                                                       :NAME
                                                       (QUOTE CONDITION)
                                                       :VALUE CONDITION :DESIRED-TYPE (QUOTE WARNING)
                                                       ))
                                         (RAISE-SIGNAL CONDITION)
                                         (CL:IF %%CONDITION-TYPES-REAL (FORMAT *ERROR-OUTPUT* 
                                                                              "~&Warning: ~A~%%" 
                                                                              CONDITION)
                                                (FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%%"
                                                       (REPORT-CONDITION CONDITION NIL)))
                                         (CL:WHEN *BREAK-ON-WARNINGS* (CL:BREAK CONDITION))
                                         CONDITION))

(DEFUN CL:BREAK
 (&OPTIONAL (DATUM "Break")
                       &REST ARGUMENTS &AUX CONDITION) 

                                                  (* ;; 

                          "Want to try and get some indication of which break you're returning from.")

   (PROCEED-CASE (DEBUG (SETF CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                                               ARGUMENTS)))
          (PROCEED NIL :REPORT "Return from BREAK" CONDITION)))

(DEFUN DEBUG
 (&OPTIONAL (DATUM "Break")
                    &REST ARGS) (LOOP (ERRORX (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                                                     ARGS))))

(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
                                                            (CL:FUNCTION (LAMBDA (PC STREAM)
                                                                           (FUNCALL
                                                                            (DEFAULT-PROCEED-REPORT
                                                                             (PROCEED-CASE-NAME
                                                                              PC))
                                                                            PC STREAM)))))

(DEFUN FIND-PROCEED-CASE
 (DATUM CONDITION) (ETYPECASE DATUM (NULL (CL:ERROR 
                                              "~S is an invalid argument to ~S;~%%    use ~S instead" 
                                                                         NIL (QUOTE FIND-PROCEED-CASE
                                                                                    )
                                                                         (QUOTE COMPUTE-PROCEED-CASES
                                                                                )))
                                                  (PROCEED-CASE (AND (FMEMB DATUM *PROCEED-CASES*)
                                                                     (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 COMPUTE-PROCEED-CASES
 (CONDITION) (for
 PC in
 *PROCEED-CASES*
                                            when
 (CATCH (QUOTE SKIP-PROCEED-CASE)
                                                        (TEST-PROCEED-CASE PC CONDITION))
                                            collect
 PC))

(DEFUN INVOKE-PROCEED-CASE
 (PROCEED-CASE CONDITION &REST VALUES)
   (LET ((PC (FIND-PROCEED-CASE PROCEED-CASE CONDITION)))
        (IF
 PC
            THEN
 
                                          (* ;; "Hack until real unwinder is in. ")

                 (AND (BOUNDP (QUOTE BREAKRESETVALS))
                      (BOUNDP (QUOTE \BREAKRESETEXPR))
                      (BREAKRESETFN (QUOTE LEAVING)))
                 (THROW (PROCEED-CASE-TAG PC)
                        (LIST* (PROCEED-CASE-SELECTOR PC)
                               CONDITION
                               (COND
                                  ((SYMBOLP PROCEED-CASE)
                                   VALUES)
                                  ((FBOUNDP (PROCEED-CASE-NAME PC))
                                   (CL:APPLY (PROCEED-ARG-COLLECTOR (PROCEED-CASE-NAME PC))
                                          CONDITION VALUES))
                                  (T VALUES))))
          ELSE
 (CL:ERROR (QUOTE BAD-PROCEED-CASE)
                      :NAME PROCEED-CASE))))

(DEFINE-PROCEED-FUNCTION ABORT
 :TEST TRUE :REPORT "Abort")

(DEFINE-PROCEED-FUNCTION PROCEED
 :REPORT "Proceed with no special action" :TEST TRUE)

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

(DEFINE-PROCEED-FUNCTION STORE-VALUE
 :REPORT "Store a new value and use it" :TEST TRUE
                                           (VALUE (PROGN (FORMAT *QUERY-IO* 
                                                                "Enter a value to store: ")
                                                         (CL:EVAL (CL:READ *QUERY-IO*)))))

(DEFUN SIMPLE-FORMAT
 (STREAM &REST ARGS) (CL:WHEN (EQ STREAM T)
                                                (SETF STREAM *STANDARD-OUTPUT*))
                                         (DOLIST (X ARGS)
                                                (CL:PRINT X STREAM)))

(MOVD? (QUOTE SIMPLE-FORMAT)
       (QUOTE FORMAT))

(PUTPROPS ERROR-RUNTIME FILETYPE
 COMPILE-FILE)
(PUTPROPS ERROR-RUNTIME COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL)))
STOP