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