src/code/late-target-error.lisp

   1 ;;;; stuff originally from CMU CL's error.lisp which can or should
   2 ;;;; come late (mostly related to the CONDITION class itself)
   3 ;;;;
   4 ;;;; FIXME: should perhaps be called condition.lisp, or moved into
   5 ;;;; classes.lisp
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!KERNEL")
  17 \f
  18 ;;;; the CONDITION class
  19
  20 (/show0 "late-target-error.lisp 20")
  21
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23
  24 (def!struct (condition-class (:include slot-class)
  25                              (:constructor bare-make-condition-class))
  26   ;; list of CONDITION-SLOT structures for the direct slots of this
  27   ;; class
  28   (slots nil :type list)
  29   ;; list of CONDITION-SLOT structures for all of the effective class
  30   ;; slots of this class
  31   (class-slots nil :type list)
  32   ;; report function or NIL
  33   (report nil :type (or function null))
  34   ;; list of alternating initargs and initforms
  35   (default-initargs () :type list)
  36   ;; class precedence list as a list of class objects, with all
  37   ;; non-condition classes removed
  38   (cpl () :type list)
  39   ;; a list of all the effective instance allocation slots of this
  40   ;; class that have a non-constant initform or default-initarg.
  41   ;; Values for these slots must be computed in the dynamic
  42   ;; environment of MAKE-CONDITION.
  43   (hairy-slots nil :type list))
  44
  45 (defun make-condition-class (&rest rest)
  46   (apply #'bare-make-condition-class
  47          (rename-key-args '((:name :%name)) rest)))
  48
  49 ) ; EVAL-WHEN
  50
  51 (defstruct (condition
  52             (:constructor make-condition-object (actual-initargs))
  53             (:alternate-metaclass instance
  54                                   condition-class
  55                                   make-condition-class)
  56             (:copier nil))
  57   ;; actual initargs supplied to MAKE-CONDITION
  58   (actual-initargs (required-argument) :type list)
  59   ;; a plist mapping slot names to any values that were assigned or
  60   ;; defaulted after creation
  61   (assigned-slots () :type list))
  62
  63 (defstruct (condition-slot (:copier nil))
  64   (name (required-argument) :type symbol)
  65   ;; list of all applicable initargs
  66   (initargs (required-argument) :type list)
  67   ;; names of reader and writer functions
  68   (readers (required-argument) :type list)
  69   (writers (required-argument) :type list)
  70   ;; true if :INITFORM was specified
  71   (initform-p (required-argument) :type (member t nil))
  72   ;; If this is a function, call it with no args. Otherwise, it's the
  73   ;; actual value.
  74   (initform (required-argument) :type t)
  75   ;; allocation of this slot, or NIL until defaulted
  76   (allocation nil :type (member :instance :class nil))
  77   ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
  78   (cell nil :type (or cons null)))
  79
  80 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
  81 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
  82 ;;; have themselves listed in their CPLs. This behavior is inherited
  83 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
  84 ;;; figured out whether it's right. -- WHN 19990612
  85 (eval-when (:compile-toplevel :load-toplevel :execute)
  86   (let ((condition-class (locally
  87                            ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
  88                            ;; constant class names which creates fast but
  89                            ;; non-cold-loadable, non-compact code. In this
  90                            ;; context, we'd rather have compact, cold-loadable
  91                            ;; code. -- WHN 19990928
  92                            (declare (notinline sb!xc:find-class))
  93                            (sb!xc:find-class 'condition))))
  94     (setf (condition-class-cpl condition-class)
  95           (list condition-class))))
  96
  97 (setf (condition-class-report (locally
  98                                 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
  99                                 ;; for constant class names which creates fast
 100                                 ;; but non-cold-loadable, non-compact code. In
 101                                 ;; this context, we'd rather have compact,
 102                                 ;; cold-loadable code. -- WHN 19990928
 103                                 (declare (notinline sb!xc:find-class))
 104                                 (find-class 'condition)))
 105       #'(lambda (cond stream)
 106           (format stream "Condition ~S was signalled." (type-of cond))))
 107
 108 (eval-when (:compile-toplevel :load-toplevel :execute)
 109
 110 (defun find-condition-layout (name parent-types)
 111   (let* ((cpl (remove-duplicates
 112                (reverse
 113                 (reduce #'append
 114                         (mapcar #'(lambda (x)
 115                                     (condition-class-cpl
 116                                      (sb!xc:find-class x)))
 117                                 parent-types)))))
 118          (cond-layout (info :type :compiler-layout 'condition))
 119          (olayout (info :type :compiler-layout name))
 120          (new-inherits
 121           (concatenate 'simple-vector
 122                        (layout-inherits cond-layout)
 123                        (mapcar #'class-layout cpl))))
 124     (if (and olayout
 125              (not (mismatch (layout-inherits olayout) new-inherits)))
 126         olayout
 127         (make-layout :class (make-undefined-class name)
 128                      :inherits new-inherits
 129                      :depthoid -1
 130                      :length (layout-length cond-layout)))))
 131
 132 ) ; EVAL-WHEN
 133
 134 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
 135 ;;;   Condition reporting is mediated through the PRINT-OBJECT method
 136 ;;;   for the condition type in question, with *PRINT-ESCAPE* always
 137 ;;;   being nil. Specifying (:REPORT REPORT-NAME) in the definition of
 138 ;;;   a condition type C is equivalent to:
 139 ;;;     (defmethod print-object ((x c) stream)
 140 ;;;       (if *print-escape* (call-next-method) (report-name x stream)))
 141 ;;; The current code doesn't seem to quite match that.
 142 (def!method print-object ((x condition) stream)
 143   (if *print-escape*
 144       (print-unreadable-object (x stream :type t :identity t))
 145       ;; KLUDGE: A comment from CMU CL here said
 146       ;;   7/13/98 BUG? CPL is not sorted and results here depend on order of
 147       ;;   superclasses in define-condition call!
 148       (dolist (class (condition-class-cpl (sb!xc:class-of x))
 149                      (error "no REPORT? shouldn't happen!"))
 150         (let ((report (condition-class-report class)))
 151           (when report
 152             (return (funcall report x stream)))))))
 153 \f
 154 ;;;; slots of CONDITION objects
 155
 156 (defvar *empty-condition-slot* '(empty))
 157
 158 (defun find-slot-default (class slot)
 159   (let ((initargs (condition-slot-initargs slot))
 160         (cpl (condition-class-cpl class)))
 161     (dolist (class cpl)
 162       (let ((default-initargs (condition-class-default-initargs class)))
 163         (dolist (initarg initargs)
 164           (let ((val (getf default-initargs initarg *empty-condition-slot*)))
 165             (unless (eq val *empty-condition-slot*)
 166               (return-from find-slot-default
 167                            (if (functionp val)
 168                                (funcall val)
 169                                val)))))))
 170
 171     (if (condition-slot-initform-p slot)
 172         (let ((initform (condition-slot-initform slot)))
 173           (if (functionp initform)
 174               (funcall initform)
 175               initform))
 176         (error "unbound condition slot: ~S" (condition-slot-name slot)))))
 177
 178 (defun find-condition-class-slot (condition-class slot-name)
 179   (dolist (sclass
 180            (condition-class-cpl condition-class)
 181            (error "There is no slot named ~S in ~S."
 182                   slot-name condition-class))
 183     (dolist (slot (condition-class-slots sclass))
 184       (when (eq (condition-slot-name slot) slot-name)
 185         (return-from find-condition-class-slot slot)))))
 186
 187 (defun condition-writer-function (condition new-value name)
 188   (dolist (cslot (condition-class-class-slots
 189                   (layout-class (%instance-layout condition)))
 190                  (setf (getf (condition-assigned-slots condition) name)
 191                        new-value))
 192     (when (eq (condition-slot-name cslot) name)
 193       (return (setf (car (condition-slot-cell cslot)) new-value)))))
 194
 195 (defun condition-reader-function (condition name)
 196   (let ((class (layout-class (%instance-layout condition))))
 197     (dolist (cslot (condition-class-class-slots class))
 198       (when (eq (condition-slot-name cslot) name)
 199         (return-from condition-reader-function
 200                      (car (condition-slot-cell cslot)))))
 201
 202     (let ((val (getf (condition-assigned-slots condition) name
 203                      *empty-condition-slot*)))
 204       (if (eq val *empty-condition-slot*)
 205           (let ((actual-initargs (condition-actual-initargs condition))
 206                 (slot (find-condition-class-slot class name)))
 207             (unless slot
 208               (error "missing slot ~S of ~S" name condition))
 209             (dolist (initarg (condition-slot-initargs slot))
 210               (let ((val (getf actual-initargs
 211                                initarg
 212                                *empty-condition-slot*)))
 213                 (unless (eq val *empty-condition-slot*)
 214                   (return-from condition-reader-function
 215                                (setf (getf (condition-assigned-slots condition)
 216                                            name)
 217                                      val)))))
 218             (setf (getf (condition-assigned-slots condition) name)
 219                   (find-slot-default class slot)))
 220           val))))
 221 \f
 222 ;;;; MAKE-CONDITION
 223
 224 (defun make-condition (thing &rest args)
 225   #!+sb-doc
 226   "Make an instance of a condition object using the specified initargs."
 227   ;; Note: ANSI specifies no exceptional situations in this function.
 228   ;; signalling simple-type-error would not be wrong.
 229   (let* ((thing (if (symbolp thing)
 230                     (sb!xc:find-class thing)
 231                     thing))
 232          (class (typecase thing
 233                   (condition-class thing)
 234                   (class
 235                    (error 'simple-type-error
 236                           :datum thing
 237                           :expected-type 'condition-class
 238                           :format-control "~S is not a condition class."
 239                           :format-arguments (list thing)))
 240                   (t
 241                    (error 'simple-type-error
 242                           :datum thing
 243                           :expected-type 'condition-class
 244                           :format-control "bad thing for class argument:~%  ~S"
 245                           :format-arguments (list thing)))))
 246          (res (make-condition-object args)))
 247     (setf (%instance-layout res) (class-layout class))
 248     ;; Set any class slots with initargs present in this call.
 249     (dolist (cslot (condition-class-class-slots class))
 250       (dolist (initarg (condition-slot-initargs cslot))
 251         (let ((val (getf args initarg *empty-condition-slot*)))
 252           (unless (eq val *empty-condition-slot*)
 253             (setf (car (condition-slot-cell cslot)) val)))))
 254     ;; Default any slots with non-constant defaults now.
 255     (dolist (hslot (condition-class-hairy-slots class))
 256       (when (dolist (initarg (condition-slot-initargs hslot) t)
 257               (unless (eq (getf args initarg *empty-condition-slot*)
 258                           *empty-condition-slot*)
 259                 (return nil)))
 260         (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
 261               (find-slot-default class hslot))))
 262
 263     res))
 264 \f
 265 ;;;; DEFINE-CONDITION
 266
 267 (eval-when (:compile-toplevel :load-toplevel :execute)
 268 (defun %compiler-define-condition (name direct-supers layout)
 269   (multiple-value-bind (class old-layout)
 270       (insured-find-class name #'condition-class-p #'make-condition-class)
 271     (setf (layout-class layout) class)
 272     (setf (class-direct-superclasses class)
 273           (mapcar #'sb!xc:find-class direct-supers))
 274     (cond ((not old-layout)
 275            (register-layout layout))
 276           ((not *type-system-initialized*)
 277            (setf (layout-class old-layout) class)
 278            (setq layout old-layout)
 279            (unless (eq (class-layout class) layout)
 280              (register-layout layout)))
 281           ((redefine-layout-warning "current"
 282                                     old-layout
 283                                     "new"
 284                                     (layout-length layout)
 285                                     (layout-inherits layout)
 286                                     (layout-depthoid layout))
 287            (register-layout layout :invalidate t))
 288           ((not (class-layout class))
 289            (register-layout layout)))
 290
 291     (setf (layout-info layout)
 292           (locally
 293             ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
 294             ;; names which creates fast but non-cold-loadable, non-compact
 295             ;; code. In this context, we'd rather have compact, cold-loadable
 296             ;; code. -- WHN 19990928
 297             (declare (notinline sb!xc:find-class))
 298             (layout-info (class-layout (sb!xc:find-class 'condition)))))
 299
 300     (setf (sb!xc:find-class name) class)
 301
 302     ;; Initialize CPL slot from layout.
 303     (collect ((cpl))
 304       (cpl class)
 305       (let ((inherits (layout-inherits layout)))
 306         (do ((i (1- (length inherits)) (1- i)))
 307             ((minusp i))
 308           (let ((super (sb!xc:find-class
 309                         (sb!xc:class-name
 310                          (layout-class (svref inherits i))))))
 311             (when (typep super 'condition-class)
 312               (cpl super)))))
 313       (setf (condition-class-cpl class) (cpl))))
 314
 315   (values))
 316
 317 ) ; EVAL-WHEN
 318
 319 ;;; Compute the effective slots of class, copying inherited slots and
 320 ;;; side-effecting direct slots.
 321 (defun compute-effective-slots (class)
 322   (collect ((res (copy-list (condition-class-slots class))))
 323     (dolist (sclass (condition-class-cpl class))
 324       (dolist (sslot (condition-class-slots sclass))
 325         (let ((found (find (condition-slot-name sslot) (res)
 326                            :test #'eq)))
 327           (cond (found
 328                  (setf (condition-slot-initargs found)
 329                        (union (condition-slot-initargs found)
 330                               (condition-slot-initargs sslot)))
 331                  (unless (condition-slot-initform-p found)
 332                    (setf (condition-slot-initform-p found)
 333                          (condition-slot-initform-p sslot))
 334                    (setf (condition-slot-initform found)
 335                          (condition-slot-initform sslot)))
 336                  (unless (condition-slot-allocation found)
 337                    (setf (condition-slot-allocation found)
 338                          (condition-slot-allocation sslot))))
 339                 (t
 340                  (res (copy-structure sslot)))))))
 341     (res)))
 342
 343 (defun %define-condition (name slots documentation report default-initargs)
 344   (let ((class (sb!xc:find-class name)))
 345     (setf (condition-class-slots class) slots)
 346     (setf (condition-class-report class) report)
 347     (setf (condition-class-default-initargs class) default-initargs)
 348     (setf (fdocumentation name 'type) documentation)
 349
 350     (dolist (slot slots)
 351
 352       ;; Set up reader and writer functions.
 353       (let ((name (condition-slot-name slot)))
 354         (dolist (reader (condition-slot-readers slot))
 355           (setf (fdefinition reader)
 356                 #'(lambda (condition)
 357                     (condition-reader-function condition name))))
 358         (dolist (writer (condition-slot-writers slot))
 359           (setf (fdefinition writer)
 360                 #'(lambda (new-value condition)
 361                     (condition-writer-function condition new-value name))))))
 362
 363     ;; Compute effective slots and set up the class and hairy slots
 364     ;; (subsets of the effective slots.)
 365     (let ((eslots (compute-effective-slots class))
 366           (e-def-initargs
 367            (reduce #'append
 368                    (mapcar #'condition-class-default-initargs
 369                            (condition-class-cpl class)))))
 370       (dolist (slot eslots)
 371         (ecase (condition-slot-allocation slot)
 372           (:class
 373            (unless (condition-slot-cell slot)
 374              (setf (condition-slot-cell slot)
 375                    (list (if (condition-slot-initform-p slot)
 376                              (let ((initform (condition-slot-initform slot)))
 377                                (if (functionp initform)
 378                                    (funcall initform)
 379                                    initform))
 380                              *empty-condition-slot*))))
 381            (push slot (condition-class-class-slots class)))
 382           ((:instance nil)
 383            (setf (condition-slot-allocation slot) :instance)
 384            (when (or (functionp (condition-slot-initform slot))
 385                      (dolist (initarg (condition-slot-initargs slot) nil)
 386                        (when (functionp (getf e-def-initargs initarg))
 387                          (return t))))
 388              (push slot (condition-class-hairy-slots class))))))))
 389   name)
 390
 391 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
 392                                  &body options)
 393   #!+sb-doc
 394   "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
 395    Define NAME as a condition type. This new type inherits slots and its
 396    report function from the specified PARENT-TYPEs. A slot spec is a list of:
 397      (slot-name :reader <rname> :initarg <iname> {Option Value}*
 398
 399    The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
 400    and :TYPE and the overall options :DEFAULT-INITARGS and
 401    [type] :DOCUMENTATION are also allowed.
 402
 403    The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
 404    a string or a two-argument lambda or function name. If a function, the
 405    function is called with the condition and stream to report the condition.
 406    If a string, the string is printed.
 407
 408    Condition types are classes, but (as allowed by ANSI and not as described in
 409    CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
 410    SLOT-VALUE may not be used on condition objects."
 411   (let* ((parent-types (or parent-types '(condition)))
 412          (layout (find-condition-layout name parent-types))
 413          (documentation nil)
 414          (report nil)
 415          (default-initargs ()))
 416     (collect ((slots)
 417               (all-readers nil append)
 418               (all-writers nil append))
 419       (dolist (spec slot-specs)
 420         (when (keywordp spec)
 421           (warn "Keyword slot name indicates probable syntax error:~%  ~S"
 422                 spec))
 423         (let* ((spec (if (consp spec) spec (list spec)))
 424                (slot-name (first spec))
 425                (allocation :instance)
 426                (initform-p nil)
 427                initform)
 428           (collect ((initargs)
 429                     (readers)
 430                     (writers))
 431             (do ((options (rest spec) (cddr options)))
 432                 ((null options))
 433               (unless (and (consp options) (consp (cdr options)))
 434                 (error "malformed condition slot spec:~%  ~S." spec))
 435               (let ((arg (second options)))
 436                 (case (first options)
 437                   (:reader (readers arg))
 438                   (:writer (writers arg))
 439                   (:accessor
 440                    (readers arg)
 441                    (writers `(setf ,arg)))
 442                   (:initform
 443                    (when initform-p
 444                      (error "more than one :INITFORM in ~S" spec))
 445                    (setq initform-p t)
 446                    (setq initform arg))
 447                   (:initarg (initargs arg))
 448                   (:allocation
 449                    (setq allocation arg))
 450                   (:type)
 451                   (t
 452                    (error "unknown slot option:~%  ~S" (first options))))))
 453
 454             (all-readers (readers))
 455             (all-writers (writers))
 456             (slots `(make-condition-slot
 457                      :name ',slot-name
 458                      :initargs ',(initargs)
 459                      :readers ',(readers)
 460                      :writers ',(writers)
 461                      :initform-p ',initform-p
 462                      :initform
 463                      ,(if (constantp initform)
 464                           `',(eval initform)
 465                           `#'(lambda () ,initform)))))))
 466
 467       (dolist (option options)
 468         (unless (consp option)
 469           (error "bad option:~%  ~S" option))
 470         (case (first option)
 471           (:documentation (setq documentation (second option)))
 472           (:report
 473            (let ((arg (second option)))
 474              (setq report
 475                    (if (stringp arg)
 476                        `#'(lambda (condition stream)
 477                             (declare (ignore condition))
 478                             (write-string ,arg stream))
 479                        `#'(lambda (condition stream)
 480                             (funcall #',arg condition stream))))))
 481           (:default-initargs
 482            (do ((initargs (rest option) (cddr initargs)))
 483                ((endp initargs))
 484              (let ((val (second initargs)))
 485                (setq default-initargs
 486                      (list* `',(first initargs)
 487                             (if (constantp val)
 488                                 `',(eval val)
 489                                 `#'(lambda () ,val))
 490                             default-initargs)))))
 491           (t
 492            (error "unknown option: ~S" (first option)))))
 493
 494       (when (all-writers)
 495         (warn "Condition slot setters probably not allowed in ANSI CL:~%  ~S"
 496               (all-writers)))
 497
 498       `(progn
 499          (eval-when (:compile-toplevel :load-toplevel :execute)
 500            (%compiler-define-condition ',name ',parent-types ',layout))
 501
 502          (declaim (ftype (function (t) t) ,@(all-readers)))
 503          (declaim (ftype (function (t t) t) ,@(all-writers)))
 504
 505          (%define-condition ',name
 506                             (list ,@(slots))
 507                             ,documentation
 508                             ,report
 509                             (list ,@default-initargs))))))
 510 \f
 511 ;;;; DESCRIBE on CONDITIONs
 512
 513 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
 514 ;;; eventually (once we get CLOS up and running so that we can define
 515 ;;; methods)
 516 (defun describe-condition (condition stream)
 517   (format stream
 518           "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
 519           condition
 520           (type-of condition)
 521           (concatenate 'list
 522                        (condition-actual-initargs condition)
 523                        (condition-assigned-slots condition))))
 524 \f
 525 ;;;; various CONDITIONs specified by ANSI
 526
 527 (define-condition serious-condition (condition) ())
 528
 529 (define-condition error (serious-condition) ())
 530
 531 (define-condition warning (condition) ())
 532 (define-condition style-warning (warning) ())
 533
 534 (defun simple-condition-printer (condition stream)
 535   (apply #'format
 536          stream
 537          (simple-condition-format-control condition)
 538          (simple-condition-format-arguments condition)))
 539
 540 (define-condition simple-condition ()
 541   ((format-control :reader simple-condition-format-control
 542                    :initarg :format-control)
 543    (format-arguments :reader simple-condition-format-arguments
 544                      :initarg :format-arguments
 545                      :initform '()))
 546   (:report simple-condition-printer))
 547
 548 (define-condition simple-warning (simple-condition warning) ())
 549
 550 ;;; This is the condition type used by ERROR and CERROR when
 551 ;;; a format-control string is supplied as the first argument.
 552 (define-condition simple-error (simple-condition error) ())
 553
 554 (define-condition storage-condition (serious-condition) ())
 555
 556 (define-condition type-error (error)
 557   ((datum :reader type-error-datum :initarg :datum)
 558    (expected-type :reader type-error-expected-type :initarg :expected-type))
 559   (:report
 560    (lambda (condition stream)
 561      (format stream
 562              "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
 563              (type-error-datum condition)
 564              (type-error-expected-type condition)))))
 565
 566 (define-condition program-error (error) ())
 567 (define-condition parse-error   (error) ())
 568 (define-condition control-error (error) ())
 569 (define-condition stream-error  (error)
 570   ((stream :reader stream-error-stream :initarg :stream)))
 571
 572 (define-condition end-of-file (stream-error) ()
 573   (:report
 574    (lambda (condition stream)
 575      (format stream
 576              "end of file on ~S"
 577              (stream-error-stream condition)))))
 578
 579 (define-condition file-error (error)
 580   ((pathname :reader file-error-pathname :initarg :pathname))
 581   (:report
 582    (lambda (condition stream)
 583      (format stream
 584              "~@<error on file ~_~S: ~2I~:_~?~:>"
 585              (file-error-pathname condition)
 586              ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and
 587              ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem
 588              ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either.
 589              ;; So how does this work?
 590              (serious-condition-format-control condition)
 591              (serious-condition-format-arguments condition)))))
 592
 593 (define-condition package-error (error)
 594   ((package :reader package-error-package :initarg :package)))
 595
 596 (define-condition cell-error (error)
 597   ((name :reader cell-error-name :initarg :name)))
 598
 599 (define-condition unbound-variable (cell-error) ()
 600   (:report
 601    (lambda (condition stream)
 602      (format stream
 603              "The variable ~S is unbound."
 604              (cell-error-name condition)))))
 605
 606 (define-condition undefined-function (cell-error) ()
 607   (:report
 608    (lambda (condition stream)
 609      (format stream
 610              "The function ~S is undefined."
 611              (cell-error-name condition)))))
 612
 613 (define-condition arithmetic-error (error)
 614   ((operation :reader arithmetic-error-operation
 615               :initarg :operation
 616               :initform nil)
 617    (operands :reader arithmetic-error-operands
 618              :initarg :operands))
 619   (:report (lambda (condition stream)
 620              (format stream
 621                      "arithmetic error ~S signalled"
 622                      (type-of condition))
 623              (when (arithmetic-error-operation condition)
 624                (format stream
 625                        "~%Operation was ~S, operands ~S."
 626                        (arithmetic-error-operation condition)
 627                        (arithmetic-error-operands condition))))))
 628
 629 (define-condition division-by-zero         (arithmetic-error) ())
 630 (define-condition floating-point-overflow  (arithmetic-error) ())
 631 (define-condition floating-point-underflow (arithmetic-error) ())
 632 (define-condition floating-point-inexact   (arithmetic-error) ())
 633 (define-condition floating-point-invalid-operation (arithmetic-error) ())
 634
 635 (define-condition print-not-readable (error)
 636   ((object :reader print-not-readable-object :initarg :object))
 637   (:report
 638    (lambda (condition stream)
 639      (let ((obj (print-not-readable-object condition))
 640            (*print-array* nil))
 641        (format stream "~S cannot be printed readably." obj)))))
 642
 643 (define-condition reader-error (parse-error stream-error)
 644   ((format-control
 645     :reader reader-error-format-control
 646     :initarg :format-control)
 647    (format-arguments
 648     :reader reader-error-format-arguments
 649     :initarg :format-arguments
 650     :initform '()))
 651   (:report
 652    (lambda (condition stream)
 653      (let ((error-stream (stream-error-stream condition)))
 654        (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
 655                (file-position error-stream) error-stream
 656                (reader-error-format-control condition)
 657                (reader-error-format-arguments condition))))))
 658 \f
 659 ;;;; various other (not specified by ANSI) CONDITIONs
 660 ;;;;
 661 ;;;; These might logically belong in other files; they're here, after
 662 ;;;; setup of CONDITION machinery, only because that makes it easier to
 663 ;;;; get cold init to work.
 664
 665 ;;; KLUDGE: a condition for floating point errors when we can't or
 666 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
 667 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
 668 ;;; know how but the old code was broken by the conversion to POSIX
 669 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
 670 ;;;
 671 ;;; FIXME: Perhaps this should also be a base class for all
 672 ;;; floating point exceptions?
 673 (define-condition floating-point-exception (arithmetic-error)
 674   ((flags :initarg :traps
 675           :initform nil
 676           :reader floating-point-exception-traps))
 677   (:report (lambda (condition stream)
 678              (format stream
 679                      "An arithmetic error ~S was signalled.~%"
 680                      (type-of condition))
 681              (let ((traps (floating-point-exception-traps condition)))
 682                (if traps
 683                    (format stream
 684                            "Trapping conditions are: ~%~{ ~S~^~}~%"
 685                            traps)
 686                    (write-line
 687                     "No traps are enabled? How can this be?"
 688                     stream))))))
 689
 690 (define-condition index-too-large-error (type-error)
 691   ()
 692   (:report
 693    (lambda (condition stream)
 694      (format stream
 695              "The index ~S is too large."
 696              (type-error-datum condition)))))
 697
 698 (define-condition io-timeout (stream-error)
 699   ((direction :reader io-timeout-direction :initarg :direction))
 700   (:report
 701    (lambda (condition stream)
 702      (declare (type stream stream))
 703      (format stream
 704              "I/O timeout ~(~A~)ing ~S"
 705              (io-timeout-direction condition)
 706              (stream-error-stream condition)))))
 707
 708 (define-condition namestring-parse-error (parse-error)
 709   ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
 710    (arguments :reader namestring-parse-error-arguments :initarg :arguments
 711               :initform nil)
 712    (namestring :reader namestring-parse-error-namestring :initarg :namestring)
 713    (offset :reader namestring-parse-error-offset :initarg :offset))
 714   (:report
 715    (lambda (condition stream)
 716      (format stream
 717              "parse error in namestring: ~?~%  ~A~%  ~V@T^"
 718              (namestring-parse-error-complaint condition)
 719              (namestring-parse-error-arguments condition)
 720              (namestring-parse-error-namestring condition)
 721              (namestring-parse-error-offset condition)))))
 722
 723 (define-condition simple-package-error (simple-condition package-error) ())
 724
 725 (define-condition reader-package-error (reader-error) ())
 726
 727 (define-condition reader-eof-error (end-of-file)
 728   ((context :reader reader-eof-error-context :initarg :context))
 729   (:report
 730    (lambda (condition stream)
 731      (format stream
 732              "unexpected end of file on ~S ~A"
 733              (stream-error-stream condition)
 734              (reader-eof-error-context condition)))))
 735 \f
 736 ;;;; restart definitions
 737
 738 (define-condition abort-failure (control-error) ()
 739   (:report
 740    "An ABORT restart was found that failed to transfer control dynamically."))
 741
 742 (defun abort (&optional condition)
 743   #!+sb-doc
 744   "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
 745    none exists."
 746   (invoke-restart (find-restart 'abort condition))
 747   ;; ABORT signals an error in case there was a restart named ABORT
 748   ;; that did not transfer control dynamically. This could happen with
 749   ;; RESTART-BIND.
 750   (error 'abort-failure))
 751
 752 (defun muffle-warning (&optional condition)
 753   #!+sb-doc
 754   "Transfer control to a restart named MUFFLE-WARNING, signalling a
 755    CONTROL-ERROR if none exists."
 756   (invoke-restart (find-restart 'muffle-warning condition)))
 757
 758 (macrolet ((define-nil-returning-restart (name args doc)
 759              #!-sb-doc (declare (ignore doc))
 760              `(defun ,name (,@args &optional condition)
 761                 #!+sb-doc ,doc
 762                 ;; FIXME: Perhaps this shared logic should be pulled out into
 763                 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
 764                 (when (find-restart ',name condition)
 765                   (invoke-restart ',name ,@args)))))
 766   (define-nil-returning-restart continue ()
 767     "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
 768   (define-nil-returning-restart store-value (value)
 769     "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
 770    none exists.")
 771   (define-nil-returning-restart use-value (value)
 772     "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
 773    none exists."))
 774
 775 (/show0 "late-target-error.lisp end of file")
 776