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 ;;;; miscellaneous support utilities
18 ;;; Signalling an error when trying to print an error condition is
19 ;;; generally a PITA, so whatever the failure encountered when
20 ;;; wondering about FILE-POSITION within a condition printer, 'tis
21 ;;; better silently to give up than to try to complain.
22 (defun file-position-or-nil-for-error (stream &optional (pos nil posp))
23 ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but
24 ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem
25 ;; absolutely unambiguously to prohibit errors when, e.g., STREAM
26 ;; has been closed so that FILE-POSITION is a nonsense question. So
27 ;; my (WHN) impression is that the conservative approach is to
28 ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew
29 ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd,
30 ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the
31 ;; time an error was reported.)
33 (ignore-errors (file-position stream pos))
34 (ignore-errors (file-position stream))))
36 ;;;; the CONDITION class
38 (/show0 "condition.lisp 20")
40 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (/show0 "condition.lisp 24")
44 (def!struct (condition-classoid (:include classoid)
45 (:constructor make-condition-classoid))
46 ;; list of CONDITION-SLOT structures for the direct slots of this
48 (slots nil :type list)
49 ;; list of CONDITION-SLOT structures for all of the effective class
50 ;; slots of this class
51 (class-slots nil :type list)
52 ;; report function or NIL
53 (report nil :type (or function null))
54 ;; list of alternating initargs and initforms
55 (default-initargs () :type list)
56 ;; class precedence list as a list of CLASS objects, with all
57 ;; non-CONDITION classes removed
59 ;; a list of all the effective instance allocation slots of this
60 ;; class that have a non-constant initform or default-initarg.
61 ;; Values for these slots must be computed in the dynamic
62 ;; environment of MAKE-CONDITION.
63 (hairy-slots nil :type list))
65 (/show0 "condition.lisp 49")
69 (!defstruct-with-alternate-metaclass condition
70 :slot-names (actual-initargs assigned-slots)
71 :boa-constructor %make-condition-object
73 :metaclass-name condition-classoid
74 :metaclass-constructor make-condition-classoid
77 (defun make-condition-object (actual-initargs)
78 (%make-condition-object actual-initargs nil))
80 (defstruct (condition-slot (:copier nil))
81 (name (missing-arg) :type symbol)
82 ;; list of all applicable initargs
83 (initargs (missing-arg) :type list)
84 ;; names of reader and writer functions
85 (readers (missing-arg) :type list)
86 (writers (missing-arg) :type list)
87 ;; true if :INITFORM was specified
88 (initform-p (missing-arg) :type (member t nil))
89 ;; If this is a function, call it with no args. Otherwise, it's the
91 (initform (missing-arg) :type t)
92 ;; allocation of this slot, or NIL until defaulted
93 (allocation nil :type (member :instance :class nil))
94 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
95 (cell nil :type (or cons null))
97 (documentation nil :type (or string null)))
99 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
100 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
101 ;;; have themselves listed in their CPLs. This behavior is inherited
102 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
103 ;;; figured out whether it's right. -- WHN 19990612
104 (eval-when (:compile-toplevel :load-toplevel :execute)
105 (/show0 "condition.lisp 103")
106 (let ((condition-class (locally
107 ;; KLUDGE: There's a DEFTRANSFORM
108 ;; FIND-CLASSOID for constant class names
109 ;; which creates fast but
110 ;; non-cold-loadable, non-compact code. In
111 ;; this context, we'd rather have compact,
112 ;; cold-loadable code. -- WHN 19990928
113 (declare (notinline find-classoid))
114 (find-classoid 'condition))))
115 (setf (condition-classoid-cpl condition-class)
116 (list condition-class)))
117 (/show0 "condition.lisp 103"))
119 (setf (condition-classoid-report (locally
120 ;; KLUDGE: There's a DEFTRANSFORM
121 ;; FIND-CLASSOID for constant class
122 ;; names which creates fast but
123 ;; non-cold-loadable, non-compact
124 ;; code. In this context, we'd
125 ;; rather have compact,
126 ;; cold-loadable code. -- WHN
128 (declare (notinline find-classoid))
129 (find-classoid 'condition)))
130 (lambda (cond stream)
131 (format stream "Condition ~S was signalled." (type-of cond))))
133 (eval-when (:compile-toplevel :load-toplevel :execute)
135 (defun find-condition-layout (name parent-types)
136 (let* ((cpl (remove-duplicates
140 (condition-classoid-cpl
143 (cond-layout (info :type :compiler-layout 'condition))
144 (olayout (info :type :compiler-layout name))
145 ;; FIXME: Does this do the right thing in case of multiple
146 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
147 ;; it obvious what ANSI intends to be done in the case of
148 ;; multiple inheritance, so it's not actually clear what the
151 (order-layout-inherits (concatenate 'simple-vector
152 (layout-inherits cond-layout)
153 (mapcar #'classoid-layout cpl)))))
155 (not (mismatch (layout-inherits olayout) new-inherits)))
157 (make-layout :classoid (make-undefined-classoid name)
158 :inherits new-inherits
160 :length (layout-length cond-layout)))))
164 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
165 ;;; Condition reporting is mediated through the PRINT-OBJECT method
166 ;;; for the condition type in question, with *PRINT-ESCAPE* always
167 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
168 ;;; a condition type C is equivalent to:
169 ;;; (defmethod print-object ((x c) stream)
170 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
171 ;;; The current code doesn't seem to quite match that.
172 (def!method print-object ((x condition) stream)
174 (if (and (typep x 'simple-condition) (slot-boundp x 'format-control))
175 (print-unreadable-object (x stream :type t :identity t)
176 (format stream "~S" (simple-condition-format-control x)))
177 (print-unreadable-object (x stream :type t :identity t)))
178 ;; KLUDGE: A comment from CMU CL here said
179 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
180 ;; superclasses in define-condition call!
181 (dolist (class (condition-classoid-cpl (classoid-of x))
182 (error "no REPORT? shouldn't happen!"))
183 (let ((report (condition-classoid-report class)))
185 (return (funcall report x stream)))))))
187 ;;;; slots of CONDITION objects
189 (defvar *empty-condition-slot* '(empty))
191 (defun find-slot-default (class slot)
192 (let ((initargs (condition-slot-initargs slot))
193 (cpl (condition-classoid-cpl class)))
195 (let ((default-initargs (condition-classoid-default-initargs class)))
196 (dolist (initarg initargs)
197 (let ((val (getf default-initargs initarg *empty-condition-slot*)))
198 (unless (eq val *empty-condition-slot*)
199 (return-from find-slot-default
204 (if (condition-slot-initform-p slot)
205 (let ((initform (condition-slot-initform slot)))
206 (if (functionp initform)
209 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
211 (defun find-condition-class-slot (condition-class slot-name)
213 (condition-classoid-cpl condition-class)
214 (error "There is no slot named ~S in ~S."
215 slot-name condition-class))
216 (dolist (slot (condition-classoid-slots sclass))
217 (when (eq (condition-slot-name slot) slot-name)
218 (return-from find-condition-class-slot slot)))))
220 (defun condition-writer-function (condition new-value name)
221 (dolist (cslot (condition-classoid-class-slots
222 (layout-classoid (%instance-layout condition)))
223 (setf (getf (condition-assigned-slots condition) name)
225 (when (eq (condition-slot-name cslot) name)
226 (return (setf (car (condition-slot-cell cslot)) new-value)))))
228 (defun condition-reader-function (condition name)
229 (let ((class (layout-classoid (%instance-layout condition))))
230 (dolist (cslot (condition-classoid-class-slots class))
231 (when (eq (condition-slot-name cslot) name)
232 (return-from condition-reader-function
233 (car (condition-slot-cell cslot)))))
234 (let ((val (getf (condition-assigned-slots condition) name
235 *empty-condition-slot*)))
236 (if (eq val *empty-condition-slot*)
237 (let ((actual-initargs (condition-actual-initargs condition))
238 (slot (find-condition-class-slot class name)))
240 (error "missing slot ~S of ~S" name condition))
241 (do ((initargs actual-initargs (cddr initargs)))
243 (setf (getf (condition-assigned-slots condition) name)
244 (find-slot-default class slot)))
245 (when (member (car initargs) (condition-slot-initargs slot))
246 (return-from condition-reader-function
247 (setf (getf (condition-assigned-slots condition)
254 (defun make-condition (type &rest args)
256 "Make an instance of a condition object using the specified initargs."
257 ;; Note: ANSI specifies no exceptional situations in this function.
258 ;; signalling simple-type-error would not be wrong.
259 (let* ((type (or (and (symbolp type) (find-classoid type nil))
261 (class (typecase type
262 (condition-classoid type)
265 (return-from make-condition (apply #'make-instance type args)))
267 (error 'simple-type-error
269 :expected-type 'condition-class
270 :format-control "~S is not a condition class."
271 :format-arguments (list type)))
273 (error 'simple-type-error
275 :expected-type 'condition-class
276 :format-control "Bad type argument:~% ~S"
277 :format-arguments (list type)))))
278 (res (make-condition-object args)))
279 (setf (%instance-layout res) (classoid-layout class))
280 ;; Set any class slots with initargs present in this call.
281 (dolist (cslot (condition-classoid-class-slots class))
282 (dolist (initarg (condition-slot-initargs cslot))
283 (let ((val (getf args initarg *empty-condition-slot*)))
284 (unless (eq val *empty-condition-slot*)
285 (setf (car (condition-slot-cell cslot)) val)))))
286 ;; Default any slots with non-constant defaults now.
287 (dolist (hslot (condition-classoid-hairy-slots class))
288 (when (dolist (initarg (condition-slot-initargs hslot) t)
289 (unless (eq (getf args initarg *empty-condition-slot*)
290 *empty-condition-slot*)
292 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
293 (find-slot-default class hslot))))
296 ;;;; DEFINE-CONDITION
298 (eval-when (:compile-toplevel :load-toplevel :execute)
299 (defun %compiler-define-condition (name direct-supers layout
300 all-readers all-writers)
301 (with-single-package-locked-error
302 (:symbol name "defining ~A as a condition")
303 (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
304 (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
305 (multiple-value-bind (class old-layout)
306 (insured-find-classoid name
307 #'condition-classoid-p
308 #'make-condition-classoid)
309 (setf (layout-classoid layout) class)
310 (setf (classoid-direct-superclasses class)
311 (mapcar #'find-classoid direct-supers))
312 (cond ((not old-layout)
313 (register-layout layout))
314 ((not *type-system-initialized*)
315 (setf (layout-classoid old-layout) class)
316 (setq layout old-layout)
317 (unless (eq (classoid-layout class) layout)
318 (register-layout layout)))
319 ((redefine-layout-warning "current"
322 (layout-length layout)
323 (layout-inherits layout)
324 (layout-depthoid layout)
325 (layout-n-untagged-slots layout))
326 (register-layout layout :invalidate t))
327 ((not (classoid-layout class))
328 (register-layout layout)))
330 (setf (layout-info layout)
332 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
333 ;; names which creates fast but non-cold-loadable, non-compact
334 ;; code. In this context, we'd rather have compact, cold-loadable
335 ;; code. -- WHN 19990928
336 (declare (notinline find-classoid))
337 (layout-info (classoid-layout (find-classoid 'condition)))))
339 (setf (find-classoid name) class)
341 ;; Initialize CPL slot.
342 (setf (condition-classoid-cpl class)
343 (remove-if-not #'condition-classoid-p
344 (std-compute-class-precedence-list class)))))
348 ;;; Compute the effective slots of CLASS, copying inherited slots and
349 ;;; destructively modifying direct slots.
351 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
352 ;;; direct slots. Presumably it follows from the semantics of
353 ;;; inheritance and redefinition of conditions, but finding the cite
354 ;;; and documenting it here would be good. (Or, if this is not in fact
355 ;;; ANSI-compliant, fixing it would also be good.:-)
356 (defun compute-effective-slots (class)
357 (collect ((res (copy-list (condition-classoid-slots class))))
358 (dolist (sclass (cdr (condition-classoid-cpl class)))
359 (dolist (sslot (condition-classoid-slots sclass))
360 (let ((found (find (condition-slot-name sslot) (res)
361 :key #'condition-slot-name)))
363 (setf (condition-slot-initargs found)
364 (union (condition-slot-initargs found)
365 (condition-slot-initargs sslot)))
366 (unless (condition-slot-initform-p found)
367 (setf (condition-slot-initform-p found)
368 (condition-slot-initform-p sslot))
369 (setf (condition-slot-initform found)
370 (condition-slot-initform sslot)))
371 (unless (condition-slot-allocation found)
372 (setf (condition-slot-allocation found)
373 (condition-slot-allocation sslot))))
375 (res (copy-structure sslot)))))))
378 ;;; Early definitions of slot accessor creators.
380 ;;; Slot accessors must be generic functions, but ANSI does not seem
381 ;;; to specify any of them, and we cannot support it before end of
382 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
383 ;;; GFs only at the end of building.
384 (declaim (notinline install-condition-slot-reader
385 install-condition-slot-writer))
386 (defun install-condition-slot-reader (name condition slot-name)
387 (declare (ignore condition))
388 (setf (fdefinition name)
390 (condition-reader-function condition slot-name))))
391 (defun install-condition-slot-writer (name condition slot-name)
392 (declare (ignore condition))
393 (setf (fdefinition name)
394 (lambda (new-value condition)
395 (condition-writer-function condition new-value slot-name))))
397 (defvar *define-condition-hooks* nil)
399 (defun %define-condition (name parent-types layout slots documentation
400 report default-initargs all-readers all-writers
402 (with-single-package-locked-error
403 (:symbol name "defining ~A as a condition")
404 (%compiler-define-condition name parent-types layout all-readers all-writers)
405 (sb!c:with-source-location (source-location)
406 (setf (layout-source-location layout)
408 (let ((class (find-classoid name)))
409 (setf (condition-classoid-slots class) slots)
410 (setf (condition-classoid-report class) report)
411 (setf (condition-classoid-default-initargs class) default-initargs)
412 (setf (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 (let ((eslots (compute-effective-slots class))
428 (mapcar #'condition-classoid-default-initargs
429 (condition-classoid-cpl class)))))
430 (dolist (slot eslots)
431 (ecase (condition-slot-allocation slot)
433 (unless (condition-slot-cell slot)
434 (setf (condition-slot-cell slot)
435 (list (if (condition-slot-initform-p slot)
436 (let ((initform (condition-slot-initform slot)))
437 (if (functionp initform)
440 *empty-condition-slot*))))
441 (push slot (condition-classoid-class-slots class)))
443 (setf (condition-slot-allocation slot) :instance)
444 (when (or (functionp (condition-slot-initform slot))
445 (dolist (initarg (condition-slot-initargs slot) nil)
446 (when (functionp (getf e-def-initargs initarg))
448 (push slot (condition-classoid-hairy-slots class)))))))
449 (when (boundp '*define-condition-hooks*)
450 (dolist (fun *define-condition-hooks*)
451 (funcall fun class))))
454 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
457 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
458 Define NAME as a condition type. This new type inherits slots and its
459 report function from the specified PARENT-TYPEs. A slot spec is a list of:
460 (slot-name :reader <rname> :initarg <iname> {Option Value}*
462 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
463 and :TYPE and the overall options :DEFAULT-INITARGS and
464 [type] :DOCUMENTATION are also allowed.
466 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
467 a string or a two-argument lambda or function name. If a function, the
468 function is called with the condition and stream to report the condition.
469 If a string, the string is printed.
471 Condition types are classes, but (as allowed by ANSI and not as described in
472 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
473 SLOT-VALUE may not be used on condition objects."
474 (let* ((parent-types (or parent-types '(condition)))
475 (layout (find-condition-layout name parent-types))
478 (default-initargs ()))
480 (all-readers nil append)
481 (all-writers nil append))
482 (dolist (spec slot-specs)
483 (when (keywordp spec)
484 (warn "Keyword slot name indicates probable syntax error:~% ~S"
486 (let* ((spec (if (consp spec) spec (list spec)))
487 (slot-name (first spec))
488 (allocation :instance)
495 (do ((options (rest spec) (cddr options)))
497 (unless (and (consp options) (consp (cdr options)))
498 (error "malformed condition slot spec:~% ~S." spec))
499 (let ((arg (second options)))
500 (case (first options)
501 (:reader (readers arg))
502 (:writer (writers arg))
505 (writers `(setf ,arg)))
508 (error "more than one :INITFORM in ~S" spec))
511 (:initarg (initargs arg))
513 (setq allocation arg))
516 (error "more than one :DOCUMENTATION in ~S" spec))
517 (unless (stringp arg)
518 (error "slot :DOCUMENTATION argument is not a string: ~S"
520 (setq documentation arg))
523 (error "unknown slot option:~% ~S" (first options))))))
525 (all-readers (readers))
526 (all-writers (writers))
527 (slots `(make-condition-slot
529 :initargs ',(initargs)
532 :initform-p ',initform-p
533 :documentation ',documentation
535 ,(if (sb!xc:constantp initform)
536 `',(constant-form-value initform)
537 `#'(lambda () ,initform)))))))
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 (do ((initargs (rest option) (cddr initargs)))
556 (let ((val (second initargs)))
557 (setq default-initargs
558 (list* `',(first initargs)
559 (if (sb!xc:constantp val)
560 `',(constant-form-value val)
562 default-initargs)))))
564 (error "unknown option: ~S" (first option)))))
567 (eval-when (:compile-toplevel)
568 (%compiler-define-condition ',name ',parent-types ',layout
569 ',(all-readers) ',(all-writers)))
570 (eval-when (:load-toplevel :execute)
571 (%define-condition ',name
577 (list ,@default-initargs)
580 (sb!c:source-location)))))))
582 ;;;; various CONDITIONs specified by ANSI
584 (define-condition serious-condition (condition) ())
586 (define-condition error (serious-condition) ())
588 (define-condition warning (condition) ())
589 (define-condition style-warning (warning) ())
591 (defun simple-condition-printer (condition stream)
594 (simple-condition-format-control condition)
595 (simple-condition-format-arguments condition)))
597 (define-condition simple-condition ()
598 ((format-control :reader simple-condition-format-control
599 :initarg :format-control
600 :type format-control)
601 (format-arguments :reader simple-condition-format-arguments
602 :initarg :format-arguments
605 (:report simple-condition-printer))
607 (define-condition simple-warning (simple-condition warning) ())
609 (define-condition simple-error (simple-condition error) ())
611 (define-condition storage-condition (serious-condition) ())
613 (define-condition type-error (error)
614 ((datum :reader type-error-datum :initarg :datum)
615 (expected-type :reader type-error-expected-type :initarg :expected-type))
617 (lambda (condition stream)
619 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
620 (type-error-datum condition)
621 (type-error-expected-type condition)))))
623 (def!method print-object ((condition type-error) stream)
625 (flet ((maybe-string (thing)
627 (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
628 (let ((type (maybe-string (type-error-expected-type condition)))
629 (datum (maybe-string (type-error-datum condition))))
631 (print-unreadable-object (condition stream :type t)
632 (format stream "~@<expected-type: ~A ~_datum: ~A~:@>" type datum))
633 (call-next-method))))
636 ;;; not specified by ANSI, but too useful not to have around.
637 (define-condition simple-style-warning (simple-condition style-warning) ())
638 (define-condition simple-type-error (simple-condition type-error) ())
640 ;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR...
641 (declaim (ftype (sfunction (t t t &rest t) nil) bad-type))
642 (defun bad-type (datum type control &rest arguments)
643 (error 'simple-type-error
646 :format-control control
647 :format-arguments arguments))
649 (define-condition program-error (error) ())
650 (define-condition parse-error (error) ())
651 (define-condition control-error (error) ())
652 (define-condition stream-error (error)
653 ((stream :reader stream-error-stream :initarg :stream)))
655 (define-condition end-of-file (stream-error) ()
657 (lambda (condition stream)
660 (stream-error-stream condition)))))
662 (define-condition closed-stream-error (stream-error) ()
664 (lambda (condition stream)
665 (format stream "~S is closed" (stream-error-stream condition)))))
667 (define-condition file-error (error)
668 ((pathname :reader file-error-pathname :initarg :pathname))
670 (lambda (condition stream)
671 (format stream "error on file ~S" (file-error-pathname condition)))))
673 (define-condition package-error (error)
674 ((package :reader package-error-package :initarg :package)))
676 (define-condition cell-error (error)
677 ((name :reader cell-error-name :initarg :name)))
679 (def!method print-object ((condition cell-error) stream)
680 (if (and *print-escape* (slot-boundp condition 'name))
681 (print-unreadable-object (condition stream :type t :identity t)
682 (princ (cell-error-name condition) stream))
685 (define-condition unbound-variable (cell-error) ()
687 (lambda (condition stream)
689 "The variable ~S is unbound."
690 (cell-error-name condition)))))
692 (define-condition undefined-function (cell-error) ()
694 (lambda (condition stream)
696 "The function ~/sb-impl::print-symbol-with-prefix/ is undefined."
697 (cell-error-name condition)))))
699 (define-condition special-form-function (undefined-function) ()
701 (lambda (condition stream)
703 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
704 (cell-error-name condition)))))
706 (define-condition arithmetic-error (error)
707 ((operation :reader arithmetic-error-operation
710 (operands :reader arithmetic-error-operands
712 (:report (lambda (condition stream)
714 "arithmetic error ~S signalled"
716 (when (arithmetic-error-operation condition)
718 "~%Operation was ~S, operands ~S."
719 (arithmetic-error-operation condition)
720 (arithmetic-error-operands condition))))))
722 (define-condition division-by-zero (arithmetic-error) ())
723 (define-condition floating-point-overflow (arithmetic-error) ())
724 (define-condition floating-point-underflow (arithmetic-error) ())
725 (define-condition floating-point-inexact (arithmetic-error) ())
726 (define-condition floating-point-invalid-operation (arithmetic-error) ())
728 (define-condition print-not-readable (error)
729 ((object :reader print-not-readable-object :initarg :object))
731 (lambda (condition stream)
732 (let ((obj (print-not-readable-object condition))
734 (format stream "~S cannot be printed readably." obj)))))
736 (define-condition reader-error (parse-error stream-error) ()
737 (:report (lambda (condition stream)
738 (%report-reader-error condition stream))))
740 ;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
741 ;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
742 ;;; within SBCL itself)
744 ;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
745 ;;; the letter of the ANSI spec: this is not a condition signalled by
746 ;;; SIGNAL when a format-control is supplied by the function's first
747 ;;; argument. It seems to me (WHN) to be basically in the spirit of
748 ;;; the spec, but if not, it'd be straightforward to do our own
749 ;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
750 ;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
751 ;;; place of CL:SIMPLE-CONDITION here.)
752 (define-condition simple-reader-error (reader-error simple-condition)
754 (:report (lambda (condition stream)
755 (%report-reader-error condition stream :simple t))))
757 ;;; base REPORTing of a READER-ERROR
759 ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
760 ;;; and FORMAT-ARGS slots.
761 (defun %report-reader-error (condition stream &key simple)
762 (let* ((error-stream (stream-error-stream condition))
763 (pos (file-position-or-nil-for-error error-stream)))
766 (< pos sb!xc:array-dimension-limit)
767 ;; KLUDGE: lseek() (which is what FILE-POSITION
768 ;; reduces to on file-streams) is undefined on
769 ;; "some devices", which in practice means that it
770 ;; can claim to succeed on /dev/stdin on Darwin
771 ;; and Solaris. This is obviously bad news,
772 ;; because the READ-SEQUENCE below will then
773 ;; block, not complete, and the report will never
774 ;; be printed. As a workaround, we exclude
775 ;; interactive streams from this attempt to report
776 ;; positions. -- CSR, 2003-08-21
777 (not (interactive-stream-p error-stream))
778 (file-position error-stream :start))
781 :element-type (stream-element-type
783 (when (= pos (read-sequence string error-stream))
784 (setq lineno (1+ (count #\Newline string))
786 (or (position #\Newline string :from-end t) -1)
788 (file-position-or-nil-for-error error-stream pos))
789 (pprint-logical-block (stream nil)
792 ~@[(line ~W~]~@[, column ~W) ~]~
794 (class-name (class-of condition))
795 pos lineno colno error-stream)
797 (format stream ":~2I~_~?"
798 (simple-condition-format-control condition)
799 (simple-condition-format-arguments condition)))))))
801 ;;;; special SBCL extension conditions
803 ;;; an error apparently caused by a bug in SBCL itself
805 ;;; Note that we don't make any serious effort to use this condition
806 ;;; for *all* errors in SBCL itself. E.g. type errors and array
807 ;;; indexing errors can occur in functions called from SBCL code, and
808 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
809 ;;; because the signalling code has no good way to know that the
810 ;;; underlying problem is a bug in SBCL. But in the fairly common case
811 ;;; that the signalling code does know that it's found a bug in SBCL,
812 ;;; this condition is appropriate, reusing boilerplate and helping
813 ;;; users to recognize it as an SBCL bug.
814 (define-condition bug (simple-error)
817 (lambda (condition stream)
820 (simple-condition-format-control condition)
821 (simple-condition-format-arguments condition)
822 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
823 SBCL might have been corrupted by bad user code, e.g. by an ~
824 undefined Lisp operation like ~S, or by stray pointers from ~
825 alien code or from unsafe Lisp code; or there might be a bug ~
826 in the OS or hardware that SBCL is running on.) If it seems to ~
827 be a bug in SBCL itself, the maintainers would like to know ~
828 about it. Bug reports are welcome on the SBCL ~
829 mailing lists, which you can find at ~
830 <http://sbcl.sourceforge.net/>.~:@>"
831 '((fmakunbound 'compile))))))
833 (define-condition simple-storage-condition (storage-condition simple-condition)
836 ;;; a condition for use in stubs for operations which aren't supported
837 ;;; on some platforms
839 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
840 ;;; #-(or freebsd linux)
841 ;;; (defun load-foreign (&rest rest)
842 ;;; (error 'unsupported-operator :name 'load-foreign))
843 ;;; #+(or freebsd linux)
844 ;;; (defun load-foreign ... actual definition ...)
845 ;;; By signalling a standard condition in this case, we make it
846 ;;; possible for test code to distinguish between (1) intentionally
847 ;;; unimplemented and (2) unintentionally just screwed up somehow.
848 ;;; (Before this condition was defined, test code tried to deal with
849 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
850 ;;; sbcl-0.7.0, a package screwup left the definition of
851 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
852 ;;; architectures where it was supposed to be supported, and the
853 ;;; regression tests cheerfully passed because they assumed that
854 ;;; unFBOUNDPness meant they were running on an system which didn't
855 ;;; support the extension.)
856 (define-condition unsupported-operator (simple-error) ())
858 ;;; (:ansi-cl :function remove)
859 ;;; (:ansi-cl :section (a b c))
860 ;;; (:ansi-cl :glossary "similar")
862 ;;; (:sbcl :node "...")
863 ;;; (:sbcl :variable *ed-functions*)
865 ;;; FIXME: this is not the right place for this.
866 (defun print-reference (reference stream)
867 (ecase (car reference)
869 (format stream "AMOP")
871 (destructuring-bind (type data) (cdr reference)
873 (:readers "Readers for ~:(~A~) Metaobjects"
874 (substitute #\ #\- (symbol-name data)))
876 (format stream "Initialization of ~:(~A~) Metaobjects"
877 (substitute #\ #\- (symbol-name data))))
878 (:generic-function (format stream "Generic Function ~S" data))
879 (:function (format stream "Function ~S" data))
880 (:section (format stream "Section ~{~D~^.~}" data)))))
882 (format stream "The ANSI Standard")
884 (destructuring-bind (type data) (cdr reference)
886 (:function (format stream "Function ~S" data))
887 (:special-operator (format stream "Special Operator ~S" data))
888 (:macro (format stream "Macro ~S" data))
889 (:section (format stream "Section ~{~D~^.~}" data))
890 (:glossary (format stream "Glossary entry for ~S" data))
891 (:issue (format stream "writeup for Issue ~A" data)))))
893 (format stream "The SBCL Manual")
895 (destructuring-bind (type data) (cdr reference)
897 (:node (format stream "Node ~S" data))
898 (:variable (format stream "Variable ~S" data))
899 (:function (format stream "Function ~S" data)))))
900 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
902 (define-condition reference-condition ()
903 ((references :initarg :references :reader reference-condition-references)))
904 (defvar *print-condition-references* t)
905 (def!method print-object :around ((o reference-condition) s)
907 (unless (or *print-escape* *print-readably*)
908 (when (and *print-condition-references*
909 (reference-condition-references o))
910 (format s "~&See also:~%")
911 (pprint-logical-block (s nil :per-line-prefix " ")
912 (do* ((rs (reference-condition-references o) (cdr rs))
913 (r (car rs) (car rs)))
915 (print-reference r s)
916 (unless (null (cdr rs))
919 (define-condition simple-reference-error (reference-condition simple-error)
922 (define-condition simple-reference-warning (reference-condition simple-warning)
925 (define-condition arguments-out-of-domain-error
926 (arithmetic-error reference-condition)
929 (define-condition duplicate-definition (reference-condition warning)
930 ((name :initarg :name :reader duplicate-definition-name))
931 (:report (lambda (c s)
932 (format s "~@<Duplicate definition for ~S found in ~
934 (duplicate-definition-name c))))
935 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
937 (define-condition constant-modified (reference-condition warning)
938 ((fun-name :initarg :fun-name :reader constant-modified-fun-name))
939 (:report (lambda (c s)
940 (format s "~@<Destructive function ~S called on ~
942 (constant-modified-fun-name c))))
943 (:default-initargs :references (list '(:ansi-cl :special-operator quote)
944 '(:ansi-cl :section (3 2 2 3)))))
946 (define-condition package-at-variance (reference-condition simple-warning)
948 (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
950 (define-condition defconstant-uneql (reference-condition error)
951 ((name :initarg :name :reader defconstant-uneql-name)
952 (old-value :initarg :old-value :reader defconstant-uneql-old-value)
953 (new-value :initarg :new-value :reader defconstant-uneql-new-value))
955 (lambda (condition stream)
957 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
958 (defconstant-uneql-name condition)
959 (defconstant-uneql-old-value condition)
960 (defconstant-uneql-new-value condition))))
961 (:default-initargs :references (list '(:ansi-cl :macro defconstant)
962 '(:sbcl :node "Idiosyncrasies"))))
964 (define-condition array-initial-element-mismatch
965 (reference-condition simple-warning)
969 '(:ansi-cl :function make-array)
970 '(:ansi-cl :function sb!xc:upgraded-array-element-type))))
972 (define-condition type-warning (reference-condition simple-warning)
974 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
975 (define-condition type-style-warning (reference-condition simple-style-warning)
977 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
979 (define-condition local-argument-mismatch (reference-condition simple-warning)
981 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
983 (define-condition format-args-mismatch (reference-condition)
985 (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2)))))
987 (define-condition format-too-few-args-warning
988 (format-args-mismatch simple-warning)
990 (define-condition format-too-many-args-warning
991 (format-args-mismatch simple-style-warning)
994 (define-condition implicit-generic-function-warning (style-warning)
995 ((name :initarg :name :reader implicit-generic-function-name))
997 (lambda (condition stream)
998 (format stream "~@<Implicitly creating new generic function ~S.~:@>"
999 (implicit-generic-function-name condition)))))
1001 (define-condition extension-failure (reference-condition simple-error)
1004 (define-condition structure-initarg-not-keyword
1005 (reference-condition simple-style-warning)
1007 (:default-initargs :references (list '(:ansi-cl :section (2 4 8 13)))))
1012 (define-condition package-lock-violation (reference-condition package-error)
1013 ((format-control :initform nil :initarg :format-control
1014 :reader package-error-format-control)
1015 (format-arguments :initform nil :initarg :format-arguments
1016 :reader package-error-format-arguments))
1018 (lambda (condition stream)
1019 (let ((control (package-error-format-control condition)))
1021 (apply #'format stream
1022 (format nil "~~@<Lock on package ~A violated when ~A.~~:@>"
1023 (package-name (package-error-package condition))
1025 (package-error-format-arguments condition))
1026 (format stream "~@<Lock on package ~A violated.~:@>"
1027 (package-name (package-error-package condition)))))))
1028 ;; no :default-initargs -- reference-stuff provided by the
1029 ;; signalling form in target-package.lisp
1032 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
1033 when a package-lock is violated."))
1035 (define-condition package-locked-error (package-lock-violation) ()
1038 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1039 signalled when an operation on a package violates a package lock."))
1041 (define-condition symbol-package-locked-error (package-lock-violation)
1042 ((symbol :initarg :symbol :reader package-locked-error-symbol))
1045 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1046 signalled when an operation on a symbol violates a package lock. The
1047 symbol that caused the violation is accessed by the function
1048 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
1052 (define-condition undefined-alien-error (cell-error) ()
1054 (lambda (condition stream)
1055 (if (slot-boundp condition 'name)
1056 (format stream "Undefined alien: ~S" (cell-error-name condition))
1057 (format stream "Undefined alien symbol.")))))
1059 (define-condition undefined-alien-variable-error (undefined-alien-error) ()
1061 (lambda (condition stream)
1062 (declare (ignore condition))
1063 (format stream "Attempt to access an undefined alien variable."))))
1065 (define-condition undefined-alien-function-error (undefined-alien-error) ()
1067 (lambda (condition stream)
1068 (declare (ignore condition))
1069 (format stream "Attempt to call an undefined alien function."))))
1072 ;;;; various other (not specified by ANSI) CONDITIONs
1074 ;;;; These might logically belong in other files; they're here, after
1075 ;;;; setup of CONDITION machinery, only because that makes it easier to
1076 ;;;; get cold init to work.
1078 ;;; OAOOM warning: see cross-condition.lisp
1079 (define-condition encapsulated-condition (condition)
1080 ((condition :initarg :condition :reader encapsulated-condition)))
1082 (define-condition values-type-error (type-error)
1085 (lambda (condition stream)
1087 "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
1088 (type-error-datum condition)
1089 (type-error-expected-type condition)))))
1091 ;;; KLUDGE: a condition for floating point errors when we can't or
1092 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
1093 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
1094 ;;; know how but the old code was broken by the conversion to POSIX
1095 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
1097 ;;; FIXME: Perhaps this should also be a base class for all
1098 ;;; floating point exceptions?
1099 (define-condition floating-point-exception (arithmetic-error)
1100 ((flags :initarg :traps
1102 :reader floating-point-exception-traps))
1103 (:report (lambda (condition stream)
1105 "An arithmetic error ~S was signalled.~%"
1106 (type-of condition))
1107 (let ((traps (floating-point-exception-traps condition)))
1110 "Trapping conditions are: ~%~{ ~S~^~}~%"
1113 "No traps are enabled? How can this be?"
1116 (define-condition invalid-array-index-error (type-error)
1117 ((array :initarg :array :reader invalid-array-index-error-array)
1118 (axis :initarg :axis :reader invalid-array-index-error-axis))
1120 (lambda (condition stream)
1121 (let ((array (invalid-array-index-error-array condition)))
1122 (format stream "Index ~W out of bounds for ~@[axis ~W of ~]~S, ~
1123 should be nonnegative and <~W."
1124 (type-error-datum condition)
1125 (when (> (array-rank array) 1)
1126 (invalid-array-index-error-axis condition))
1128 ;; Extract the bound from (INTEGER 0 (BOUND))
1129 (caaddr (type-error-expected-type condition)))))))
1131 (define-condition invalid-array-error (reference-condition type-error) ()
1133 (lambda (condition stream)
1134 (let ((*print-array* nil))
1136 "~@<Displaced array originally of type ~S has been invalidated ~
1137 due its displaced-to array ~S having become too small to hold ~
1138 it: the displaced array's dimensions have all been set to zero ~
1139 to trap accesses to it.~:@>"
1140 (type-error-expected-type condition)
1141 (array-displacement (type-error-datum condition))))))
1144 (list '(:ansi-cl :function adjust-array))))
1146 (define-condition index-too-large-error (type-error)
1149 (lambda (condition stream)
1151 "The index ~S is too large."
1152 (type-error-datum condition)))))
1154 (define-condition bounding-indices-bad-error (reference-condition type-error)
1155 ((object :reader bounding-indices-bad-object :initarg :object))
1157 (lambda (condition stream)
1158 (let* ((datum (type-error-datum condition))
1161 (object (bounding-indices-bad-object condition)))
1165 "The bounding indices ~S and ~S are bad ~
1166 for a sequence of length ~S."
1167 start end (length object)))
1169 ;; from WITH-ARRAY-DATA
1171 "The START and END parameters ~S and ~S are ~
1172 bad for an array of total size ~S."
1173 start end (array-total-size object)))))))
1176 (list '(:ansi-cl :glossary "bounding index designator")
1177 '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1179 (define-condition nil-array-accessed-error (reference-condition type-error)
1181 (:report (lambda (condition stream)
1182 (declare (ignore condition))
1184 "An attempt to access an array of element-type ~
1185 NIL was made. Congratulations!")))
1187 :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type)
1188 '(:ansi-cl :section (15 1 2 1))
1189 '(:ansi-cl :section (15 1 2 2)))))
1191 (define-condition namestring-parse-error (parse-error)
1192 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
1193 (args :reader namestring-parse-error-args :initarg :args :initform nil)
1194 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
1195 (offset :reader namestring-parse-error-offset :initarg :offset))
1197 (lambda (condition stream)
1199 "parse error in namestring: ~?~% ~A~% ~V@T^"
1200 (namestring-parse-error-complaint condition)
1201 (namestring-parse-error-args condition)
1202 (namestring-parse-error-namestring condition)
1203 (namestring-parse-error-offset condition)))))
1205 (define-condition simple-package-error (simple-condition package-error) ())
1207 (define-condition simple-reader-package-error (simple-reader-error) ())
1209 (define-condition reader-eof-error (end-of-file)
1210 ((context :reader reader-eof-error-context :initarg :context))
1212 (lambda (condition stream)
1214 "unexpected end of file on ~S ~A"
1215 (stream-error-stream condition)
1216 (reader-eof-error-context condition)))))
1218 (define-condition reader-impossible-number-error (simple-reader-error)
1219 ((error :reader reader-impossible-number-error-error :initarg :error))
1221 (lambda (condition stream)
1222 (let ((error-stream (stream-error-stream condition)))
1224 "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1225 (file-position-or-nil-for-error error-stream) error-stream
1226 (simple-condition-format-control condition)
1227 (simple-condition-format-arguments condition)
1228 (reader-impossible-number-error-error condition))))))
1230 (define-condition standard-readtable-modified-error (reference-condition error)
1231 ((operation :initarg :operation :reader standard-readtable-modified-operation))
1232 (:report (lambda (condition stream)
1233 (format stream "~S would modify the standard readtable."
1234 (standard-readtable-modified-operation condition))))
1235 (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
1236 (:ansi-cl :glossary "standard readtable"))))
1238 (define-condition standard-pprint-dispatch-table-modified-error
1239 (reference-condition error)
1240 ((operation :initarg :operation
1241 :reader standard-pprint-dispatch-table-modified-operation))
1242 (:report (lambda (condition stream)
1243 (format stream "~S would modify the standard pprint dispatch table."
1244 (standard-pprint-dispatch-table-modified-operation
1247 :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
1249 (define-condition timeout (serious-condition)
1250 ((seconds :initarg :seconds :initform nil :reader timeout-seconds))
1251 (:report (lambda (condition stream)
1252 (format stream "Timeout occurred~@[ after ~A seconds~]."
1253 (timeout-seconds condition)))))
1255 (define-condition io-timeout (stream-error timeout)
1256 ((direction :reader io-timeout-direction :initarg :direction))
1258 (lambda (condition stream)
1259 (declare (type stream stream))
1261 "I/O timeout while doing ~(~A~) on ~S."
1262 (io-timeout-direction condition)
1263 (stream-error-stream condition)))))
1265 (define-condition deadline-timeout (timeout) ()
1266 (:report (lambda (condition stream)
1267 (format stream "A deadline was reached after ~A seconds."
1268 (timeout-seconds condition)))))
1270 (define-condition declaration-type-conflict-error (reference-condition
1274 :format-control "symbol ~S cannot be both the name of a type and the name of a declaration"
1275 :references (list '(:ansi-cl :section (3 8 21)))))
1277 ;;; Single stepping conditions
1279 (define-condition step-condition ()
1280 ((form :initarg :form :reader step-condition-form))
1283 (:documentation "Common base class of single-stepping conditions.
1284 STEP-CONDITION-FORM holds a string representation of the form being
1288 (setf (fdocumentation 'step-condition-form 'function)
1289 "Form associated with the STEP-CONDITION.")
1291 (define-condition step-form-condition (step-condition)
1292 ((args :initarg :args :reader step-condition-args))
1294 (lambda (condition stream)
1295 (let ((*print-circle* t)
1297 (*print-readably* nil))
1299 "Evaluating call:~%~< ~@;~A~:>~%~
1300 ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%"
1301 (list (step-condition-form condition))
1302 (eq (step-condition-args condition) :unknown)
1303 (step-condition-args condition)))))
1305 (:documentation "Condition signalled by code compiled with
1306 single-stepping information when about to execute a form.
1307 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1308 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1309 holds the source-path to the original form within that file or NIL.
1310 Associated with this condition are always the restarts STEP-INTO,
1311 STEP-NEXT, and STEP-CONTINUE."))
1313 (define-condition step-result-condition (step-condition)
1314 ((result :initarg :result :reader step-condition-result)))
1317 (setf (fdocumentation 'step-condition-result 'function)
1318 "Return values associated with STEP-VALUES-CONDITION as a list,
1319 or the variable value associated with STEP-VARIABLE-CONDITION.")
1321 (define-condition step-values-condition (step-result-condition)
1324 (:documentation "Condition signalled by code compiled with
1325 single-stepping information after executing a form.
1326 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1327 the values returned by the form as a list. No associated restarts."))
1329 (define-condition step-finished-condition (step-condition)
1332 (lambda (condition stream)
1333 (declare (ignore condition))
1334 (format stream "Returning from STEP")))
1336 (:documentation "Condition signaled when STEP returns."))
1338 ;;; A knob for muffling warnings, mostly for use while loading files.
1339 (defvar *muffled-warnings* 'uninteresting-redefinition
1340 "A type that ought to specify a subtype of WARNING. Whenever a
1341 warning is signaled, if the warning if of this type and is not
1342 handled by any other handler, it will be muffled.")
1344 ;;; Various STYLE-WARNING signaled in the system.
1345 ;; For the moment, we're only getting into the details for function
1346 ;; redefinitions, but other redefinitions could be done later
1348 (define-condition redefinition-warning (style-warning)
1351 (define-condition function-redefinition-warning (redefinition-warning)
1352 ((name :initarg :name :reader function-redefinition-warning-name)
1353 (old :initarg :old :reader function-redefinition-warning-old-fdefinition)
1354 ;; For DEFGENERIC and perhaps others, the redefinition
1355 ;; destructively modifies the original, rather than storing a new
1356 ;; object, so there's no NEW here, but only in subclasses.
1359 (define-condition redefinition-with-defun (function-redefinition-warning)
1360 ((new :initarg :new :reader redefinition-with-defun-new-fdefinition)
1361 ;; KLUDGE: it would be nice to fix the unreasonably late
1362 ;; back-patching of DEBUG-SOURCEs in the DEBUG-INFO during
1363 ;; fasloading and just use the new fdefinition, but for the moment
1364 ;; we'll compare the SOURCE-LOCATION created during DEFUN with the
1365 ;; previous DEBUG-SOURCE.
1366 (new-location :initarg :new-location
1367 :reader redefinition-with-defun-new-location))
1368 (:report (lambda (warning stream)
1369 (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
1371 (function-redefinition-warning-name warning)))))
1373 (define-condition redefinition-with-defgeneric (function-redefinition-warning)
1374 ((new-location :initarg :new-location
1375 :reader redefinition-with-defgeneric-new-location))
1376 (:report (lambda (warning stream)
1377 (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
1379 (function-redefinition-warning-name warning)))))
1381 (define-condition redefinition-with-defmethod (redefinition-warning)
1382 ((gf :initarg :generic-function
1383 :reader redefinition-with-defmethod-generic-function)
1384 (qualifiers :initarg :qualifiers
1385 :reader redefinition-with-defmethod-qualifiers)
1386 (specializers :initarg :specializers
1387 :reader redefinition-with-defmethod-specializers)
1388 (new-location :initarg :new-location
1389 :reader redefinition-with-defmethod-new-location)
1390 (old-method :initarg :old-method
1391 :reader redefinition-with-defmethod-old-method))
1392 (:report (lambda (warning stream)
1393 (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1394 (redefinition-with-defmethod-generic-function warning)
1395 (redefinition-with-defmethod-qualifiers warning)
1396 (redefinition-with-defmethod-specializers warning)))))
1398 ;; FIXME: see the FIXMEs in defmacro.lisp, then maybe instantiate this.
1399 (define-condition redefinition-with-defmacro (function-redefinition-warning)
1402 ;; Here are a few predicates for what people might find interesting
1403 ;; about redefinitions.
1405 ;; DEFUN can replace a generic function with an ordinary function.
1406 ;; (Attempting to replace an ordinary function with a generic one
1407 ;; causes an error, though.)
1408 (defun redefinition-replaces-generic-function-p (warning)
1409 (and (typep warning 'redefinition-with-defun)
1410 (typep (function-redefinition-warning-old-fdefinition warning)
1411 'generic-function)))
1413 (defun redefinition-replaces-compiled-function-with-interpreted-p (warning)
1414 (and (typep warning 'redefinition-with-defun)
1415 (compiled-function-p
1416 (function-redefinition-warning-old-fdefinition warning))
1417 (not (compiled-function-p
1418 (redefinition-with-defun-new-fdefinition warning)))))
1420 ;; Most people seem to agree that re-running a DEFUN in a file is
1421 ;; completely uninteresting.
1422 (defun uninteresting-ordinary-function-redefinition-p (warning)
1423 ;; OAOO violation: this duplicates code in SB-INTROSPECT.
1424 ;; Additionally, there are some functions that aren't
1425 ;; funcallable-instances for which finding the source location is
1426 ;; complicated (e.g. DEFSTRUCT-defined predicates and accessors),
1427 ;; but I don't think they're defined with %DEFUN, so the warning
1429 (flet ((fdefinition-file-namestring (fdefn)
1431 (when (typep fdefn 'sb!eval:interpreted-function)
1432 (return-from fdefinition-file-namestring
1433 (sb!c:definition-source-location-namestring
1434 (sb!eval:interpreted-function-source-location fdefn))))
1435 ;; All the following accesses are guarded with conditionals
1436 ;; because it's not clear whether any of the slots we're
1437 ;; chasing down are guaranteed to be filled in.
1439 ;; KLUDGE: although this looks like it only works
1440 ;; for %SIMPLE-FUNs, in fact there's a pun such
1441 ;; that %SIMPLE-FUN-SELF returns the simple-fun
1442 ;; object for closures and
1443 ;; funcallable-instances. -- CSR, circa 2005
1444 (sb!kernel:%simple-fun-self fdefn))
1445 (code (if fdefn (sb!kernel:fun-code-header fdefn)))
1446 (debug-info (if code (sb!kernel:%code-debug-info code)))
1447 (debug-source (if debug-info
1448 (sb!c::debug-info-source debug-info)))
1449 (namestring (if debug-source
1450 (sb!c::debug-source-namestring debug-source))))
1453 ;; There's garbage in various places when the first DEFUN runs in
1455 sb!kernel::*cold-init-complete-p*
1456 (typep warning 'redefinition-with-defun)
1458 (function-redefinition-warning-old-fdefinition warning))
1460 (redefinition-with-defun-new-fdefinition warning)))
1461 ;; Replacing a compiled function with a compiled function is
1462 ;; clearly uninteresting, and we'll say arbitrarily that
1463 ;; replacing an interpreted function with an interpreted
1464 ;; function is uninteresting, too, but leave out the
1465 ;; compiled-to-interpreted case.
1468 '(or #!+sb-eval sb!eval:interpreted-function))
1469 (and (typep old-fdefn
1470 '(and compiled-function
1471 (not funcallable-instance)))
1472 ;; Since this is a REDEFINITION-WITH-DEFUN,
1473 ;; NEW-FDEFN can't be a FUNCALLABLE-INSTANCE.
1474 (typep new-fdefn 'compiled-function)))
1475 (let* ((old-namestring (fdefinition-file-namestring old-fdefn))
1477 (or (fdefinition-file-namestring new-fdefn)
1479 (redefinition-with-defun-new-location warning)))
1481 (sb!c::definition-source-location-namestring
1485 (equal old-namestring new-namestring))))))))
1487 (defun uninteresting-generic-function-redefinition-p (warning)
1488 (and (typep warning 'redefinition-with-defgeneric)
1490 (function-redefinition-warning-old-fdefinition warning))
1492 (if (typep old-fdefn 'generic-function)
1493 (sb!pcl::definition-source old-fdefn)))
1496 (sb!c:definition-source-location-namestring old-location)))
1498 (redefinition-with-defgeneric-new-location warning))
1501 (sb!c:definition-source-location-namestring new-location))))
1504 (equal old-namestring new-namestring)))))
1506 (defun uninteresting-method-redefinition-p (warning)
1507 (and (typep warning 'redefinition-with-defmethod)
1508 (let* ((old-method (redefinition-with-defmethod-old-method warning))
1509 (old-location (sb!pcl::definition-source old-method))
1510 (old-namestring (if old-location
1511 (sb!c:definition-source-location-namestring
1513 (new-location (redefinition-with-defmethod-new-location warning))
1514 (new-namestring (if new-location
1515 (sb!c:definition-source-location-namestring
1519 (equal new-namestring old-namestring)))))
1521 (deftype uninteresting-redefinition ()
1522 '(or (satisfies uninteresting-ordinary-function-redefinition-p)
1523 (satisfies uninteresting-generic-function-redefinition-p)
1524 (satisfies uninteresting-method-redefinition-p)))
1526 (define-condition redefinition-with-deftransform (redefinition-warning)
1527 ((transform :initarg :transform
1528 :reader redefinition-with-deftransform-transform))
1529 (:report (lambda (warning stream)
1530 (format stream "Overwriting ~S"
1531 (redefinition-with-deftransform-transform warning)))))
1533 ;;; Various other STYLE-WARNINGS
1534 (define-condition dubious-asterisks-around-variable-name
1535 (style-warning simple-condition)
1537 (:report (lambda (warning stream)
1538 (format stream "~@?, even though the name follows~@
1539 the usual naming convention (names like *FOO*) for special variables"
1540 (simple-condition-format-control warning)
1541 (simple-condition-format-arguments warning)))))
1543 (define-condition asterisks-around-lexical-variable-name
1544 (dubious-asterisks-around-variable-name)
1547 (define-condition asterisks-around-constant-variable-name
1548 (dubious-asterisks-around-variable-name)
1551 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1552 ;; subclasses of ERROR above having to do with undefined aliens.
1553 (define-condition undefined-alien-style-warning (style-warning)
1554 ((symbol :initarg :symbol :reader undefined-alien-symbol))
1555 (:report (lambda (warning stream)
1556 (format stream "Undefined alien: ~S"
1557 (undefined-alien-symbol warning)))))
1560 (define-condition lexical-environment-too-complex (style-warning)
1561 ((form :initarg :form :reader lexical-environment-too-complex-form)
1562 (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv))
1563 (:report (lambda (warning stream)
1565 "~@<Native lexical environment too complex for ~
1566 SB-EVAL to evaluate ~S, falling back to ~
1567 SIMPLE-EVAL-IN-LEXENV. Lexenv: ~S~:@>"
1568 (lexical-environment-too-complex-form warning)
1569 (lexical-environment-too-complex-lexenv warning)))))
1571 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1572 (define-condition character-decoding-error-in-comment (style-warning)
1573 ((stream :initarg :stream :reader decoding-error-in-comment-stream)
1574 (position :initarg :position :reader decoding-error-in-comment-position))
1575 (:report (lambda (warning stream)
1577 "Character decoding error in a ~A-comment at ~
1578 position ~A reading source stream ~A, ~
1580 (decoding-error-in-comment-macro warning)
1581 (decoding-error-in-comment-position warning)
1582 (decoding-error-in-comment-stream warning)))))
1584 (define-condition character-decoding-error-in-macro-char-comment
1585 (character-decoding-error-in-comment)
1586 ((char :initform #\; :initarg :char
1587 :reader character-decoding-error-in-macro-char-comment-char)))
1589 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1590 (character-decoding-error-in-comment)
1591 ;; ANSI doesn't give a way for a reader function invoked by a
1592 ;; dispatch macro character to determine which dispatch character
1593 ;; was used, so if a user wants to signal one of these from a custom
1594 ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1595 ((disp-char :initform #\# :initarg :disp-char
1596 :reader character-decoding-error-in-macro-char-comment-disp-char)
1597 (sub-char :initarg :sub-char
1598 :reader character-decoding-error-in-macro-char-comment-sub-char)))
1600 (defun decoding-error-in-comment-macro (warning)
1602 (character-decoding-error-in-macro-char-comment
1603 (character-decoding-error-in-macro-char-comment-char warning))
1604 (character-decoding-error-in-dispatch-macro-char-comment
1607 (character-decoding-error-in-macro-char-comment-disp-char warning)
1608 (character-decoding-error-in-macro-char-comment-sub-char warning)))))
1610 (define-condition deprecated-eval-when-situations (style-warning)
1611 ((situations :initarg :situations
1612 :reader deprecated-eval-when-situations-situations))
1613 (:report (lambda (warning stream)
1614 (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}"
1615 (deprecated-eval-when-situations-situations warning)))))
1617 (define-condition proclamation-mismatch (style-warning)
1618 ((name :initarg :name :reader proclamation-mismatch-name)
1619 (old :initarg :old :reader proclamation-mismatch-old)
1620 (new :initarg :new :reader proclamation-mismatch-new)))
1622 (define-condition type-proclamation-mismatch (proclamation-mismatch)
1624 (:report (lambda (warning stream)
1626 "The new TYPE proclamation~% ~S for ~S does not ~
1627 match the old TYPE proclamation ~S"
1628 (proclamation-mismatch-new warning)
1629 (proclamation-mismatch-name warning)
1630 (proclamation-mismatch-old warning)))))
1632 (define-condition ftype-proclamation-mismatch (proclamation-mismatch)
1634 (:report (lambda (warning stream)
1636 "The new FTYPE proclamation~% ~S for ~S does not ~
1637 match the old FTYPE proclamation ~S"
1638 (proclamation-mismatch-new warning)
1639 (proclamation-mismatch-name warning)
1640 (proclamation-mismatch-old warning)))))
1642 ;;;; restart definitions
1644 (define-condition abort-failure (control-error) ()
1646 "An ABORT restart was found that failed to transfer control dynamically."))
1648 (defun abort (&optional condition)
1650 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1652 (invoke-restart (find-restart-or-control-error 'abort condition))
1653 ;; ABORT signals an error in case there was a restart named ABORT
1654 ;; that did not transfer control dynamically. This could happen with
1656 (error 'abort-failure))
1658 (defun muffle-warning (&optional condition)
1660 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1661 CONTROL-ERROR if none exists."
1662 (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1664 (defun try-restart (name condition &rest arguments)
1665 (let ((restart (find-restart name condition)))
1667 (apply #'invoke-restart restart arguments))))
1669 (macrolet ((define-nil-returning-restart (name args doc)
1670 #!-sb-doc (declare (ignore doc))
1671 `(defun ,name (,@args &optional condition)
1673 (try-restart ',name condition ,@args))))
1674 (define-nil-returning-restart continue ()
1675 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1676 (define-nil-returning-restart store-value (value)
1677 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
1679 (define-nil-returning-restart use-value (value)
1680 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
1683 ;;; single-stepping restarts
1685 (macrolet ((def (name doc)
1686 #!-sb-doc (declare (ignore doc))
1687 `(defun ,name (condition)
1689 (invoke-restart (find-restart-or-control-error ',name condition)))))
1691 "Transfers control to the STEP-CONTINUE restart associated with
1692 the condition, continuing execution without stepping. Signals a
1693 CONTROL-ERROR if the restart does not exist.")
1695 "Transfers control to the STEP-NEXT restart associated with the
1696 condition, executing the current form without stepping and continuing
1697 stepping with the next form. Signals CONTROL-ERROR is the restart does
1700 "Transfers control to the STEP-INTO restart associated with the
1701 condition, stepping into the current form. Signals a CONTROL-ERROR is
1702 the restart does not exist."))
1704 (/show0 "condition.lisp end of file")