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   (:documentation
1200    "Signaled when an operation does not complete within an allotted time budget."))
1201
1202 (define-condition io-timeout (stream-error timeout)
1203   ((direction :reader io-timeout-direction :initarg :direction))
1204   (:report
1205    (lambda (condition stream)
1206      (declare (type stream stream))
1207      (format stream
1208              "I/O timeout while doing ~(~A~) on ~S."
1209              (io-timeout-direction condition)
1210              (stream-error-stream condition)))))
1211
1212 (define-condition deadline-timeout (timeout)
1213   ()
1214   (:report (lambda (condition stream)
1215              (format stream "A deadline was reached after ~A second~:P."
1216                      (timeout-seconds condition))))
1217   (:documentation
1218    "Signaled when an operation in the context of a deadline takes
1219 longer than permitted by the deadline."))
1220
1221 (define-condition declaration-type-conflict-error (reference-condition
1222                                                    simple-error)
1223   ()
1224   (:default-initargs
1225    :format-control  "Symbol ~/sb-ext:print-symbol-with-prefix/ cannot ~
1226                      be both the name of a type and the name of a ~
1227                      declaration"
1228    :references '((:ansi-cl :section (3 8 21)))))
1229
1230 ;;; Single stepping conditions
1231
1232 (define-condition step-condition ()
1233   ((form :initarg :form :reader step-condition-form))
1234   (:documentation "Common base class of single-stepping conditions.
1235 STEP-CONDITION-FORM holds a string representation of the form being
1236 stepped."))
1237
1238 (setf (fdocumentation 'step-condition-form 'function)
1239       "Form associated with the STEP-CONDITION.")
1240
1241 (define-condition step-form-condition (step-condition)
1242   ((args :initarg :args :reader step-condition-args))
1243   (:report
1244    (lambda (condition stream)
1245      (let ((*print-circle* t)
1246            (*print-pretty* t)
1247            (*print-readably* nil))
1248        (format stream
1249                  "Evaluating call:~%~<  ~@;~A~:>~%~
1250                   ~:[With arguments:~%~{  ~S~%~}~;With unknown arguments~]~%"
1251                (list (step-condition-form condition))
1252                (eq (step-condition-args condition) :unknown)
1253                (step-condition-args condition)))))
1254   (:documentation "Condition signalled by code compiled with
1255 single-stepping information when about to execute a form.
1256 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1257 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1258 holds the source-path to the original form within that file or NIL.
1259 Associated with this condition are always the restarts STEP-INTO,
1260 STEP-NEXT, and STEP-CONTINUE."))
1261
1262 (define-condition step-result-condition (step-condition)
1263   ((result :initarg :result :reader step-condition-result)))
1264
1265 (setf (fdocumentation 'step-condition-result 'function)
1266       "Return values associated with STEP-VALUES-CONDITION as a list,
1267 or the variable value associated with STEP-VARIABLE-CONDITION.")
1268
1269 (define-condition step-values-condition (step-result-condition)
1270   ()
1271   (:documentation "Condition signalled by code compiled with
1272 single-stepping information after executing a form.
1273 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1274 the values returned by the form as a list. No associated restarts."))
1275
1276 (define-condition step-finished-condition (step-condition)
1277   ()
1278   (:report
1279    (lambda (condition stream)
1280      (declare (ignore condition))
1281      (format stream "Returning from STEP")))
1282   (:documentation "Condition signaled when STEP returns."))
1283 \f
1284 ;;; A knob for muffling warnings, mostly for use while loading files.
1285 (defvar *muffled-warnings* 'uninteresting-redefinition
1286   "A type that ought to specify a subtype of WARNING.  Whenever a
1287 warning is signaled, if the warning is of this type and is not
1288 handled by any other handler, it will be muffled.")
1289 \f
1290 ;;; Various STYLE-WARNING signaled in the system.
1291 ;; For the moment, we're only getting into the details for function
1292 ;; redefinitions, but other redefinitions could be done later
1293 ;; (e.g. methods).
1294 (define-condition redefinition-warning (style-warning)
1295   ((name
1296     :initarg :name
1297     :reader redefinition-warning-name)
1298    (new-location
1299     :initarg :new-location
1300     :reader redefinition-warning-new-location)))
1301
1302 (define-condition function-redefinition-warning (redefinition-warning)
1303   ((new-function
1304     :initarg :new-function
1305     :reader function-redefinition-warning-new-function)))
1306
1307 (define-condition redefinition-with-defun (function-redefinition-warning)
1308   ()
1309   (:report (lambda (warning stream)
1310              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1311                              in DEFUN"
1312                      (redefinition-warning-name warning)))))
1313
1314 (define-condition redefinition-with-defmacro (function-redefinition-warning)
1315   ()
1316   (:report (lambda (warning stream)
1317              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1318                              in DEFMACRO"
1319                      (redefinition-warning-name warning)))))
1320
1321 (define-condition redefinition-with-defgeneric (redefinition-warning)
1322   ()
1323   (:report (lambda (warning stream)
1324              (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~
1325                              in DEFGENERIC"
1326                      (redefinition-warning-name warning)))))
1327
1328 (define-condition redefinition-with-defmethod (redefinition-warning)
1329   ((qualifiers :initarg :qualifiers
1330                :reader redefinition-with-defmethod-qualifiers)
1331    (specializers :initarg :specializers
1332                  :reader redefinition-with-defmethod-specializers)
1333    (new-location :initarg :new-location
1334                  :reader redefinition-with-defmethod-new-location)
1335    (old-method :initarg :old-method
1336                :reader redefinition-with-defmethod-old-method))
1337   (:report (lambda (warning stream)
1338              (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1339                      (redefinition-warning-name warning)
1340                      (redefinition-with-defmethod-qualifiers warning)
1341                      (redefinition-with-defmethod-specializers warning)))))
1342
1343 ;;;; Deciding which redefinitions are "interesting".
1344
1345 (defun function-file-namestring (function)
1346   #!+sb-eval
1347   (when (typep function 'sb!eval:interpreted-function)
1348     (return-from function-file-namestring
1349       (sb!c:definition-source-location-namestring
1350           (sb!eval:interpreted-function-source-location function))))
1351   #!+sb-fasteval
1352   (when (typep function 'sb!interpreter:interpreted-function)
1353     (return-from function-file-namestring
1354       (awhen (sb!interpreter:fun-source-location function)
1355         (sb!c:definition-source-location-namestring it))))
1356   (let* ((fun (%fun-fun function))
1357          (code (fun-code-header fun))
1358          (debug-info (%code-debug-info code))
1359          (debug-source (when debug-info
1360                          (sb!c::debug-info-source debug-info)))
1361          (namestring (when debug-source
1362                        (sb!c::debug-source-namestring debug-source))))
1363     namestring))
1364
1365 (defun interesting-function-redefinition-warning-p (warning old)
1366   (let ((new (function-redefinition-warning-new-function warning))
1367         (source-location (redefinition-warning-new-location warning)))
1368     (or
1369      ;; compiled->interpreted is interesting.
1370      (and (typep old 'compiled-function)
1371           (typep new '(not compiled-function)))
1372      ;; fin->regular is interesting except for interpreted->compiled.
1373      (and (typep new '(not funcallable-instance))
1374           (typep old '(and funcallable-instance
1375                            #!+sb-fasteval (not sb!interpreter:interpreted-function)
1376                            #!+sb-eval (not sb!eval:interpreted-function))))
1377      ;; different file or unknown location is interesting.
1378      (let* ((old-namestring (function-file-namestring old))
1379             (new-namestring
1380              (or (function-file-namestring new)
1381                  (when source-location
1382                    (sb!c::definition-source-location-namestring source-location)))))
1383        (and (or (not old-namestring)
1384                 (not new-namestring)
1385                 (not (string= old-namestring new-namestring))))))))
1386
1387 (setf (info :function :predicate-truth-constraint
1388             'uninteresting-ordinary-function-redefinition-p) 'warning)
1389 (defun uninteresting-ordinary-function-redefinition-p (warning)
1390   (and
1391    (typep warning 'redefinition-with-defun)
1392    ;; Shared logic.
1393    (let ((name (redefinition-warning-name warning)))
1394      (not (interesting-function-redefinition-warning-p
1395            warning (or (fdefinition name) (macro-function name)))))))
1396
1397 (setf (info :function :predicate-truth-constraint
1398             'uninteresting-macro-redefinition-p) 'warning)
1399 (defun uninteresting-macro-redefinition-p (warning)
1400   (and
1401    (typep warning 'redefinition-with-defmacro)
1402    ;; Shared logic.
1403    (let ((name (redefinition-warning-name warning)))
1404      (not (interesting-function-redefinition-warning-p
1405            warning (or (macro-function name) (fdefinition name)))))))
1406
1407 (setf (info :function :predicate-truth-constraint
1408             'uninteresting-generic-function-redefinition-p) 'warning)
1409 (defun uninteresting-generic-function-redefinition-p (warning)
1410   (and
1411    (typep warning 'redefinition-with-defgeneric)
1412    ;; Can't use the shared logic above, since GF's don't get a "new"
1413    ;; definition -- rather the FIN-FUNCTION is set.
1414    (let* ((name (redefinition-warning-name warning))
1415           (old (fdefinition name))
1416           (old-location (when (typep old 'generic-function)
1417                           (sb!pcl::definition-source old)))
1418           (old-namestring (when old-location
1419                             (sb!c:definition-source-location-namestring old-location)))
1420           (new-location (redefinition-warning-new-location warning))
1421           (new-namestring (when new-location
1422                            (sb!c:definition-source-location-namestring new-location))))
1423      (and old-namestring
1424           new-namestring
1425           (string= old-namestring new-namestring)))))
1426
1427 (setf (info :function :predicate-truth-constraint
1428             'uninteresting-method-redefinition-p) 'warning)
1429 (defun uninteresting-method-redefinition-p (warning)
1430   (and
1431    (typep warning 'redefinition-with-defmethod)
1432    ;; Can't use the shared logic above, since GF's don't get a "new"
1433    ;; definition -- rather the FIN-FUNCTION is set.
1434    (let* ((old-method (redefinition-with-defmethod-old-method warning))
1435           (old-location (sb!pcl::definition-source old-method))
1436           (old-namestring (when old-location
1437                             (sb!c:definition-source-location-namestring old-location)))
1438           (new-location (redefinition-warning-new-location warning))
1439           (new-namestring (when new-location
1440                             (sb!c:definition-source-location-namestring new-location))))
1441          (and new-namestring
1442               old-namestring
1443               (string= new-namestring old-namestring)))))
1444
1445 (deftype uninteresting-redefinition ()
1446   '(or (satisfies uninteresting-ordinary-function-redefinition-p)
1447        (satisfies uninteresting-macro-redefinition-p)
1448        (satisfies uninteresting-generic-function-redefinition-p)
1449        (satisfies uninteresting-method-redefinition-p)))
1450
1451 (define-condition redefinition-with-deftransform (redefinition-warning)
1452   ((transform :initarg :transform
1453               :reader redefinition-with-deftransform-transform))
1454   (:report (lambda (warning stream)
1455              (format stream "Overwriting ~S"
1456                      (redefinition-with-deftransform-transform warning)))))
1457 \f
1458 ;;; Various other STYLE-WARNINGS
1459 (define-condition dubious-asterisks-around-variable-name
1460     (style-warning simple-condition)
1461   ()
1462   (:report (lambda (warning stream)
1463              (format stream "~@?, even though the name follows~@
1464 the usual naming convention (names like *FOO*) for special variables"
1465                      (simple-condition-format-control warning)
1466                      (simple-condition-format-arguments warning)))))
1467
1468 (define-condition asterisks-around-lexical-variable-name
1469     (dubious-asterisks-around-variable-name)
1470   ())
1471
1472 (define-condition asterisks-around-constant-variable-name
1473     (dubious-asterisks-around-variable-name)
1474   ())
1475
1476 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1477 ;; subclasses of ERROR above having to do with undefined aliens.
1478 (define-condition undefined-alien-style-warning (style-warning)
1479   ((symbol :initarg :symbol :reader undefined-alien-symbol))
1480   (:report (lambda (warning stream)
1481              (format stream "Undefined alien: ~S"
1482                      (undefined-alien-symbol warning)))))
1483
1484 #!+(or sb-eval sb-fasteval)
1485 (define-condition lexical-environment-too-complex (style-warning)
1486   ((form :initarg :form :reader lexical-environment-too-complex-form)
1487    (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv))
1488   (:report (lambda (warning stream)
1489              (format stream
1490                      "~@<Native lexical environment too complex for ~
1491                          SB-EVAL to evaluate ~S, falling back to ~
1492                          SIMPLE-EVAL-IN-LEXENV.  Lexenv: ~S~:@>"
1493                      (lexical-environment-too-complex-form warning)
1494                      (lexical-environment-too-complex-lexenv warning)))))
1495
1496 ;; If the interpreter is in use (and the REPL is interpreted),
1497 ;; it's easy to accidentally make the macroexpand-hook an interpreted
1498 ;; function. So MACROEXPAND-1 is a little more careful,
1499 ;; and might signal this, instead of only EVAL being able to signal it.
1500 (define-condition macroexpand-hook-type-error (type-error)
1501   ()
1502   (:report (lambda (condition stream)
1503              (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~S"
1504                      (type-error-datum condition)))))
1505
1506 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1507 (define-condition character-decoding-error-in-comment (style-warning)
1508   ((stream :initarg :stream :reader decoding-error-in-comment-stream)
1509    (position :initarg :position :reader decoding-error-in-comment-position))
1510   (:report (lambda (warning stream)
1511              (format stream
1512                       "Character decoding error in a ~A-comment at ~
1513                       position ~A reading source stream ~A, ~
1514                       resyncing."
1515                       (decoding-error-in-comment-macro warning)
1516                       (decoding-error-in-comment-position warning)
1517                       (decoding-error-in-comment-stream warning)))))
1518
1519 (define-condition character-decoding-error-in-macro-char-comment
1520     (character-decoding-error-in-comment)
1521   ((char :initform #\; :initarg :char
1522          :reader character-decoding-error-in-macro-char-comment-char)))
1523
1524 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1525     (character-decoding-error-in-comment)
1526   ;; ANSI doesn't give a way for a reader function invoked by a
1527   ;; dispatch macro character to determine which dispatch character
1528   ;; was used, so if a user wants to signal one of these from a custom
1529   ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1530   ((disp-char :initform #\# :initarg :disp-char
1531               :reader character-decoding-error-in-macro-char-comment-disp-char)
1532    (sub-char :initarg :sub-char
1533              :reader character-decoding-error-in-macro-char-comment-sub-char)))
1534
1535 (defun decoding-error-in-comment-macro (warning)
1536   (etypecase warning
1537     (character-decoding-error-in-macro-char-comment
1538      (character-decoding-error-in-macro-char-comment-char warning))
1539     (character-decoding-error-in-dispatch-macro-char-comment
1540      (format
1541       nil "~C~C"
1542       (character-decoding-error-in-macro-char-comment-disp-char warning)
1543       (character-decoding-error-in-macro-char-comment-sub-char warning)))))
1544
1545 (define-condition deprecated-eval-when-situations (style-warning)
1546   ((situations :initarg :situations
1547                :reader deprecated-eval-when-situations-situations))
1548   (:report (lambda (warning stream)
1549              (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}"
1550                      (deprecated-eval-when-situations-situations warning)))))
1551
1552 (define-condition proclamation-mismatch (condition)
1553   ((kind :initarg :kind :reader proclamation-mismatch-kind)
1554    (description :initarg :description :reader proclamation-mismatch-description :initform nil)
1555    (name :initarg :name :reader proclamation-mismatch-name)
1556    (old :initarg :old :reader proclamation-mismatch-old)
1557    (new :initarg :new :reader proclamation-mismatch-new))
1558   (:report
1559    (lambda (condition stream)
1560      (format stream
1561              "~@<The new ~A proclamation for~@[ ~A~] ~
1562                ~/sb!impl:print-symbol-with-prefix/~
1563                ~@:_~2@T~/sb!impl:print-type-specifier/~@:_~
1564                does not match the old ~4:*~A~3* proclamation~
1565                ~@:_~2@T~/sb!impl:print-type-specifier/~@:>"
1566              (proclamation-mismatch-kind condition)
1567              (proclamation-mismatch-description condition)
1568              (proclamation-mismatch-name condition)
1569              (proclamation-mismatch-new condition)
1570              (proclamation-mismatch-old condition)))))
1571
1572 (define-condition type-proclamation-mismatch (proclamation-mismatch)
1573   ()
1574   (:default-initargs :kind 'type))
1575
1576 (define-condition type-proclamation-mismatch-warning (style-warning
1577                                                       type-proclamation-mismatch)
1578   ())
1579
1580 (define-condition ftype-proclamation-mismatch (proclamation-mismatch)
1581   ()
1582   (:default-initargs :kind 'ftype))
1583
1584 (define-condition ftype-proclamation-mismatch-warning (style-warning
1585                                                        ftype-proclamation-mismatch)
1586   ())
1587
1588 (define-condition ftype-proclamation-mismatch-error (error
1589                                                      ftype-proclamation-mismatch)
1590   ()
1591   (:default-initargs :kind 'ftype :description "known function"))
1592
1593 \f
1594 ;;;; deprecation conditions
1595
1596 (define-condition deprecation-condition (reference-condition)
1597   ((namespace     :initarg :namespace
1598                   :reader deprecation-condition-namespace)
1599    (name          :initarg :name
1600                   :reader deprecation-condition-name)
1601    (replacements  :initarg :replacements
1602                   :reader deprecation-condition-replacements)
1603    (software      :initarg :software
1604                   :reader deprecation-condition-software)
1605    (version       :initarg :version
1606                   :reader deprecation-condition-version)
1607    (runtime-error :initarg :runtime-error
1608                   :reader deprecation-condition-runtime-error
1609                   :initform nil))
1610   (:default-initargs
1611    :namespace (missing-arg)
1612    :name (missing-arg)
1613    :replacements (missing-arg)
1614    :software (missing-arg)
1615    :version (missing-arg)
1616    :references '((:sbcl :node "Deprecation Conditions")))
1617   (:documentation
1618    "Superclass for deprecation-related error and warning
1619 conditions."))
1620
1621 (defmethod print-object ((condition deprecation-condition) stream)
1622   (flet ((print-it (stream)
1623            (print-deprecation-message
1624             (deprecation-condition-namespace condition)
1625             (deprecation-condition-name condition)
1626             (deprecation-condition-software condition)
1627             (deprecation-condition-version condition)
1628             (deprecation-condition-replacements condition)
1629             stream)))
1630     (if *print-escape*
1631         (print-unreadable-object (condition stream :type t)
1632           (print-it stream))
1633         (print-it stream))))
1634
1635 (macrolet ((define-deprecation-warning
1636                (name superclass check-runtime-error format-string
1637                 &optional documentation)
1638              `(progn
1639                 (define-condition ,name (,superclass deprecation-condition)
1640                   ()
1641                   ,@(when documentation
1642                       `((:documentation ,documentation))))
1643
1644                 (defmethod print-object :after ((condition ,name) stream)
1645                   (when (and (not *print-escape*)
1646                              ,@(when check-runtime-error
1647                                 `((deprecation-condition-runtime-error condition))))
1648                     (format stream ,format-string
1649                             (deprecation-condition-software condition)
1650                             (deprecation-condition-name condition)))))))
1651
1652   ;; PRINT-SYMBOL-WITH-PREFIX is spelled using its target package name,
1653   ;; not its cold package name, because these methods aren't unsable until
1654   ;; warm load. (!CALL-A-METHOD does not understand method qualifiers)
1655   (define-deprecation-warning early-deprecation-warning style-warning nil
1656      "~%~@<~:@_In future~@[ ~A~] versions ~
1657       ~/sb-ext:print-symbol-with-prefix/ will signal a full warning ~
1658       at compile-time.~:@>"
1659     "This warning is signaled when the use of a variable,
1660 function, type, etc. in :EARLY deprecation is detected at
1661 compile-time. The use will work at run-time with no warning or
1662 error.")
1663
1664   (define-deprecation-warning late-deprecation-warning warning t
1665      "~%~@<~:@_In future~@[ ~A~] versions ~
1666       ~/sb-ext:print-symbol-with-prefix/ will signal a runtime ~
1667       error.~:@>"
1668     "This warning is signaled when the use of a variable,
1669 function, type, etc. in :LATE deprecation is detected at
1670 compile-time. The use will work at run-time with no warning or
1671 error.")
1672
1673   (define-deprecation-warning final-deprecation-warning warning t
1674      "~%~@<~:@_~*An error will be signaled at runtime for ~
1675       ~/sb-ext:print-symbol-with-prefix/.~:@>"
1676     "This warning is signaled when the use of a variable,
1677 function, type, etc. in :FINAL deprecation is detected at
1678 compile-time. An error will be signaled at run-time."))
1679
1680 (define-condition deprecation-error (error deprecation-condition)
1681   ()
1682   (:documentation
1683    "This error is signaled at run-time when an attempt is made to use
1684 a thing that is in :FINAL deprecation, i.e. call a function or access
1685 a variable."))
1686 \f
1687 ;;;; restart definitions
1688
1689 (define-condition abort-failure (control-error) ()
1690   (:report
1691    "An ABORT restart was found that failed to transfer control dynamically."))
1692
1693 (defun abort (&optional condition)
1694   "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1695    none exists."
1696   (invoke-restart (find-restart-or-control-error 'abort condition))
1697   ;; ABORT signals an error in case there was a restart named ABORT
1698   ;; that did not transfer control dynamically. This could happen with
1699   ;; RESTART-BIND.
1700   (error 'abort-failure))
1701
1702 (defun muffle-warning (&optional condition)
1703   "Transfer control to a restart named MUFFLE-WARNING, signalling a
1704    CONTROL-ERROR if none exists."
1705   (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1706
1707 (defun try-restart (name condition &rest arguments)
1708   (let ((restart (find-restart name condition)))
1709     (when restart
1710       (apply #'invoke-restart restart arguments))))
1711
1712 (macrolet ((define-nil-returning-restart (name args doc)
1713              `(defun ,name (,@args &optional condition)
1714                 ,doc
1715                 (try-restart ',name condition ,@args))))
1716   (define-nil-returning-restart continue ()
1717     "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1718   (define-nil-returning-restart store-value (value)
1719     "Transfer control and VALUE to a restart named STORE-VALUE, or
1720 return NIL if none exists.")
1721   (define-nil-returning-restart use-value (value)
1722     "Transfer control and VALUE to a restart named USE-VALUE, or
1723 return NIL if none exists.")
1724   (define-nil-returning-restart print-unreadably ()
1725     "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
1726 return NIL if none exists."))
1727
1728 ;;; single-stepping restarts
1729
1730 (macrolet ((def (name doc)
1731                `(defun ,name (condition)
1732                  ,doc
1733                  (invoke-restart (find-restart-or-control-error ',name condition)))))
1734   (def step-continue
1735       "Transfers control to the STEP-CONTINUE restart associated with
1736 the condition, continuing execution without stepping. Signals a
1737 CONTROL-ERROR if the restart does not exist.")
1738   (def step-next
1739       "Transfers control to the STEP-NEXT restart associated with the
1740 condition, executing the current form without stepping and continuing
1741 stepping with the next form. Signals CONTROL-ERROR is the restart does
1742 not exists.")
1743   (def step-into
1744       "Transfers control to the STEP-INTO restart associated with the
1745 condition, stepping into the current form. Signals a CONTROL-ERROR is
1746 the restart does not exist."))
1747
1748 ;;; Compiler macro magic
1749
1750 (define-condition compiler-macro-keyword-problem ()
1751   ((argument :initarg :argument :reader compiler-macro-keyword-argument))
1752   (:report (lambda (condition stream)
1753              (format stream "~@<Argument ~S in keyword position is not ~
1754                              a self-evaluating symbol, preventing compiler-macro ~
1755                              expansion.~@:>"
1756                      (compiler-macro-keyword-argument condition)))))
1757
1758 ;; After (or if) we deem this the optimal name for this condition,
1759 ;; it should be exported from SB-EXT so that people can muffle it.
1760 (define-condition sb!c:inlining-dependency-failure (simple-style-warning) ())
1761
1762 (/show0 "condition.lisp end of file")