src/code/condition.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
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!KERNEL")
  15 \f
  16 ;;;; the CONDITION class
  17
  18 (/show0 "condition.lisp 20")
  19
  20 (defstruct (condition-slot (:copier nil))
  21   (name (missing-arg) :type symbol)
  22   ;; list of all applicable initargs
  23   (initargs (missing-arg) :type list)
  24   ;; names of reader and writer functions
  25   (readers (missing-arg) :type list)
  26   (writers (missing-arg) :type list)
  27   ;; true if :INITFORM was specified
  28   (initform-p (missing-arg) :type (member t nil))
  29   ;; the initform if :INITFORM was specified, otherwise NIL
  30   (initform nil :type t)
  31   ;; if this is a function, call it with no args to get the initform value
  32   (initfunction (missing-arg) :type t)
  33   ;; allocation of this slot, or NIL until defaulted
  34   (allocation nil :type (member :instance :class nil))
  35   ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value
  36   (cell nil :type (or cons null))
  37   ;; slot documentation
  38   (documentation nil :type (or string null)))
  39
  40 (eval-when (:compile-toplevel :load-toplevel :execute)
  41   (/show0 "condition.lisp 103")
  42   (let ((condition-class (find-classoid 'condition)))
  43     (setf (condition-classoid-cpl condition-class)
  44           (list condition-class)))
  45   (/show0 "condition.lisp 103"))
  46
  47 (setf (condition-classoid-report (find-classoid 'condition))
  48       (lambda (cond stream)
  49         (format stream "Condition ~/sb!impl:print-type-specifier/ was signalled."
  50                 (type-of cond))))
  51
  52 (eval-when (:compile-toplevel :load-toplevel :execute)
  53
  54 (defun find-condition-layout (name parent-types)
  55   (let* ((cpl (remove-duplicates
  56                (reverse
  57                 (reduce #'append
  58                         (mapcar (lambda (x)
  59                                   (condition-classoid-cpl
  60                                    (find-classoid x)))
  61                                 parent-types)))))
  62          (cond-layout (info :type :compiler-layout 'condition))
  63          (olayout (info :type :compiler-layout name))
  64          ;; FIXME: Does this do the right thing in case of multiple
  65          ;; inheritance? A quick look at DEFINE-CONDITION didn't make
  66          ;; it obvious what ANSI intends to be done in the case of
  67          ;; multiple inheritance, so it's not actually clear what the
  68          ;; right thing is..
  69          (new-inherits
  70           (order-layout-inherits (concatenate 'simple-vector
  71                                               (layout-inherits cond-layout)
  72                                               (mapcar #'classoid-layout cpl)))))
  73     (if (and olayout
  74              (not (mismatch (layout-inherits olayout) new-inherits)))
  75         olayout
  76         (make-layout :classoid (make-undefined-classoid name)
  77                      :%flags +condition-layout-flag+
  78                      :inherits new-inherits
  79                      :depthoid -1
  80                      :length (layout-length cond-layout)))))
  81
  82 ) ; EVAL-WHEN
  83
  84 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
  85 ;;;   Condition reporting is mediated through the PRINT-OBJECT method
  86 ;;;   for the condition type in question, with *PRINT-ESCAPE* always
  87 ;;;   being nil. Specifying (:REPORT REPORT-NAME) in the definition of
  88 ;;;   a condition type C is equivalent to:
  89 ;;;     (defmethod print-object ((x c) stream)
  90 ;;;       (if *print-escape* (call-next-method) (report-name x stream)))
  91 ;;; The current code doesn't seem to quite match that.
  92 (defmethod print-object ((object condition) stream)
  93   (cond
  94     ((not *print-escape*)
  95      ;; KLUDGE: A comment from CMU CL here said
  96      ;;   7/13/98 BUG? CPL is not sorted and results here depend on order of
  97      ;;   superclasses in define-condition call!
  98      (funcall (or (some #'condition-classoid-report
  99                         (condition-classoid-cpl (classoid-of object)))
 100                   (error "no REPORT? shouldn't happen!"))
 101               object stream))
 102     ((and (typep object 'simple-condition)
 103           (condition-slot-value object 'format-control))
 104      (print-unreadable-object (object stream :type t :identity t)
 105        (write (simple-condition-format-control object)
 106               :stream stream :lines 1)))
 107     (t
 108      (print-unreadable-object (object stream :type t :identity t)))))
 109 \f
 110 ;;;; slots of CONDITION objects
 111
 112 (defun find-slot-default (class slot)
 113   (let ((initargs (condition-slot-initargs slot))
 114         (cpl (condition-classoid-cpl class)))
 115     ;; When CLASS or a superclass has a default initarg for SLOT, use
 116     ;; that.
 117     (dolist (class cpl)
 118       (let ((direct-default-initargs
 119               (condition-classoid-direct-default-initargs class)))
 120         (dolist (initarg initargs)
 121           (let ((initfunction (third (assoc initarg direct-default-initargs))))
 122             (when initfunction
 123               (return-from find-slot-default (funcall initfunction)))))))
 124
 125     ;; Otherwise use the initform of SLOT, if there is one.
 126     (if (condition-slot-initform-p slot)
 127         (let ((initfun (condition-slot-initfunction slot)))
 128           (aver (functionp initfun))
 129           (funcall initfun))
 130         (error "unbound condition slot: ~S" (condition-slot-name slot)))))
 131
 132 (defun find-condition-class-slot (condition-class slot-name)
 133   (dolist (sclass
 134            (condition-classoid-cpl condition-class)
 135            (error "There is no slot named ~S in ~S."
 136                   slot-name condition-class))
 137     (dolist (slot (condition-classoid-slots sclass))
 138       (when (eq (condition-slot-name slot) slot-name)
 139         (return-from find-condition-class-slot slot)))))
 140
 141 (defun set-condition-slot-value (condition new-value name)
 142   (dolist (cslot (condition-classoid-class-slots
 143                   (layout-classoid (%instance-layout condition)))
 144                  (setf (getf (condition-assigned-slots condition) name)
 145                        new-value))
 146     (when (eq (condition-slot-name cslot) name)
 147       (return (setf (car (condition-slot-cell cslot)) new-value)))))
 148
 149 (defun condition-slot-value (condition name)
 150   (let ((val (getf (condition-assigned-slots condition) name sb!pcl:+slot-unbound+)))
 151     (if (unbound-marker-p val)
 152         (let ((class (layout-classoid (%instance-layout condition))))
 153           (dolist (cslot
 154                    (condition-classoid-class-slots class)
 155                    (let ((instance-length (%instance-length condition))
 156                          (slot (or (find-condition-class-slot class name)
 157                                    (error "missing slot ~S of ~S" name condition))))
 158                      (setf (getf (condition-assigned-slots condition) name)
 159                            (do ((i (+ sb!vm:instance-data-start 2) (+ i 2)))
 160                                ((>= i instance-length) (find-slot-default class slot))
 161                                (when (member (%instance-ref condition i)
 162                                              (condition-slot-initargs slot))
 163                                  (return (%instance-ref condition (1+ i))))))))
 164             (when (eq (condition-slot-name cslot) name)
 165               (return (car (condition-slot-cell cslot))))))
 166         val)))
 167 \f
 168 ;;;; MAKE-CONDITION
 169
 170 (defun allocate-condition (designator &rest initargs)
 171   (when (oddp (length initargs))
 172     (error 'simple-error
 173            :format-control "odd-length initializer list: ~S."
 174            :format-arguments
 175            (let (list)
 176              ;; avoid direct reference to INITARGS as a list
 177              ;; so that it is not reified unless we reach here.
 178              (do-rest-arg ((arg) initargs) (push arg list))
 179              (nreverse list))))
 180   ;; I am going to assume that people are not somehow getting to here
 181   ;; with a CLASSOID, which is not strictly legal as a designator,
 182   ;; but which is accepted because it is actually the desired thing.
 183   ;; It doesn't seem worth sweating over that detail, and in any event
 184   ;; we could say that it's a supported extension.
 185   (let ((classoid (named-let lookup ((designator designator))
 186                     (typecase designator
 187                      (symbol (find-classoid designator nil))
 188                      (class (lookup (class-name designator)))
 189                      (t designator)))))
 190     (if (condition-classoid-p classoid)
 191         ;; Interestingly we fail to validate the actual-initargs,
 192         ;; allowing any random initarg names.  Is this permissible?
 193         ;; And why is lazily filling in ASSIGNED-SLOTS beneficial anyway?
 194         (let ((instance (%make-instance (+ sb!vm:instance-data-start
 195                                            2 ; ASSIGNED-SLOTS and HASH
 196                                            (length initargs))))) ; rest
 197           (setf (%instance-layout instance) (classoid-layout classoid)
 198                 (condition-assigned-slots instance) nil
 199                 (condition-hash instance) (sb!impl::new-instance-hash-code))
 200           (do-rest-arg ((val index) initargs)
 201             (setf (%instance-ref instance (+ sb!vm:instance-data-start index 2)) val))
 202           (values instance classoid))
 203         (error 'simple-type-error
 204                :datum designator
 205                ;; CONDITION-CLASS isn't a type-specifier. Is this legal?
 206                :expected-type 'condition-class
 207                :format-control "~S does not designate a condition class."
 208                :format-arguments (list designator)))))
 209
 210 (defun make-condition (type &rest initargs)
 211   "Make an instance of a condition object using the specified initargs."
 212   ;; Note: While ANSI specifies no exceptional situations in this function,
 213   ;; ALLOCATE-CONDITION will signal a type error if TYPE does not designate
 214   ;; a condition class. This seems fair enough.
 215   (declare (explicit-check))
 216   ;; FIXME: the compiler should have a way to make GETF operate on a &MORE arg
 217   ;; so that the initargs are never listified.
 218   (declare (dynamic-extent initargs))
 219   (multiple-value-bind (condition classoid)
 220       (apply #'allocate-condition type initargs)
 221
 222     ;; Set any class slots with initargs present in this call.
 223     (dolist (cslot (condition-classoid-class-slots classoid))
 224       (dolist (initarg (condition-slot-initargs cslot))
 225         (let ((val (getf initargs initarg sb!pcl:+slot-unbound+)))
 226           (unless (unbound-marker-p val)
 227             (setf (car (condition-slot-cell cslot)) val)))))
 228
 229     ;; Default any slots with non-constant defaults now.
 230     (dolist (hslot (condition-classoid-hairy-slots classoid))
 231       (when (dolist (initarg (condition-slot-initargs hslot) t)
 232               (unless (unbound-marker-p (getf initargs initarg sb!pcl:+slot-unbound+))
 233                 (return nil)))
 234         (setf (getf (condition-assigned-slots condition)
 235                     (condition-slot-name hslot))
 236               (find-slot-default classoid hslot))))
 237
 238     condition))
 239
 240 \f
 241 ;;;; DEFINE-CONDITION
 242
 243 ;;; Compute the effective slots of CLASS, copying inherited slots and
 244 ;;; destructively modifying direct slots.
 245 ;;;
 246 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
 247 ;;; direct slots. Presumably it follows from the semantics of
 248 ;;; inheritance and redefinition of conditions, but finding the cite
 249 ;;; and documenting it here would be good. (Or, if this is not in fact
 250 ;;; ANSI-compliant, fixing it would also be good.:-)
 251 (defun compute-effective-slots (class)
 252   (collect ((res (copy-list (condition-classoid-slots class))))
 253     (dolist (sclass (cdr (condition-classoid-cpl class)))
 254       (dolist (sslot (condition-classoid-slots sclass))
 255         (let ((found (find (condition-slot-name sslot) (res)
 256                            :key #'condition-slot-name)))
 257           (cond (found
 258                  (setf (condition-slot-initargs found)
 259                        (union (condition-slot-initargs found)
 260                               (condition-slot-initargs sslot)))
 261                  (unless (condition-slot-initform-p found)
 262                    (setf (condition-slot-initform-p found)
 263                          (condition-slot-initform-p sslot))
 264                    (setf (condition-slot-initform found)
 265                          (condition-slot-initform sslot))
 266                    (setf (condition-slot-initfunction found)
 267                          (condition-slot-initfunction sslot)))
 268                  (unless (condition-slot-allocation found)
 269                    (setf (condition-slot-allocation found)
 270                          (condition-slot-allocation sslot))))
 271                 (t
 272                  (res (copy-structure sslot)))))))
 273     (res)))
 274
 275 ;;; Early definitions of slot accessor creators.
 276 ;;;
 277 ;;; Slot accessors must be generic functions, but ANSI does not seem
 278 ;;; to specify any of them, and we cannot support it before end of
 279 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
 280 ;;; GFs only at the end of building.
 281 (declaim (notinline install-condition-slot-reader
 282                     install-condition-slot-writer))
 283 (defun install-condition-slot-reader (name condition slot-name)
 284   (declare (ignore condition))
 285   (setf (fdefinition name)
 286         (set-closure-name
 287          (lambda (condition) (condition-slot-value condition slot-name))
 288          t
 289          `(condition-slot-reader ,name))))
 290 (defun install-condition-slot-writer (name condition slot-name)
 291   (declare (ignore condition))
 292   (setf (fdefinition name)
 293         (set-closure-name
 294          (lambda (new-value condition)
 295            (set-condition-slot-value condition new-value slot-name))
 296          t
 297          `(condition-slot-writer ,name))))
 298
 299 (!defvar *define-condition-hooks* nil)
 300
 301 (defun %set-condition-report (name report)
 302   (setf (condition-classoid-report (find-classoid name))
 303         report))
 304
 305 (defun %define-condition (name parent-types layout slots
 306                           direct-default-initargs all-readers all-writers
 307                           source-location &optional documentation)
 308   (call-with-defining-class
 309    'condition name
 310    (lambda ()
 311      (%%compiler-define-condition name parent-types layout all-readers all-writers)
 312      (when source-location
 313        (setf (layout-source-location layout) source-location))
 314      (let ((classoid (find-classoid name)))
 315        (setf (condition-classoid-slots classoid) slots
 316              (condition-classoid-direct-default-initargs classoid) direct-default-initargs
 317              (fdocumentation name 'type) documentation)
 318
 319        (dolist (slot slots)
 320          ;; Set up reader and writer functions.
 321          (let ((slot-name (condition-slot-name slot)))
 322            (dolist (reader (condition-slot-readers slot))
 323              (install-condition-slot-reader reader name slot-name))
 324            (dolist (writer (condition-slot-writers slot))
 325              (install-condition-slot-writer writer name slot-name))))
 326
 327        ;; Compute effective slots and set up the class and hairy slots
 328        ;; (subsets of the effective slots.)
 329        (setf (condition-classoid-class-slots classoid) '()
 330              (condition-classoid-hairy-slots classoid) '())
 331        (let ((eslots (compute-effective-slots classoid))
 332              (e-def-initargs
 333               (reduce #'append
 334                       (mapcar #'condition-classoid-direct-default-initargs
 335                               (condition-classoid-cpl classoid)))))
 336          (dolist (slot eslots)
 337            (ecase (condition-slot-allocation slot)
 338              (:class
 339               (unless (condition-slot-cell slot)
 340                 (setf (condition-slot-cell slot)
 341                       (list (if (condition-slot-initform-p slot)
 342                                 (let ((initfun (condition-slot-initfunction slot)))
 343                                   (aver (functionp initfun))
 344                                   (funcall initfun))
 345                                 sb!pcl:+slot-unbound+))))
 346               (push slot (condition-classoid-class-slots classoid)))
 347              ((:instance nil)
 348               (setf (condition-slot-allocation slot) :instance)
 349               ;; FIXME: isn't this "always hairy"?
 350               (when (or (functionp (condition-slot-initfunction slot))
 351                         (dolist (initarg (condition-slot-initargs slot) nil)
 352                           (when (functionp (third (assoc initarg e-def-initargs)))
 353                             (return t))))
 354                 (push slot (condition-classoid-hairy-slots classoid)))))))
 355        (dolist (fun *define-condition-hooks*)
 356          (funcall fun classoid)))))
 357   name)
 358
 359 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
 360                                  &body options)
 361   "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
 362    Define NAME as a condition type. This new type inherits slots and its
 363    report function from the specified PARENT-TYPEs. A slot spec is a list of:
 364      (slot-name :reader <rname> :initarg <iname> {Option Value}*
 365
 366    The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
 367    and :TYPE and the overall options :DEFAULT-INITARGS and
 368    [type] :DOCUMENTATION are also allowed.
 369
 370    The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
 371    a string or a two-argument lambda or function name. If a function, the
 372    function is called with the condition and stream to report the condition.
 373    If a string, the string is printed.
 374
 375    Condition types are classes, but (as allowed by ANSI and not as described in
 376    CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
 377    SLOT-VALUE may not be used on condition objects."
 378   (let* ((parent-types (or parent-types '(condition)))
 379          (layout (find-condition-layout name parent-types))
 380          (documentation nil)
 381          (report nil)
 382          (direct-default-initargs ()))
 383     (collect ((slots)
 384               (all-readers nil append)
 385               (all-writers nil append))
 386       (dolist (spec slot-specs)
 387         (when (keywordp spec)
 388           (warn "Keyword slot name indicates probable syntax error:~%  ~S"
 389                 spec))
 390         (let* ((spec (if (consp spec) spec (list spec)))
 391                (slot-name (first spec))
 392                (allocation :instance)
 393                (initform-p nil)
 394                documentation
 395                initform)
 396           (collect ((initargs)
 397                     (readers)
 398                     (writers))
 399             (do ((options (rest spec) (cddr options)))
 400                 ((null options))
 401               (unless (and (consp options) (consp (cdr options)))
 402                 (error "malformed condition slot spec:~%  ~S." spec))
 403               (let ((arg (second options)))
 404                 (case (first options)
 405                   (:reader (readers arg))
 406                   (:writer (writers arg))
 407                   (:accessor
 408                    (readers arg)
 409                    (writers `(setf ,arg)))
 410                   (:initform
 411                    (when initform-p
 412                      (error "more than one :INITFORM in ~S" spec))
 413                    (setq initform-p t)
 414                    (setq initform arg))
 415                   (:initarg (initargs arg))
 416                   (:allocation
 417                    (setq allocation arg))
 418                   (:documentation
 419                    (when documentation
 420                      (error "more than one :DOCUMENTATION in ~S" spec))
 421                    (unless (stringp arg)
 422                      (error "slot :DOCUMENTATION argument is not a string: ~S"
 423                             arg))
 424                    (setq documentation arg))
 425                   (:type)
 426                   (t
 427                    (error "unknown slot option:~%  ~S" (first options))))))
 428
 429             (all-readers (readers))
 430             (all-writers (writers))
 431             (slots `(make-condition-slot
 432                      :name ',slot-name
 433                      :initargs ',(initargs)
 434                      :readers ',(readers)
 435                      :writers ',(writers)
 436                      :initform-p ',initform-p
 437                      :documentation ',documentation
 438                      :initform ,(when initform-p `',initform)
 439                      :initfunction ,(when initform-p
 440                                       `#'(lambda () ,initform))
 441                      :allocation ',allocation)))))
 442
 443       (dolist (option options)
 444         (unless (consp option)
 445           (error "bad option:~%  ~S" option))
 446         (case (first option)
 447           (:documentation (setq documentation (second option)))
 448           (:report
 449            (let ((arg (second option)))
 450              (setq report
 451                    `#'(named-lambda (condition-report ,name) (condition stream)
 452                         (declare (type condition condition)
 453                                  (type stream stream))
 454                         ,@(if (stringp arg)
 455                               `((declare (ignore condition))
 456                                 (write-string ,arg stream))
 457                               `((funcall #',arg condition stream)))))))
 458           (:default-initargs
 459            (doplist (initarg initform) (rest option)
 460              (push ``(,',initarg ,',initform ,#'(lambda () ,initform))
 461                    direct-default-initargs)))
 462           (t
 463            (error "unknown option: ~S" (first option)))))
 464
 465       ;; Maybe kill docstring, but only under the cross-compiler.
 466       #!+(and (not sb-doc) (host-feature sb-xc-host)) (setq documentation nil)
 467       `(progn
 468          (eval-when (:compile-toplevel)
 469            (%compiler-define-condition ',name ',parent-types ',layout
 470                                        ',(all-readers) ',(all-writers)))
 471          (%define-condition ',name
 472                             ',parent-types
 473                             ',layout
 474                             (list ,@(slots))
 475                             (list ,@direct-default-initargs)
 476                             ',(all-readers)
 477                             ',(all-writers)
 478                             (sb!c:source-location)
 479                             ,@(and documentation
 480                                    `(,documentation)))
 481          ;; This needs to be after %DEFINE-CONDITION in case :REPORT
 482          ;; is a lambda referring to condition slot accessors:
 483          ;; they're not proclaimed as functions before it has run if
 484          ;; we're under EVAL or loaded as source.
 485          (%set-condition-report ',name ,report)
 486          ',name))))
 487 \f
 488 ;;;; various CONDITIONs specified by ANSI
 489
 490 (define-condition serious-condition (condition) ())
 491
 492 (define-condition error (serious-condition) ())
 493
 494 (define-condition warning (condition) ())
 495 (define-condition style-warning (warning) ())
 496
 497 (defun simple-condition-printer (condition stream)
 498   (let ((control (simple-condition-format-control condition)))
 499     (if control
 500         (apply #'format stream
 501                control
 502                (simple-condition-format-arguments condition))
 503         (error "No format-control for ~S" condition))))
 504
 505 (define-condition simple-condition ()
 506   ((format-control :reader simple-condition-format-control
 507                    :initarg :format-control
 508                    :initform nil
 509                    :type format-control)
 510    (format-arguments :reader simple-condition-format-arguments
 511                      :initarg :format-arguments
 512                      :initform nil
 513                      :type list))
 514   (:report simple-condition-printer))
 515
 516 (define-condition simple-warning (simple-condition warning) ())
 517
 518 (define-condition simple-error (simple-condition error) ())
 519
 520 (define-condition storage-condition (serious-condition) ())
 521
 522 (defun decode-type-error-context (context type)
 523   (typecase context
 524     (cons
 525      (case (car context)
 526        (:struct
 527         (format nil "when setting slot ~s of structure ~s"
 528                 (cddr context) (cadr context)))
 529        (t context)))
 530     ((eql :aref)
 531      (let (*print-circle*)
 532        (format nil "when setting an element of (ARRAY ~s)"
 533                type)))
 534     ((eql :ftype)
 535      "from the function type declaration.")
 536     ((and symbol
 537           (not null))
 538      (format nil "when binding ~s" context))
 539     (t
 540      context)))
 541
 542 (define-condition type-error (error)
 543   ((datum :reader type-error-datum :initarg :datum)
 544    (expected-type :reader type-error-expected-type :initarg :expected-type)
 545    (context :initform nil :reader type-error-context :initarg :context))
 546   (:report
 547    (lambda (condition stream)
 548      (let ((type (type-error-expected-type condition)))
 549        (format stream  "~@<The value ~
 550                       ~@:_~2@T~S ~
 551                       ~@:_is not of type ~
 552                       ~@:_~2@T~/sb!impl:print-type-specifier/~@[ ~
 553                       ~@:_~a~]~:@>"
 554                (type-error-datum condition)
 555                type
 556                (decode-type-error-context (type-error-context condition)
 557                                           type))))))
 558
 559 ;;; not specified by ANSI, but too useful not to have around.
 560 (define-condition simple-style-warning (simple-condition style-warning) ())
 561 (define-condition simple-type-error (simple-condition type-error) ())
 562
 563 (define-condition program-error (error) ())
 564 (define-condition parse-error   (error) ())
 565 (define-condition control-error (error) ())
 566 (define-condition stream-error  (error)
 567   ((stream :reader stream-error-stream :initarg :stream)))
 568
 569 (define-condition end-of-file (stream-error) ()
 570   (:report
 571    (lambda (condition stream)
 572      (format stream
 573              "end of file on ~S"
 574              (stream-error-stream condition)))))
 575
 576 (define-condition closed-stream-error (stream-error) ()
 577   (:report
 578    (lambda (condition stream)
 579      (format stream "~S is closed" (stream-error-stream condition)))))
 580
 581 (define-condition file-error (error)
 582   ((pathname :reader file-error-pathname :initarg :pathname))
 583   (:report
 584    (lambda (condition stream)
 585      (format stream "error on file ~S" (file-error-pathname condition)))))
 586
 587 (define-condition package-error (error)
 588   ((package :reader package-error-package :initarg :package)))
 589
 590 (define-condition cell-error (error)
 591   ((name :reader cell-error-name :initarg :name)))
 592
 593 (define-condition values-list-argument-error (type-error)
 594   ()
 595   (:report
 596    (lambda (condition stream)
 597      (format stream "~@<Attempt to use ~S on a dotted list: ~
 598                      ~2I~_~S~:>"
 599              'values-list (type-error-datum condition)))))
 600
 601 (define-condition unbound-variable (cell-error) ()
 602   (:report
 603    (lambda (condition stream)
 604      (format stream
 605              "The variable ~S is unbound."
 606              (cell-error-name condition)))))
 607
 608 (define-condition retry-unbound-variable
 609     (simple-condition unbound-variable) ())
 610
 611 (define-condition undefined-function (cell-error) ()
 612   (:report
 613    (lambda (condition stream)
 614      (let ((*package* (find-package :keyword)))
 615        (format stream
 616                "The function ~S is undefined."
 617                (cell-error-name condition))))))
 618
 619 (define-condition retry-undefined-function
 620     (simple-condition undefined-function) ())
 621
 622 (define-condition special-form-function (undefined-function) ()
 623   (:report
 624    (lambda (condition stream)
 625      (format stream
 626              "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
 627              (cell-error-name condition)))))
 628
 629 (define-condition arithmetic-error (error)
 630   ((operation :reader arithmetic-error-operation
 631               :initarg :operation
 632               :initform nil)
 633    (operands :reader arithmetic-error-operands
 634              :initarg :operands))
 635   (:report (lambda (condition stream)
 636              (format stream
 637                      "arithmetic error ~S signalled"
 638                      (type-of condition))
 639              (when (arithmetic-error-operation condition)
 640                (format stream
 641                        "~%Operation was (~S ~{~S~^ ~})."
 642                        (arithmetic-error-operation condition)
 643                        (arithmetic-error-operands condition))))))
 644
 645 (define-condition division-by-zero         (arithmetic-error) ())
 646 (define-condition floating-point-overflow  (arithmetic-error) ())
 647 (define-condition floating-point-underflow (arithmetic-error) ())
 648 (define-condition floating-point-inexact   (arithmetic-error) ())
 649 (define-condition floating-point-invalid-operation (arithmetic-error) ())
 650
 651 (define-condition print-not-readable (error)
 652   ((object :reader print-not-readable-object :initarg :object))
 653   (:report
 654    (lambda (condition stream)
 655      (let ((obj (print-not-readable-object condition))
 656            (*print-array* nil))
 657        (format stream "~S cannot be printed readably." obj)))))
 658
 659 (define-condition reader-error (parse-error stream-error) ()
 660   (:report (lambda (condition stream)
 661              (%report-reader-error condition stream))))
 662
 663 ;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
 664 ;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
 665 ;;; within SBCL itself)
 666 ;;;
 667 ;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
 668 ;;; the letter of the ANSI spec: this is not a condition signalled by
 669 ;;; SIGNAL when a format-control is supplied by the function's first
 670 ;;; argument. It seems to me (WHN) to be basically in the spirit of
 671 ;;; the spec, but if not, it'd be straightforward to do our own
 672 ;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
 673 ;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
 674 ;;; place of CL:SIMPLE-CONDITION here.)
 675 (define-condition simple-reader-error (reader-error simple-condition)
 676   ()
 677   (:report (lambda (condition stream)
 678              (%report-reader-error condition stream :simple t))))
 679
 680 ;;; base REPORTing of a READER-ERROR
 681 ;;;
 682 ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
 683 ;;; and FORMAT-ARGS slots.
 684 (defun %report-reader-error (condition stream &key simple position)
 685   (let ((error-stream (stream-error-stream condition)))
 686     (pprint-logical-block (stream nil)
 687       (if simple
 688           (apply #'format stream
 689                  (simple-condition-format-control condition)
 690                  (simple-condition-format-arguments condition))
 691           (prin1 (class-name (class-of condition)) stream))
 692       (format stream "~2I~@[~:@_ ~:@_~:{~:(~A~): ~S~:^, ~:_~}~]~:@_ ~:@_Stream: ~S"
 693               (stream-error-position-info error-stream position)
 694               error-stream))))
 695 \f
 696 ;;;; special SBCL extension conditions
 697
 698 ;;; an error apparently caused by a bug in SBCL itself
 699 ;;;
 700 ;;; Note that we don't make any serious effort to use this condition
 701 ;;; for *all* errors in SBCL itself. E.g. type errors and array
 702 ;;; indexing errors can occur in functions called from SBCL code, and
 703 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
 704 ;;; because the signalling code has no good way to know that the
 705 ;;; underlying problem is a bug in SBCL. But in the fairly common case
 706 ;;; that the signalling code does know that it's found a bug in SBCL,
 707 ;;; this condition is appropriate, reusing boilerplate and helping
 708 ;;; users to recognize it as an SBCL bug.
 709 (define-condition bug (simple-error)
 710   ()
 711   (:report
 712    (lambda (condition stream)
 713      (format stream
 714              "~@<  ~? ~:@_~?~:>"
 715              (simple-condition-format-control condition)
 716              (simple-condition-format-arguments condition)
 717              "~@<This is probably a bug in SBCL itself. (Alternatively, ~
 718               SBCL might have been corrupted by bad user code, e.g. by an ~
 719               undefined Lisp operation like ~S, or by stray pointers from ~
 720               alien code or from unsafe Lisp code; or there might be a bug ~
 721               in the OS or hardware that SBCL is running on.) If it seems to ~
 722               be a bug in SBCL itself, the maintainers would like to know ~
 723               about it. Bug reports are welcome on the SBCL ~
 724               mailing lists, which you can find at ~
 725               <http://sbcl.sourceforge.net/>.~:@>"
 726              '((fmakunbound 'compile))))))
 727
 728 (define-condition simple-storage-condition (storage-condition simple-condition)
 729   ())
 730
 731 ;;; a condition for use in stubs for operations which aren't supported
 732 ;;; on some platforms
 733 ;;;
 734 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
 735 ;;;   #-(or freebsd linux)
 736 ;;;   (defun load-foreign (&rest rest)
 737 ;;;     (error 'unsupported-operator :name 'load-foreign))
 738 ;;;   #+(or freebsd linux)
 739 ;;;   (defun load-foreign ... actual definition ...)
 740 ;;; By signalling a standard condition in this case, we make it
 741 ;;; possible for test code to distinguish between (1) intentionally
 742 ;;; unimplemented and (2) unintentionally just screwed up somehow.
 743 ;;; (Before this condition was defined, test code tried to deal with
 744 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
 745 ;;; sbcl-0.7.0, a package screwup left the definition of
 746 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
 747 ;;; architectures where it was supposed to be supported, and the
 748 ;;; regression tests cheerfully passed because they assumed that
 749 ;;; unFBOUNDPness meant they were running on an system which didn't
 750 ;;; support the extension.)
 751 (define-condition unsupported-operator (simple-error) ())
 752 \f
 753 ;;; (:ansi-cl :function remove)
 754 ;;; (:ansi-cl :section (a b c))
 755 ;;; (:ansi-cl :glossary "similar")
 756 ;;;
 757 ;;; (:sbcl :node "...")
 758 ;;; (:sbcl :variable *ed-functions*)
 759 ;;;
 760 ;;; FIXME: this is not the right place for this.
 761 (defun print-reference (reference stream)
 762   (ecase (car reference)
 763     (:amop
 764      (format stream "AMOP")
 765      (format stream ", ")
 766      (destructuring-bind (type data) (cdr reference)
 767        (ecase type
 768          (:readers "Readers for ~:(~A~) Metaobjects"
 769                    (substitute #\  #\- (symbol-name data)))
 770          (:initialization
 771           (format stream "Initialization of ~:(~A~) Metaobjects"
 772                   (substitute #\  #\- (symbol-name data))))
 773          (:generic-function (format stream "Generic Function ~S" data))
 774          (:function (format stream "Function ~S" data))
 775          (:section (format stream "Section ~{~D~^.~}" data)))))
 776     (:ansi-cl
 777      (format stream "The ANSI Standard")
 778      (format stream ", ")
 779      (destructuring-bind (type data) (cdr reference)
 780        (ecase type
 781          (:function (format stream "Function ~S" data))
 782          (:special-operator (format stream "Special Operator ~S" data))
 783          (:macro (format stream "Macro ~S" data))
 784          (:section (format stream "Section ~{~D~^.~}" data))
 785          (:glossary (format stream "Glossary entry for ~S" data))
 786          (:type (format stream "Type ~S" data))
 787          (:system-class (format stream "System Class ~S" data))
 788          (:issue (format stream "writeup for Issue ~A" data)))))
 789     (:sbcl
 790      (format stream "The SBCL Manual")
 791      (format stream ", ")
 792      (destructuring-bind (type data) (cdr reference)
 793        (ecase type
 794          (:node (format stream "Node ~S" data))
 795          (:variable (format stream "Variable ~S" data))
 796          (:function (format stream "Function ~S" data)))))
 797     ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
 798     ))
 799 (define-condition reference-condition ()
 800   ((references :initarg :references :reader reference-condition-references)))
 801 (defvar *print-condition-references* t)
 802
 803 (define-condition simple-reference-error (reference-condition simple-error)
 804   ())
 805
 806 (define-condition simple-reference-warning (reference-condition simple-warning)
 807   ())
 808
 809 (define-condition arguments-out-of-domain-error
 810     (arithmetic-error reference-condition)
 811   ())
 812
 813 ;; per CLHS: "The consequences are unspecified if functions are ...
 814 ;; multiply defined in the same file." so we are within reason to do any
 815 ;; unspecified behavior at compile-time and/or time, but the compiler was
 816 ;; annoyingly mum about genuinely inadvertent duplicate macro definitions.
 817 ;; Redefinition is henceforth a style-warning, and for compatibility it does
 818 ;; not cause the ERRORP value from COMPILE-TIME to be T.
 819 ;; Nor do we cite section 3.2.2.3 as the governing prohibition.
 820 (defun report-duplicate-definition (condition stream)
 821   (format stream "~@<Duplicate definition for ~S found in one file.~@:>"
 822           (slot-value condition 'name)))
 823
 824 (define-condition duplicate-definition (reference-condition warning)
 825   ((name :initarg :name :reader duplicate-definition-name))
 826   (:report report-duplicate-definition)
 827   (:default-initargs :references '((:ansi-cl :section (3 2 2 3)))))
 828 ;; To my thinking, DUPLICATE-DEFINITION should be the ancestor condition,
 829 ;; and not fatal. But changing the meaning of that concept would be a bad idea,
 830 ;; so instead there is a new condition for the softer variant, which does not
 831 ;; inherit from the former.
 832 (define-condition same-file-redefinition-warning (style-warning)
 833   ;; Slot readers aren't proper generic functions until CLOS is built,
 834   ;; so this doesn't get a reader because you can't pick the same name,
 835   ;; and it wouldn't do any good to pick a different name that nothing knows.
 836   ((name :initarg :name))
 837   (:report report-duplicate-definition))
 838
 839 (define-condition constant-modified (reference-condition warning)
 840   ((fun-name :initarg :fun-name :reader constant-modified-fun-name)
 841    (value :initarg :value :reader constant-modified-value))
 842   (:report (lambda (c s)
 843              (format s "~@<Destructive function ~S called on ~
 844                         constant data: ~s.~@:>"
 845                      (constant-modified-fun-name c)
 846                      (constant-modified-value c))))
 847   (:default-initargs :references '((:ansi-cl :special-operator quote)
 848                                    (:ansi-cl :section (3 2 2 3)))))
 849
 850 (define-condition package-at-variance (reference-condition simple-warning)
 851   ()
 852   (:default-initargs :references '((:ansi-cl :macro defpackage)
 853                                    (:sbcl :variable *on-package-variance*))))
 854
 855 (define-condition package-at-variance-error (reference-condition simple-condition
 856                                              package-error)
 857   ()
 858   (:default-initargs :references '((:ansi-cl :macro defpackage))))
 859
 860 (define-condition defconstant-uneql (reference-condition error)
 861   ((name :initarg :name :reader defconstant-uneql-name)
 862    (old-value :initarg :old-value :reader defconstant-uneql-old-value)
 863    (new-value :initarg :new-value :reader defconstant-uneql-new-value))
 864   (:report
 865    (lambda (condition stream)
 866      (format stream
 867              "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
 868              (defconstant-uneql-name condition)
 869              (defconstant-uneql-old-value condition)
 870              (defconstant-uneql-new-value condition))))
 871   (:default-initargs :references '((:ansi-cl :macro defconstant)
 872                                    (:sbcl :node "Idiosyncrasies"))))
 873
 874 (define-condition array-initial-element-mismatch
 875     (reference-condition simple-warning)
 876   ()
 877   (:default-initargs
 878       :references '((:ansi-cl :function make-array)
 879                     (:ansi-cl :function sb!xc:upgraded-array-element-type))))
 880
 881 (define-condition type-warning (reference-condition simple-warning)
 882   ()
 883   (:default-initargs :references '((:sbcl :node "Handling of Types"))))
 884 (define-condition type-style-warning (reference-condition simple-style-warning)
 885   ()
 886   (:default-initargs :references '((:sbcl :node "Handling of Types"))))
 887
 888 (define-condition local-argument-mismatch (reference-condition simple-warning)
 889   ()
 890   (:default-initargs :references '((:ansi-cl :section (3 2 2 3)))))
 891
 892 (define-condition format-args-mismatch (reference-condition)
 893   ()
 894   (:default-initargs :references '((:ansi-cl :section (22 3 10 2)))))
 895
 896 (define-condition format-too-few-args-warning
 897     (format-args-mismatch simple-warning)
 898   ())
 899 (define-condition format-too-many-args-warning
 900     (format-args-mismatch simple-style-warning)
 901   ())
 902
 903 (define-condition implicit-generic-function-warning (style-warning)
 904   ((name :initarg :name :reader implicit-generic-function-name))
 905   (:report
 906    (lambda (condition stream)
 907      (format stream "~@<Implicitly creating new generic function ~
 908                      ~/sb-ext:print-symbol-with-prefix/.~:@>"
 909              (implicit-generic-function-name condition)))))
 910
 911 (define-condition extension-failure (reference-condition simple-error)
 912   ())
 913
 914 (define-condition structure-initarg-not-keyword
 915     (reference-condition simple-style-warning)
 916   ()
 917   (:default-initargs :references '((:ansi-cl :section (2 4 8 13)))))
 918
 919 #!+sb-package-locks
 920 (progn
 921
 922 (define-condition package-lock-violation (package-error
 923                                           reference-condition
 924                                           simple-condition)
 925   ((current-package :initform *package*
 926                     :reader package-lock-violation-in-package))
 927   (:report
 928    (lambda (condition stream)
 929      (let ((control (simple-condition-format-control condition))
 930            (error-package (package-name
 931                            (package-error-package condition)))
 932            (current-package (package-name
 933                              (package-lock-violation-in-package condition))))
 934        (format stream "~@<Lock on package ~A violated~@[~{ when ~?~}~] ~
 935                        while in package ~A.~:@>"
 936                error-package
 937                (when control
 938                  (list control (simple-condition-format-arguments condition)))
 939                current-package))))
 940   ;; no :default-initargs -- reference-stuff provided by the
 941   ;; signalling form in target-package.lisp
 942   (:documentation
 943    "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
 944 when a package-lock is violated."))
 945
 946 (define-condition package-locked-error (package-lock-violation) ()
 947   (:documentation
 948    "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
 949 signalled when an operation on a package violates a package lock."))
 950
 951 (define-condition symbol-package-locked-error (package-lock-violation)
 952   ((symbol :initarg :symbol :reader package-locked-error-symbol))
 953   (:documentation
 954    "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
 955 signalled when an operation on a symbol violates a package lock. The
 956 symbol that caused the violation is accessed by the function
 957 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
 958
 959 ) ; progn
 960
 961 (define-condition undefined-alien-error (cell-error) ()
 962   (:report
 963    (lambda (condition stream)
 964      (if (slot-boundp condition 'name)
 965          (format stream "Undefined alien: ~S" (cell-error-name condition))
 966          (format stream "Undefined alien symbol.")))))
 967
 968 (define-condition undefined-alien-variable-error (undefined-alien-error) ()
 969   (:report
 970    (lambda (condition stream)
 971      (declare (ignore condition))
 972      (format stream "Attempt to access an undefined alien variable."))))
 973
 974 (define-condition undefined-alien-function-error (undefined-alien-error) ()
 975   (:report
 976    (lambda (condition stream)
 977      (if (and (slot-boundp condition 'name)
 978               (cell-error-name condition))
 979          (format stream "The alien function ~s is undefined."
 980                  (cell-error-name condition))
 981          (format stream "Attempt to call an undefined alien function.")))))
 982
 983 (define-condition unknown-keyword-argument (program-error)
 984   ((name :reader unknown-keyword-argument-name :initarg :name))
 985   (:report
 986    (lambda (condition stream)
 987      (format stream "Unknown &KEY argument: ~S"
 988              (unknown-keyword-argument-name condition)))))
 989
 990 \f
 991 ;;;; various other (not specified by ANSI) CONDITIONs
 992 ;;;;
 993 ;;;; These might logically belong in other files; they're here, after
 994 ;;;; setup of CONDITION machinery, only because that makes it easier to
 995 ;;;; get cold init to work.
 996
 997 ;;; OAOOM warning: see cross-condition.lisp
 998 (define-condition encapsulated-condition (condition)
 999   ((condition :initarg :condition :reader encapsulated-condition)))
1000
1001 ;;; KLUDGE: a condition for floating point errors when we can't or
1002 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
1003 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
1004 ;;; know how but the old code was broken by the conversion to POSIX
1005 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
1006 ;;;
1007 ;;; FIXME: Perhaps this should also be a base class for all
1008 ;;; floating point exceptions?
1009 (define-condition floating-point-exception (arithmetic-error)
1010   ((flags :initarg :traps
1011           :initform nil
1012           :reader floating-point-exception-traps))
1013   (:report (lambda (condition stream)
1014              (format stream
1015                      "An arithmetic error ~S was signalled.~%"
1016                      (type-of condition))
1017              (let ((traps (floating-point-exception-traps condition)))
1018                (if traps
1019                    (format stream
1020                            "Trapping conditions are: ~%~{ ~S~^~}~%"
1021                            traps)
1022                    (write-line
1023                     "No traps are enabled? How can this be?"
1024                     stream))))))
1025
1026 (define-condition invalid-array-index-error (type-error)
1027   ((array :initarg :array :reader invalid-array-index-error-array)
1028    (axis :initarg :axis :reader invalid-array-index-error-axis))
1029   (:report
1030    (lambda (condition stream)
1031      (let ((array (invalid-array-index-error-array condition)))
1032        (format stream "Invalid index ~W for ~@[axis ~W of ~]~S, ~
1033                        should be a non-negative integer below ~W."
1034                (type-error-datum condition)
1035                (when (> (array-rank array) 1)
1036                  (invalid-array-index-error-axis condition))
1037                (type-of array)
1038                ;; Extract the bound from (INTEGER 0 (BOUND))
1039                (caaddr (type-error-expected-type condition)))))))
1040
1041 (define-condition invalid-array-error (reference-condition type-error) ()
1042   (:report
1043    (lambda (condition stream)
1044      (let ((*print-array* nil))
1045        (format stream
1046                "~@<Displaced array originally of type ~
1047                  ~/sb!impl:print-type-specifier/ has been invalidated ~
1048                  due its displaced-to array ~S having become too small ~
1049                  to hold it: the displaced array's dimensions have all ~
1050                  been set to zero to trap accesses to it.~:@>"
1051                (type-error-expected-type condition)
1052                (array-displacement (type-error-datum condition))))))
1053   (:default-initargs
1054       :references
1055       (list '(:ansi-cl :function adjust-array))))
1056
1057 (define-condition index-too-large-error (type-error)
1058   ()
1059   (:report
1060    (lambda (condition stream)
1061      (format stream
1062              "The index ~S is too large."
1063              (type-error-datum condition)))))
1064
1065 (define-condition bounding-indices-bad-error (reference-condition type-error)
1066   ((object :reader bounding-indices-bad-object :initarg :object))
1067   (:report
1068    (lambda (condition stream)
1069      (let* ((datum (type-error-datum condition))
1070             (start (car datum))
1071             (end (cdr datum))
1072             (object (bounding-indices-bad-object condition)))
1073        (etypecase object
1074          (sequence
1075           (format stream
1076                   "The bounding indices ~S and ~S are bad ~
1077                    for a sequence of length ~S."
1078                   start end (length object)))
1079          (array
1080           ;; from WITH-ARRAY-DATA
1081           (format stream
1082                   "The START and END parameters ~S and ~S are ~
1083                    bad for an array of total size ~S."
1084                   start end (array-total-size object)))))))
1085   (:default-initargs
1086       :references
1087       (list '(:ansi-cl :glossary "bounding index designator")
1088             '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1089
1090 (define-condition nil-array-accessed-error (reference-condition type-error)
1091   ()
1092   (:report (lambda (condition stream)
1093              (declare (ignore condition))
1094              (format stream
1095                      "An attempt to access an array of element-type ~
1096                       NIL was made.  Congratulations!")))
1097   (:default-initargs
1098       :references '((:ansi-cl :function sb!xc:upgraded-array-element-type)
1099                     (:ansi-cl :section (15 1 2 1))
1100                     (:ansi-cl :section (15 1 2 2)))))
1101
1102 (define-condition namestring-parse-error (parse-error)
1103   ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
1104    (args :reader namestring-parse-error-args :initarg :args :initform nil)
1105    (namestring :reader namestring-parse-error-namestring :initarg :namestring)
1106    (offset :reader namestring-parse-error-offset :initarg :offset))
1107   (:report
1108    (lambda (condition stream)
1109      (format stream
1110              "parse error in namestring: ~?~%  ~A~%  ~V@T^"
1111              (namestring-parse-error-complaint condition)
1112              (namestring-parse-error-args condition)
1113              (namestring-parse-error-namestring condition)
1114              (namestring-parse-error-offset condition)))))
1115
1116 (define-condition pathname-unparse-error (file-error
1117                                           simple-condition)
1118   ((problem :reader pathname-unparse-error-problem :initarg :problem))
1119   (:report (lambda (condition stream)
1120              (format stream "~@<The pathname ~S ~A~:[.~; because ~:*~?~]~@:>"
1121                      (file-error-pathname condition)
1122                      (pathname-unparse-error-problem condition)
1123                      (simple-condition-format-control condition)
1124                      (simple-condition-format-arguments condition))))
1125   (:default-initargs
1126    :problem (missing-arg)))
1127
1128 (define-condition no-namestring-error (pathname-unparse-error
1129                                        reference-condition)
1130   ()
1131   (:default-initargs
1132    :problem "does not have a namestring"
1133    :references '((:ansi-cl :section (19 1 2)))))
1134 (defun no-namestring-error
1135     (pathname &optional format-control &rest format-arguments)
1136   (error 'no-namestring-error
1137          :pathname pathname
1138          :format-control format-control :format-arguments format-arguments))
1139
1140 (define-condition no-native-namestring-error (pathname-unparse-error)
1141   ()
1142   (:default-initargs
1143    :problem "does not have a native namestring"))
1144 (defun no-native-namestring-error
1145     (pathname &optional format-control &rest format-arguments)
1146   (error 'no-native-namestring-error
1147          :pathname pathname
1148          :format-control format-control :format-arguments format-arguments))
1149
1150 (define-condition simple-package-error (simple-condition package-error) ())
1151
1152 (define-condition simple-reader-package-error (simple-reader-error package-error) ())
1153
1154 (define-condition reader-eof-error (end-of-file)
1155   ((context :reader reader-eof-error-context :initarg :context))
1156   (:report
1157    (lambda (condition stream)
1158      (format stream
1159              "unexpected end of file on ~S ~A"
1160              (stream-error-stream condition)
1161              (reader-eof-error-context condition)))))
1162
1163 (define-condition reader-impossible-number-error (simple-reader-error)
1164   ((error :reader reader-impossible-number-error-error :initarg :error))
1165   (:report
1166    (lambda (condition stream)
1167      (let ((error-stream (stream-error-stream condition)))
1168        (format stream
1169                "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1170                (sb!impl::file-position-or-nil-for-error error-stream) error-stream
1171                (simple-condition-format-control condition)
1172                (simple-condition-format-arguments condition)
1173                (reader-impossible-number-error-error condition))))))
1174
1175 (define-condition standard-readtable-modified-error (reference-condition error)
1176   ((operation :initarg :operation :reader standard-readtable-modified-operation))
1177   (:report (lambda (condition stream)
1178              (format stream "~S would modify the standard readtable."
1179                      (standard-readtable-modified-operation condition))))
1180   (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
1181                                    (:ansi-cl :glossary "standard readtable"))))
1182
1183 (define-condition standard-pprint-dispatch-table-modified-error
1184     (reference-condition error)
1185   ((operation :initarg :operation
1186               :reader standard-pprint-dispatch-table-modified-operation))
1187   (:report (lambda (condition stream)
1188              (format stream "~S would modify the standard pprint dispatch table."
1189                      (standard-pprint-dispatch-table-modified-operation
1190                       condition))))
1191   (:default-initargs
1192       :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
1193
1194 (define-condition timeout (serious-condition)
1195   ((seconds :initarg :seconds :initform nil :reader timeout-seconds))
1196   (:report (lambda (condition stream)
1197              (format stream "Timeout occurred~@[ after ~A second~:P~]."
1198                      (timeout-seconds condition)))))
1199
1200 (define-condition io-timeout (stream-error timeout)
1201   ((direction :reader io-timeout-direction :initarg :direction))
1202   (:report
1203    (lambda (condition stream)
1204      (declare (type stream stream))
1205      (format stream
1206              "I/O timeout while doing ~(~A~) on ~S."
1207              (io-timeout-direction condition)
1208              (stream-error-stream condition)))))
1209
1210 (define-condition deadline-timeout (timeout) ()
1211   (:report (lambda (condition stream)
1212              (format stream "A deadline was reached after ~A second~:P."
1213                      (timeout-seconds condition)))))
1214
1215 (define-condition declaration-type-conflict-error (reference-condition
1216                                                    simple-error)
1217   ()
1218   (:default-initargs
1219    :format-control  "Symbol ~/sb-ext:print-symbol-with-prefix/ cannot ~
1220                      be both the name of a type and the name of a ~
1221                      declaration"
1222    :references '((:ansi-cl :section (3 8 21)))))
1223
1224 ;;; Single stepping conditions
1225
1226 (define-condition step-condition ()
1227   ((form :initarg :form :reader step-condition-form))
1228
1229   (:documentation "Common base class of single-stepping conditions.
1230 STEP-CONDITION-FORM holds a string representation of the form being
1231 stepped."))
1232
1233 (setf (fdocumentation 'step-condition-form 'function)
1234       "Form associated with the STEP-CONDITION.")
1235
1236 (define-condition step-form-condition (step-condition)
1237   ((args :initarg :args :reader step-condition-args))
1238   (:report
1239    (lambda (condition stream)
1240      (let ((*print-circle* t)
1241            (*print-pretty* t)
1242            (*print-readably* nil))
1243        (format stream
1244                  "Evaluating call:~%~<  ~@;~A~:>~%~
1245                   ~:[With arguments:~%~{  ~S~%~}~;With unknown arguments~]~%"
1246                (list (step-condition-form condition))
1247                (eq (step-condition-args condition) :unknown)
1248                (step-condition-args condition)))))
1249   (:documentation "Condition signalled by code compiled with
1250 single-stepping information when about to execute a form.
1251 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1252 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1253 holds the source-path to the original form within that file or NIL.
1254 Associated with this condition are always the restarts STEP-INTO,
1255 STEP-NEXT, and STEP-CONTINUE."))
1256
1257 (define-condition step-result-condition (step-condition)
1258   ((result :initarg :result :reader step-condition-result)))
1259
1260 (setf (fdocumentation 'step-condition-result 'function)
1261       "Return values associated with STEP-VALUES-CONDITION as a list,
1262 or the variable value associated with STEP-VARIABLE-CONDITION.")
1263
1264 (define-condition step-values-condition (step-result-condition)
1265   ()
1266   (:documentation "Condition signalled by code compiled with
1267 single-stepping information after executing a form.
1268 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1269 the values returned by the form as a list. No associated restarts."))
1270
1271 (define-condition step-finished-condition (step-condition)
1272   ()
1273   (:report
1274    (lambda (condition stream)
1275      (declare (ignore condition))
1276      (format stream "Returning from STEP")))
1277   (:documentation "Condition signaled when STEP returns."))
1278 \f
1279 ;;; A knob for muffling warnings, mostly for use while loading files.
1280 (defvar *muffled-warnings* 'uninteresting-redefinition
1281   "A type that ought to specify a subtype of WARNING.  Whenever a
1282 warning is signaled, if the warning is of this type and is not
1283 handled by any other handler, it will be muffled.")
1284 \f
1285 ;;; Various STYLE-WARNING signaled in the system.
1286 ;; For the moment, we're only getting into the details for function
1287 ;; redefinitions, but other redefinitions could be done later
1288 ;; (e.g. methods).
1289 (define-condition redefinition-warning (style-warning)
1290   ((name
1291     :initarg :name
1292     :reader redefinition-warning-name)
1293    (new-location
1294     :initarg :new-location
1295     :reader redefinition-warning-new-location)))
1296
1297 (define-condition function-redefinition-warning (redefinition-warning)
1298   ((new-function
1299     :initarg :new-function
1300     :reader function-redefinition-warning-new-function)))
1301
1302 (define-condition redefinition-with-defun (function-redefinition-warning)
1303   ()
1304   (:report (lambda (warning stream)
1305              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1306                              in DEFUN"
1307                      (redefinition-warning-name warning)))))
1308
1309 (define-condition redefinition-with-defmacro (function-redefinition-warning)
1310   ()
1311   (:report (lambda (warning stream)
1312              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1313                              in DEFMACRO"
1314                      (redefinition-warning-name warning)))))
1315
1316 (define-condition redefinition-with-defgeneric (redefinition-warning)
1317   ()
1318   (:report (lambda (warning stream)
1319              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1320                              in DEFGENERIC"
1321                      (redefinition-warning-name warning)))))
1322
1323 (define-condition redefinition-with-defmethod (redefinition-warning)
1324   ((qualifiers :initarg :qualifiers
1325                :reader redefinition-with-defmethod-qualifiers)
1326    (specializers :initarg :specializers
1327                  :reader redefinition-with-defmethod-specializers)
1328    (new-location :initarg :new-location
1329                  :reader redefinition-with-defmethod-new-location)
1330    (old-method :initarg :old-method
1331                :reader redefinition-with-defmethod-old-method))
1332   (:report (lambda (warning stream)
1333              (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1334                      (redefinition-warning-name warning)
1335                      (redefinition-with-defmethod-qualifiers warning)
1336                      (redefinition-with-defmethod-specializers warning)))))
1337
1338 ;;;; Deciding which redefinitions are "interesting".
1339
1340 (defun function-file-namestring (function)
1341   #!+sb-eval
1342   (when (typep function 'sb!eval:interpreted-function)
1343     (return-from function-file-namestring
1344       (sb!c:definition-source-location-namestring
1345           (sb!eval:interpreted-function-source-location function))))
1346   #!+sb-fasteval
1347   (when (typep function 'sb!interpreter:interpreted-function)
1348     (return-from function-file-namestring
1349       (awhen (sb!interpreter:fun-source-location function)
1350         (sb!c:definition-source-location-namestring it))))
1351   (let* ((fun (%fun-fun function))
1352          (code (fun-code-header fun))
1353          (debug-info (%code-debug-info code))
1354          (debug-source (when debug-info
1355                          (sb!c::debug-info-source debug-info)))
1356          (namestring (when debug-source
1357                        (sb!c::debug-source-namestring debug-source))))
1358     namestring))
1359
1360 (defun interesting-function-redefinition-warning-p (warning old)
1361   (let ((new (function-redefinition-warning-new-function warning))
1362         (source-location (redefinition-warning-new-location warning)))
1363     (or
1364      ;; compiled->interpreted is interesting.
1365      (and (typep old 'compiled-function)
1366           (typep new '(not compiled-function)))
1367      ;; fin->regular is interesting except for interpreted->compiled.
1368      (and (typep new '(not funcallable-instance))
1369           (typep old '(and funcallable-instance
1370                            #!+sb-fasteval (not sb!interpreter:interpreted-function)
1371                            #!+sb-eval (not sb!eval:interpreted-function))))
1372      ;; different file or unknown location is interesting.
1373      (let* ((old-namestring (function-file-namestring old))
1374             (new-namestring
1375              (or (function-file-namestring new)
1376                  (when source-location
1377                    (sb!c::definition-source-location-namestring source-location)))))
1378        (and (or (not old-namestring)
1379                 (not new-namestring)
1380                 (not (string= old-namestring new-namestring))))))))
1381
1382 (setf (info :function :predicate-truth-constraint
1383             'uninteresting-ordinary-function-redefinition-p) 'warning)
1384 (defun uninteresting-ordinary-function-redefinition-p (warning)
1385   (and
1386    (typep warning 'redefinition-with-defun)
1387    ;; Shared logic.
1388    (let ((name (redefinition-warning-name warning)))
1389      (not (interesting-function-redefinition-warning-p
1390            warning (or (fdefinition name) (macro-function name)))))))
1391
1392 (setf (info :function :predicate-truth-constraint
1393             'uninteresting-macro-redefinition-p) 'warning)
1394 (defun uninteresting-macro-redefinition-p (warning)
1395   (and
1396    (typep warning 'redefinition-with-defmacro)
1397    ;; Shared logic.
1398    (let ((name (redefinition-warning-name warning)))
1399      (not (interesting-function-redefinition-warning-p
1400            warning (or (macro-function name) (fdefinition name)))))))
1401
1402 (setf (info :function :predicate-truth-constraint
1403             'uninteresting-generic-function-redefinition-p) 'warning)
1404 (defun uninteresting-generic-function-redefinition-p (warning)
1405   (and
1406    (typep warning 'redefinition-with-defgeneric)
1407    ;; Can't use the shared logic above, since GF's don't get a "new"
1408    ;; definition -- rather the FIN-FUNCTION is set.
1409    (let* ((name (redefinition-warning-name warning))
1410           (old (fdefinition name))
1411           (old-location (when (typep old 'generic-function)
1412                           (sb!pcl::definition-source old)))
1413           (old-namestring (when old-location
1414                             (sb!c:definition-source-location-namestring old-location)))
1415           (new-location (redefinition-warning-new-location warning))
1416           (new-namestring (when new-location
1417                            (sb!c:definition-source-location-namestring new-location))))
1418      (and old-namestring
1419           new-namestring
1420           (string= old-namestring new-namestring)))))
1421
1422 (setf (info :function :predicate-truth-constraint
1423             'uninteresting-method-redefinition-p) 'warning)
1424 (defun uninteresting-method-redefinition-p (warning)
1425   (and
1426    (typep warning 'redefinition-with-defmethod)
1427    ;; Can't use the shared logic above, since GF's don't get a "new"
1428    ;; definition -- rather the FIN-FUNCTION is set.
1429    (let* ((old-method (redefinition-with-defmethod-old-method warning))
1430           (old-location (sb!pcl::definition-source old-method))
1431           (old-namestring (when old-location
1432                             (sb!c:definition-source-location-namestring old-location)))
1433           (new-location (redefinition-warning-new-location warning))
1434           (new-namestring (when new-location
1435                             (sb!c:definition-source-location-namestring new-location))))
1436          (and new-namestring
1437               old-namestring
1438               (string= new-namestring old-namestring)))))
1439
1440 (deftype uninteresting-redefinition ()
1441   '(or (satisfies uninteresting-ordinary-function-redefinition-p)
1442        (satisfies uninteresting-macro-redefinition-p)
1443        (satisfies uninteresting-generic-function-redefinition-p)
1444        (satisfies uninteresting-method-redefinition-p)))
1445
1446 (define-condition redefinition-with-deftransform (redefinition-warning)
1447   ((transform :initarg :transform
1448               :reader redefinition-with-deftransform-transform))
1449   (:report (lambda (warning stream)
1450              (format stream "Overwriting ~S"
1451                      (redefinition-with-deftransform-transform warning)))))
1452 \f
1453 ;;; Various other STYLE-WARNINGS
1454 (define-condition dubious-asterisks-around-variable-name
1455     (style-warning simple-condition)
1456   ()
1457   (:report (lambda (warning stream)
1458              (format stream "~@?, even though the name follows~@
1459 the usual naming convention (names like *FOO*) for special variables"
1460                      (simple-condition-format-control warning)
1461                      (simple-condition-format-arguments warning)))))
1462
1463 (define-condition asterisks-around-lexical-variable-name
1464     (dubious-asterisks-around-variable-name)
1465   ())
1466
1467 (define-condition asterisks-around-constant-variable-name
1468     (dubious-asterisks-around-variable-name)
1469   ())
1470
1471 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1472 ;; subclasses of ERROR above having to do with undefined aliens.
1473 (define-condition undefined-alien-style-warning (style-warning)
1474   ((symbol :initarg :symbol :reader undefined-alien-symbol))
1475   (:report (lambda (warning stream)
1476              (format stream "Undefined alien: ~S"
1477                      (undefined-alien-symbol warning)))))
1478
1479 #!+(or sb-eval sb-fasteval)
1480 (define-condition lexical-environment-too-complex (style-warning)
1481   ((form :initarg :form :reader lexical-environment-too-complex-form)
1482    (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv))
1483   (:report (lambda (warning stream)
1484              (format stream
1485                      "~@<Native lexical environment too complex for ~
1486                          SB-EVAL to evaluate ~S, falling back to ~
1487                          SIMPLE-EVAL-IN-LEXENV.  Lexenv: ~S~:@>"
1488                      (lexical-environment-too-complex-form warning)
1489                      (lexical-environment-too-complex-lexenv warning)))))
1490
1491 ;; If the interpreter is in use (and the REPL is interpreted),
1492 ;; it's easy to accidentally make the macroexpand-hook an interpreted
1493 ;; function. So MACROEXPAND-1 is a little more careful,
1494 ;; and might signal this, instead of only EVAL being able to signal it.
1495 (define-condition macroexpand-hook-type-error (type-error)
1496   ()
1497   (:report (lambda (condition stream)
1498              (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~S"
1499                      (type-error-datum condition)))))
1500
1501 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1502 (define-condition character-decoding-error-in-comment (style-warning)
1503   ((stream :initarg :stream :reader decoding-error-in-comment-stream)
1504    (position :initarg :position :reader decoding-error-in-comment-position))
1505   (:report (lambda (warning stream)
1506              (format stream
1507                       "Character decoding error in a ~A-comment at ~
1508                       position ~A reading source stream ~A, ~
1509                       resyncing."
1510                       (decoding-error-in-comment-macro warning)
1511                       (decoding-error-in-comment-position warning)
1512                       (decoding-error-in-comment-stream warning)))))
1513
1514 (define-condition character-decoding-error-in-macro-char-comment
1515     (character-decoding-error-in-comment)
1516   ((char :initform #\; :initarg :char
1517          :reader character-decoding-error-in-macro-char-comment-char)))
1518
1519 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1520     (character-decoding-error-in-comment)
1521   ;; ANSI doesn't give a way for a reader function invoked by a
1522   ;; dispatch macro character to determine which dispatch character
1523   ;; was used, so if a user wants to signal one of these from a custom
1524   ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1525   ((disp-char :initform #\# :initarg :disp-char
1526               :reader character-decoding-error-in-macro-char-comment-disp-char)
1527    (sub-char :initarg :sub-char
1528              :reader character-decoding-error-in-macro-char-comment-sub-char)))
1529
1530 (defun decoding-error-in-comment-macro (warning)
1531   (etypecase warning
1532     (character-decoding-error-in-macro-char-comment
1533      (character-decoding-error-in-macro-char-comment-char warning))
1534     (character-decoding-error-in-dispatch-macro-char-comment
1535      (format
1536       nil "~C~C"
1537       (character-decoding-error-in-macro-char-comment-disp-char warning)
1538       (character-decoding-error-in-macro-char-comment-sub-char warning)))))
1539
1540 (define-condition deprecated-eval-when-situations (style-warning)
1541   ((situations :initarg :situations
1542                :reader deprecated-eval-when-situations-situations))
1543   (:report (lambda (warning stream)
1544              (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}"
1545                      (deprecated-eval-when-situations-situations warning)))))
1546
1547 (define-condition proclamation-mismatch (condition)
1548   ((kind :initarg :kind :reader proclamation-mismatch-kind)
1549    (description :initarg :description :reader proclamation-mismatch-description :initform nil)
1550    (name :initarg :name :reader proclamation-mismatch-name)
1551    (old :initarg :old :reader proclamation-mismatch-old)
1552    (new :initarg :new :reader proclamation-mismatch-new))
1553   (:report
1554    (lambda (condition stream)
1555      (format stream
1556              "~@<The new ~A proclamation for~@[ ~A~] ~
1557                ~/sb!impl:print-symbol-with-prefix/~
1558                ~@:_~2@T~/sb!impl:print-type-specifier/~@:_~
1559                does not match the old ~4:*~A~3* proclamation~
1560                ~@:_~2@T~/sb!impl:print-type-specifier/~@:>"
1561              (proclamation-mismatch-kind condition)
1562              (proclamation-mismatch-description condition)
1563              (proclamation-mismatch-name condition)
1564              (proclamation-mismatch-new condition)
1565              (proclamation-mismatch-old condition)))))
1566
1567 (define-condition type-proclamation-mismatch (proclamation-mismatch)
1568   ()
1569   (:default-initargs :kind 'type))
1570
1571 (define-condition type-proclamation-mismatch-warning (style-warning
1572                                                       type-proclamation-mismatch)
1573   ())
1574
1575 (define-condition ftype-proclamation-mismatch (proclamation-mismatch)
1576   ()
1577   (:default-initargs :kind 'ftype))
1578
1579 (define-condition ftype-proclamation-mismatch-warning (style-warning
1580                                                        ftype-proclamation-mismatch)
1581   ())
1582
1583 (define-condition ftype-proclamation-mismatch-error (error
1584                                                      ftype-proclamation-mismatch)
1585   ()
1586   (:default-initargs :kind 'ftype :description "known function"))
1587
1588 \f
1589 ;;;; deprecation conditions
1590
1591 (define-condition deprecation-condition (reference-condition)
1592   ((namespace     :initarg :namespace
1593                   :reader deprecation-condition-namespace)
1594    (name          :initarg :name
1595                   :reader deprecation-condition-name)
1596    (replacements  :initarg :replacements
1597                   :reader deprecation-condition-replacements)
1598    (software      :initarg :software
1599                   :reader deprecation-condition-software)
1600    (version       :initarg :version
1601                   :reader deprecation-condition-version)
1602    (runtime-error :initarg :runtime-error
1603                   :reader deprecation-condition-runtime-error
1604                   :initform nil))
1605   (:default-initargs
1606    :namespace (missing-arg)
1607    :name (missing-arg)
1608    :replacements (missing-arg)
1609    :software (missing-arg)
1610    :version (missing-arg)
1611    :references '((:sbcl :node "Deprecation Conditions")))
1612   (:documentation
1613    "Superclass for deprecation-related error and warning
1614 conditions."))
1615
1616 (defmethod print-object ((condition deprecation-condition) stream)
1617   (flet ((print-it (stream)
1618            (print-deprecation-message
1619             (deprecation-condition-namespace condition)
1620             (deprecation-condition-name condition)
1621             (deprecation-condition-software condition)
1622             (deprecation-condition-version condition)
1623             (deprecation-condition-replacements condition)
1624             stream)))
1625     (if *print-escape*
1626         (print-unreadable-object (condition stream :type t)
1627           (print-it stream))
1628         (print-it stream))))
1629
1630 (macrolet ((define-deprecation-warning
1631                (name superclass check-runtime-error format-string
1632                 &optional documentation)
1633              `(progn
1634                 (define-condition ,name (,superclass deprecation-condition)
1635                   ()
1636                   ,@(when documentation
1637                       `((:documentation ,documentation))))
1638
1639                 (defmethod print-object :after ((condition ,name) stream)
1640                   (when (and (not *print-escape*)
1641                              ,@(when check-runtime-error
1642                                 `((deprecation-condition-runtime-error condition))))
1643                     (format stream ,format-string
1644                             (deprecation-condition-software condition)
1645                             (deprecation-condition-name condition)))))))
1646
1647   ;; PRINT-SYMBOL-WITH-PREFIX is spelled using its target package name,
1648   ;; not its cold package name, because these methods aren't unsable until
1649   ;; warm load. (!CALL-A-METHOD does not understand method qualifiers)
1650   (define-deprecation-warning early-deprecation-warning style-warning nil
1651      "~%~@<~:@_In future~@[ ~A~] versions ~
1652       ~/sb-ext:print-symbol-with-prefix/ will signal a full warning ~
1653       at compile-time.~:@>"
1654     "This warning is signaled when the use of a variable,
1655 function, type, etc. in :EARLY deprecation is detected at
1656 compile-time. The use will work at run-time with no warning or
1657 error.")
1658
1659   (define-deprecation-warning late-deprecation-warning warning t
1660      "~%~@<~:@_In future~@[ ~A~] versions ~
1661       ~/sb-ext:print-symbol-with-prefix/ will signal a runtime ~
1662       error.~:@>"
1663     "This warning is signaled when the use of a variable,
1664 function, type, etc. in :LATE deprecation is detected at
1665 compile-time. The use will work at run-time with no warning or
1666 error.")
1667
1668   (define-deprecation-warning final-deprecation-warning warning t
1669      "~%~@<~:@_~*An error will be signaled at runtime for ~
1670       ~/sb-ext:print-symbol-with-prefix/.~:@>"
1671     "This warning is signaled when the use of a variable,
1672 function, type, etc. in :FINAL deprecation is detected at
1673 compile-time. An error will be signaled at run-time."))
1674
1675 (define-condition deprecation-error (error deprecation-condition)
1676   ()
1677   (:documentation
1678    "This error is signaled at run-time when an attempt is made to use
1679 a thing that is in :FINAL deprecation, i.e. call a function or access
1680 a variable."))
1681 \f
1682 ;;;; restart definitions
1683
1684 (define-condition abort-failure (control-error) ()
1685   (:report
1686    "An ABORT restart was found that failed to transfer control dynamically."))
1687
1688 (defun abort (&optional condition)
1689   "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1690    none exists."
1691   (invoke-restart (find-restart-or-control-error 'abort condition))
1692   ;; ABORT signals an error in case there was a restart named ABORT
1693   ;; that did not transfer control dynamically. This could happen with
1694   ;; RESTART-BIND.
1695   (error 'abort-failure))
1696
1697 (defun muffle-warning (&optional condition)
1698   "Transfer control to a restart named MUFFLE-WARNING, signalling a
1699    CONTROL-ERROR if none exists."
1700   (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1701
1702 (defun try-restart (name condition &rest arguments)
1703   (let ((restart (find-restart name condition)))
1704     (when restart
1705       (apply #'invoke-restart restart arguments))))
1706
1707 (macrolet ((define-nil-returning-restart (name args doc)
1708              `(defun ,name (,@args &optional condition)
1709                 ,doc
1710                 (try-restart ',name condition ,@args))))
1711   (define-nil-returning-restart continue ()
1712     "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1713   (define-nil-returning-restart store-value (value)
1714     "Transfer control and VALUE to a restart named STORE-VALUE, or
1715 return NIL if none exists.")
1716   (define-nil-returning-restart use-value (value)
1717     "Transfer control and VALUE to a restart named USE-VALUE, or
1718 return NIL if none exists.")
1719   (define-nil-returning-restart print-unreadably ()
1720     "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
1721 return NIL if none exists."))
1722
1723 ;;; single-stepping restarts
1724
1725 (macrolet ((def (name doc)
1726                `(defun ,name (condition)
1727                  ,doc
1728                  (invoke-restart (find-restart-or-control-error ',name condition)))))
1729   (def step-continue
1730       "Transfers control to the STEP-CONTINUE restart associated with
1731 the condition, continuing execution without stepping. Signals a
1732 CONTROL-ERROR if the restart does not exist.")
1733   (def step-next
1734       "Transfers control to the STEP-NEXT restart associated with the
1735 condition, executing the current form without stepping and continuing
1736 stepping with the next form. Signals CONTROL-ERROR is the restart does
1737 not exists.")
1738   (def step-into
1739       "Transfers control to the STEP-INTO restart associated with the
1740 condition, stepping into the current form. Signals a CONTROL-ERROR is
1741 the restart does not exist."))
1742
1743 ;;; Compiler macro magic
1744
1745 (define-condition compiler-macro-keyword-problem ()
1746   ((argument :initarg :argument :reader compiler-macro-keyword-argument))
1747   (:report (lambda (condition stream)
1748              (format stream "~@<Argument ~S in keyword position is not ~
1749                              a self-evaluating symbol, preventing compiler-macro ~
1750                              expansion.~@:>"
1751                      (compiler-macro-keyword-argument condition)))))
1752
1753 ;; After (or if) we deem this the optimal name for this condition,
1754 ;; it should be exported from SB-EXT so that people can muffle it.
1755 (define-condition sb!c:inlining-dependency-failure (simple-style-warning) ())
1756
1757 (/show0 "condition.lisp end of file")