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