1 ;;;; stuff originally from CMU CL's error.lisp which can or should
2 ;;;; come late (mostly related to the CONDITION class itself)
5 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (in-package "SB!KERNEL")
16 ;;;; the CONDITION class
18 (/show0 "condition.lisp 20")
20 (eval-when (:compile-toplevel :load-toplevel :execute)
22 (/show0 "condition.lisp 24")
24 (def!struct (condition-classoid (:include classoid)
25 (:constructor make-condition-classoid))
26 ;; list of CONDITION-SLOT structures for the direct slots of this
28 (slots nil :type list)
29 ;; list of CONDITION-SLOT structures for all of the effective class
30 ;; slots of this class
31 (class-slots nil :type list)
32 ;; report function or NIL
33 (report nil :type (or function null))
34 ;; list of specifications of the form
36 ;; (INITARG INITFORM THUNK)
38 ;; where THUNK, when called without arguments, returns the value for
40 (direct-default-initargs () :type list)
41 ;; class precedence list as a list of CLASS objects, with all
42 ;; non-CONDITION classes removed
44 ;; a list of all the effective instance allocation slots of this
45 ;; class that have a non-constant initform or default-initarg.
46 ;; Values for these slots must be computed in the dynamic
47 ;; environment of MAKE-CONDITION.
48 (hairy-slots nil :type list))
50 (/show0 "condition.lisp 49")
54 (!defstruct-with-alternate-metaclass condition
55 :slot-names (actual-initargs assigned-slots)
56 :boa-constructor %make-condition-object
58 :metaclass-name condition-classoid
59 :metaclass-constructor make-condition-classoid
62 (defstruct (condition-slot (:copier nil))
63 (name (missing-arg) :type symbol)
64 ;; list of all applicable initargs
65 (initargs (missing-arg) :type list)
66 ;; names of reader and writer functions
67 (readers (missing-arg) :type list)
68 (writers (missing-arg) :type list)
69 ;; true if :INITFORM was specified
70 (initform-p (missing-arg) :type (member t nil))
71 ;; If this is a function, call it with no args. Otherwise, it's the
73 (initform (missing-arg) :type t)
74 ;; allocation of this slot, or NIL until defaulted
75 (allocation nil :type (member :instance :class nil))
76 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
77 (cell nil :type (or cons null))
79 (documentation nil :type (or string null)))
81 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
82 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
83 ;;; have themselves listed in their CPLs. This behavior is inherited
84 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
85 ;;; figured out whether it's right. -- WHN 19990612
86 (eval-when (:compile-toplevel :load-toplevel :execute)
87 (/show0 "condition.lisp 103")
88 (let ((condition-class (locally
89 ;; KLUDGE: There's a DEFTRANSFORM
90 ;; FIND-CLASSOID for constant class names
91 ;; which creates fast but
92 ;; non-cold-loadable, non-compact code. In
93 ;; this context, we'd rather have compact,
94 ;; cold-loadable code. -- WHN 19990928
95 (declare (notinline find-classoid))
96 (find-classoid 'condition))))
97 (setf (condition-classoid-cpl condition-class)
98 (list condition-class)))
99 (/show0 "condition.lisp 103"))
101 (setf (condition-classoid-report (locally
102 ;; KLUDGE: There's a DEFTRANSFORM
103 ;; FIND-CLASSOID for constant class
104 ;; names which creates fast but
105 ;; non-cold-loadable, non-compact
106 ;; code. In this context, we'd
107 ;; rather have compact,
108 ;; cold-loadable code. -- WHN
110 (declare (notinline find-classoid))
111 (find-classoid 'condition)))
112 (lambda (cond stream)
113 (format stream "Condition ~S was signalled." (type-of cond))))
115 (eval-when (:compile-toplevel :load-toplevel :execute)
117 (defun find-condition-layout (name parent-types)
118 (let* ((cpl (remove-duplicates
122 (condition-classoid-cpl
125 (cond-layout (info :type :compiler-layout 'condition))
126 (olayout (info :type :compiler-layout name))
127 ;; FIXME: Does this do the right thing in case of multiple
128 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
129 ;; it obvious what ANSI intends to be done in the case of
130 ;; multiple inheritance, so it's not actually clear what the
133 (order-layout-inherits (concatenate 'simple-vector
134 (layout-inherits cond-layout)
135 (mapcar #'classoid-layout cpl)))))
137 (not (mismatch (layout-inherits olayout) new-inherits)))
139 (make-layout :classoid (make-undefined-classoid name)
140 :inherits new-inherits
142 :length (layout-length cond-layout)))))
146 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
147 ;;; Condition reporting is mediated through the PRINT-OBJECT method
148 ;;; for the condition type in question, with *PRINT-ESCAPE* always
149 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
150 ;;; a condition type C is equivalent to:
151 ;;; (defmethod print-object ((x c) stream)
152 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
153 ;;; The current code doesn't seem to quite match that.
154 (def!method print-object ((x condition) stream)
156 (if (and (typep x 'simple-condition) (slot-value x 'format-control))
157 (print-unreadable-object (x stream :type t :identity t)
158 (write (simple-condition-format-control x)
161 (print-unreadable-object (x stream :type t :identity t)))
162 ;; KLUDGE: A comment from CMU CL here said
163 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
164 ;; superclasses in define-condition call!
165 (dolist (class (condition-classoid-cpl (classoid-of x))
166 (error "no REPORT? shouldn't happen!"))
167 (let ((report (condition-classoid-report class)))
169 (return (funcall report x stream)))))))
171 ;;;; slots of CONDITION objects
173 (defvar *empty-condition-slot* '(empty))
175 (defun find-slot-default (class slot)
176 (let ((initargs (condition-slot-initargs slot))
177 (cpl (condition-classoid-cpl class)))
178 ;; When CLASS or a superclass has a default initarg for SLOT, use
181 (let ((direct-default-initargs
182 (condition-classoid-direct-default-initargs class)))
183 (dolist (initarg initargs)
184 (let ((initfunction (third (assoc initarg direct-default-initargs))))
186 (return-from find-slot-default (funcall initfunction)))))))
188 ;; Otherwise use the initform of SLOT, if there is one.
189 (if (condition-slot-initform-p slot)
190 (let ((initform (condition-slot-initform slot)))
191 (if (functionp initform)
194 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
196 (defun find-condition-class-slot (condition-class slot-name)
198 (condition-classoid-cpl condition-class)
199 (error "There is no slot named ~S in ~S."
200 slot-name condition-class))
201 (dolist (slot (condition-classoid-slots sclass))
202 (when (eq (condition-slot-name slot) slot-name)
203 (return-from find-condition-class-slot slot)))))
205 (defun condition-writer-function (condition new-value name)
206 (dolist (cslot (condition-classoid-class-slots
207 (layout-classoid (%instance-layout condition)))
208 (setf (getf (condition-assigned-slots condition) name)
210 (when (eq (condition-slot-name cslot) name)
211 (return (setf (car (condition-slot-cell cslot)) new-value)))))
213 (defun condition-reader-function (condition name)
214 (let ((class (layout-classoid (%instance-layout condition))))
215 (dolist (cslot (condition-classoid-class-slots class))
216 (when (eq (condition-slot-name cslot) name)
217 (return-from condition-reader-function
218 (car (condition-slot-cell cslot)))))
219 (let ((val (getf (condition-assigned-slots condition) name
220 *empty-condition-slot*)))
221 (if (eq val *empty-condition-slot*)
222 (let ((actual-initargs (condition-actual-initargs condition))
223 (slot (find-condition-class-slot class name)))
225 (error "missing slot ~S of ~S" name condition))
226 (do ((initargs actual-initargs (cddr initargs)))
228 (setf (getf (condition-assigned-slots condition) name)
229 (find-slot-default class slot)))
230 (when (member (car initargs) (condition-slot-initargs slot))
231 (return-from condition-reader-function
232 (setf (getf (condition-assigned-slots condition)
239 (defun allocate-condition (type &rest initargs)
240 (let* ((type (if (symbolp type)
241 (find-classoid type nil)
243 (class (typecase type
244 (condition-classoid type)
246 (return-from allocate-condition
247 (apply #'allocate-condition (class-name type) initargs)))
249 (error 'simple-type-error
251 :expected-type 'condition-class
252 :format-control "~S is not a condition class."
253 :format-arguments (list type)))
255 (error 'simple-type-error
257 :expected-type 'condition-class
259 "~s does not designate a condition class."
260 :format-arguments (list type)))))
261 (condition (%make-condition-object initargs '())))
262 (setf (%instance-layout condition) (classoid-layout class))
263 (values condition class)))
265 (defun make-condition (type &rest initargs)
267 "Make an instance of a condition object using the specified initargs."
268 ;; Note: ANSI specifies no exceptional situations in this function.
269 ;; signalling simple-type-error would not be wrong.
270 (multiple-value-bind (condition class)
271 (apply #'allocate-condition type initargs)
273 ;; Set any class slots with initargs present in this call.
274 (dolist (cslot (condition-classoid-class-slots class))
275 (dolist (initarg (condition-slot-initargs cslot))
276 (let ((val (getf initargs initarg *empty-condition-slot*)))
277 (unless (eq val *empty-condition-slot*)
278 (setf (car (condition-slot-cell cslot)) val)))))
280 ;; Default any slots with non-constant defaults now.
281 (dolist (hslot (condition-classoid-hairy-slots class))
282 (when (dolist (initarg (condition-slot-initargs hslot) t)
283 (unless (eq (getf initargs initarg *empty-condition-slot*)
284 *empty-condition-slot*)
286 (setf (getf (condition-assigned-slots condition)
287 (condition-slot-name hslot))
288 (find-slot-default class hslot))))
293 ;;;; DEFINE-CONDITION
295 (eval-when (:compile-toplevel :load-toplevel :execute)
296 (defun %compiler-define-condition (name direct-supers layout
297 all-readers all-writers)
298 (with-single-package-locked-error
299 (:symbol name "defining ~A as a condition")
300 (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
301 (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
302 (multiple-value-bind (class old-layout)
303 (insured-find-classoid name
304 #'condition-classoid-p
305 #'make-condition-classoid)
306 (setf (layout-classoid layout) class)
307 (setf (classoid-direct-superclasses class)
308 (mapcar #'find-classoid direct-supers))
309 (cond ((not old-layout)
310 (register-layout layout))
311 ((not *type-system-initialized*)
312 (setf (layout-classoid old-layout) class)
313 (setq layout old-layout)
314 (unless (eq (classoid-layout class) layout)
315 (register-layout layout)))
316 ((redefine-layout-warning "current"
319 (layout-length layout)
320 (layout-inherits layout)
321 (layout-depthoid layout)
322 (layout-n-untagged-slots layout))
323 (register-layout layout :invalidate t))
324 ((not (classoid-layout class))
325 (register-layout layout)))
327 (setf (layout-info layout)
329 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
330 ;; names which creates fast but non-cold-loadable, non-compact
331 ;; code. In this context, we'd rather have compact, cold-loadable
332 ;; code. -- WHN 19990928
333 (declare (notinline find-classoid))
334 (layout-info (classoid-layout (find-classoid 'condition)))))
336 (setf (find-classoid name) class)
338 ;; Initialize CPL slot.
339 (setf (condition-classoid-cpl class)
340 (remove-if-not #'condition-classoid-p
341 (std-compute-class-precedence-list class)))))
345 ;;; Compute the effective slots of CLASS, copying inherited slots and
346 ;;; destructively modifying direct slots.
348 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
349 ;;; direct slots. Presumably it follows from the semantics of
350 ;;; inheritance and redefinition of conditions, but finding the cite
351 ;;; and documenting it here would be good. (Or, if this is not in fact
352 ;;; ANSI-compliant, fixing it would also be good.:-)
353 (defun compute-effective-slots (class)
354 (collect ((res (copy-list (condition-classoid-slots class))))
355 (dolist (sclass (cdr (condition-classoid-cpl class)))
356 (dolist (sslot (condition-classoid-slots sclass))
357 (let ((found (find (condition-slot-name sslot) (res)
358 :key #'condition-slot-name)))
360 (setf (condition-slot-initargs found)
361 (union (condition-slot-initargs found)
362 (condition-slot-initargs sslot)))
363 (unless (condition-slot-initform-p found)
364 (setf (condition-slot-initform-p found)
365 (condition-slot-initform-p sslot))
366 (setf (condition-slot-initform found)
367 (condition-slot-initform sslot)))
368 (unless (condition-slot-allocation found)
369 (setf (condition-slot-allocation found)
370 (condition-slot-allocation sslot))))
372 (res (copy-structure sslot)))))))
375 ;;; Early definitions of slot accessor creators.
377 ;;; Slot accessors must be generic functions, but ANSI does not seem
378 ;;; to specify any of them, and we cannot support it before end of
379 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
380 ;;; GFs only at the end of building.
381 (declaim (notinline install-condition-slot-reader
382 install-condition-slot-writer))
383 (defun install-condition-slot-reader (name condition slot-name)
384 (declare (ignore condition))
385 (setf (fdefinition name)
387 (condition-reader-function condition slot-name))))
388 (defun install-condition-slot-writer (name condition slot-name)
389 (declare (ignore condition))
390 (setf (fdefinition name)
391 (lambda (new-value condition)
392 (condition-writer-function condition new-value slot-name))))
394 (defvar *define-condition-hooks* nil)
396 (defun %set-condition-report (name report)
397 (setf (condition-classoid-report (find-classoid name))
400 (defun %define-condition (name parent-types layout slots documentation
401 direct-default-initargs all-readers all-writers
403 (with-single-package-locked-error
404 (:symbol name "defining ~A as a condition")
405 (%compiler-define-condition name parent-types layout all-readers all-writers)
406 (sb!c:with-source-location (source-location)
407 (setf (layout-source-location layout)
409 (let ((class (find-classoid name)))
410 (setf (condition-classoid-slots class) slots
411 (condition-classoid-direct-default-initargs class) direct-default-initargs
412 (fdocumentation name 'type) documentation)
416 ;; Set up reader and writer functions.
417 (let ((slot-name (condition-slot-name slot)))
418 (dolist (reader (condition-slot-readers slot))
419 (install-condition-slot-reader reader name slot-name))
420 (dolist (writer (condition-slot-writers slot))
421 (install-condition-slot-writer writer name slot-name))))
423 ;; Compute effective slots and set up the class and hairy slots
424 ;; (subsets of the effective slots.)
425 (setf (condition-classoid-hairy-slots class) '())
426 (let ((eslots (compute-effective-slots class))
429 (mapcar #'condition-classoid-direct-default-initargs
430 (condition-classoid-cpl class)))))
431 (dolist (slot eslots)
432 (ecase (condition-slot-allocation slot)
434 (unless (condition-slot-cell slot)
435 (setf (condition-slot-cell slot)
436 (list (if (condition-slot-initform-p slot)
437 (let ((initform (condition-slot-initform slot)))
438 (if (functionp initform)
441 *empty-condition-slot*))))
442 (push slot (condition-classoid-class-slots class)))
444 (setf (condition-slot-allocation slot) :instance)
445 (when (or (functionp (condition-slot-initform slot))
446 (dolist (initarg (condition-slot-initargs slot) nil)
447 (when (functionp (third (assoc initarg e-def-initargs)))
449 (push slot (condition-classoid-hairy-slots class)))))))
450 (when (boundp '*define-condition-hooks*)
451 (dolist (fun *define-condition-hooks*)
452 (funcall fun class))))
455 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
458 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
459 Define NAME as a condition type. This new type inherits slots and its
460 report function from the specified PARENT-TYPEs. A slot spec is a list of:
461 (slot-name :reader <rname> :initarg <iname> {Option Value}*
463 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
464 and :TYPE and the overall options :DEFAULT-INITARGS and
465 [type] :DOCUMENTATION are also allowed.
467 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
468 a string or a two-argument lambda or function name. If a function, the
469 function is called with the condition and stream to report the condition.
470 If a string, the string is printed.
472 Condition types are classes, but (as allowed by ANSI and not as described in
473 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
474 SLOT-VALUE may not be used on condition objects."
475 (let* ((parent-types (or parent-types '(condition)))
476 (layout (find-condition-layout name parent-types))
479 (direct-default-initargs ()))
481 (all-readers nil append)
482 (all-writers nil append))
483 (dolist (spec slot-specs)
484 (when (keywordp spec)
485 (warn "Keyword slot name indicates probable syntax error:~% ~S"
487 (let* ((spec (if (consp spec) spec (list spec)))
488 (slot-name (first spec))
489 (allocation :instance)
496 (do ((options (rest spec) (cddr options)))
498 (unless (and (consp options) (consp (cdr options)))
499 (error "malformed condition slot spec:~% ~S." spec))
500 (let ((arg (second options)))
501 (case (first options)
502 (:reader (readers arg))
503 (:writer (writers arg))
506 (writers `(setf ,arg)))
509 (error "more than one :INITFORM in ~S" spec))
512 (:initarg (initargs arg))
514 (setq allocation arg))
517 (error "more than one :DOCUMENTATION in ~S" spec))
518 (unless (stringp arg)
519 (error "slot :DOCUMENTATION argument is not a string: ~S"
521 (setq documentation arg))
524 (error "unknown slot option:~% ~S" (first options))))))
526 (all-readers (readers))
527 (all-writers (writers))
528 (slots `(make-condition-slot
530 :initargs ',(initargs)
533 :initform-p ',initform-p
534 :documentation ',documentation
535 :initform ,(when initform-p
536 `#'(lambda () ,initform))
537 :allocation ',allocation)))))
539 (dolist (option options)
540 (unless (consp option)
541 (error "bad option:~% ~S" option))
543 (:documentation (setq documentation (second option)))
545 (let ((arg (second option)))
548 `#'(lambda (condition stream)
549 (declare (ignore condition))
550 (write-string ,arg stream))
551 `#'(lambda (condition stream)
552 (funcall #',arg condition stream))))))
554 (doplist (initarg initform) (rest option)
555 (push ``(,',initarg ,',initform ,#'(lambda () ,initform))
556 direct-default-initargs)))
558 (error "unknown option: ~S" (first option)))))
561 (eval-when (:compile-toplevel)
562 (%compiler-define-condition ',name ',parent-types ',layout
563 ',(all-readers) ',(all-writers)))
564 (eval-when (:load-toplevel :execute)
565 (%define-condition ',name
570 (list ,@direct-default-initargs)
573 (sb!c:source-location))
574 ;; This needs to be after %DEFINE-CONDITION in case :REPORT
575 ;; is a lambda referring to condition slot accessors:
576 ;; they're not proclaimed as functions before it has run if
577 ;; we're under EVAL or loaded as source.
578 (%set-condition-report ',name ,report)
581 ;;;; various CONDITIONs specified by ANSI
583 (define-condition serious-condition (condition) ())
585 (define-condition error (serious-condition) ())
587 (define-condition warning (condition) ())
588 (define-condition style-warning (warning) ())
590 (defun simple-condition-printer (condition stream)
591 (let ((control (simple-condition-format-control condition)))
593 (apply #'format stream
595 (simple-condition-format-arguments condition))
596 (error "No format-control for ~S" condition))))
598 (define-condition simple-condition ()
599 ((format-control :reader simple-condition-format-control
600 :initarg :format-control
602 :type format-control)
603 (format-arguments :reader simple-condition-format-arguments
604 :initarg :format-arguments
607 (:report simple-condition-printer))
609 (define-condition simple-warning (simple-condition warning) ())
611 (define-condition simple-error (simple-condition error) ())
613 (define-condition storage-condition (serious-condition) ())
615 (define-condition type-error (error)
616 ((datum :reader type-error-datum :initarg :datum)
617 (expected-type :reader type-error-expected-type :initarg :expected-type))
619 (lambda (condition stream)
621 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
622 (type-error-datum condition)
623 (type-error-expected-type condition)))))
625 (def!method print-object ((condition type-error) stream)
626 (if (and *print-escape*
627 (slot-boundp condition 'expected-type)
628 (slot-boundp condition 'datum))
629 (flet ((maybe-string (thing)
631 (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
632 (let ((type (maybe-string (type-error-expected-type condition)))
633 (datum (maybe-string (type-error-datum condition))))
635 (print-unreadable-object (condition stream :type t)
636 (format stream "~@<expected-type: ~A ~_datum: ~A~:@>" type datum))
637 (call-next-method))))
640 ;;; not specified by ANSI, but too useful not to have around.
641 (define-condition simple-style-warning (simple-condition style-warning) ())
642 (define-condition simple-type-error (simple-condition type-error) ())
644 ;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR...
645 (declaim (ftype (sfunction (t t t &rest t) nil) bad-type))
646 (defun bad-type (datum type control &rest arguments)
647 (error 'simple-type-error
650 :format-control control
651 :format-arguments arguments))
653 (define-condition program-error (error) ())
654 (define-condition parse-error (error) ())
655 (define-condition control-error (error) ())
656 (define-condition stream-error (error)
657 ((stream :reader stream-error-stream :initarg :stream)))
659 (define-condition end-of-file (stream-error) ()
661 (lambda (condition stream)
664 (stream-error-stream condition)))))
666 (define-condition closed-stream-error (stream-error) ()
668 (lambda (condition stream)
669 (format stream "~S is closed" (stream-error-stream condition)))))
671 (define-condition file-error (error)
672 ((pathname :reader file-error-pathname :initarg :pathname))
674 (lambda (condition stream)
675 (format stream "error on file ~S" (file-error-pathname condition)))))
677 (define-condition package-error (error)
678 ((package :reader package-error-package :initarg :package)))
680 (define-condition cell-error (error)
681 ((name :reader cell-error-name :initarg :name)))
683 (def!method print-object ((condition cell-error) stream)
684 (if (and *print-escape* (slot-boundp condition 'name))
685 (print-unreadable-object (condition stream :type t :identity t)
686 (princ (cell-error-name condition) stream))
689 (define-condition unbound-variable (cell-error) ()
691 (lambda (condition stream)
693 "The variable ~S is unbound."
694 (cell-error-name condition)))))
696 (define-condition undefined-function (cell-error) ()
698 (lambda (condition stream)
699 (let ((*package* (find-package :keyword)))
701 "The function ~S is undefined."
702 (cell-error-name condition))))))
704 (define-condition special-form-function (undefined-function) ()
706 (lambda (condition stream)
708 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
709 (cell-error-name condition)))))
711 (define-condition arithmetic-error (error)
712 ((operation :reader arithmetic-error-operation
715 (operands :reader arithmetic-error-operands
717 (:report (lambda (condition stream)
719 "arithmetic error ~S signalled"
721 (when (arithmetic-error-operation condition)
723 "~%Operation was ~S, operands ~S."
724 (arithmetic-error-operation condition)
725 (arithmetic-error-operands condition))))))
727 (define-condition division-by-zero (arithmetic-error) ())
728 (define-condition floating-point-overflow (arithmetic-error) ())
729 (define-condition floating-point-underflow (arithmetic-error) ())
730 (define-condition floating-point-inexact (arithmetic-error) ())
731 (define-condition floating-point-invalid-operation (arithmetic-error) ())
733 (define-condition print-not-readable (error)
734 ((object :reader print-not-readable-object :initarg :object))
736 (lambda (condition stream)
737 (let ((obj (print-not-readable-object condition))
739 (format stream "~S cannot be printed readably." obj)))))
741 (define-condition reader-error (parse-error stream-error) ()
742 (:report (lambda (condition stream)
743 (%report-reader-error condition stream))))
745 ;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
746 ;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
747 ;;; within SBCL itself)
749 ;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
750 ;;; the letter of the ANSI spec: this is not a condition signalled by
751 ;;; SIGNAL when a format-control is supplied by the function's first
752 ;;; argument. It seems to me (WHN) to be basically in the spirit of
753 ;;; the spec, but if not, it'd be straightforward to do our own
754 ;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
755 ;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
756 ;;; place of CL:SIMPLE-CONDITION here.)
757 (define-condition simple-reader-error (reader-error simple-condition)
759 (:report (lambda (condition stream)
760 (%report-reader-error condition stream :simple t))))
762 ;;; base REPORTing of a READER-ERROR
764 ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
765 ;;; and FORMAT-ARGS slots.
766 (defun %report-reader-error (condition stream &key simple position)
767 (let ((error-stream (stream-error-stream condition)))
768 (pprint-logical-block (stream nil)
770 (apply #'format stream
771 (simple-condition-format-control condition)
772 (simple-condition-format-arguments condition))
773 (prin1 (class-name (class-of condition)) stream))
774 (format stream "~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S"
775 (stream-error-position-info error-stream position)
778 ;;;; special SBCL extension conditions
780 ;;; an error apparently caused by a bug in SBCL itself
782 ;;; Note that we don't make any serious effort to use this condition
783 ;;; for *all* errors in SBCL itself. E.g. type errors and array
784 ;;; indexing errors can occur in functions called from SBCL code, and
785 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
786 ;;; because the signalling code has no good way to know that the
787 ;;; underlying problem is a bug in SBCL. But in the fairly common case
788 ;;; that the signalling code does know that it's found a bug in SBCL,
789 ;;; this condition is appropriate, reusing boilerplate and helping
790 ;;; users to recognize it as an SBCL bug.
791 (define-condition bug (simple-error)
794 (lambda (condition stream)
797 (simple-condition-format-control condition)
798 (simple-condition-format-arguments condition)
799 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
800 SBCL might have been corrupted by bad user code, e.g. by an ~
801 undefined Lisp operation like ~S, or by stray pointers from ~
802 alien code or from unsafe Lisp code; or there might be a bug ~
803 in the OS or hardware that SBCL is running on.) If it seems to ~
804 be a bug in SBCL itself, the maintainers would like to know ~
805 about it. Bug reports are welcome on the SBCL ~
806 mailing lists, which you can find at ~
807 <http://sbcl.sourceforge.net/>.~:@>"
808 '((fmakunbound 'compile))))))
810 (define-condition simple-storage-condition (storage-condition simple-condition)
813 ;;; a condition for use in stubs for operations which aren't supported
814 ;;; on some platforms
816 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
817 ;;; #-(or freebsd linux)
818 ;;; (defun load-foreign (&rest rest)
819 ;;; (error 'unsupported-operator :name 'load-foreign))
820 ;;; #+(or freebsd linux)
821 ;;; (defun load-foreign ... actual definition ...)
822 ;;; By signalling a standard condition in this case, we make it
823 ;;; possible for test code to distinguish between (1) intentionally
824 ;;; unimplemented and (2) unintentionally just screwed up somehow.
825 ;;; (Before this condition was defined, test code tried to deal with
826 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
827 ;;; sbcl-0.7.0, a package screwup left the definition of
828 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
829 ;;; architectures where it was supposed to be supported, and the
830 ;;; regression tests cheerfully passed because they assumed that
831 ;;; unFBOUNDPness meant they were running on an system which didn't
832 ;;; support the extension.)
833 (define-condition unsupported-operator (simple-error) ())
835 ;;; (:ansi-cl :function remove)
836 ;;; (:ansi-cl :section (a b c))
837 ;;; (:ansi-cl :glossary "similar")
839 ;;; (:sbcl :node "...")
840 ;;; (:sbcl :variable *ed-functions*)
842 ;;; FIXME: this is not the right place for this.
843 (defun print-reference (reference stream)
844 (ecase (car reference)
846 (format stream "AMOP")
848 (destructuring-bind (type data) (cdr reference)
850 (:readers "Readers for ~:(~A~) Metaobjects"
851 (substitute #\ #\- (symbol-name data)))
853 (format stream "Initialization of ~:(~A~) Metaobjects"
854 (substitute #\ #\- (symbol-name data))))
855 (:generic-function (format stream "Generic Function ~S" data))
856 (:function (format stream "Function ~S" data))
857 (:section (format stream "Section ~{~D~^.~}" data)))))
859 (format stream "The ANSI Standard")
861 (destructuring-bind (type data) (cdr reference)
863 (:function (format stream "Function ~S" data))
864 (:special-operator (format stream "Special Operator ~S" data))
865 (:macro (format stream "Macro ~S" data))
866 (:section (format stream "Section ~{~D~^.~}" data))
867 (:glossary (format stream "Glossary entry for ~S" data))
868 (:issue (format stream "writeup for Issue ~A" data)))))
870 (format stream "The SBCL Manual")
872 (destructuring-bind (type data) (cdr reference)
874 (:node (format stream "Node ~S" data))
875 (:variable (format stream "Variable ~S" data))
876 (:function (format stream "Function ~S" data)))))
877 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
879 (define-condition reference-condition ()
880 ((references :initarg :references :reader reference-condition-references)))
881 (defvar *print-condition-references* t)
882 (def!method print-object :around ((o reference-condition) s)
884 (unless (or *print-escape* *print-readably*)
885 (when (and *print-condition-references*
886 (reference-condition-references o))
887 (format s "~&See also:~%")
888 (pprint-logical-block (s nil :per-line-prefix " ")
889 (do* ((rs (reference-condition-references o) (cdr rs))
890 (r (car rs) (car rs)))
892 (print-reference r s)
893 (unless (null (cdr rs))
896 (define-condition simple-reference-error (reference-condition simple-error)
899 (define-condition simple-reference-warning (reference-condition simple-warning)
902 (define-condition arguments-out-of-domain-error
903 (arithmetic-error reference-condition)
906 (define-condition duplicate-definition (reference-condition warning)
907 ((name :initarg :name :reader duplicate-definition-name))
908 (:report (lambda (c s)
909 (format s "~@<Duplicate definition for ~S found in ~
911 (duplicate-definition-name c))))
912 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
914 (define-condition constant-modified (reference-condition warning)
915 ((fun-name :initarg :fun-name :reader constant-modified-fun-name))
916 (:report (lambda (c s)
917 (format s "~@<Destructive function ~S called on ~
919 (constant-modified-fun-name c))))
920 (:default-initargs :references (list '(:ansi-cl :special-operator quote)
921 '(:ansi-cl :section (3 2 2 3)))))
923 (define-condition package-at-variance (reference-condition simple-warning)
925 (:default-initargs :references (list '(:ansi-cl :macro defpackage)
926 '(:sbcl :variable *on-package-variance*))))
928 (define-condition package-at-variance-error (reference-condition simple-condition
931 (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
933 (define-condition defconstant-uneql (reference-condition error)
934 ((name :initarg :name :reader defconstant-uneql-name)
935 (old-value :initarg :old-value :reader defconstant-uneql-old-value)
936 (new-value :initarg :new-value :reader defconstant-uneql-new-value))
938 (lambda (condition stream)
940 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
941 (defconstant-uneql-name condition)
942 (defconstant-uneql-old-value condition)
943 (defconstant-uneql-new-value condition))))
944 (:default-initargs :references (list '(:ansi-cl :macro defconstant)
945 '(:sbcl :node "Idiosyncrasies"))))
947 (define-condition array-initial-element-mismatch
948 (reference-condition simple-warning)
952 '(:ansi-cl :function make-array)
953 '(:ansi-cl :function sb!xc:upgraded-array-element-type))))
955 (define-condition type-warning (reference-condition simple-warning)
957 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
958 (define-condition type-style-warning (reference-condition simple-style-warning)
960 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
962 (define-condition local-argument-mismatch (reference-condition simple-warning)
964 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
966 (define-condition format-args-mismatch (reference-condition)
968 (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2)))))
970 (define-condition format-too-few-args-warning
971 (format-args-mismatch simple-warning)
973 (define-condition format-too-many-args-warning
974 (format-args-mismatch simple-style-warning)
977 (define-condition implicit-generic-function-warning (style-warning)
978 ((name :initarg :name :reader implicit-generic-function-name))
980 (lambda (condition stream)
981 (format stream "~@<Implicitly creating new generic function ~
982 ~/sb-impl::print-symbol-with-prefix/.~:@>"
983 (implicit-generic-function-name condition)))))
985 (define-condition extension-failure (reference-condition simple-error)
988 (define-condition structure-initarg-not-keyword
989 (reference-condition simple-style-warning)
991 (:default-initargs :references (list '(:ansi-cl :section (2 4 8 13)))))
996 (define-condition package-lock-violation (package-error
999 ((current-package :initform *package*
1000 :reader package-lock-violation-in-package))
1002 (lambda (condition stream)
1003 (let ((control (simple-condition-format-control condition))
1004 (error-package (package-name (package-error-package condition)))
1005 (current-package (package-name (package-lock-violation-in-package condition))))
1007 (apply #'format stream
1008 (format nil "~~@<Lock on package ~A violated when ~A while in package ~A.~~:@>"
1012 (simple-condition-format-arguments condition))
1013 (format stream "~@<Lock on package ~A violated while in package ~A.~:@>"
1015 current-package)))))
1016 ;; no :default-initargs -- reference-stuff provided by the
1017 ;; signalling form in target-package.lisp
1020 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
1021 when a package-lock is violated."))
1023 (define-condition package-locked-error (package-lock-violation) ()
1026 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1027 signalled when an operation on a package violates a package lock."))
1029 (define-condition symbol-package-locked-error (package-lock-violation)
1030 ((symbol :initarg :symbol :reader package-locked-error-symbol))
1033 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1034 signalled when an operation on a symbol violates a package lock. The
1035 symbol that caused the violation is accessed by the function
1036 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
1040 (define-condition undefined-alien-error (cell-error) ()
1042 (lambda (condition stream)
1043 (if (slot-boundp condition 'name)
1044 (format stream "Undefined alien: ~S" (cell-error-name condition))
1045 (format stream "Undefined alien symbol.")))))
1047 (define-condition undefined-alien-variable-error (undefined-alien-error) ()
1049 (lambda (condition stream)
1050 (declare (ignore condition))
1051 (format stream "Attempt to access an undefined alien variable."))))
1053 (define-condition undefined-alien-function-error (undefined-alien-error) ()
1055 (lambda (condition stream)
1056 (declare (ignore condition))
1057 (format stream "Attempt to call an undefined alien function."))))
1060 ;;;; various other (not specified by ANSI) CONDITIONs
1062 ;;;; These might logically belong in other files; they're here, after
1063 ;;;; setup of CONDITION machinery, only because that makes it easier to
1064 ;;;; get cold init to work.
1066 ;;; OAOOM warning: see cross-condition.lisp
1067 (define-condition encapsulated-condition (condition)
1068 ((condition :initarg :condition :reader encapsulated-condition)))
1070 ;;; KLUDGE: a condition for floating point errors when we can't or
1071 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
1072 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
1073 ;;; know how but the old code was broken by the conversion to POSIX
1074 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
1076 ;;; FIXME: Perhaps this should also be a base class for all
1077 ;;; floating point exceptions?
1078 (define-condition floating-point-exception (arithmetic-error)
1079 ((flags :initarg :traps
1081 :reader floating-point-exception-traps))
1082 (:report (lambda (condition stream)
1084 "An arithmetic error ~S was signalled.~%"
1085 (type-of condition))
1086 (let ((traps (floating-point-exception-traps condition)))
1089 "Trapping conditions are: ~%~{ ~S~^~}~%"
1092 "No traps are enabled? How can this be?"
1095 (define-condition invalid-array-index-error (type-error)
1096 ((array :initarg :array :reader invalid-array-index-error-array)
1097 (axis :initarg :axis :reader invalid-array-index-error-axis))
1099 (lambda (condition stream)
1100 (let ((array (invalid-array-index-error-array condition)))
1101 (format stream "Index ~W out of bounds for ~@[axis ~W of ~]~S, ~
1102 should be nonnegative and <~W."
1103 (type-error-datum condition)
1104 (when (> (array-rank array) 1)
1105 (invalid-array-index-error-axis condition))
1107 ;; Extract the bound from (INTEGER 0 (BOUND))
1108 (caaddr (type-error-expected-type condition)))))))
1110 (define-condition invalid-array-error (reference-condition type-error) ()
1112 (lambda (condition stream)
1113 (let ((*print-array* nil))
1115 "~@<Displaced array originally of type ~S has been invalidated ~
1116 due its displaced-to array ~S having become too small to hold ~
1117 it: the displaced array's dimensions have all been set to zero ~
1118 to trap accesses to it.~:@>"
1119 (type-error-expected-type condition)
1120 (array-displacement (type-error-datum condition))))))
1123 (list '(:ansi-cl :function adjust-array))))
1125 (define-condition index-too-large-error (type-error)
1128 (lambda (condition stream)
1130 "The index ~S is too large."
1131 (type-error-datum condition)))))
1133 (define-condition bounding-indices-bad-error (reference-condition type-error)
1134 ((object :reader bounding-indices-bad-object :initarg :object))
1136 (lambda (condition stream)
1137 (let* ((datum (type-error-datum condition))
1140 (object (bounding-indices-bad-object condition)))
1144 "The bounding indices ~S and ~S are bad ~
1145 for a sequence of length ~S."
1146 start end (length object)))
1148 ;; from WITH-ARRAY-DATA
1150 "The START and END parameters ~S and ~S are ~
1151 bad for an array of total size ~S."
1152 start end (array-total-size object)))))))
1155 (list '(:ansi-cl :glossary "bounding index designator")
1156 '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1158 (define-condition nil-array-accessed-error (reference-condition type-error)
1160 (:report (lambda (condition stream)
1161 (declare (ignore condition))
1163 "An attempt to access an array of element-type ~
1164 NIL was made. Congratulations!")))
1166 :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type)
1167 '(:ansi-cl :section (15 1 2 1))
1168 '(:ansi-cl :section (15 1 2 2)))))
1170 (define-condition namestring-parse-error (parse-error)
1171 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
1172 (args :reader namestring-parse-error-args :initarg :args :initform nil)
1173 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
1174 (offset :reader namestring-parse-error-offset :initarg :offset))
1176 (lambda (condition stream)
1178 "parse error in namestring: ~?~% ~A~% ~V@T^"
1179 (namestring-parse-error-complaint condition)
1180 (namestring-parse-error-args condition)
1181 (namestring-parse-error-namestring condition)
1182 (namestring-parse-error-offset condition)))))
1184 (define-condition simple-package-error (simple-condition package-error) ())
1186 (define-condition simple-reader-package-error (simple-reader-error package-error) ())
1188 (define-condition reader-eof-error (end-of-file)
1189 ((context :reader reader-eof-error-context :initarg :context))
1191 (lambda (condition stream)
1193 "unexpected end of file on ~S ~A"
1194 (stream-error-stream condition)
1195 (reader-eof-error-context condition)))))
1197 (define-condition reader-impossible-number-error (simple-reader-error)
1198 ((error :reader reader-impossible-number-error-error :initarg :error))
1200 (lambda (condition stream)
1201 (let ((error-stream (stream-error-stream condition)))
1203 "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1204 (file-position-or-nil-for-error error-stream) error-stream
1205 (simple-condition-format-control condition)
1206 (simple-condition-format-arguments condition)
1207 (reader-impossible-number-error-error condition))))))
1209 (define-condition standard-readtable-modified-error (reference-condition error)
1210 ((operation :initarg :operation :reader standard-readtable-modified-operation))
1211 (:report (lambda (condition stream)
1212 (format stream "~S would modify the standard readtable."
1213 (standard-readtable-modified-operation condition))))
1214 (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
1215 (:ansi-cl :glossary "standard readtable"))))
1217 (define-condition standard-pprint-dispatch-table-modified-error
1218 (reference-condition error)
1219 ((operation :initarg :operation
1220 :reader standard-pprint-dispatch-table-modified-operation))
1221 (:report (lambda (condition stream)
1222 (format stream "~S would modify the standard pprint dispatch table."
1223 (standard-pprint-dispatch-table-modified-operation
1226 :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
1228 (define-condition timeout (serious-condition)
1229 ((seconds :initarg :seconds :initform nil :reader timeout-seconds))
1230 (:report (lambda (condition stream)
1231 (format stream "Timeout occurred~@[ after ~A seconds~]."
1232 (timeout-seconds condition)))))
1234 (define-condition io-timeout (stream-error timeout)
1235 ((direction :reader io-timeout-direction :initarg :direction))
1237 (lambda (condition stream)
1238 (declare (type stream stream))
1240 "I/O timeout while doing ~(~A~) on ~S."
1241 (io-timeout-direction condition)
1242 (stream-error-stream condition)))))
1244 (define-condition deadline-timeout (timeout) ()
1245 (:report (lambda (condition stream)
1246 (format stream "A deadline was reached after ~A seconds."
1247 (timeout-seconds condition)))))
1249 (define-condition declaration-type-conflict-error (reference-condition
1253 :format-control "symbol ~S cannot be both the name of a type and the name of a declaration"
1254 :references (list '(:ansi-cl :section (3 8 21)))))
1256 ;;; Single stepping conditions
1258 (define-condition step-condition ()
1259 ((form :initarg :form :reader step-condition-form))
1262 (:documentation "Common base class of single-stepping conditions.
1263 STEP-CONDITION-FORM holds a string representation of the form being
1267 (setf (fdocumentation 'step-condition-form 'function)
1268 "Form associated with the STEP-CONDITION.")
1270 (define-condition step-form-condition (step-condition)
1271 ((args :initarg :args :reader step-condition-args))
1273 (lambda (condition stream)
1274 (let ((*print-circle* t)
1276 (*print-readably* nil))
1278 "Evaluating call:~%~< ~@;~A~:>~%~
1279 ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%"
1280 (list (step-condition-form condition))
1281 (eq (step-condition-args condition) :unknown)
1282 (step-condition-args condition)))))
1284 (:documentation "Condition signalled by code compiled with
1285 single-stepping information when about to execute a form.
1286 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1287 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1288 holds the source-path to the original form within that file or NIL.
1289 Associated with this condition are always the restarts STEP-INTO,
1290 STEP-NEXT, and STEP-CONTINUE."))
1292 (define-condition step-result-condition (step-condition)
1293 ((result :initarg :result :reader step-condition-result)))
1296 (setf (fdocumentation 'step-condition-result 'function)
1297 "Return values associated with STEP-VALUES-CONDITION as a list,
1298 or the variable value associated with STEP-VARIABLE-CONDITION.")
1300 (define-condition step-values-condition (step-result-condition)
1303 (:documentation "Condition signalled by code compiled with
1304 single-stepping information after executing a form.
1305 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1306 the values returned by the form as a list. No associated restarts."))
1308 (define-condition step-finished-condition (step-condition)
1311 (lambda (condition stream)
1312 (declare (ignore condition))
1313 (format stream "Returning from STEP")))
1315 (:documentation "Condition signaled when STEP returns."))
1317 ;;; A knob for muffling warnings, mostly for use while loading files.
1318 (defvar *muffled-warnings* 'uninteresting-redefinition
1319 "A type that ought to specify a subtype of WARNING. Whenever a
1320 warning is signaled, if the warning if of this type and is not
1321 handled by any other handler, it will be muffled.")
1323 ;;; Various STYLE-WARNING signaled in the system.
1324 ;; For the moment, we're only getting into the details for function
1325 ;; redefinitions, but other redefinitions could be done later
1327 (define-condition redefinition-warning (style-warning)
1330 :reader redefinition-warning-name)
1332 :initarg :new-location
1333 :reader redefinition-warning-new-location)))
1335 (define-condition function-redefinition-warning (redefinition-warning)
1337 :initarg :new-function
1338 :reader function-redefinition-warning-new-function)))
1340 (define-condition redefinition-with-defun (function-redefinition-warning)
1342 (:report (lambda (warning stream)
1343 (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
1345 (redefinition-warning-name warning)))))
1347 (define-condition redefinition-with-defmacro (function-redefinition-warning)
1349 (:report (lambda (warning stream)
1350 (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
1352 (redefinition-warning-name warning)))))
1354 (define-condition redefinition-with-defgeneric (redefinition-warning)
1356 (:report (lambda (warning stream)
1357 (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
1359 (redefinition-warning-name warning)))))
1361 (define-condition redefinition-with-defmethod (redefinition-warning)
1362 ((qualifiers :initarg :qualifiers
1363 :reader redefinition-with-defmethod-qualifiers)
1364 (specializers :initarg :specializers
1365 :reader redefinition-with-defmethod-specializers)
1366 (new-location :initarg :new-location
1367 :reader redefinition-with-defmethod-new-location)
1368 (old-method :initarg :old-method
1369 :reader redefinition-with-defmethod-old-method))
1370 (:report (lambda (warning stream)
1371 (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1372 (redefinition-warning-name warning)
1373 (redefinition-with-defmethod-qualifiers warning)
1374 (redefinition-with-defmethod-specializers warning)))))
1376 ;;;; Deciding which redefinitions are "interesting".
1378 (defun function-file-namestring (function)
1380 (when (typep function 'sb!eval:interpreted-function)
1381 (return-from function-file-namestring
1382 (sb!c:definition-source-location-namestring
1383 (sb!eval:interpreted-function-source-location function))))
1384 (let* ((fun (sb!kernel:%fun-fun function))
1385 (code (sb!kernel:fun-code-header fun))
1386 (debug-info (sb!kernel:%code-debug-info code))
1387 (debug-source (when debug-info
1388 (sb!c::debug-info-source debug-info)))
1389 (namestring (when debug-source
1390 (sb!c::debug-source-namestring debug-source))))
1393 (defun interesting-function-redefinition-warning-p (warning old)
1394 (let ((new (function-redefinition-warning-new-function warning))
1395 (source-location (redefinition-warning-new-location warning)))
1397 ;; Compiled->Interpreted is interesting.
1398 (and (typep old 'compiled-function)
1399 (typep new '(not compiled-function)))
1400 ;; FIN->Regular is interesting.
1401 (and (typep old 'funcallable-instance)
1402 (typep new '(not funcallable-instance)))
1403 ;; Different file or unknown location is interesting.
1404 (let* ((old-namestring (function-file-namestring old))
1406 (or (function-file-namestring new)
1407 (when source-location
1408 (sb!c::definition-source-location-namestring source-location)))))
1409 (and (or (not old-namestring)
1410 (not new-namestring)
1411 (not (string= old-namestring new-namestring))))))))
1413 (defun uninteresting-ordinary-function-redefinition-p (warning)
1415 ;; There's garbage in various places when the first DEFUN runs in
1417 sb!kernel::*cold-init-complete-p*
1418 (typep warning 'redefinition-with-defun)
1420 (let ((name (redefinition-warning-name warning)))
1421 (not (interesting-function-redefinition-warning-p
1422 warning (or (fdefinition name) (macro-function name)))))))
1424 (defun uninteresting-macro-redefinition-p (warning)
1426 (typep warning 'redefinition-with-defmacro)
1428 (let ((name (redefinition-warning-name warning)))
1429 (not (interesting-function-redefinition-warning-p
1430 warning (or (macro-function name) (fdefinition name)))))))
1432 (defun uninteresting-generic-function-redefinition-p (warning)
1434 (typep warning 'redefinition-with-defgeneric)
1435 ;; Can't use the shared logic above, since GF's don't get a "new"
1436 ;; definition -- rather the FIN-FUNCTION is set.
1437 (let* ((name (redefinition-warning-name warning))
1438 (old (fdefinition name))
1439 (old-location (when (typep old 'generic-function)
1440 (sb!pcl::definition-source old)))
1441 (old-namestring (when old-location
1442 (sb!c:definition-source-location-namestring old-location)))
1443 (new-location (redefinition-warning-new-location warning))
1444 (new-namestring (when new-location
1445 (sb!c:definition-source-location-namestring new-location))))
1448 (string= old-namestring new-namestring)))))
1450 (defun uninteresting-method-redefinition-p (warning)
1452 (typep warning 'redefinition-with-defmethod)
1453 ;; Can't use the shared logic above, since GF's don't get a "new"
1454 ;; definition -- rather the FIN-FUNCTION is set.
1455 (let* ((old-method (redefinition-with-defmethod-old-method warning))
1456 (old-location (sb!pcl::definition-source old-method))
1457 (old-namestring (when old-location
1458 (sb!c:definition-source-location-namestring old-location)))
1459 (new-location (redefinition-warning-new-location warning))
1460 (new-namestring (when new-location
1461 (sb!c:definition-source-location-namestring new-location))))
1464 (string= new-namestring old-namestring)))))
1466 (deftype uninteresting-redefinition ()
1467 '(or (satisfies uninteresting-ordinary-function-redefinition-p)
1468 (satisfies uninteresting-macro-redefinition-p)
1469 (satisfies uninteresting-generic-function-redefinition-p)
1470 (satisfies uninteresting-method-redefinition-p)))
1472 (define-condition redefinition-with-deftransform (redefinition-warning)
1473 ((transform :initarg :transform
1474 :reader redefinition-with-deftransform-transform))
1475 (:report (lambda (warning stream)
1476 (format stream "Overwriting ~S"
1477 (redefinition-with-deftransform-transform warning)))))
1479 ;;; Various other STYLE-WARNINGS
1480 (define-condition dubious-asterisks-around-variable-name
1481 (style-warning simple-condition)
1483 (:report (lambda (warning stream)
1484 (format stream "~@?, even though the name follows~@
1485 the usual naming convention (names like *FOO*) for special variables"
1486 (simple-condition-format-control warning)
1487 (simple-condition-format-arguments warning)))))
1489 (define-condition asterisks-around-lexical-variable-name
1490 (dubious-asterisks-around-variable-name)
1493 (define-condition asterisks-around-constant-variable-name
1494 (dubious-asterisks-around-variable-name)
1497 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1498 ;; subclasses of ERROR above having to do with undefined aliens.
1499 (define-condition undefined-alien-style-warning (style-warning)
1500 ((symbol :initarg :symbol :reader undefined-alien-symbol))
1501 (:report (lambda (warning stream)
1502 (format stream "Undefined alien: ~S"
1503 (undefined-alien-symbol warning)))))
1506 (define-condition lexical-environment-too-complex (style-warning)
1507 ((form :initarg :form :reader lexical-environment-too-complex-form)
1508 (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv))
1509 (:report (lambda (warning stream)
1511 "~@<Native lexical environment too complex for ~
1512 SB-EVAL to evaluate ~S, falling back to ~
1513 SIMPLE-EVAL-IN-LEXENV. Lexenv: ~S~:@>"
1514 (lexical-environment-too-complex-form warning)
1515 (lexical-environment-too-complex-lexenv warning)))))
1517 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1518 (define-condition character-decoding-error-in-comment (style-warning)
1519 ((stream :initarg :stream :reader decoding-error-in-comment-stream)
1520 (position :initarg :position :reader decoding-error-in-comment-position))
1521 (:report (lambda (warning stream)
1523 "Character decoding error in a ~A-comment at ~
1524 position ~A reading source stream ~A, ~
1526 (decoding-error-in-comment-macro warning)
1527 (decoding-error-in-comment-position warning)
1528 (decoding-error-in-comment-stream warning)))))
1530 (define-condition character-decoding-error-in-macro-char-comment
1531 (character-decoding-error-in-comment)
1532 ((char :initform #\; :initarg :char
1533 :reader character-decoding-error-in-macro-char-comment-char)))
1535 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1536 (character-decoding-error-in-comment)
1537 ;; ANSI doesn't give a way for a reader function invoked by a
1538 ;; dispatch macro character to determine which dispatch character
1539 ;; was used, so if a user wants to signal one of these from a custom
1540 ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1541 ((disp-char :initform #\# :initarg :disp-char
1542 :reader character-decoding-error-in-macro-char-comment-disp-char)
1543 (sub-char :initarg :sub-char
1544 :reader character-decoding-error-in-macro-char-comment-sub-char)))
1546 (defun decoding-error-in-comment-macro (warning)
1548 (character-decoding-error-in-macro-char-comment
1549 (character-decoding-error-in-macro-char-comment-char warning))
1550 (character-decoding-error-in-dispatch-macro-char-comment
1553 (character-decoding-error-in-macro-char-comment-disp-char warning)
1554 (character-decoding-error-in-macro-char-comment-sub-char warning)))))
1556 (define-condition deprecated-eval-when-situations (style-warning)
1557 ((situations :initarg :situations
1558 :reader deprecated-eval-when-situations-situations))
1559 (:report (lambda (warning stream)
1560 (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}"
1561 (deprecated-eval-when-situations-situations warning)))))
1563 (define-condition proclamation-mismatch (style-warning)
1564 ((name :initarg :name :reader proclamation-mismatch-name)
1565 (old :initarg :old :reader proclamation-mismatch-old)
1566 (new :initarg :new :reader proclamation-mismatch-new)))
1568 (define-condition type-proclamation-mismatch (proclamation-mismatch)
1570 (:report (lambda (warning stream)
1572 "The new TYPE proclamation~% ~S for ~S does not ~
1573 match the old TYPE proclamation ~S"
1574 (proclamation-mismatch-new warning)
1575 (proclamation-mismatch-name warning)
1576 (proclamation-mismatch-old warning)))))
1578 (define-condition ftype-proclamation-mismatch (proclamation-mismatch)
1580 (:report (lambda (warning stream)
1582 "The new FTYPE proclamation~% ~S for ~S does not ~
1583 match the old FTYPE proclamation ~S"
1584 (proclamation-mismatch-new warning)
1585 (proclamation-mismatch-name warning)
1586 (proclamation-mismatch-old warning)))))
1588 ;;;; deprecation conditions
1590 (define-condition deprecation-condition ()
1591 ((name :initarg :name :reader deprecated-name)
1592 (replacements :initarg :replacements :reader deprecated-name-replacements)
1593 (since :initarg :since :reader deprecated-since)
1594 (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error)))
1596 (def!method print-object ((condition deprecation-condition) stream)
1597 (let ((*package* (find-package :keyword)))
1599 (print-unreadable-object (condition stream :type t)
1601 stream "~S is deprecated.~
1602 ~#[~; Use ~S instead.~; ~
1603 Use ~S or ~S instead.~:; ~
1604 Use~@{~#[~; or~] ~S~^,~} instead.~]"
1605 (deprecated-name condition)
1606 (deprecated-name-replacements condition)))
1608 stream "~@<~S has been deprecated as of SBCL ~A.~
1609 ~#[~; Use ~S instead.~; ~
1610 Use ~S or ~S instead.~:; ~
1611 Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>"
1612 (deprecated-name condition)
1613 (deprecated-since condition)
1614 (deprecated-name-replacements condition)))))
1616 (define-condition early-deprecation-warning (style-warning deprecation-condition)
1619 (def!method print-object :after ((warning early-deprecation-warning) stream)
1620 (unless *print-escape*
1621 (let ((*package* (find-package :keyword)))
1622 (format stream "~%~@<~:@_In future SBCL versions ~S will signal a full warning ~
1623 at compile-time.~:@>"
1624 (deprecated-name warning)))))
1626 (define-condition late-deprecation-warning (warning deprecation-condition)
1629 (def!method print-object :after ((warning late-deprecation-warning) stream)
1630 (unless *print-escape*
1631 (when (deprecated-name-runtime-error warning)
1632 (let ((*package* (find-package :keyword)))
1633 (format stream "~%~@<~:@_In future SBCL versions ~S will signal a runtime error.~:@>"
1634 (deprecated-name warning))))))
1636 (define-condition final-deprecation-warning (warning deprecation-condition)
1639 (def!method print-object :after ((warning final-deprecation-warning) stream)
1640 (unless *print-escape*
1641 (when (deprecated-name-runtime-error warning)
1642 (let ((*package* (find-package :keyword)))
1643 (format stream "~%~@<~:@_An error will be signaled at runtime for ~S.~:@>"
1644 (deprecated-name warning))))))
1646 (define-condition deprecation-error (error deprecation-condition)
1649 ;;;; restart definitions
1651 (define-condition abort-failure (control-error) ()
1653 "An ABORT restart was found that failed to transfer control dynamically."))
1655 (defun abort (&optional condition)
1657 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1659 (invoke-restart (find-restart-or-control-error 'abort condition))
1660 ;; ABORT signals an error in case there was a restart named ABORT
1661 ;; that did not transfer control dynamically. This could happen with
1663 (error 'abort-failure))
1665 (defun muffle-warning (&optional condition)
1667 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1668 CONTROL-ERROR if none exists."
1669 (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1671 (defun try-restart (name condition &rest arguments)
1672 (let ((restart (find-restart name condition)))
1674 (apply #'invoke-restart restart arguments))))
1676 (macrolet ((define-nil-returning-restart (name args doc)
1677 #!-sb-doc (declare (ignore doc))
1678 `(defun ,name (,@args &optional condition)
1680 (try-restart ',name condition ,@args))))
1681 (define-nil-returning-restart continue ()
1682 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1683 (define-nil-returning-restart store-value (value)
1684 "Transfer control and VALUE to a restart named STORE-VALUE, or
1685 return NIL if none exists.")
1686 (define-nil-returning-restart use-value (value)
1687 "Transfer control and VALUE to a restart named USE-VALUE, or
1688 return NIL if none exists.")
1689 (define-nil-returning-restart print-unreadably ()
1690 "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
1691 return NIL if none exists."))
1693 ;;; single-stepping restarts
1695 (macrolet ((def (name doc)
1696 #!-sb-doc (declare (ignore doc))
1697 `(defun ,name (condition)
1699 (invoke-restart (find-restart-or-control-error ',name condition)))))
1701 "Transfers control to the STEP-CONTINUE restart associated with
1702 the condition, continuing execution without stepping. Signals a
1703 CONTROL-ERROR if the restart does not exist.")
1705 "Transfers control to the STEP-NEXT restart associated with the
1706 condition, executing the current form without stepping and continuing
1707 stepping with the next form. Signals CONTROL-ERROR is the restart does
1710 "Transfers control to the STEP-INTO restart associated with the
1711 condition, stepping into the current form. Signals a CONTROL-ERROR is
1712 the restart does not exist."))
1714 ;;; Compiler macro magic
1716 (define-condition compiler-macro-keyword-problem ()
1717 ((argument :initarg :argument :reader compiler-macro-keyword-argument))
1718 (:report (lambda (condition stream)
1719 (format stream "~@<Argument ~S in keyword position is not ~
1720 a self-evaluating symbol, preventing compiler-macro ~
1722 (compiler-macro-keyword-argument condition)))))
1724 (/show0 "condition.lisp end of file")