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

(filecreated "24-Oct-86 21:51:49" {eris}<lispcore>sources>error-runtime.\;13
 32459  

      |changes| |to:|  (structures condition too-few-arguments cl:error simple-error 
                              old-interlisp-error cell-error control-error stream-error 
                              real-proceed-case)
                       (functions %proceed-case-printer invoke-proceed-case)
                       (vars error-runtimecoms should-be-in-package)

      |previous| |date:| "21-Oct-86 04:02:59" {eris}<lispcore>sources>error-runtime.\;10)


; 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 %proceed-case-printer 
                     %proceed-case-default-reporter 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 simple-error old-interlisp-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 invalid-argument-list)
              (structures stream-error read-error end-of-file)
              (structures storage-condition stack-overflow storage-exhausted))
        (coms (* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")
              (variables *break-on-warnings*)
              (functions make-condition signal cl:error cl:cerror cl:warn cl:break debug)
              (structures proceed-case real-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? 'simple-format 'cl:format)))
        (declare\: dontcopy (vars should-be-in-package))
        (prop filetype error-runtime)))



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


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

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

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

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

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

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

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

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

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

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

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

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

(cl: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
                                                                           (cl:funcall reporter 
                                                                                  condition stream)
                                                                           (cl:with-output-to-string
                                                                            (stream)
                                                                            (cl:funcall reporter 
                                                                                   condition stream))
                                                                           )))))

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

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

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

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

(cl: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)
                        (declare
 (ignore condition))
                        proceedable)
                 :report
                 (cl:format t "Change the value of ~A" place)
                 v)))

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

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

                                                   (* |;;| "The entire thing should be a typecase.")

   (cl:if (condition-typep datum 'condition)
          datum
          (cl:etypecase datum (cl:symbol (cl:if (condition-subtypep datum '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)))))

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

(cl: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 (cl:funcall handler 
                                                                                   condition)))))

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

(cl: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
                                                                                   '
                                                                                  %condition-children
                                                                                   )))
                                                                   (cl:setf (get old-parent
                                                                                 '%condition-children
                                                                                 )
                                                                          (dremove name children))))
                                                       (cl:pushnew name (getprop new-parent
                                                                               '%condition-children))
                                                       (cl:setf (condition-parent name)
                                                              new-parent)))

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

(cl:defun test-proceed-case
 (pc condition &aux test) (cond
                                                        ((cl:setf test (proceed-case-test pc))
                                                         (cl:funcall test condition))
                                                        ((and (proceed-case-name pc)
                                                              (cl:setf test
                                                                     (or (default-proceed-test
                                                                          (proceed-case-name pc))
                                                                         (no-proceed-test
                                                                          (proceed-case-name pc)))))
                                                         (cl: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-function (lambda (condition *standard-output*)
                                                         (cl:format t "Condition ~S occurred." 
                                                                condition))
                                  --dummy-slot--)

(define-condition simple-condition
 condition :report (cl:apply #'cl:format t format-string 
                                                            format-arguments)
                                         format-string format-arguments)

(define-condition warning
 condition)

(define-condition simple-warning
 warning :report (cl:apply (function cl: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 (cl:format t "Serious condition ~S occurred."
                                                             (condition-type-of condition)))

(define-condition cl:error
 serious-condition)

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

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

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

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

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

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

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

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

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

(define-condition type-mismatch
 cell-error :report (cl: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 (cl:format t "GO to a non-existant tag: ~S." tag)
                                   tag)

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

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

(define-condition bad-proceed-case
 control-error :report (cl: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)
                                                               (cl:format t "Too many arguments to ~A:~%   ~D ~:*~[were~;was~:;were~] given but at most ~D ~:*~[are~;is~:;are~] accepted" 
                                                                      callee actual maximum)
                                                               (cl:format t 
                                                                      "Too many arguments to ~A" 
                                                                      callee))
                                           maximum actual)

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

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

(define-condition stream-error
 cl:error :report (cl: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. Anything here that's not in CL should be in XCL.")


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

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

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

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

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

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

(cl: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 (cl:setf condition (make-into-condition datum 'simple-condition arguments)))
          (proceed nil :report "Return from BREAK" condition)))

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

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

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

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

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

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

                 (and (boundp 'breakresetvals)
                      (boundp '\\breakresetexpr)
                      (breakresetfn 'leaving))
                 (cl:typecase pc (real-proceed-case
                                  (let ((tag (real-proceed-case-tag pc))
                                        (continuation (real-proceed-case-continuation pc))
                                        (name (real-proceed-case-name pc)))
                                       (cl:throw tag (cl:values-list (list* continuation condition
                                                                            (cond
                                                                               ((cl:symbolp 
                                                                                       proceed-case)
                                                                                cl:values)
                                                                               ((cl:fboundp name)
                                                                                (cl:apply
                                                                                 (
                                                                                proceed-arg-collector
                                                                                  name)
                                                                                 condition cl:values)
                                                                                )
                                                                               (t cl:values)))))))
                        (proceed-case (let ((tag (proceed-case-tag pc))
                                            (selector (proceed-case-selector pc))
                                            (name (proceed-case-name pc)))
                                           (cl:throw tag (list* selector condition
                                                                (cond
                                                                   ((cl:symbolp proceed-case)
                                                                    cl:values)
                                                                   ((cl:fboundp name)
                                                                    (cl:apply (proceed-arg-collector
                                                                               name)
                                                                           condition cl:values))
                                                                   (t cl:values)))))))
          else
 (cl:error '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 (cl: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 (cl:format *query-io* 
                                                                "Enter a value to store: ")
                                                         (cl:eval (cl:read *query-io*)))))

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

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

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

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