(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "LISP")

(il:filecreated "20-Oct-86 17:23:29" il:{eris}<lispcore>sources>error-runtime.\;8
 34800  

      il:|changes| il:|to:|  (il:vars il:error-runtimecoms)
                             (il:functions il:condition-typep il:condition-subtypep 
                                    il:condition-type-of)
                             (il:structures error)

      il:|previous| il:|date:| "17-Oct-86 17:49:26" il:{eris}<lispcore>sources>error-runtime.\;7)


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

(il:prettycomprint il:error-runtimecoms)

(il:rpaqq il:error-runtimecoms
 
          ((il:coms (il:* il:|;;;| "Internal functions.")
                  (il:functions il:condition-typep il:condition-subtypep il:condition-type-of 
                         il:fake-typep-for-conditions il:fake-subtypep-for-conditions 
                         il:fake-type-of-for-conditions)
                  (il:functions il:condition-handler il:condition-reporter il:%print-condition 
                         il:%proceed-case-printer il:%proceed-case-default-reporter 
                         il:report-condition il:condition-parent)
                  (il:variables il:*condition-handler-bindings* il:*proceed-cases*)
                  (il:functions il:check-type-fail il:ecase-fail il:assert-fail)
                  (il:functions il:make-into-condition il:raise-signal il:default-handle-condition 
                         il:default-proceed-reporter il:fix-inheritance-links il:default-proceed-test 
                         il:test-proceed-case))
           (il:coms (il:* il:|;;;| "Pre-defined condition types.")
                  (il:structures il:condition il:simple-condition il:warning il:simple-warning 
                         il:old-break1 il:serious-condition error il:simple-error 
                         il:old-interlisp-error il:assertion-failed il:cell-error il:unbound-variable 
                         il:undefined-function il:no-proceed-test il:index-bounds-error)
                  (il:coms (il:functions il:pretty-type-name)
                         (il:structures il:type-mismatch))
                  (il:structures il:control-error il:illegal-go il:illegal-return il:illegal-throw 
                         il:bad-proceed-case)
                  (il:structures il:call-error il:too-many-arguments il:too-few-arguments 
                         il:invalid-argument-list)
                  (il:structures il:stream-error il:read-error il:end-of-file)
                  (il:structures il:storage-condition il:stack-overflow il:storage-exhausted))
           (il:coms (il:* il:|;;;| 
                          "Exported symbols. Anything here that's not in CL should be in XCL.")
                  (il:variables *break-on-warnings*)
                  (il:functions il:make-condition il:signal error cerror warn break il:debug)
                  (il:structures il:proceed-case il:real-proceed-case)
                  (il:functions il:find-proceed-case il:compute-proceed-cases il:invoke-proceed-case)
                  (il:functions il:abort il:proceed il:use-value il:store-value))
           (il:coms (il:functions il:simple-format)
                  (il:p (il:movd? 'il:simple-format 'format)))
           (il:declare\: il:dontcopy (il:vars il:should-be-in-package))
           (il:prop il:filetype il:error-runtime)))



(il:* il:|;;;| "Internal functions.")


(defmacro il:condition-typep
 (il:datum type) (if il:%condition-types-real `(typep ,il:datum
                                                                                  ,type)
                                                 `(il:fake-typep-for-conditions ,il:datum
                                                         ,type)))

(defmacro il:condition-subtypep
 (il:t1 il:t2) (if il:%condition-types-real `(subtypep ,il:t1
                                                                                   ,il:t2)
                                                  `(il:fake-subtypep-for-conditions ,il:t1
                                                          ,il:t2)))

(defmacro il:condition-type-of
 (il:datum) (if il:%condition-types-real `(type-of ,il:datum)
                                              `(il:fake-type-of-for-conditions ,il:datum)))

(defun il:fake-typep-for-conditions
 (il:datum type) 
         (il:* il:|amd| " 9-Apr-86 17:41")

   (and (consp il:datum)
        (symbolp (car il:datum))
        (il:condition-subtypep (car il:datum)
               type)))

(defun il:fake-subtypep-for-conditions
 (il:t1 il:t2) (values (and (il:|for| il:|old| il:t1 il:|by|
                                                                         (il:condition-parent il:t1)
                                                                         il:|while| il:t1 
                                                                         il:|thereis|
                                                                         (eq il:t1 il:t2))
                                                                  t)
                                                            t))

(defun il:fake-type-of-for-conditions
 (il:datum) (car il:datum))

(defmacro il:condition-handler
 (il:condition-type) `(il:getprop ,il:condition-type '
                                                           il:%condition-handler))

(defmacro il:condition-reporter
 (il:condition-type) `(il:getprop ,il:condition-type '
                                                            il:%condition-reporter))

(defun il:%print-condition
 (il:condition stream il:level) (declare (ignore il:level))
                                                          (if *print-escape* (format stream 
                                                                            "#<Condition ~S @ ~O,~O>"
                                                                                    (type-of 
                                                                                         il:condition
                                                                                           )
                                                                                    (il:\\hiloc
                                                                                     il:condition)
                                                                                    (il:\\loloc
                                                                                     il:condition))
                                                              (il:report-condition il:condition 
                                                                     stream)))

(defun il:%proceed-case-printer
 (il:pc stream il:level) (declare (ignore il:level))
                                                        (if *print-escape* (
                                                                         il:default-structure-printer
                                                                            il:pc stream il:level)
                                                            (funcall (il:proceed-case-report il:pc)
                                                                   il:pc stream)))

(defun il:%proceed-case-default-reporter
 (il:pc stream) (funcall (il:default-proceed-report
                                                                  (il:proceed-case-name il:pc))
                                                               il:pc stream))

(defun il:report-condition
 (il:condition stream) (do* ((type (il:condition-type-of il:condition)
                                                             (il:condition-parent type))
                                                       (il:reporter (il:condition-reporter type)
                                                              (il:condition-reporter type)))
                                                      ((null type)
                                                       (break "No report function found for ~S." 
                                                              il:condition))
                                                      (when il:reporter
                                                            (return (if stream (funcall il:reporter 
                                                                                      il:condition 
                                                                                      stream)
                                                                        (with-output-to-string
                                                                         (stream)
                                                                         (funcall il:reporter 
                                                                                il:condition stream))
                                                                        )))))

(defmacro il:condition-parent
 (type) `(il:getprop ,type 'il:%condition-parent))

(defvar il:*condition-handler-bindings*
 nil "Condition handler binding stack")

(defvar il:*proceed-cases*
 nil "Active proceed case stack")

(defun il:check-type-fail
 (il:proceedable il:place il:value il:desired-type il:message)
   (il:proceed-case (error 'il:type-mismatch :name il:place :value il:value :desired-type 
                           il:desired-type :message il:message)
          (il:store-value (ignore il:new)
                 :report
                 (format t "Change the value of ~A" il:place)
                 :test
                 (lambda (il:condition)
                        (and il:proceedable (il:condition-typep il:condition 'il:type-mismatch)))
                 il:new)))

(defun il:ecase-fail
 (il:proceedable il:place il:value il:selectors)
   (il:proceed-case (error "The value of ~S, ~S,~&is ~?." il:place il:value 
                           "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" 
                           il:selectors)
          (il:store-value (ignore il:v)
                 :test
                 (lambda (il:condition)
                        (declare (ignore il:condition))
                        il:proceedable)
                 :report
                 (format t "Change the value of ~A" il:place)
                 il:v)))

(defun il:assert-fail
 (string &rest il:args) (il:proceed-case (error 'il:assertion-failed 
                                                                     :format-string string 
                                                                     :format-arguments il:args)
                                                    (il:proceed nil :report "Re-test assertion")))

(defun il:make-into-condition
 (il:datum il:desired-type il:args) 

                                                  (il:* il:|;;| 

                                                  "The entire thing should be a typecase.")

   (if (il:condition-typep il:datum 'il:condition)
       il:datum
       (etypecase il:datum (symbol (if (il:condition-subtypep il:datum 'il:condition)
                                       (apply (il:function il:make-condition)
                                              il:datum il:args)
                                       (error "~S is not a condition type." il:datum)))
              (string (il:make-condition il:desired-type :format-string il:datum :format-arguments 
                             il:args)))))

(defun il:raise-signal
 (il:c) (do* ((il:*condition-handler-bindings* il:*condition-handler-bindings*
                                           (cdr il:*condition-handler-bindings*)))
                                   ((null il:*condition-handler-bindings*)
                                    (il:default-handle-condition il:c)
                                    il:c)
                                   (il:destructuring-bind (type . il:handler)
                                          (car il:*condition-handler-bindings*)
                                          (when (il:condition-typep il:c type)
                                                (let ((il:*condition-handler-bindings* (cdr 
                                                                      il:*condition-handler-bindings*
                                                                                            )))
                                                     (funcall il:handler il:c))))))

(defun il:default-handle-condition
 (il:condition) (do ((type (il:condition-type-of il:condition)
                                                             (il:condition-parent type)))
                                                      ((null type))
                                                      (let ((il:handler (il:condition-handler type)))
                                                           (when il:handler (funcall il:handler 
                                                                                   il:condition)))))

(defun il:default-proceed-reporter
 (il:pc stream) (format stream "Proceed-type: ~A" (
                                                                                 il:proceed-case-name
                                                                                     il:pc)))

(defun il:fix-inheritance-links
 (il:name il:new-parent)
   (let ((il:old-parent (il:condition-parent il:name)))
        (unless (or (eq il:new-parent il:old-parent)
                    (null il:old-parent))
               (let ((il:children (get il:old-parent 'il:%condition-children)))
                    (setf (get il:old-parent 'il:%condition-children)
                          (il:dremove il:name il:children))))
        (pushnew il:name (il:getprop il:new-parent 'il:%condition-children))
        (setf (il:condition-parent il:name)
              il:new-parent)))

(defmacro il:default-proceed-test
 (il:proceed-type) `(il:getprop ,il:proceed-type '
                                                            il:%default-proceed-test))

(defun il:test-proceed-case
 (il:pc il:condition &aux il:test)
   (cond
      ((setf il:test (il:proceed-case-test il:pc))
       (funcall il:test il:condition))
      ((and (il:proceed-case-name il:pc)
            (setf il:test (or (il:default-proceed-test (il:proceed-case-name il:pc))
                              (il:no-proceed-test (il:proceed-case-name il:pc)))))
       (funcall il:test il:condition))
      (t 
                                                  (il:* il:\; "This case shouldn't happen")

         (il:proceed-case (error "Couldn't find test function for ~S." il:pc)
                (il:proceed nil :test il:true :report "Assume proceed case is enabled" t)))))




(il:* il:|;;;| "Pre-defined condition types.")


(il:define-condition il:condition
 il:condition :report "Condition ~S occurred." il:--dummy-slot--)

(il:define-condition il:simple-condition
 il:condition :report (apply (il:function format)
                                                                     t il:format-string 
                                                                     il:format-arguments)
                                               il:format-string il:format-arguments)

(il:define-condition il:warning
 il:condition)

(il:define-condition il:simple-warning
 il:warning :report (apply (il:function format)
                                                                 t il:format-string 
                                                                 il:format-arguments)
                                             il:format-string il:format-arguments)

(il:define-condition il:old-break1
 il:condition :report (il:destructuring-bind (il:mess1 il:mess2 
                                                                                      il:mess3)
                                                               list
                                                               (il:errormess1 il:mess1 il:mess2 
                                                                      il:mess3))
                                         list)

(il:define-condition il:serious-condition
 il:condition :report (format t 
                                                                     "Serious condition ~S occurred."
                                                                      (il:condition-type-of 
                                                                             il:condition)))

(il:define-condition error
 il:serious-condition)

(il:define-condition il:simple-error
 il:error :report (apply (il:function format)
                                                             t il:format-string il:format-arguments)
                                           il:format-string il:format-arguments)

(il:define-condition il:old-interlisp-error
 il:error :report (if (eq il:number 17)
                                                                 (il:destructuring-bind
                                                                  (il:mess1 . il:mess2)
                                                                  il:message
                                                                  (il:errormess1 il:mess1 il:mess2
                                                                         'il:error))
                                                                 (il:errorm (list il:number 
                                                                                  il:message)))
                                                  il:number il:message)

(il:define-condition il:assertion-failed
 il:simple-error :report (apply (il:function format)
                                                                        t
                                                                        (or il:format-string 
                                                                            "Assertion failed.")
                                                                        il:format-arguments))

(il:define-condition il:cell-error
 il:error il:name)

(il:define-condition il:unbound-variable
 il:cell-error :report (format t "Unbound variable: ~S." 
                                                                      il:name))

(il:define-condition il:undefined-function
 il:cell-error :report (format t "Undefined function: ~S." 
                                                                        il:name))

(il:define-condition il:no-proceed-test
 il:undefined-function :report (format t 
                                                            "No test specified for proceed case: ~S." 
                                                                             il:name))

(il:define-condition il:index-bounds-error
 il:cell-error :report (format t "Index out of bounds: ~D." 
                                                                        il:index)
                                                 il:index)

(defun il:pretty-type-name
 (il:typespec) (il:concat "a " il:typespec))

(il:define-condition il:type-mismatch
 il:cell-error :report (format t 
                                                                   "The value of ~A, ~A, is not ~A." 
                                                                   il:name il:value
                                                                   (or il:message (
                                                                                  il:pretty-type-name
                                                                                   il:desired-type)))
                                            il:value il:desired-type il:message)

(il:define-condition il:control-error
 il:error)

(il:define-condition il:illegal-go
 il:control-error :report (format t "GO to a non-existant tag: ~S." 
                                                                   il:tag)
                                         il:tag)

(il:define-condition il:illegal-return
 il:control-error :report (format t 
                                                                  "RETURN to non-existant block: ~S." 
                                                                       il:tag)
                                             il:tag)

(il:define-condition il:illegal-throw
 il:control-error :report (format t 
                                                                      "Tag for THROW not found: ~S." 
                                                                      il:tag)
                                            il:tag)

(il:define-condition il:bad-proceed-case
 il:control-error :report (format t 
                                                           "Proceed case ~S is not currently active." 
                                                                         il:name)
                                               il:name)

(il:define-condition il:call-error
 il:control-error il:callee)

(il:define-condition il:too-many-arguments
 il:call-error :report
                                                 (if (and il:maximum il:actual)
                                                     (format t "Too many arguments to ~A:~%   ~D ~:*~[were~;was~:;were~] given but at most ~D ~:*~[are~;is~:;are~] accepted" 
                                                            il:callee il:actual il:maximum)
                                                     (format t "Too many arguments to ~A" il:callee))
                                                 il:maximum il:actual)

(il:define-condition il:too-few-arguments
 il:call-error :report
                                                (if (and il:minimum il:actual)
                                                    (format t "Too few arguments to ~A:~%   ~D ~:*~[were~;was~:;were~] given but at least ~D ~:*~[are~;is~:;are~] necessary" 
                                                           il:callee il:actual il:minimum)
                                                    (format t "Too few arguments to ~A" il:callee))
                                                il:minimum il:actual)

(il:define-condition il:invalid-argument-list
 il:call-error :report (format t 
                                                                    "~S has an invalid argument list" 
                                                                           il:callee))

(il:define-condition il:stream-error
 il:error :report (format t "Stream error on ~S." stream)
                                           stream)

(il:define-condition il:read-error
 il:stream-error)

(il:define-condition il:end-of-file
 il:read-error :report "End of file:~%    ~S" stream)

(il:define-condition il:storage-condition
 il:serious-condition)

(il:define-condition il:stack-overflow
 il:storage-condition :report "Stack overflow")

(il:define-condition il:storage-exhausted
 il:storage-condition)




(il:* il:|;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")


(defvar *break-on-warnings*
 nil 
                          "If true, calls to WARN will cause a break as well as logging the warning.")

(defun il:make-condition
 (type &rest il:slot-initializations) 
                                                   "Create a condition object of the specified type."
   (apply (il:structure-constructor type)
          il:slot-initializations))

(defun il:signal
 (il:datum &rest il:args) (let ((il:condition (il:make-into-condition il:datum
                                                                     'il:simple-condition il:args)))
                                               (il:raise-signal il:condition)
                                               (if (il:condition-typep il:condition '
                                                          il:serious-condition)
                                                   (il:debug il:condition)
                                                   (return-from il:signal il:condition))))

(defun error
 (il:datum &rest il:args) (il:debug (il:raise-signal (il:make-into-condition il:datum
                                                                        'il:simple-error il:args))))

(defun cerror
 (il:proceed-format-string il:datum &rest il:arguments &aux il:condition)
   (il:proceed-case (il:debug (il:raise-signal (setf il:condition (il:make-into-condition
                                                                   il:datum
                                                                   'il:simple-error il:arguments))))
          (il:proceed nil :report (apply (il:function format)
                                         t il:proceed-format-string il:arguments)
                 il:condition)))

(defun warn
 (il:datum &rest il:arguments) (let ((il:condition (il:make-into-condition il:datum
                                                                     'il:simple-warning il:arguments)
                                                       ))
                                               (unless (il:condition-typep il:condition 'il:warning)
                                                      (cerror 
                                                             "Signal and report the condition anyway"
                                                             'il:type-mismatch :name 'il:condition 
                                                             :value il:condition :desired-type
                                                             'il:warning))
                                               (il:raise-signal il:condition)
                                               (if il:%condition-types-real (format *error-output* 
                                                                                   "~&Warning: ~A~%" 
                                                                                   il:condition)
                                                   (format *error-output* "~&Warning: ~A~%"
                                                          (il:report-condition il:condition nil)))
                                               (when *break-on-warnings* (break il:condition))
                                               il:condition))

(defun break
 (&optional (il:datum "Break")
                    &rest il:arguments &aux il:condition) 

                                                  (il:* il:|;;| 

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

   (il:proceed-case (il:debug (setf il:condition (il:make-into-condition il:datum '
                                                        il:simple-condition il:arguments)))
          (il:proceed nil :report "Return from BREAK" il:condition)))

(defun il:debug
 (&optional (il:datum "Break")
                       &rest il:args) (loop (il:errorx (il:make-into-condition il:datum '
                                                              il:simple-condition il:args))))

(defstruct (il:proceed-case
 (:print-function il:%proceed-case-printer)) il:name il:tag il:selector 
                                                                              il:test
                                                                              (il:report '
                                                                    il:%proceed-case-default-reporter
                                                                                     ))

(defstruct (il:real-proceed-case
 (:include il:proceed-case)
                                 (:print-function il:%proceed-case-printer)) il:continuation)

(defun il:find-proceed-case
 (il:datum il:condition)
   (etypecase il:datum (null (error "~S is an invalid argument to ~S;~%    use ~S instead" nil
                                    'il:find-proceed-case
                                    'il:compute-proceed-cases))
          (il:proceed-case (and (il:fmemb il:datum il:*proceed-cases*)
                                (il:test-proceed-case il:datum il:condition)
                                il:datum))
          (symbol (il:|for| il:pc il:|in| il:*proceed-cases* il:|thereis| (and (eq (
                                                                                 il:proceed-case-name
                                                                                    il:pc)
                                                                                   il:datum)
                                                                               (il:test-proceed-case
                                                                                il:pc il:condition)
                                                                               il:pc)))))

(defun il:compute-proceed-cases
 (il:condition) (il:|for| il:pc il:|in| il:*proceed-cases* il:|when|
                                                      (catch 'il:skip-proceed-case (
                                                                                 il:test-proceed-case
                                                                                    il:pc 
                                                                                    il:condition))
                                                      il:|collect| il:pc))

(defun il:invoke-proceed-case
 (il:proceed-case il:condition &rest values)
   (let ((il:pc (il:find-proceed-case il:proceed-case il:condition)))
        (il:if il:pc il:then 
                      (il:* il:|;;| "Hack until real unwinder is in. ")

               (and (boundp 'il:breakresetvals)
                    (boundp 'il:\\breakresetexpr)
                    (il:breakresetfn 'il:leaving))
               (typecase il:pc (il:real-proceed-case
                                (il:|with| il:real-proceed-case il:pc
                                       (throw il:tag (values-list (list* il:continuation il:condition
                                                                         (cond
                                                                            ((symbolp il:proceed-case
                                                                                    )
                                                                             values)
                                                                            ((fboundp il:name)
                                                                             (apply (
                                                                             il:proceed-arg-collector
                                                                                     il:name)
                                                                                    il:condition 
                                                                                    values))
                                                                            (t values)))))))
                      (il:proceed-case (il:|with| il:proceed-case il:pc
                                              (throw il:tag (list* il:selector il:condition
                                                                   (cond
                                                                      ((symbolp il:proceed-case)
                                                                       values)
                                                                      ((fboundp il:name)
                                                                       (apply (
                                                                             il:proceed-arg-collector
                                                                               il:name)
                                                                              il:condition values))
                                                                      (t values)))))))
               il:else
               (error 'il:bad-proceed-case :name il:proceed-case))))

(il:define-proceed-function il:abort
 :test il:true :report "Abort")

(il:define-proceed-function il:proceed
 :report "Proceed with no special action" :test il:true)

(il:define-proceed-function il:use-value
 :report "Use a different value" :test il:true
                                               (il:value (progn (format *query-io* 
                                                                       "Enter a new value: ")
                                                                (il:eval (read *query-io*)))))

(il:define-proceed-function il:store-value
 :report "Store a new value and use it" :test il:true
                                                 (il:value (progn (format *query-io* 
                                                                         "Enter a value to store: ")
                                                                  (eval (read *query-io*)))))

(defun il:simple-format
 (stream &rest il:args) (when (eq stream t)
                                                     (setf stream *standard-output*))
                                               (dolist (il:x il:args)
                                                      (print il:x stream)))

(il:movd? 'il:simple-format 'format)
(il:declare\: il:dontcopy 

(il:rpaqq il:should-be-in-package
 
          (("XCL" :external il:define-condition il:handler-bind il:condition-bind il:condition-case 
                  il:ignore-errors il:proceed-case il:define-proceed-function il:catch-abort 
                  il:condition il:simple-condition il:warning il:simple-warning il:serious-condition 
                  il:error il:simple-error il:assertion-failed il:cell-error il:unbound-variable 
                  il:undefined-function il:index-bounds-error il:type-mismatch il:control-error 
                  il:illegal-go il:illegal-return il:illegal-throw il:call-error 
                  il:too-many-arguments il:too-few-arguments il:invalid-argument-list il:stream-error 
                  il:read-error il:end-of-file il:storage-condition il:stack-overflow 
                  il:storage-exhausted il:make-condition il:signal il:debug il:find-proceed-case 
                  il:compute-proceed-cases il:invoke-proceed-case il:abort il:proceed il:use-value 
                  il:store-value)
           ("SI" :internal il:*proceed-cases* il:*condition-handler-bindings*)))
)

(il:putprops il:error-runtime il:filetype
 compile-file)
(il:putprops il:error-runtime il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop