losp/muerte/conditions.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      conditions.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Wed Nov 20 15:47:04 2002
  12 ;;;;
  13 ;;;; $Id: conditions.lisp,v 1.24 2007/03/12 21:53:40 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (provide :muerte/conditions)
  19
  20 (in-package muerte)
  21
  22 (defparameter *break-on-signals* nil)
  23
  24 (defparameter *debugger-function* nil)
  25 (defvar *debugger-dynamic-context* nil)
  26 (defparameter *debugger-invoked-stack-frame* nil)
  27 (defvar *debugger-condition*)
  28
  29 (defmacro define-condition (name parent-types slot-specs &rest options)
  30   `(progn
  31      (defclass ,name ,(or parent-types '(condition)) ,slot-specs (:metaclass read-only-class))
  32      ,@(let ((reporter (cadr (assoc :report options))))
  33          (when reporter
  34            `((defmethod print-object ((condition ,name) stream)
  35                (if *print-escape*
  36                    (call-next-method)
  37                  (funcall (function ,reporter) condition stream))
  38                condition))))
  39      ',name))
  40
  41 #+ignore
  42 (defmethod print-object ((c condition) s)
  43   foo)
  44
  45 (define-condition condition (standard-object)
  46   ((format-control
  47     :initarg :format-control
  48     :initform nil
  49     :reader condition-format-control)
  50    (format-arguments
  51     :initarg :format-arguments
  52     :initform nil
  53     :reader condition-format-arguments))
  54   (:report (lambda (condition stream)
  55              (if (or *print-escape*
  56                      (not (condition-format-control condition)))
  57                  (call-next-method)
  58                (apply #'format stream
  59                       (condition-format-control condition)
  60                       (condition-format-arguments condition))))))
  61
  62 (define-condition simple-condition (condition)
  63   ((format-control
  64     :reader simple-condition-format-control)
  65    (format-arguments
  66     :reader simple-condition-format-arguments)))
  67 (define-condition serious-condition () ())
  68 (define-condition error (serious-condition) ())
  69 (define-condition warning () ())
  70 (define-condition style-warning () ())
  71 (define-condition simple-error (simple-condition error) ())
  72 (define-condition simple-warning (simple-condition warning) ())
  73
  74 (define-condition cell-error (error)
  75   ((name
  76     :initarg :name
  77     :reader cell-error-name))
  78   (:report (lambda (c s)
  79              (format s "Error accessing cell ~S."
  80                      (cell-error-name c)))))
  81
  82 (define-condition undefined-function (cell-error)
  83   ()
  84   (:report (lambda (c s)
  85              (format s "Undefined function ~S."
  86                      (cell-error-name c)))))
  87
  88 (define-condition undefined-function-call (undefined-function)
  89   ((arguments
  90     :initarg :arguments
  91     :reader undefined-function-call-arguments))
  92   (:report (lambda (c s)
  93              (format s "Undefined function ~S called with arguments ~:S."
  94                      (cell-error-name c)
  95                      (undefined-function-call-arguments c)))))
  96
  97 (define-condition unbound-variable (cell-error)
  98   ()
  99   (:report (lambda (c s)
 100              (format s "Unbound variable ~S."
 101                      (cell-error-name c)))))
 102
 103 (define-condition program-error (error) ())
 104
 105 (define-condition type-error (error)
 106   ((expected-type
 107     :initarg :expected-type
 108     :reader type-error-expected-type)
 109    (datum
 110     :initarg :datum
 111     :reader type-error-datum))
 112   (:report (lambda (c s)
 113              (format s "The object ~Z `~S' is not of type ~S."
 114                      (type-error-datum c)
 115                      (type-error-datum c)
 116                      (type-error-expected-type c)))))
 117
 118 (define-condition etypecase-error (type-error)
 119   ()
 120   (:report (lambda (c s)
 121              (format s "The object '~S' fell through an etypecase where the legal types were ~S."
 122                      (type-error-datum c)
 123                      (type-error-expected-type c)))))
 124
 125 (defun etypecase-error (datum expecteds)
 126   (error 'etypecase-error
 127          :datum datum
 128          :expected-type (cons 'or expecteds)))
 129
 130 (define-condition control-error (error) ())
 131
 132 (define-condition throw-error (control-error)
 133   ((tag
 134     :initarg :tag
 135     :reader throw-error-tag))
 136   (:report (lambda (c s)
 137              (format s "Cannot throw to tag `~S'." (throw-error-tag c)))))
 138
 139 (define-condition wrong-argument-count (program-error)
 140   ((function
 141     :initarg :function
 142     :reader condition-function)
 143    (argument-count
 144     :initarg :argument-count
 145     :reader condition-argument-count))
 146   (:report (lambda (c s)
 147              (format s "Function ~S ~:A received ~D arguments."
 148                      (funobj-name (condition-function c))
 149                      (funobj-lambda-list (condition-function c))
 150                      (condition-argument-count c)))))
 151
 152 (define-condition index-out-of-range (error)
 153   ((index
 154     :initarg :index
 155     :reader condition-index)
 156    (range
 157     :initarg :range
 158     :reader condition-range))
 159   (:report (lambda (c s)
 160              (format s "Index ~D is beyond range 0-~D."
 161                      (condition-index c)
 162                      (condition-range c)))))
 163
 164 (define-condition stream-error (error)
 165   ((stream
 166     :initarg :stream
 167     :reader stream-error-stream)))
 168
 169 (define-condition end-of-file (stream-error)
 170   ()
 171   (:report (lambda (c s)
 172              (format s "End of file encountered on ~W."
 173                      (stream-error-stream c)))))
 174
 175 (define-condition arithmetic-error (error)
 176   ((operation
 177     :initarg :operation
 178     :initform nil
 179     :reader arithmetic-error-operation)
 180    (operands
 181     :initarg :operands
 182     :initform nil
 183     :reader arithmetic-error-operands)))
 184
 185 (define-condition division-by-zero (arithmetic-error)
 186   ()
 187   (:report (lambda (c s)
 188              (declare (ignore c))
 189              (format s "Division by zero."))))
 190
 191 (defun make-condition (type &rest slot-initializations)
 192   (declare (dynamic-extent slot-initializations))
 193   (apply 'make-instance type slot-initializations))
 194
 195
 196 (defun warn (datum &rest arguments)
 197   (declare (dynamic-extent arguments))
 198   (cond
 199    ((not (eq t (get 'clos-bootstrap 'have-bootstrapped)))
 200     (fresh-line)
 201     (write-string "Warning: ")
 202     (apply 'format t datum arguments)
 203     (fresh-line))
 204    (t (with-simple-restart (muffle-warning "Muffle warning.")
 205         (let ((c (signal-simple 'simple-warning datum arguments))
 206               (*standard-output* *error-output*))
 207           (typecase datum
 208             (string
 209              (fresh-line)
 210              (write-string "Warning: ")
 211              (apply 'format t datum arguments)
 212              (terpri))
 213             (t (format t "~&Warning: ~A"
 214                        (or c (coerce-to-condition 'simple-warning datum arguments)))))))))
 215   nil)
 216
 217 (defun coerce-to-condition (default-type datum args)
 218   ;; (declare (dynamic-extent args))
 219   (etypecase datum
 220     (condition
 221      datum)
 222     (symbol
 223      (apply 'make-condition datum args))
 224     (string
 225      (make-condition default-type
 226        :format-control datum
 227        :format-arguments (copy-list args)))))
 228
 229 (defun signal-simple (default-type datum args)
 230   "Signal the condition denoted by a condition designator.
 231 Will only make-instance a condition when it is required.
 232 Return the condition object, if there was one."
 233   (let* ((class (etypecase datum
 234                   (symbol
 235                    (or (find-class datum nil)
 236                        (error "No condition class named ~S." datum)))
 237                   (string
 238                    (find-class default-type))
 239                   (condition
 240                    (class-of datum))))
 241          (cpl (class-precedence-list class))
 242          (condition nil)
 243          (bos-type *break-on-signals*))
 244     (with-simple-restart (continue "Ignore *break-on-signals*.")
 245       (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty.
 246         (when (typecase bos-type
 247                 (null nil)
 248                 (symbol
 249                  (let ((bos-class (find-class bos-type nil)))
 250                    (if (not bos-class)
 251                        (typep (class-prototype-value class) bos-type)
 252                        (member bos-class cpl))))
 253                 (list
 254                  (typep (class-prototype-value class) bos-type))
 255                 (t (member bos-type cpl)))
 256           (break "Signalling ~S" datum))))
 257     (macrolet ((invoke-handler (handler)
 258                  `(funcall ,handler
 259                            (or condition
 260                                (setf condition
 261                                      (coerce-to-condition default-type datum args))))))
 262       (let ((*active-condition-handlers* *active-condition-handlers*))
 263         (do () ((null *active-condition-handlers*))
 264           (let ((handlers (pop *active-condition-handlers*)))
 265             (dolist (handler handlers)
 266               (let ((handler-type (car handler)))
 267                 (typecase handler-type
 268                   (symbol
 269                    (let ((handler-class (find-class handler-type nil)))
 270                      (when (if (not handler-class)
 271                                (typep (class-prototype-value class) handler-type)
 272                                (progn
 273                                  (setf (car handler) handler-class) ; XXX memoize this find-class..
 274                                  (member handler-class cpl)))
 275                        (invoke-handler (cdr handler)))))
 276                   (cons
 277                    (when (typep (class-prototype-value class) handler-type)
 278                      (invoke-handler (cdr handler))))
 279                   (null)
 280                   (t (when (member handler-type cpl)
 281                        (invoke-handler (cdr handler)))))))))))
 282     (or condition
 283         (when (typep datum condition)
 284           datum))))
 285
 286 (defun signal (datum &rest args)
 287   (declare (dynamic-extent args))
 288   (signal-simple 'simple-condition datum args)
 289   nil)
 290
 291 (defun invoke-debugger (condition)
 292   (when *debugger-hook*
 293     (let ((hook *debugger-hook*)
 294           (*debugger-hook* nil))
 295       (funcall hook condition hook)))
 296   #+ignore
 297   (unless *debugger-function*
 298     (setf *debugger-function* #'muerte.init::my-debugger))
 299   (cond
 300    ((not *debugger-function*)
 301     (let ((*never-use-print-object* t))
 302       (backtrace :spartan t))
 303     (format t "~&No debugger in *debugger-function*...")
 304     (dotimes (i 100000)
 305       (write-string ""))
 306     (format t "Trying to continue or abort.")
 307     (invoke-restart (or (find-restart 'continue)
 308                         (find-restart 'abort)
 309                         (format t "~%Condition for debugger: ~Z" condition)
 310                         (format t "~%No abort restart is active. Halting CPU.")
 311                         (halt-cpu))))
 312    (t (let ((*debugger-invoked-stack-frame* (stack-frame-uplink nil (current-stack-frame))))
 313         (funcall *debugger-function* condition))))
 314   (format *debug-io* "~&Debugger ~@[on ~S ]returned!~%Trying to abort...~%" condition)
 315   (let ((r (find-restart 'abort)))
 316     (when r
 317       (invoke-restart r))
 318     (format *debug-io* "~&Aborting failed. Halting CPU.")
 319     (halt-cpu)))
 320
 321 (defun invoke-debugger-on-designator (&rest designator)
 322   (declare (dynamic-extent designator))
 323   (if (or (eq 'break (car designator))
 324           (and *error-no-condition-for-debugger*
 325                (symbolp (car designator)))
 326           ;; don't let an error trigger CLOS bootstrapping.
 327           (not (eq t (get 'clos-bootstrap 'have-bootstrapped))))
 328       (invoke-debugger designator)
 329     (invoke-debugger (coerce-to-condition (car designator)
 330                                           (cadr designator)
 331                                           (cddr designator)))))
 332
 333 (defun break (&optional format-control &rest format-arguments)
 334   (declare (dynamic-extent format-arguments))
 335   (with-simple-restart (continue "Return from break~:[.~;~:*: ~?~]" format-control format-arguments)
 336     ;; (format *debug-io* "~&Break: ~?" format-control format-arguments)
 337     (let ((*debugger-hook* nil))
 338       (apply 'invoke-debugger-on-designator
 339              'break
 340              (or format-control "Break was invoked.")
 341              format-arguments)))
 342   nil)
 343
 344 (define-condition newline () ())