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 ;; the initform if :INITFORM was specified, otherwise NIL
72 (initform nil
:type t
)
73 ;; if this is a function, call it with no args to get the initform value
74 (initfunction (missing-arg) :type t
)
75 ;; allocation of this slot, or NIL until defaulted
76 (allocation nil
:type
(member :instance
:class nil
))
77 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value
78 (cell nil
:type
(or cons null
))
80 (documentation nil
:type
(or string null
)))
82 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
83 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
84 ;;; have themselves listed in their CPLs. This behavior is inherited
85 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
86 ;;; figured out whether it's right. -- WHN 19990612
87 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
88 (/show0
"condition.lisp 103")
89 (let ((condition-class (locally
90 ;; KLUDGE: There's a DEFTRANSFORM
91 ;; FIND-CLASSOID for constant class names
92 ;; which creates fast but
93 ;; non-cold-loadable, non-compact code. In
94 ;; this context, we'd rather have compact,
95 ;; cold-loadable code. -- WHN 19990928
96 (declare (notinline find-classoid
))
97 (find-classoid 'condition
))))
98 (setf (condition-classoid-cpl condition-class
)
99 (list condition-class
)))
100 (/show0
"condition.lisp 103"))
102 (setf (condition-classoid-report (locally
103 ;; KLUDGE: There's a DEFTRANSFORM
104 ;; FIND-CLASSOID for constant class
105 ;; names which creates fast but
106 ;; non-cold-loadable, non-compact
107 ;; code. In this context, we'd
108 ;; rather have compact,
109 ;; cold-loadable code. -- WHN
111 (declare (notinline find-classoid
))
112 (find-classoid 'condition
)))
113 (lambda (cond stream
)
114 (format stream
"Condition ~S was signalled." (type-of cond
))))
116 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
118 (defun find-condition-layout (name parent-types
)
119 (let* ((cpl (remove-duplicates
123 (condition-classoid-cpl
126 (cond-layout (info :type
:compiler-layout
'condition
))
127 (olayout (info :type
:compiler-layout name
))
128 ;; FIXME: Does this do the right thing in case of multiple
129 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
130 ;; it obvious what ANSI intends to be done in the case of
131 ;; multiple inheritance, so it's not actually clear what the
134 (order-layout-inherits (concatenate 'simple-vector
135 (layout-inherits cond-layout
)
136 (mapcar #'classoid-layout cpl
)))))
138 (not (mismatch (layout-inherits olayout
) new-inherits
)))
140 (make-layout :classoid
(make-undefined-classoid name
)
141 :inherits new-inherits
143 :length
(layout-length cond-layout
)))))
147 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
148 ;;; Condition reporting is mediated through the PRINT-OBJECT method
149 ;;; for the condition type in question, with *PRINT-ESCAPE* always
150 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
151 ;;; a condition type C is equivalent to:
152 ;;; (defmethod print-object ((x c) stream)
153 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
154 ;;; The current code doesn't seem to quite match that.
155 (def!method print-object
((x condition
) stream
)
157 (if (and (typep x
'simple-condition
) (slot-value x
'format-control
))
158 (print-unreadable-object (x stream
:type t
:identity t
)
159 (write (simple-condition-format-control x
)
162 (print-unreadable-object (x stream
:type t
:identity t
)))
163 ;; KLUDGE: A comment from CMU CL here said
164 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
165 ;; superclasses in define-condition call!
166 (dolist (class (condition-classoid-cpl (classoid-of x
))
167 (error "no REPORT? shouldn't happen!"))
168 (let ((report (condition-classoid-report class
)))
170 (return (funcall report x stream
)))))))
172 ;;;; slots of CONDITION objects
174 (defvar *empty-condition-slot
* '(empty))
176 (defun find-slot-default (class slot
)
177 (let ((initargs (condition-slot-initargs slot
))
178 (cpl (condition-classoid-cpl class
)))
179 ;; When CLASS or a superclass has a default initarg for SLOT, use
182 (let ((direct-default-initargs
183 (condition-classoid-direct-default-initargs class
)))
184 (dolist (initarg initargs
)
185 (let ((initfunction (third (assoc initarg direct-default-initargs
))))
187 (return-from find-slot-default
(funcall initfunction
)))))))
189 ;; Otherwise use the initform of SLOT, if there is one.
190 (if (condition-slot-initform-p slot
)
191 (let ((initfun (condition-slot-initfunction slot
)))
192 (aver (functionp initfun
))
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* ((classoid (if (symbolp type
)
241 (find-classoid type nil
)
243 (class (typecase classoid
244 (condition-classoid classoid
)
246 (return-from allocate-condition
247 (apply #'allocate-condition
(class-name classoid
) 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 (setf (condition-slot-initfunction found
)
369 (condition-slot-initfunction sslot
)))
370 (unless (condition-slot-allocation found
)
371 (setf (condition-slot-allocation found
)
372 (condition-slot-allocation sslot
))))
374 (res (copy-structure sslot
)))))))
377 ;;; Early definitions of slot accessor creators.
379 ;;; Slot accessors must be generic functions, but ANSI does not seem
380 ;;; to specify any of them, and we cannot support it before end of
381 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
382 ;;; GFs only at the end of building.
383 (declaim (notinline install-condition-slot-reader
384 install-condition-slot-writer
))
385 (defun install-condition-slot-reader (name condition slot-name
)
386 (declare (ignore condition
))
387 (setf (fdefinition name
)
389 (condition-reader-function condition slot-name
))))
390 (defun install-condition-slot-writer (name condition slot-name
)
391 (declare (ignore condition
))
392 (setf (fdefinition name
)
393 (lambda (new-value condition
)
394 (condition-writer-function condition new-value slot-name
))))
396 (defvar *define-condition-hooks
* nil
)
398 (defun %set-condition-report
(name report
)
399 (setf (condition-classoid-report (find-classoid name
))
402 (defun %define-condition
(name parent-types layout slots documentation
403 direct-default-initargs all-readers all-writers
405 (with-single-package-locked-error
406 (:symbol name
"defining ~A as a condition")
407 (%compiler-define-condition name parent-types layout all-readers all-writers
)
408 (sb!c
:with-source-location
(source-location)
409 (setf (layout-source-location layout
)
411 (let ((class (find-classoid name
)))
412 (setf (condition-classoid-slots class
) slots
413 (condition-classoid-direct-default-initargs class
) direct-default-initargs
414 (fdocumentation name
'type
) documentation
)
418 ;; Set up reader and writer functions.
419 (let ((slot-name (condition-slot-name slot
)))
420 (dolist (reader (condition-slot-readers slot
))
421 (install-condition-slot-reader reader name slot-name
))
422 (dolist (writer (condition-slot-writers slot
))
423 (install-condition-slot-writer writer name slot-name
))))
425 ;; Compute effective slots and set up the class and hairy slots
426 ;; (subsets of the effective slots.)
427 (setf (condition-classoid-hairy-slots class
) '())
428 (let ((eslots (compute-effective-slots class
))
431 (mapcar #'condition-classoid-direct-default-initargs
432 (condition-classoid-cpl class
)))))
433 (dolist (slot eslots
)
434 (ecase (condition-slot-allocation slot
)
436 (unless (condition-slot-cell slot
)
437 (setf (condition-slot-cell slot
)
438 (list (if (condition-slot-initform-p slot
)
439 (let ((initfun (condition-slot-initfunction slot
)))
440 (aver (functionp initfun
))
442 *empty-condition-slot
*))))
443 (push slot
(condition-classoid-class-slots class
)))
445 (setf (condition-slot-allocation slot
) :instance
)
446 ;; FIXME: isn't this "always hairy"?
447 (when (or (functionp (condition-slot-initfunction slot
))
448 (dolist (initarg (condition-slot-initargs slot
) nil
)
449 (when (functionp (third (assoc initarg e-def-initargs
)))
451 (push slot
(condition-classoid-hairy-slots class
)))))))
452 (when (boundp '*define-condition-hooks
*)
453 (dolist (fun *define-condition-hooks
*)
454 (funcall fun class
))))
457 (defmacro define-condition
(name (&rest parent-types
) (&rest slot-specs
)
460 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
461 Define NAME as a condition type. This new type inherits slots and its
462 report function from the specified PARENT-TYPEs. A slot spec is a list of:
463 (slot-name :reader <rname> :initarg <iname> {Option Value}*
465 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
466 and :TYPE and the overall options :DEFAULT-INITARGS and
467 [type] :DOCUMENTATION are also allowed.
469 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
470 a string or a two-argument lambda or function name. If a function, the
471 function is called with the condition and stream to report the condition.
472 If a string, the string is printed.
474 Condition types are classes, but (as allowed by ANSI and not as described in
475 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
476 SLOT-VALUE may not be used on condition objects."
477 (let* ((parent-types (or parent-types
'(condition)))
478 (layout (find-condition-layout name parent-types
))
481 (direct-default-initargs ()))
483 (all-readers nil append
)
484 (all-writers nil append
))
485 (dolist (spec slot-specs
)
486 (when (keywordp spec
)
487 (warn "Keyword slot name indicates probable syntax error:~% ~S"
489 (let* ((spec (if (consp spec
) spec
(list spec
)))
490 (slot-name (first spec
))
491 (allocation :instance
)
498 (do ((options (rest spec
) (cddr options
)))
500 (unless (and (consp options
) (consp (cdr options
)))
501 (error "malformed condition slot spec:~% ~S." spec
))
502 (let ((arg (second options
)))
503 (case (first options
)
504 (:reader
(readers arg
))
505 (:writer
(writers arg
))
508 (writers `(setf ,arg
)))
511 (error "more than one :INITFORM in ~S" spec
))
514 (:initarg
(initargs arg
))
516 (setq allocation arg
))
519 (error "more than one :DOCUMENTATION in ~S" spec
))
520 (unless (stringp arg
)
521 (error "slot :DOCUMENTATION argument is not a string: ~S"
523 (setq documentation arg
))
526 (error "unknown slot option:~% ~S" (first options
))))))
528 (all-readers (readers))
529 (all-writers (writers))
530 (slots `(make-condition-slot
532 :initargs
',(initargs)
535 :initform-p
',initform-p
536 :documentation
',documentation
537 :initform
,(when initform-p
`',initform
)
538 :initfunction
,(when initform-p
539 `#'(lambda () ,initform
))
540 :allocation
',allocation
)))))
542 (dolist (option options
)
543 (unless (consp option
)
544 (error "bad option:~% ~S" option
))
546 (:documentation
(setq documentation
(second option
)))
548 (let ((arg (second option
)))
551 `#'(lambda (condition stream
)
552 (declare (ignore condition
))
553 (write-string ,arg stream
))
554 `#'(lambda (condition stream
)
555 (funcall #',arg condition stream
))))))
557 (doplist (initarg initform
) (rest option
)
558 (push ``(,',initarg
,',initform
,#'(lambda () ,initform
))
559 direct-default-initargs
)))
561 (error "unknown option: ~S" (first option
)))))
564 (eval-when (:compile-toplevel
)
565 (%compiler-define-condition
',name
',parent-types
',layout
566 ',(all-readers) ',(all-writers)))
567 (%define-condition
',name
572 (list ,@direct-default-initargs
)
575 (sb!c
:source-location
))
576 ;; This needs to be after %DEFINE-CONDITION in case :REPORT
577 ;; is a lambda referring to condition slot accessors:
578 ;; they're not proclaimed as functions before it has run if
579 ;; we're under EVAL or loaded as source.
580 (%set-condition-report
',name
,report
)
583 ;;;; various CONDITIONs specified by ANSI
585 (define-condition serious-condition
(condition) ())
587 (define-condition error
(serious-condition) ())
589 (define-condition warning
(condition) ())
590 (define-condition style-warning
(warning) ())
592 (defun simple-condition-printer (condition stream
)
593 (let ((control (simple-condition-format-control condition
)))
595 (apply #'format stream
597 (simple-condition-format-arguments condition
))
598 (error "No format-control for ~S" condition
))))
600 (define-condition simple-condition
()
601 ((format-control :reader simple-condition-format-control
602 :initarg
:format-control
604 :type format-control
)
605 (format-arguments :reader simple-condition-format-arguments
606 :initarg
:format-arguments
609 (:report simple-condition-printer
))
611 (define-condition simple-warning
(simple-condition warning
) ())
613 (define-condition simple-error
(simple-condition error
) ())
615 (define-condition storage-condition
(serious-condition) ())
617 (define-condition type-error
(error)
618 ((datum :reader type-error-datum
:initarg
:datum
)
619 (expected-type :reader type-error-expected-type
:initarg
:expected-type
))
621 (lambda (condition stream
)
623 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
624 (type-error-datum condition
)
625 (type-error-expected-type condition
)))))
627 (def!method print-object
((condition type-error
) stream
)
628 (if (and *print-escape
*
629 (slot-boundp condition
'expected-type
)
630 (slot-boundp condition
'datum
))
631 (flet ((maybe-string (thing)
633 (write-to-string thing
:lines
1 :readably nil
:array nil
:pretty t
))))
634 (let ((type (maybe-string (type-error-expected-type condition
)))
635 (datum (maybe-string (type-error-datum condition
))))
637 (print-unreadable-object (condition stream
:type t
)
638 (format stream
"~@<expected-type: ~A ~_datum: ~A~:@>" type datum
))
639 (call-next-method))))
642 ;;; not specified by ANSI, but too useful not to have around.
643 (define-condition simple-style-warning
(simple-condition style-warning
) ())
644 (define-condition simple-type-error
(simple-condition type-error
) ())
646 ;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR...
647 (declaim (ftype (sfunction (t t t
&rest t
) nil
) bad-type
))
648 (defun bad-type (datum type control
&rest arguments
)
649 (error 'simple-type-error
652 :format-control control
653 :format-arguments arguments
))
655 (define-condition program-error
(error) ())
656 (define-condition parse-error
(error) ())
657 (define-condition control-error
(error) ())
658 (define-condition stream-error
(error)
659 ((stream :reader stream-error-stream
:initarg
:stream
)))
661 (define-condition end-of-file
(stream-error) ()
663 (lambda (condition stream
)
666 (stream-error-stream condition
)))))
668 (define-condition closed-stream-error
(stream-error) ()
670 (lambda (condition stream
)
671 (format stream
"~S is closed" (stream-error-stream condition
)))))
673 (define-condition file-error
(error)
674 ((pathname :reader file-error-pathname
:initarg
:pathname
))
676 (lambda (condition stream
)
677 (format stream
"error on file ~S" (file-error-pathname condition
)))))
679 (define-condition package-error
(error)
680 ((package :reader package-error-package
:initarg
:package
)))
682 (define-condition cell-error
(error)
683 ((name :reader cell-error-name
:initarg
:name
)))
685 (def!method print-object
((condition cell-error
) stream
)
686 (if (and *print-escape
* (slot-boundp condition
'name
))
687 (print-unreadable-object (condition stream
:type t
:identity t
)
688 (princ (cell-error-name condition
) stream
))
691 (define-condition unbound-variable
(cell-error) ()
693 (lambda (condition stream
)
695 "The variable ~S is unbound."
696 (cell-error-name condition
)))))
698 (define-condition undefined-function
(cell-error) ()
700 (lambda (condition stream
)
701 (let ((*package
* (find-package :keyword
)))
703 "The function ~S is undefined."
704 (cell-error-name condition
))))))
706 (define-condition special-form-function
(undefined-function) ()
708 (lambda (condition stream
)
710 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
711 (cell-error-name condition
)))))
713 (define-condition arithmetic-error
(error)
714 ((operation :reader arithmetic-error-operation
717 (operands :reader arithmetic-error-operands
719 (:report
(lambda (condition stream
)
721 "arithmetic error ~S signalled"
723 (when (arithmetic-error-operation condition
)
725 "~%Operation was ~S, operands ~S."
726 (arithmetic-error-operation condition
)
727 (arithmetic-error-operands condition
))))))
729 (define-condition division-by-zero
(arithmetic-error) ())
730 (define-condition floating-point-overflow
(arithmetic-error) ())
731 (define-condition floating-point-underflow
(arithmetic-error) ())
732 (define-condition floating-point-inexact
(arithmetic-error) ())
733 (define-condition floating-point-invalid-operation
(arithmetic-error) ())
735 (define-condition print-not-readable
(error)
736 ((object :reader print-not-readable-object
:initarg
:object
))
738 (lambda (condition stream
)
739 (let ((obj (print-not-readable-object condition
))
741 (format stream
"~S cannot be printed readably." obj
)))))
743 (define-condition reader-error
(parse-error stream-error
) ()
744 (:report
(lambda (condition stream
)
745 (%report-reader-error condition stream
))))
747 ;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
748 ;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
749 ;;; within SBCL itself)
751 ;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
752 ;;; the letter of the ANSI spec: this is not a condition signalled by
753 ;;; SIGNAL when a format-control is supplied by the function's first
754 ;;; argument. It seems to me (WHN) to be basically in the spirit of
755 ;;; the spec, but if not, it'd be straightforward to do our own
756 ;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
757 ;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
758 ;;; place of CL:SIMPLE-CONDITION here.)
759 (define-condition simple-reader-error
(reader-error simple-condition
)
761 (:report
(lambda (condition stream
)
762 (%report-reader-error condition stream
:simple t
))))
764 ;;; base REPORTing of a READER-ERROR
766 ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
767 ;;; and FORMAT-ARGS slots.
768 (defun %report-reader-error
(condition stream
&key simple position
)
769 (let ((error-stream (stream-error-stream condition
)))
770 (pprint-logical-block (stream nil
)
772 (apply #'format stream
773 (simple-condition-format-control condition
)
774 (simple-condition-format-arguments condition
))
775 (prin1 (class-name (class-of condition
)) stream
))
776 (format stream
"~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S"
777 (stream-error-position-info error-stream position
)
780 ;;;; special SBCL extension conditions
782 ;;; an error apparently caused by a bug in SBCL itself
784 ;;; Note that we don't make any serious effort to use this condition
785 ;;; for *all* errors in SBCL itself. E.g. type errors and array
786 ;;; indexing errors can occur in functions called from SBCL code, and
787 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
788 ;;; because the signalling code has no good way to know that the
789 ;;; underlying problem is a bug in SBCL. But in the fairly common case
790 ;;; that the signalling code does know that it's found a bug in SBCL,
791 ;;; this condition is appropriate, reusing boilerplate and helping
792 ;;; users to recognize it as an SBCL bug.
793 (define-condition bug
(simple-error)
796 (lambda (condition stream
)
799 (simple-condition-format-control condition
)
800 (simple-condition-format-arguments condition
)
801 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
802 SBCL might have been corrupted by bad user code, e.g. by an ~
803 undefined Lisp operation like ~S, or by stray pointers from ~
804 alien code or from unsafe Lisp code; or there might be a bug ~
805 in the OS or hardware that SBCL is running on.) If it seems to ~
806 be a bug in SBCL itself, the maintainers would like to know ~
807 about it. Bug reports are welcome on the SBCL ~
808 mailing lists, which you can find at ~
809 <http://sbcl.sourceforge.net/>.~:@>"
810 '((fmakunbound 'compile
))))))
812 (define-condition simple-storage-condition
(storage-condition simple-condition
)
815 ;;; a condition for use in stubs for operations which aren't supported
816 ;;; on some platforms
818 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
819 ;;; #-(or freebsd linux)
820 ;;; (defun load-foreign (&rest rest)
821 ;;; (error 'unsupported-operator :name 'load-foreign))
822 ;;; #+(or freebsd linux)
823 ;;; (defun load-foreign ... actual definition ...)
824 ;;; By signalling a standard condition in this case, we make it
825 ;;; possible for test code to distinguish between (1) intentionally
826 ;;; unimplemented and (2) unintentionally just screwed up somehow.
827 ;;; (Before this condition was defined, test code tried to deal with
828 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
829 ;;; sbcl-0.7.0, a package screwup left the definition of
830 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
831 ;;; architectures where it was supposed to be supported, and the
832 ;;; regression tests cheerfully passed because they assumed that
833 ;;; unFBOUNDPness meant they were running on an system which didn't
834 ;;; support the extension.)
835 (define-condition unsupported-operator
(simple-error) ())
837 ;;; (:ansi-cl :function remove)
838 ;;; (:ansi-cl :section (a b c))
839 ;;; (:ansi-cl :glossary "similar")
841 ;;; (:sbcl :node "...")
842 ;;; (:sbcl :variable *ed-functions*)
844 ;;; FIXME: this is not the right place for this.
845 (defun print-reference (reference stream
)
846 (ecase (car reference
)
848 (format stream
"AMOP")
850 (destructuring-bind (type data
) (cdr reference
)
852 (:readers
"Readers for ~:(~A~) Metaobjects"
853 (substitute #\
#\-
(symbol-name data
)))
855 (format stream
"Initialization of ~:(~A~) Metaobjects"
856 (substitute #\
#\-
(symbol-name data
))))
857 (:generic-function
(format stream
"Generic Function ~S" data
))
858 (:function
(format stream
"Function ~S" data
))
859 (:section
(format stream
"Section ~{~D~^.~}" data
)))))
861 (format stream
"The ANSI Standard")
863 (destructuring-bind (type data
) (cdr reference
)
865 (:function
(format stream
"Function ~S" data
))
866 (:special-operator
(format stream
"Special Operator ~S" data
))
867 (:macro
(format stream
"Macro ~S" data
))
868 (:section
(format stream
"Section ~{~D~^.~}" data
))
869 (:glossary
(format stream
"Glossary entry for ~S" data
))
870 (:type
(format stream
"Type ~S" data
))
871 (:system-class
(format stream
"System Class ~S" data
))
872 (:issue
(format stream
"writeup for Issue ~A" data
)))))
874 (format stream
"The SBCL Manual")
876 (destructuring-bind (type data
) (cdr reference
)
878 (:node
(format stream
"Node ~S" data
))
879 (:variable
(format stream
"Variable ~S" data
))
880 (:function
(format stream
"Function ~S" data
)))))
881 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
883 (define-condition reference-condition
()
884 ((references :initarg
:references
:reader reference-condition-references
)))
885 (defvar *print-condition-references
* t
)
886 (def!method print-object
:around
((o reference-condition
) s
)
888 (unless (or *print-escape
* *print-readably
*)
889 (when (and *print-condition-references
*
890 (reference-condition-references o
))
891 (format s
"~&See also:~%")
892 (pprint-logical-block (s nil
:per-line-prefix
" ")
893 (do* ((rs (reference-condition-references o
) (cdr rs
))
894 (r (car rs
) (car rs
)))
896 (print-reference r s
)
897 (unless (null (cdr rs
))
900 (define-condition simple-reference-error
(reference-condition simple-error
)
903 (define-condition simple-reference-warning
(reference-condition simple-warning
)
906 (define-condition arguments-out-of-domain-error
907 (arithmetic-error reference-condition
)
910 (define-condition duplicate-definition
(reference-condition warning
)
911 ((name :initarg
:name
:reader duplicate-definition-name
))
912 (:report
(lambda (c s
)
913 (format s
"~@<Duplicate definition for ~S found in ~
915 (duplicate-definition-name c
))))
916 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
918 (define-condition constant-modified
(reference-condition warning
)
919 ((fun-name :initarg
:fun-name
:reader constant-modified-fun-name
))
920 (:report
(lambda (c s
)
921 (format s
"~@<Destructive function ~S called on ~
923 (constant-modified-fun-name c
))))
924 (:default-initargs
:references
(list '(:ansi-cl
:special-operator quote
)
925 '(:ansi-cl
:section
(3 2 2 3)))))
927 (define-condition package-at-variance
(reference-condition simple-warning
)
929 (:default-initargs
:references
(list '(:ansi-cl
:macro defpackage
)
930 '(:sbcl
:variable
*on-package-variance
*))))
932 (define-condition package-at-variance-error
(reference-condition simple-condition
935 (:default-initargs
:references
(list '(:ansi-cl
:macro defpackage
))))
937 (define-condition defconstant-uneql
(reference-condition error
)
938 ((name :initarg
:name
:reader defconstant-uneql-name
)
939 (old-value :initarg
:old-value
:reader defconstant-uneql-old-value
)
940 (new-value :initarg
:new-value
:reader defconstant-uneql-new-value
))
942 (lambda (condition stream
)
944 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
945 (defconstant-uneql-name condition
)
946 (defconstant-uneql-old-value condition
)
947 (defconstant-uneql-new-value condition
))))
948 (:default-initargs
:references
(list '(:ansi-cl
:macro defconstant
)
949 '(:sbcl
:node
"Idiosyncrasies"))))
951 (define-condition array-initial-element-mismatch
952 (reference-condition simple-warning
)
956 '(:ansi-cl
:function make-array
)
957 '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
))))
959 (define-condition type-warning
(reference-condition simple-warning
)
961 (:default-initargs
:references
(list '(:sbcl
:node
"Handling of Types"))))
962 (define-condition type-style-warning
(reference-condition simple-style-warning
)
964 (:default-initargs
:references
(list '(:sbcl
:node
"Handling of Types"))))
966 (define-condition local-argument-mismatch
(reference-condition simple-warning
)
968 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
970 (define-condition format-args-mismatch
(reference-condition)
972 (:default-initargs
:references
(list '(:ansi-cl
:section
(22 3 10 2)))))
974 (define-condition format-too-few-args-warning
975 (format-args-mismatch simple-warning
)
977 (define-condition format-too-many-args-warning
978 (format-args-mismatch simple-style-warning
)
981 (define-condition implicit-generic-function-warning
(style-warning)
982 ((name :initarg
:name
:reader implicit-generic-function-name
))
984 (lambda (condition stream
)
985 (format stream
"~@<Implicitly creating new generic function ~
986 ~/sb-impl::print-symbol-with-prefix/.~:@>"
987 (implicit-generic-function-name condition
)))))
989 (define-condition extension-failure
(reference-condition simple-error
)
992 (define-condition structure-initarg-not-keyword
993 (reference-condition simple-style-warning
)
995 (:default-initargs
:references
(list '(:ansi-cl
:section
(2 4 8 13)))))
1000 (define-condition package-lock-violation
(package-error
1003 ((current-package :initform
*package
*
1004 :reader package-lock-violation-in-package
))
1006 (lambda (condition stream
)
1007 (let ((control (simple-condition-format-control condition
))
1008 (error-package (package-name
1009 (package-error-package condition
)))
1010 (current-package (package-name
1011 (package-lock-violation-in-package condition
))))
1012 (format stream
"~@<Lock on package ~A violated~@[~{ when ~?~}~] ~
1013 while in package ~A.~:@>"
1016 (list control
(simple-condition-format-arguments condition
)))
1018 ;; no :default-initargs -- reference-stuff provided by the
1019 ;; signalling form in target-package.lisp
1022 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
1023 when a package-lock is violated."))
1025 (define-condition package-locked-error
(package-lock-violation) ()
1028 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1029 signalled when an operation on a package violates a package lock."))
1031 (define-condition symbol-package-locked-error
(package-lock-violation)
1032 ((symbol :initarg
:symbol
:reader package-locked-error-symbol
))
1035 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
1036 signalled when an operation on a symbol violates a package lock. The
1037 symbol that caused the violation is accessed by the function
1038 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
1042 (define-condition undefined-alien-error
(cell-error) ()
1044 (lambda (condition stream
)
1045 (if (slot-boundp condition
'name
)
1046 (format stream
"Undefined alien: ~S" (cell-error-name condition
))
1047 (format stream
"Undefined alien symbol.")))))
1049 (define-condition undefined-alien-variable-error
(undefined-alien-error) ()
1051 (lambda (condition stream
)
1052 (declare (ignore condition
))
1053 (format stream
"Attempt to access an undefined alien variable."))))
1055 (define-condition undefined-alien-function-error
(undefined-alien-error) ()
1057 (lambda (condition stream
)
1058 (if (and (slot-boundp condition
'name
)
1059 (cell-error-name condition
))
1060 (format stream
"The alien function ~s is undefined."
1061 (cell-error-name condition
))
1062 (format stream
"Attempt to call an undefined alien function.")))))
1065 ;;;; various other (not specified by ANSI) CONDITIONs
1067 ;;;; These might logically belong in other files; they're here, after
1068 ;;;; setup of CONDITION machinery, only because that makes it easier to
1069 ;;;; get cold init to work.
1071 ;;; OAOOM warning: see cross-condition.lisp
1072 (define-condition encapsulated-condition
(condition)
1073 ((condition :initarg
:condition
:reader encapsulated-condition
)))
1075 ;;; KLUDGE: a condition for floating point errors when we can't or
1076 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
1077 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
1078 ;;; know how but the old code was broken by the conversion to POSIX
1079 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
1081 ;;; FIXME: Perhaps this should also be a base class for all
1082 ;;; floating point exceptions?
1083 (define-condition floating-point-exception
(arithmetic-error)
1084 ((flags :initarg
:traps
1086 :reader floating-point-exception-traps
))
1087 (:report
(lambda (condition stream
)
1089 "An arithmetic error ~S was signalled.~%"
1090 (type-of condition
))
1091 (let ((traps (floating-point-exception-traps condition
)))
1094 "Trapping conditions are: ~%~{ ~S~^~}~%"
1097 "No traps are enabled? How can this be?"
1100 (define-condition invalid-array-index-error
(type-error)
1101 ((array :initarg
:array
:reader invalid-array-index-error-array
)
1102 (axis :initarg
:axis
:reader invalid-array-index-error-axis
))
1104 (lambda (condition stream
)
1105 (let ((array (invalid-array-index-error-array condition
)))
1106 (format stream
"Index ~W out of bounds for ~@[axis ~W of ~]~S, ~
1107 should be nonnegative and <~W."
1108 (type-error-datum condition
)
1109 (when (> (array-rank array
) 1)
1110 (invalid-array-index-error-axis condition
))
1112 ;; Extract the bound from (INTEGER 0 (BOUND))
1113 (caaddr (type-error-expected-type condition
)))))))
1115 (define-condition invalid-array-error
(reference-condition type-error
) ()
1117 (lambda (condition stream
)
1118 (let ((*print-array
* nil
))
1120 "~@<Displaced array originally of type ~S has been invalidated ~
1121 due its displaced-to array ~S having become too small to hold ~
1122 it: the displaced array's dimensions have all been set to zero ~
1123 to trap accesses to it.~:@>"
1124 (type-error-expected-type condition
)
1125 (array-displacement (type-error-datum condition
))))))
1128 (list '(:ansi-cl
:function adjust-array
))))
1130 (define-condition index-too-large-error
(type-error)
1133 (lambda (condition stream
)
1135 "The index ~S is too large."
1136 (type-error-datum condition
)))))
1138 (define-condition bounding-indices-bad-error
(reference-condition type-error
)
1139 ((object :reader bounding-indices-bad-object
:initarg
:object
))
1141 (lambda (condition stream
)
1142 (let* ((datum (type-error-datum condition
))
1145 (object (bounding-indices-bad-object condition
)))
1149 "The bounding indices ~S and ~S are bad ~
1150 for a sequence of length ~S."
1151 start end
(length object
)))
1153 ;; from WITH-ARRAY-DATA
1155 "The START and END parameters ~S and ~S are ~
1156 bad for an array of total size ~S."
1157 start end
(array-total-size object
)))))))
1160 (list '(:ansi-cl
:glossary
"bounding index designator")
1161 '(:ansi-cl
:issue
"SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1163 (define-condition nil-array-accessed-error
(reference-condition type-error
)
1165 (:report
(lambda (condition stream
)
1166 (declare (ignore condition
))
1168 "An attempt to access an array of element-type ~
1169 NIL was made. Congratulations!")))
1171 :references
(list '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
)
1172 '(:ansi-cl
:section
(15 1 2 1))
1173 '(:ansi-cl
:section
(15 1 2 2)))))
1175 (define-condition namestring-parse-error
(parse-error)
1176 ((complaint :reader namestring-parse-error-complaint
:initarg
:complaint
)
1177 (args :reader namestring-parse-error-args
:initarg
:args
:initform nil
)
1178 (namestring :reader namestring-parse-error-namestring
:initarg
:namestring
)
1179 (offset :reader namestring-parse-error-offset
:initarg
:offset
))
1181 (lambda (condition stream
)
1183 "parse error in namestring: ~?~% ~A~% ~V@T^"
1184 (namestring-parse-error-complaint condition
)
1185 (namestring-parse-error-args condition
)
1186 (namestring-parse-error-namestring condition
)
1187 (namestring-parse-error-offset condition
)))))
1189 (define-condition simple-package-error
(simple-condition package-error
) ())
1191 (define-condition simple-reader-package-error
(simple-reader-error package-error
) ())
1193 (define-condition reader-eof-error
(end-of-file)
1194 ((context :reader reader-eof-error-context
:initarg
:context
))
1196 (lambda (condition stream
)
1198 "unexpected end of file on ~S ~A"
1199 (stream-error-stream condition
)
1200 (reader-eof-error-context condition
)))))
1202 (define-condition reader-impossible-number-error
(simple-reader-error)
1203 ((error :reader reader-impossible-number-error-error
:initarg
:error
))
1205 (lambda (condition stream
)
1206 (let ((error-stream (stream-error-stream condition
)))
1208 "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1209 (file-position-or-nil-for-error error-stream
) error-stream
1210 (simple-condition-format-control condition
)
1211 (simple-condition-format-arguments condition
)
1212 (reader-impossible-number-error-error condition
))))))
1214 (define-condition standard-readtable-modified-error
(reference-condition error
)
1215 ((operation :initarg
:operation
:reader standard-readtable-modified-operation
))
1216 (:report
(lambda (condition stream
)
1217 (format stream
"~S would modify the standard readtable."
1218 (standard-readtable-modified-operation condition
))))
1219 (:default-initargs
:references
`((:ansi-cl
:section
(2 1 1 2))
1220 (:ansi-cl
:glossary
"standard readtable"))))
1222 (define-condition standard-pprint-dispatch-table-modified-error
1223 (reference-condition error
)
1224 ((operation :initarg
:operation
1225 :reader standard-pprint-dispatch-table-modified-operation
))
1226 (:report
(lambda (condition stream
)
1227 (format stream
"~S would modify the standard pprint dispatch table."
1228 (standard-pprint-dispatch-table-modified-operation
1231 :references
`((:ansi-cl
:glossary
"standard pprint dispatch table"))))
1233 (define-condition timeout
(serious-condition)
1234 ((seconds :initarg
:seconds
:initform nil
:reader timeout-seconds
))
1235 (:report
(lambda (condition stream
)
1236 (format stream
"Timeout occurred~@[ after ~A seconds~]."
1237 (timeout-seconds condition
)))))
1239 (define-condition io-timeout
(stream-error timeout
)
1240 ((direction :reader io-timeout-direction
:initarg
:direction
))
1242 (lambda (condition stream
)
1243 (declare (type stream stream
))
1245 "I/O timeout while doing ~(~A~) on ~S."
1246 (io-timeout-direction condition
)
1247 (stream-error-stream condition
)))))
1249 (define-condition deadline-timeout
(timeout) ()
1250 (:report
(lambda (condition stream
)
1251 (format stream
"A deadline was reached after ~A seconds."
1252 (timeout-seconds condition
)))))
1254 (define-condition declaration-type-conflict-error
(reference-condition
1258 :format-control
"symbol ~S cannot be both the name of a type and the name of a declaration"
1259 :references
(list '(:ansi-cl
:section
(3 8 21)))))
1261 ;;; Single stepping conditions
1263 (define-condition step-condition
()
1264 ((form :initarg
:form
:reader step-condition-form
))
1267 (:documentation
"Common base class of single-stepping conditions.
1268 STEP-CONDITION-FORM holds a string representation of the form being
1272 (setf (fdocumentation 'step-condition-form
'function
)
1273 "Form associated with the STEP-CONDITION.")
1275 (define-condition step-form-condition
(step-condition)
1276 ((args :initarg
:args
:reader step-condition-args
))
1278 (lambda (condition stream
)
1279 (let ((*print-circle
* t
)
1281 (*print-readably
* nil
))
1283 "Evaluating call:~%~< ~@;~A~:>~%~
1284 ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%"
1285 (list (step-condition-form condition
))
1286 (eq (step-condition-args condition
) :unknown
)
1287 (step-condition-args condition
)))))
1289 (:documentation
"Condition signalled by code compiled with
1290 single-stepping information when about to execute a form.
1291 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1292 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1293 holds the source-path to the original form within that file or NIL.
1294 Associated with this condition are always the restarts STEP-INTO,
1295 STEP-NEXT, and STEP-CONTINUE."))
1297 (define-condition step-result-condition
(step-condition)
1298 ((result :initarg
:result
:reader step-condition-result
)))
1301 (setf (fdocumentation 'step-condition-result
'function
)
1302 "Return values associated with STEP-VALUES-CONDITION as a list,
1303 or the variable value associated with STEP-VARIABLE-CONDITION.")
1305 (define-condition step-values-condition
(step-result-condition)
1308 (:documentation
"Condition signalled by code compiled with
1309 single-stepping information after executing a form.
1310 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1311 the values returned by the form as a list. No associated restarts."))
1313 (define-condition step-finished-condition
(step-condition)
1316 (lambda (condition stream
)
1317 (declare (ignore condition
))
1318 (format stream
"Returning from STEP")))
1320 (:documentation
"Condition signaled when STEP returns."))
1322 ;;; A knob for muffling warnings, mostly for use while loading files.
1323 (defvar *muffled-warnings
* 'uninteresting-redefinition
1325 "A type that ought to specify a subtype of WARNING. Whenever a
1326 warning is signaled, if the warning if of this type and is not
1327 handled by any other handler, it will be muffled.")
1329 ;;; Various STYLE-WARNING signaled in the system.
1330 ;; For the moment, we're only getting into the details for function
1331 ;; redefinitions, but other redefinitions could be done later
1333 (define-condition redefinition-warning
(style-warning)
1336 :reader redefinition-warning-name
)
1338 :initarg
:new-location
1339 :reader redefinition-warning-new-location
)))
1341 (define-condition function-redefinition-warning
(redefinition-warning)
1343 :initarg
:new-function
1344 :reader function-redefinition-warning-new-function
)))
1346 (define-condition redefinition-with-defun
(function-redefinition-warning)
1348 (:report
(lambda (warning stream
)
1349 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1351 (redefinition-warning-name warning
)))))
1353 (define-condition redefinition-with-defmacro
(function-redefinition-warning)
1355 (:report
(lambda (warning stream
)
1356 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1358 (redefinition-warning-name warning
)))))
1360 (define-condition redefinition-with-defgeneric
(redefinition-warning)
1362 (:report
(lambda (warning stream
)
1363 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1365 (redefinition-warning-name warning
)))))
1367 (define-condition redefinition-with-defmethod
(redefinition-warning)
1368 ((qualifiers :initarg
:qualifiers
1369 :reader redefinition-with-defmethod-qualifiers
)
1370 (specializers :initarg
:specializers
1371 :reader redefinition-with-defmethod-specializers
)
1372 (new-location :initarg
:new-location
1373 :reader redefinition-with-defmethod-new-location
)
1374 (old-method :initarg
:old-method
1375 :reader redefinition-with-defmethod-old-method
))
1376 (:report
(lambda (warning stream
)
1377 (format stream
"redefining ~S~{ ~S~} ~S in DEFMETHOD"
1378 (redefinition-warning-name warning
)
1379 (redefinition-with-defmethod-qualifiers warning
)
1380 (redefinition-with-defmethod-specializers warning
)))))
1382 ;;;; Deciding which redefinitions are "interesting".
1384 (defun function-file-namestring (function)
1386 (when (typep function
'sb
!eval
:interpreted-function
)
1387 (return-from function-file-namestring
1388 (sb!c
:definition-source-location-namestring
1389 (sb!eval
:interpreted-function-source-location function
))))
1390 (let* ((fun (%fun-fun function
))
1391 (code (fun-code-header fun
))
1392 (debug-info (%code-debug-info code
))
1393 (debug-source (when debug-info
1394 (sb!c
::debug-info-source debug-info
)))
1395 (namestring (when debug-source
1396 (sb!c
::debug-source-namestring debug-source
))))
1399 (defun interesting-function-redefinition-warning-p (warning old
)
1400 (let ((new (function-redefinition-warning-new-function warning
))
1401 (source-location (redefinition-warning-new-location warning
)))
1403 ;; compiled->interpreted is interesting.
1404 (and (typep old
'compiled-function
)
1405 (typep new
'(not compiled-function
)))
1406 ;; fin->regular is interesting except for interpreted->compiled.
1407 (and (typep old
'(and funcallable-instance
1408 #!+sb-eval
(not sb
!eval
:interpreted-function
)))
1409 (typep new
'(not funcallable-instance
)))
1410 ;; different file or unknown location is interesting.
1411 (let* ((old-namestring (function-file-namestring old
))
1413 (or (function-file-namestring new
)
1414 (when source-location
1415 (sb!c
::definition-source-location-namestring source-location
)))))
1416 (and (or (not old-namestring
)
1417 (not new-namestring
)
1418 (not (string= old-namestring new-namestring
))))))))
1420 (defun uninteresting-ordinary-function-redefinition-p (warning)
1422 ;; There's garbage in various places when the first DEFUN runs in
1424 *cold-init-complete-p
*
1425 (typep warning
'redefinition-with-defun
)
1427 (let ((name (redefinition-warning-name warning
)))
1428 (not (interesting-function-redefinition-warning-p
1429 warning
(or (fdefinition name
) (macro-function name
)))))))
1431 (defun uninteresting-macro-redefinition-p (warning)
1433 (typep warning
'redefinition-with-defmacro
)
1435 (let ((name (redefinition-warning-name warning
)))
1436 (not (interesting-function-redefinition-warning-p
1437 warning
(or (macro-function name
) (fdefinition name
)))))))
1439 (defun uninteresting-generic-function-redefinition-p (warning)
1441 (typep warning
'redefinition-with-defgeneric
)
1442 ;; Can't use the shared logic above, since GF's don't get a "new"
1443 ;; definition -- rather the FIN-FUNCTION is set.
1444 (let* ((name (redefinition-warning-name warning
))
1445 (old (fdefinition name
))
1446 (old-location (when (typep old
'generic-function
)
1447 (sb!pcl
::definition-source old
)))
1448 (old-namestring (when old-location
1449 (sb!c
:definition-source-location-namestring old-location
)))
1450 (new-location (redefinition-warning-new-location warning
))
1451 (new-namestring (when new-location
1452 (sb!c
:definition-source-location-namestring new-location
))))
1455 (string= old-namestring new-namestring
)))))
1457 (defun uninteresting-method-redefinition-p (warning)
1459 (typep warning
'redefinition-with-defmethod
)
1460 ;; Can't use the shared logic above, since GF's don't get a "new"
1461 ;; definition -- rather the FIN-FUNCTION is set.
1462 (let* ((old-method (redefinition-with-defmethod-old-method warning
))
1463 (old-location (sb!pcl
::definition-source old-method
))
1464 (old-namestring (when old-location
1465 (sb!c
:definition-source-location-namestring old-location
)))
1466 (new-location (redefinition-warning-new-location warning
))
1467 (new-namestring (when new-location
1468 (sb!c
:definition-source-location-namestring new-location
))))
1471 (string= new-namestring old-namestring
)))))
1473 (deftype uninteresting-redefinition
()
1474 '(or (satisfies uninteresting-ordinary-function-redefinition-p
)
1475 (satisfies uninteresting-macro-redefinition-p
)
1476 (satisfies uninteresting-generic-function-redefinition-p
)
1477 (satisfies uninteresting-method-redefinition-p
)))
1479 (define-condition redefinition-with-deftransform
(redefinition-warning)
1480 ((transform :initarg
:transform
1481 :reader redefinition-with-deftransform-transform
))
1482 (:report
(lambda (warning stream
)
1483 (format stream
"Overwriting ~S"
1484 (redefinition-with-deftransform-transform warning
)))))
1486 ;;; Various other STYLE-WARNINGS
1487 (define-condition dubious-asterisks-around-variable-name
1488 (style-warning simple-condition
)
1490 (:report
(lambda (warning stream
)
1491 (format stream
"~@?, even though the name follows~@
1492 the usual naming convention (names like *FOO*) for special variables"
1493 (simple-condition-format-control warning
)
1494 (simple-condition-format-arguments warning
)))))
1496 (define-condition asterisks-around-lexical-variable-name
1497 (dubious-asterisks-around-variable-name)
1500 (define-condition asterisks-around-constant-variable-name
1501 (dubious-asterisks-around-variable-name)
1504 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1505 ;; subclasses of ERROR above having to do with undefined aliens.
1506 (define-condition undefined-alien-style-warning
(style-warning)
1507 ((symbol :initarg
:symbol
:reader undefined-alien-symbol
))
1508 (:report
(lambda (warning stream
)
1509 (format stream
"Undefined alien: ~S"
1510 (undefined-alien-symbol warning
)))))
1513 (define-condition lexical-environment-too-complex
(style-warning)
1514 ((form :initarg
:form
:reader lexical-environment-too-complex-form
)
1515 (lexenv :initarg
:lexenv
:reader lexical-environment-too-complex-lexenv
))
1516 (:report
(lambda (warning stream
)
1518 "~@<Native lexical environment too complex for ~
1519 SB-EVAL to evaluate ~S, falling back to ~
1520 SIMPLE-EVAL-IN-LEXENV. Lexenv: ~S~:@>"
1521 (lexical-environment-too-complex-form warning
)
1522 (lexical-environment-too-complex-lexenv warning
)))))
1524 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1525 (define-condition character-decoding-error-in-comment
(style-warning)
1526 ((stream :initarg
:stream
:reader decoding-error-in-comment-stream
)
1527 (position :initarg
:position
:reader decoding-error-in-comment-position
))
1528 (:report
(lambda (warning stream
)
1530 "Character decoding error in a ~A-comment at ~
1531 position ~A reading source stream ~A, ~
1533 (decoding-error-in-comment-macro warning
)
1534 (decoding-error-in-comment-position warning
)
1535 (decoding-error-in-comment-stream warning
)))))
1537 (define-condition character-decoding-error-in-macro-char-comment
1538 (character-decoding-error-in-comment)
1539 ((char :initform
#\
; :initarg :char
1540 :reader character-decoding-error-in-macro-char-comment-char
)))
1542 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1543 (character-decoding-error-in-comment)
1544 ;; ANSI doesn't give a way for a reader function invoked by a
1545 ;; dispatch macro character to determine which dispatch character
1546 ;; was used, so if a user wants to signal one of these from a custom
1547 ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1548 ((disp-char :initform
#\
# :initarg
:disp-char
1549 :reader character-decoding-error-in-macro-char-comment-disp-char
)
1550 (sub-char :initarg
:sub-char
1551 :reader character-decoding-error-in-macro-char-comment-sub-char
)))
1553 (defun decoding-error-in-comment-macro (warning)
1555 (character-decoding-error-in-macro-char-comment
1556 (character-decoding-error-in-macro-char-comment-char warning
))
1557 (character-decoding-error-in-dispatch-macro-char-comment
1560 (character-decoding-error-in-macro-char-comment-disp-char warning
)
1561 (character-decoding-error-in-macro-char-comment-sub-char warning
)))))
1563 (define-condition deprecated-eval-when-situations
(style-warning)
1564 ((situations :initarg
:situations
1565 :reader deprecated-eval-when-situations-situations
))
1566 (:report
(lambda (warning stream
)
1567 (format stream
"using deprecated EVAL-WHEN situation names~{ ~S~}"
1568 (deprecated-eval-when-situations-situations warning
)))))
1570 (define-condition proclamation-mismatch
(condition)
1571 ((kind :initarg
:kind
:reader proclamation-mismatch-kind
)
1572 (description :initarg
:description
:reader proclamation-mismatch-description
:initform nil
)
1573 (name :initarg
:name
:reader proclamation-mismatch-name
)
1574 (old :initarg
:old
:reader proclamation-mismatch-old
)
1575 (new :initarg
:new
:reader proclamation-mismatch-new
))
1577 (lambda (condition stream
)
1578 ;; if we later decide we want package-qualified names, bind
1579 ;; *PACKAGE* to (find-package "KEYWORD") here.
1581 "~@<The new ~A proclamation for~@[ ~A~] ~S~
1583 does not match the old ~4:*~A~3* proclamation~
1585 (proclamation-mismatch-kind condition
)
1586 (proclamation-mismatch-description condition
)
1587 (proclamation-mismatch-name condition
)
1588 (proclamation-mismatch-new condition
)
1589 (proclamation-mismatch-old condition
)))))
1591 (define-condition type-proclamation-mismatch
(proclamation-mismatch)
1593 (:default-initargs
:kind
'type
))
1595 (define-condition type-proclamation-mismatch-warning
(style-warning
1596 type-proclamation-mismatch
)
1599 (defun type-proclamation-mismatch-warn (name old new
&optional description
)
1600 (warn 'type-proclamation-mismatch-warning
1601 :name name
:old old
:new new
:description description
))
1603 (define-condition ftype-proclamation-mismatch
(proclamation-mismatch)
1605 (:default-initargs
:kind
'ftype
))
1607 (define-condition ftype-proclamation-mismatch-warning
(style-warning
1608 ftype-proclamation-mismatch
)
1611 (defun ftype-proclamation-mismatch-warn (name old new
&optional description
)
1612 (warn 'ftype-proclamation-mismatch-warning
1613 :name name
:old old
:new new
:description description
))
1615 (define-condition ftype-proclamation-mismatch-error
(error
1616 ftype-proclamation-mismatch
)
1618 (:default-initargs
:kind
'ftype
:description
"known function"))
1621 ;;;; deprecation conditions
1623 (define-condition deprecation-condition
()
1624 ((name :initarg
:name
:reader deprecated-name
)
1625 (replacements :initarg
:replacements
:reader deprecated-name-replacements
)
1626 (since :initarg
:since
:reader deprecated-since
)
1627 (runtime-error :initarg
:runtime-error
:reader deprecated-name-runtime-error
)))
1629 (def!method print-object
((condition deprecation-condition
) stream
)
1630 (let ((*package
* (find-package :keyword
)))
1632 (print-unreadable-object (condition stream
:type t
)
1634 stream
"~S is deprecated.~
1635 ~#[~; Use ~S instead.~; ~
1636 Use ~S or ~S instead.~:; ~
1637 Use~@{~#[~; or~] ~S~^,~} instead.~]"
1638 (deprecated-name condition
)
1639 (deprecated-name-replacements condition
)))
1641 stream
"~@<~S has been deprecated as of SBCL ~A.~
1642 ~#[~; Use ~S instead.~; ~
1643 Use ~S or ~S instead.~:; ~
1644 Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>"
1645 (deprecated-name condition
)
1646 (deprecated-since condition
)
1647 (deprecated-name-replacements condition
)))))
1649 (define-condition early-deprecation-warning
(style-warning deprecation-condition
)
1652 (def!method print-object
:after
((warning early-deprecation-warning
) stream
)
1653 (unless *print-escape
*
1654 (let ((*package
* (find-package :keyword
)))
1655 (format stream
"~%~@<~:@_In future SBCL versions ~S will signal a full warning ~
1656 at compile-time.~:@>"
1657 (deprecated-name warning
)))))
1659 (define-condition late-deprecation-warning
(warning deprecation-condition
)
1662 (def!method print-object
:after
((warning late-deprecation-warning
) stream
)
1663 (unless *print-escape
*
1664 (when (deprecated-name-runtime-error warning
)
1665 (let ((*package
* (find-package :keyword
)))
1666 (format stream
"~%~@<~:@_In future SBCL versions ~S will signal a runtime error.~:@>"
1667 (deprecated-name warning
))))))
1669 (define-condition final-deprecation-warning
(warning deprecation-condition
)
1672 (def!method print-object
:after
((warning final-deprecation-warning
) stream
)
1673 (unless *print-escape
*
1674 (when (deprecated-name-runtime-error warning
)
1675 (let ((*package
* (find-package :keyword
)))
1676 (format stream
"~%~@<~:@_An error will be signaled at runtime for ~S.~:@>"
1677 (deprecated-name warning
))))))
1679 (define-condition deprecation-error
(error deprecation-condition
)
1682 ;;;; restart definitions
1684 (define-condition abort-failure
(control-error) ()
1686 "An ABORT restart was found that failed to transfer control dynamically."))
1688 (defun abort (&optional condition
)
1690 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1692 (invoke-restart (find-restart-or-control-error 'abort condition
))
1693 ;; ABORT signals an error in case there was a restart named ABORT
1694 ;; that did not transfer control dynamically. This could happen with
1696 (error 'abort-failure
))
1698 (defun muffle-warning (&optional condition
)
1700 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1701 CONTROL-ERROR if none exists."
1702 (invoke-restart (find-restart-or-control-error 'muffle-warning condition
)))
1704 (defun try-restart (name condition
&rest arguments
)
1705 (let ((restart (find-restart name condition
)))
1707 (apply #'invoke-restart restart arguments
))))
1709 (macrolet ((define-nil-returning-restart (name args doc
)
1710 #!-sb-doc
(declare (ignore doc
))
1711 `(defun ,name
(,@args
&optional condition
)
1713 (try-restart ',name condition
,@args
))))
1714 (define-nil-returning-restart continue
()
1715 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1716 (define-nil-returning-restart store-value
(value)
1717 "Transfer control and VALUE to a restart named STORE-VALUE, or
1718 return NIL if none exists.")
1719 (define-nil-returning-restart use-value
(value)
1720 "Transfer control and VALUE to a restart named USE-VALUE, or
1721 return NIL if none exists.")
1722 (define-nil-returning-restart print-unreadably
()
1723 "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
1724 return NIL if none exists."))
1726 ;;; single-stepping restarts
1728 (macrolet ((def (name doc
)
1729 #!-sb-doc
(declare (ignore doc
))
1730 `(defun ,name
(condition)
1732 (invoke-restart (find-restart-or-control-error ',name condition
)))))
1734 "Transfers control to the STEP-CONTINUE restart associated with
1735 the condition, continuing execution without stepping. Signals a
1736 CONTROL-ERROR if the restart does not exist.")
1738 "Transfers control to the STEP-NEXT restart associated with the
1739 condition, executing the current form without stepping and continuing
1740 stepping with the next form. Signals CONTROL-ERROR is the restart does
1743 "Transfers control to the STEP-INTO restart associated with the
1744 condition, stepping into the current form. Signals a CONTROL-ERROR is
1745 the restart does not exist."))
1747 ;;; Compiler macro magic
1749 (define-condition compiler-macro-keyword-problem
()
1750 ((argument :initarg
:argument
:reader compiler-macro-keyword-argument
))
1751 (:report
(lambda (condition stream
)
1752 (format stream
"~@<Argument ~S in keyword position is not ~
1753 a self-evaluating symbol, preventing compiler-macro ~
1755 (compiler-macro-keyword-argument condition
)))))
1757 (/show0
"condition.lisp end of file")