(FILECREATED "22-Sep-86 15:43:08" {ERIS}<LISPCORE>SOURCES>ERROR-RUNTIME.;2
 26427  

      changes to:  (VARS ERROR-RUNTIMECOMS)

      previous date: " 9-Sep-86 18:55:29" {ERIS}<LISPCORE>SOURCES>ERROR-RUNTIME.;1)


(* 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)
              (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 REPORT-TYPE-MISMATCH)
                    (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))
        (COMS (FUNCTIONS SIMPLE-FORMAT)
              (P (MOVD? (QUOTE SIMPLE-FORMAT)
                        (QUOTE FORMAT))))
        (PROP FILETYPE ERROR-RUNTIME)))



(* ;;; "Internal functions.")


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

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

(DEFMACRO CONDITION-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
 (GETPROP T1 (QUOTE 
                                                                                   %%CONDITION-PARENT
                                                                                           ))
                                                            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))))

(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)
          (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 MAKE-INTO-CONDITION
 (DATUM DESIRED-TYPE ARGS CALLER)
   (if
 (CONDITION-TYPEP DATUM (QUOTE CONDITION))
       then
 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 (CL:ERROR "Bad argument to ~S: ~S." CALLER DATUM)))))

(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)
                                                          (GETPROP TYPE (QUOTE %%CONDITION-PARENT))))
                                                   ((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 (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 (GETPROP NEW-PARENT (QUOTE
                                                                                          
                                                                                 %%CONDITION-CHILDREN
                                                                                          )))
                                                    (SETF (GET NAME (QUOTE %%CONDITION-PARENT))
                                                          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)

(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 OLD-BREAK1
 CONDITION :REPORT (DESTRUCTURING-BIND (MESS1 MESS2 MESS3)
                                                      (OLD-BREAK1-LIST CONDITION)
                                                      (ERRORMESS1 MESS1 MESS2 MESS3))
                                   LIST)

(DEFINE-CONDITION SERIOUS-CONDITION
 CONDITION)

(DEFINE-CONDITION CL:ERROR
 SERIOUS-CONDITION)

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

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

(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 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 BAD-PROCEED-CASE
 CONTROL-ERROR)

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

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

(DEFINE-CONDITION TOO-FEW-ARGUMENTS
 CALL-ERROR :REPORT (FORMAT T "Too few arguments to ~A"
                                                              (TOO-FEW-ARGUMENTS-CALLEE CONDITION)))

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




(* ;;; "Exported symbols.")


(DEFVAR *BREAK-ON-WARNINGS*
 NIL)

(DEFUN MAKE-CONDITION
 (TYPE &REST SLOT-INITIALIZATIONS) (CL:APPLY (STRUCTURE-CONSTRUCTOR TYPE)
                                                               SLOT-INITIALIZATIONS))

(DEFUN SIGNAL
 (DATUM &REST ARGS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                                                         ARGS
                                                         (QUOTE SIGNAL))))
                                      (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
                                                               (QUOTE CL:ERROR)))))

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

(DEFUN WARN
 (DATUM &REST ARGUMENTS) (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-WARNING
                                                                                       )
                                                            ARGUMENTS
                                                            (QUOTE WARN))))
                                         (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:BREAK
 (&OPTIONAL (DATUM "Break.")
                       &REST ARGUMENTS)
   (DECLARE
 (SPECIAL NBREAKS))
   (LET ((CONDITION (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-BREAK)
                           ARGUMENTS
                           (QUOTE CL:BREAK)))
         (HACK (BQUOTE (CL:LAMBDA (P S)
                              (FORMAT S "Return from break: ~D" (\, (ADD1 NBREAKS)))))))
          
          (* * HACK 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 DEBUG
 (&OPTIONAL (DATUM "Break.")
                    &REST ARGS) (LOOP (ERRORX (MAKE-INTO-CONDITION DATUM (QUOTE SIMPLE-CONDITION)
                                                     ARGS
                                                     (QUOTE DEBUG)))))

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

(DEFUN FIND-PROCEED-CASE
 (DATUM CONDITION) (TYPECASE DATUM (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
 (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))))

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

(DEFINE-PROCEED-FUNCTION PROCEED
 :TEST TRUE)

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

(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