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 (defstruct (condition-slot (:copier nil
))
21 (name (missing-arg) :type symbol
)
22 ;; list of all applicable initargs
23 (initargs (missing-arg) :type list
)
24 ;; names of reader and writer functions
25 (readers (missing-arg) :type list
)
26 (writers (missing-arg) :type list
)
27 ;; true if :INITFORM was specified
28 (initform-p (missing-arg) :type
(member t nil
))
29 ;; the initform if :INITFORM was specified, otherwise NIL
30 (initform nil
:type t
)
31 ;; if this is a function, call it with no args to get the initform value
32 (initfunction (missing-arg) :type t
)
33 ;; allocation of this slot, or NIL until defaulted
34 (allocation nil
:type
(member :instance
:class nil
))
35 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value
36 (cell nil
:type
(or cons null
))
38 (documentation nil
:type
(or string null
)))
40 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
41 (/show0
"condition.lisp 103")
42 (let ((condition-class (find-classoid 'condition
)))
43 (setf (condition-classoid-cpl condition-class
)
44 (list condition-class
)))
45 (/show0
"condition.lisp 103"))
47 (setf (condition-classoid-report (find-classoid 'condition
))
49 (format stream
"Condition ~/sb!impl:print-type-specifier/ was signalled."
52 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
54 (defun find-condition-layout (name parent-types
)
55 (let* ((cpl (remove-duplicates
59 (condition-classoid-cpl
62 (cond-layout (info :type
:compiler-layout
'condition
))
63 (olayout (info :type
:compiler-layout name
))
64 ;; FIXME: Does this do the right thing in case of multiple
65 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
66 ;; it obvious what ANSI intends to be done in the case of
67 ;; multiple inheritance, so it's not actually clear what the
70 (order-layout-inherits (concatenate 'simple-vector
71 (layout-inherits cond-layout
)
72 (mapcar #'classoid-layout cpl
)))))
74 (not (mismatch (layout-inherits olayout
) new-inherits
)))
76 (make-layout :classoid
(make-undefined-classoid name
)
77 :inherits new-inherits
79 :length
(layout-length cond-layout
)))))
83 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
84 ;;; Condition reporting is mediated through the PRINT-OBJECT method
85 ;;; for the condition type in question, with *PRINT-ESCAPE* always
86 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
87 ;;; a condition type C is equivalent to:
88 ;;; (defmethod print-object ((x c) stream)
89 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
90 ;;; The current code doesn't seem to quite match that.
91 (defmethod print-object ((object condition
) stream
)
94 ;; KLUDGE: A comment from CMU CL here said
95 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
96 ;; superclasses in define-condition call!
97 (funcall (or (some #'condition-classoid-report
98 (condition-classoid-cpl (classoid-of object
)))
99 (error "no REPORT? shouldn't happen!"))
101 ((and (typep object
'simple-condition
)
102 (condition-slot-value object
'format-control
))
103 (print-unreadable-object (object stream
:type t
:identity t
)
104 (write (simple-condition-format-control object
)
105 :stream stream
:lines
1)))
107 (print-unreadable-object (object stream
:type t
:identity t
)))))
109 ;;;; slots of CONDITION objects
111 (defun find-slot-default (class slot
)
112 (let ((initargs (condition-slot-initargs slot
))
113 (cpl (condition-classoid-cpl class
)))
114 ;; When CLASS or a superclass has a default initarg for SLOT, use
117 (let ((direct-default-initargs
118 (condition-classoid-direct-default-initargs class
)))
119 (dolist (initarg initargs
)
120 (let ((initfunction (third (assoc initarg direct-default-initargs
))))
122 (return-from find-slot-default
(funcall initfunction
)))))))
124 ;; Otherwise use the initform of SLOT, if there is one.
125 (if (condition-slot-initform-p slot
)
126 (let ((initfun (condition-slot-initfunction slot
)))
127 (aver (functionp initfun
))
129 (error "unbound condition slot: ~S" (condition-slot-name slot
)))))
131 (defun find-condition-class-slot (condition-class slot-name
)
133 (condition-classoid-cpl condition-class
)
134 (error "There is no slot named ~S in ~S."
135 slot-name condition-class
))
136 (dolist (slot (condition-classoid-slots sclass
))
137 (when (eq (condition-slot-name slot
) slot-name
)
138 (return-from find-condition-class-slot slot
)))))
140 (defun set-condition-slot-value (condition new-value name
)
141 (dolist (cslot (condition-classoid-class-slots
142 (layout-classoid (%instance-layout condition
)))
143 (setf (getf (condition-assigned-slots condition
) name
)
145 (when (eq (condition-slot-name cslot
) name
)
146 (return (setf (car (condition-slot-cell cslot
)) new-value
)))))
148 (defun condition-slot-value (condition name
)
149 (let ((val (getf (condition-assigned-slots condition
) name sb
!pcl
:+slot-unbound
+)))
150 (if (eq val sb
!pcl
:+slot-unbound
+)
151 (let ((class (layout-classoid (%instance-layout condition
))))
153 (condition-classoid-class-slots class
)
154 (let ((instance-length (%instance-length condition
))
155 (slot (or (find-condition-class-slot class name
)
156 (error "missing slot ~S of ~S" name condition
))))
157 (setf (getf (condition-assigned-slots condition
) name
)
158 (do ((i (+ sb
!vm
:instance-data-start
2) (+ i
2)))
159 ((>= i instance-length
) (find-slot-default class slot
))
160 (when (member (%instance-ref condition i
)
161 (condition-slot-initargs slot
))
162 (return (%instance-ref condition
(1+ i
))))))))
163 (when (eq (condition-slot-name cslot
) name
)
164 (return (car (condition-slot-cell cslot
))))))
169 (defun allocate-condition (designator &rest initargs
)
170 (when (oddp (length initargs
))
172 :format-control
"odd-length initializer list: ~S."
175 ;; avoid direct reference to INITARGS as a list
176 ;; so that it is not reified unless we reach here.
177 (do-rest-arg ((arg) initargs
) (push arg list
))
179 ;; I am going to assume that people are not somehow getting to here
180 ;; with a CLASSOID, which is not strictly legal as a designator,
181 ;; but which is accepted because it is actually the desired thing.
182 ;; It doesn't seem worth sweating over that detail, and in any event
183 ;; we could say that it's a supported extension.
184 (let ((classoid (named-let lookup
((designator designator
))
186 (symbol (find-classoid designator nil
))
187 (class (lookup (class-name designator
)))
189 (if (condition-classoid-p classoid
)
190 ;; Interestingly we fail to validate the actual-initargs,
191 ;; allowing any random initarg names. Is this permissible?
192 ;; And why is lazily filling in ASSIGNED-SLOTS beneficial anyway?
193 (let ((instance (%make-instance
(+ sb
!vm
:instance-data-start
194 2 ; ASSIGNED-SLOTS and HASH
195 (length initargs
))))) ; rest
196 (setf (%instance-layout instance
) (classoid-layout classoid
)
197 (condition-assigned-slots instance
) nil
198 (condition-hash instance
) (sb!impl
::new-instance-hash-code
))
199 (do-rest-arg ((val index
) initargs
)
200 (setf (%instance-ref instance
(+ sb
!vm
:instance-data-start index
2)) val
))
201 (values instance classoid
))
202 (error 'simple-type-error
204 ;; CONDITION-CLASS isn't a type-specifier. Is this legal?
205 :expected-type
'condition-class
206 :format-control
"~S does not designate a condition class."
207 :format-arguments
(list designator
)))))
209 (defun make-condition (type &rest initargs
)
210 "Make an instance of a condition object using the specified initargs."
211 ;; Note: While ANSI specifies no exceptional situations in this function,
212 ;; ALLOCATE-CONDITION will signal a type error if TYPE does not designate
213 ;; a condition class. This seems fair enough.
214 (declare (explicit-check))
215 ;; FIXME: the compiler should have a way to make GETF operate on a &MORE arg
216 ;; so that the initargs are never listified.
217 (declare (dynamic-extent initargs
))
218 (multiple-value-bind (condition classoid
)
219 (apply #'allocate-condition type initargs
)
221 ;; Set any class slots with initargs present in this call.
222 (dolist (cslot (condition-classoid-class-slots classoid
))
223 (dolist (initarg (condition-slot-initargs cslot
))
224 (let ((val (getf initargs initarg sb
!pcl
:+slot-unbound
+)))
225 (unless (eq val sb
!pcl
:+slot-unbound
+)
226 (setf (car (condition-slot-cell cslot
)) val
)))))
228 ;; Default any slots with non-constant defaults now.
229 (dolist (hslot (condition-classoid-hairy-slots classoid
))
230 (when (dolist (initarg (condition-slot-initargs hslot
) t
)
231 (unless (eq (getf initargs initarg sb
!pcl
:+slot-unbound
+)
232 sb
!pcl
:+slot-unbound
+)
234 (setf (getf (condition-assigned-slots condition
)
235 (condition-slot-name hslot
))
236 (find-slot-default classoid hslot
))))
241 ;;;; DEFINE-CONDITION
243 ;;; Compute the effective slots of CLASS, copying inherited slots and
244 ;;; destructively modifying direct slots.
246 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
247 ;;; direct slots. Presumably it follows from the semantics of
248 ;;; inheritance and redefinition of conditions, but finding the cite
249 ;;; and documenting it here would be good. (Or, if this is not in fact
250 ;;; ANSI-compliant, fixing it would also be good.:-)
251 (defun compute-effective-slots (class)
252 (collect ((res (copy-list (condition-classoid-slots class
))))
253 (dolist (sclass (cdr (condition-classoid-cpl class
)))
254 (dolist (sslot (condition-classoid-slots sclass
))
255 (let ((found (find (condition-slot-name sslot
) (res)
256 :key
#'condition-slot-name
)))
258 (setf (condition-slot-initargs found
)
259 (union (condition-slot-initargs found
)
260 (condition-slot-initargs sslot
)))
261 (unless (condition-slot-initform-p found
)
262 (setf (condition-slot-initform-p found
)
263 (condition-slot-initform-p sslot
))
264 (setf (condition-slot-initform found
)
265 (condition-slot-initform sslot
))
266 (setf (condition-slot-initfunction found
)
267 (condition-slot-initfunction sslot
)))
268 (unless (condition-slot-allocation found
)
269 (setf (condition-slot-allocation found
)
270 (condition-slot-allocation sslot
))))
272 (res (copy-structure sslot
)))))))
275 ;;; Early definitions of slot accessor creators.
277 ;;; Slot accessors must be generic functions, but ANSI does not seem
278 ;;; to specify any of them, and we cannot support it before end of
279 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
280 ;;; GFs only at the end of building.
281 (declaim (notinline install-condition-slot-reader
282 install-condition-slot-writer
))
283 (defun install-condition-slot-reader (name condition slot-name
)
284 (declare (ignore condition
))
285 (setf (fdefinition name
)
287 (condition-slot-value condition slot-name
))))
288 (defun install-condition-slot-writer (name condition slot-name
)
289 (declare (ignore condition
))
290 (setf (fdefinition name
)
291 (lambda (new-value condition
)
292 (set-condition-slot-value condition new-value slot-name
))))
294 (!defvar
*define-condition-hooks
* nil
)
296 (defun %set-condition-report
(name report
)
297 (setf (condition-classoid-report (find-classoid name
))
300 (defun %define-condition
(name parent-types layout slots
301 direct-default-initargs all-readers all-writers
302 source-location
&optional documentation
)
303 (call-with-defining-class
306 (%%compiler-define-condition name parent-types layout all-readers all-writers
)
307 (when source-location
308 (setf (layout-source-location layout
) source-location
))
309 (let ((classoid (find-classoid name
)))
310 (setf (condition-classoid-slots classoid
) slots
311 (condition-classoid-direct-default-initargs classoid
) direct-default-initargs
312 (fdocumentation name
'type
) documentation
)
315 ;; Set up reader and writer functions.
316 (let ((slot-name (condition-slot-name slot
)))
317 (dolist (reader (condition-slot-readers slot
))
318 (install-condition-slot-reader reader name slot-name
))
319 (dolist (writer (condition-slot-writers slot
))
320 (install-condition-slot-writer writer name slot-name
))))
322 ;; Compute effective slots and set up the class and hairy slots
323 ;; (subsets of the effective slots.)
324 (setf (condition-classoid-class-slots classoid
) '()
325 (condition-classoid-hairy-slots classoid
) '())
326 (let ((eslots (compute-effective-slots classoid
))
329 (mapcar #'condition-classoid-direct-default-initargs
330 (condition-classoid-cpl classoid
)))))
331 (dolist (slot eslots
)
332 (ecase (condition-slot-allocation slot
)
334 (unless (condition-slot-cell slot
)
335 (setf (condition-slot-cell slot
)
336 (list (if (condition-slot-initform-p slot
)
337 (let ((initfun (condition-slot-initfunction slot
)))
338 (aver (functionp initfun
))
340 sb
!pcl
:+slot-unbound
+))))
341 (push slot
(condition-classoid-class-slots classoid
)))
343 (setf (condition-slot-allocation slot
) :instance
)
344 ;; FIXME: isn't this "always hairy"?
345 (when (or (functionp (condition-slot-initfunction slot
))
346 (dolist (initarg (condition-slot-initargs slot
) nil
)
347 (when (functionp (third (assoc initarg e-def-initargs
)))
349 (push slot
(condition-classoid-hairy-slots classoid
)))))))
350 (dolist (fun *define-condition-hooks
*)
351 (funcall fun classoid
)))))
354 (defmacro define-condition
(name (&rest parent-types
) (&rest slot-specs
)
356 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
357 Define NAME as a condition type. This new type inherits slots and its
358 report function from the specified PARENT-TYPEs. A slot spec is a list of:
359 (slot-name :reader <rname> :initarg <iname> {Option Value}*
361 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
362 and :TYPE and the overall options :DEFAULT-INITARGS and
363 [type] :DOCUMENTATION are also allowed.
365 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
366 a string or a two-argument lambda or function name. If a function, the
367 function is called with the condition and stream to report the condition.
368 If a string, the string is printed.
370 Condition types are classes, but (as allowed by ANSI and not as described in
371 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
372 SLOT-VALUE may not be used on condition objects."
373 (let* ((parent-types (or parent-types
'(condition)))
374 (layout (find-condition-layout name parent-types
))
377 (direct-default-initargs ()))
379 (all-readers nil append
)
380 (all-writers nil append
))
381 (dolist (spec slot-specs
)
382 (when (keywordp spec
)
383 (warn "Keyword slot name indicates probable syntax error:~% ~S"
385 (let* ((spec (if (consp spec
) spec
(list spec
)))
386 (slot-name (first spec
))
387 (allocation :instance
)
394 (do ((options (rest spec
) (cddr options
)))
396 (unless (and (consp options
) (consp (cdr options
)))
397 (error "malformed condition slot spec:~% ~S." spec
))
398 (let ((arg (second options
)))
399 (case (first options
)
400 (:reader
(readers arg
))
401 (:writer
(writers arg
))
404 (writers `(setf ,arg
)))
407 (error "more than one :INITFORM in ~S" spec
))
410 (:initarg
(initargs arg
))
412 (setq allocation arg
))
415 (error "more than one :DOCUMENTATION in ~S" spec
))
416 (unless (stringp arg
)
417 (error "slot :DOCUMENTATION argument is not a string: ~S"
419 (setq documentation arg
))
422 (error "unknown slot option:~% ~S" (first options
))))))
424 (all-readers (readers))
425 (all-writers (writers))
426 (slots `(make-condition-slot
428 :initargs
',(initargs)
431 :initform-p
',initform-p
432 :documentation
',documentation
433 :initform
,(when initform-p
`',initform
)
434 :initfunction
,(when initform-p
435 `#'(lambda () ,initform
))
436 :allocation
',allocation
)))))
438 (dolist (option options
)
439 (unless (consp option
)
440 (error "bad option:~% ~S" option
))
442 (:documentation
(setq documentation
(second option
)))
444 (let ((arg (second option
)))
446 `#'(named-lambda (condition-report ,name
) (condition stream
)
447 (declare (type condition condition
)
448 (type stream stream
))
450 `((declare (ignore condition
))
451 (write-string ,arg stream
))
452 `((funcall #',arg condition stream
)))))))
454 (doplist (initarg initform
) (rest option
)
455 (push ``(,',initarg
,',initform
,#'(lambda () ,initform
))
456 direct-default-initargs
)))
458 (error "unknown option: ~S" (first option
)))))
460 ;; Maybe kill docstring, but only under the cross-compiler.
461 #!+(and (not sb-doc
) (host-feature sb-xc-host
)) (setq documentation nil
)
463 (eval-when (:compile-toplevel
)
464 (%compiler-define-condition
',name
',parent-types
',layout
465 ',(all-readers) ',(all-writers)))
466 (%define-condition
',name
470 (list ,@direct-default-initargs
)
473 (sb!c
:source-location
)
476 ;; This needs to be after %DEFINE-CONDITION in case :REPORT
477 ;; is a lambda referring to condition slot accessors:
478 ;; they're not proclaimed as functions before it has run if
479 ;; we're under EVAL or loaded as source.
480 (%set-condition-report
',name
,report
)
483 ;;;; various CONDITIONs specified by ANSI
485 (define-condition serious-condition
(condition) ())
487 (define-condition error
(serious-condition) ())
489 (define-condition warning
(condition) ())
490 (define-condition style-warning
(warning) ())
492 (defun simple-condition-printer (condition stream
)
493 (let ((control (simple-condition-format-control condition
)))
495 (apply #'format stream
497 (simple-condition-format-arguments condition
))
498 (error "No format-control for ~S" condition
))))
500 (define-condition simple-condition
()
501 ((format-control :reader simple-condition-format-control
502 :initarg
:format-control
504 :type format-control
)
505 (format-arguments :reader simple-condition-format-arguments
506 :initarg
:format-arguments
509 (:report simple-condition-printer
))
511 (define-condition simple-warning
(simple-condition warning
) ())
513 (define-condition simple-error
(simple-condition error
) ())
515 (define-condition storage-condition
(serious-condition) ())
517 (defun decode-type-error-context (context type
)
522 (format nil
"when setting slot ~s of structure ~s"
523 (cddr context
) (cadr context
)))
525 (format nil
"when binding ~s"
529 (let (*print-circle
*)
530 (format nil
"when setting an element of (ARRAY ~s)"
535 (define-condition type-error
(error)
536 ((datum :reader type-error-datum
:initarg
:datum
)
537 (expected-type :reader type-error-expected-type
:initarg
:expected-type
)
538 (context :initform nil
:reader type-error-context
:initarg
:context
))
540 (lambda (condition stream
)
541 (let ((type (type-error-expected-type condition
)))
542 (format stream
"~@<The value ~
545 ~@:_~2@T~/sb!impl:print-type-specifier/~@[ ~
547 (type-error-datum condition
)
549 (decode-type-error-context (type-error-context condition
)
552 ;;; not specified by ANSI, but too useful not to have around.
553 (define-condition simple-style-warning
(simple-condition style-warning
) ())
554 (define-condition simple-type-error
(simple-condition type-error
) ())
556 (define-condition program-error
(error) ())
557 (define-condition parse-error
(error) ())
558 (define-condition control-error
(error) ())
559 (define-condition stream-error
(error)
560 ((stream :reader stream-error-stream
:initarg
:stream
)))
562 (define-condition end-of-file
(stream-error) ()
564 (lambda (condition stream
)
567 (stream-error-stream condition
)))))
569 (define-condition closed-stream-error
(stream-error) ()
571 (lambda (condition stream
)
572 (format stream
"~S is closed" (stream-error-stream condition
)))))
574 (define-condition file-error
(error)
575 ((pathname :reader file-error-pathname
:initarg
:pathname
))
577 (lambda (condition stream
)
578 (format stream
"error on file ~S" (file-error-pathname condition
)))))
580 (define-condition package-error
(error)
581 ((package :reader package-error-package
:initarg
:package
)))
583 (define-condition cell-error
(error)
584 ((name :reader cell-error-name
:initarg
:name
)))
586 (define-condition unbound-variable
(cell-error) ()
588 (lambda (condition stream
)
590 "The variable ~S is unbound."
591 (cell-error-name condition
)))))
593 (define-condition undefined-function
(cell-error) ()
595 (lambda (condition stream
)
596 (let ((*package
* (find-package :keyword
)))
598 "The function ~S is undefined."
599 (cell-error-name condition
))))))
601 (define-condition retry-undefined-function
602 (simple-condition undefined-function
) ())
604 (define-condition special-form-function
(undefined-function) ()
606 (lambda (condition stream
)
608 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
609 (cell-error-name condition
)))))
611 (define-condition arithmetic-error
(error)
612 ((operation :reader arithmetic-error-operation
615 (operands :reader arithmetic-error-operands
617 (:report
(lambda (condition stream
)
619 "arithmetic error ~S signalled"
621 (when (arithmetic-error-operation condition
)
623 "~%Operation was (~S ~{~S~^ ~})."
624 (arithmetic-error-operation condition
)
625 (arithmetic-error-operands condition
))))))
627 (define-condition division-by-zero
(arithmetic-error) ())
628 (define-condition floating-point-overflow
(arithmetic-error) ())
629 (define-condition floating-point-underflow
(arithmetic-error) ())
630 (define-condition floating-point-inexact
(arithmetic-error) ())
631 (define-condition floating-point-invalid-operation
(arithmetic-error) ())
633 (define-condition print-not-readable
(error)
634 ((object :reader print-not-readable-object
:initarg
:object
))
636 (lambda (condition stream
)
637 (let ((obj (print-not-readable-object condition
))
639 (format stream
"~S cannot be printed readably." obj
)))))
641 (define-condition reader-error
(parse-error stream-error
) ()
642 (:report
(lambda (condition stream
)
643 (%report-reader-error condition stream
))))
645 ;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
646 ;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
647 ;;; within SBCL itself)
649 ;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
650 ;;; the letter of the ANSI spec: this is not a condition signalled by
651 ;;; SIGNAL when a format-control is supplied by the function's first
652 ;;; argument. It seems to me (WHN) to be basically in the spirit of
653 ;;; the spec, but if not, it'd be straightforward to do our own
654 ;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
655 ;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
656 ;;; place of CL:SIMPLE-CONDITION here.)
657 (define-condition simple-reader-error
(reader-error simple-condition
)
659 (:report
(lambda (condition stream
)
660 (%report-reader-error condition stream
:simple t
))))
662 ;;; base REPORTing of a READER-ERROR
664 ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
665 ;;; and FORMAT-ARGS slots.
666 (defun %report-reader-error
(condition stream
&key simple position
)
667 (let ((error-stream (stream-error-stream condition
)))
668 (pprint-logical-block (stream nil
)
670 (apply #'format stream
671 (simple-condition-format-control condition
)
672 (simple-condition-format-arguments condition
))
673 (prin1 (class-name (class-of condition
)) stream
))
674 (format stream
"~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S"
675 (stream-error-position-info error-stream position
)
678 ;;;; special SBCL extension conditions
680 ;;; an error apparently caused by a bug in SBCL itself
682 ;;; Note that we don't make any serious effort to use this condition
683 ;;; for *all* errors in SBCL itself. E.g. type errors and array
684 ;;; indexing errors can occur in functions called from SBCL code, and
685 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
686 ;;; because the signalling code has no good way to know that the
687 ;;; underlying problem is a bug in SBCL. But in the fairly common case
688 ;;; that the signalling code does know that it's found a bug in SBCL,
689 ;;; this condition is appropriate, reusing boilerplate and helping
690 ;;; users to recognize it as an SBCL bug.
691 (define-condition bug
(simple-error)
694 (lambda (condition stream
)
697 (simple-condition-format-control condition
)
698 (simple-condition-format-arguments condition
)
699 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
700 SBCL might have been corrupted by bad user code, e.g. by an ~
701 undefined Lisp operation like ~S, or by stray pointers from ~
702 alien code or from unsafe Lisp code; or there might be a bug ~
703 in the OS or hardware that SBCL is running on.) If it seems to ~
704 be a bug in SBCL itself, the maintainers would like to know ~
705 about it. Bug reports are welcome on the SBCL ~
706 mailing lists, which you can find at ~
707 <http://sbcl.sourceforge.net/>.~:@>"
708 '((fmakunbound 'compile
))))))
710 (define-condition simple-storage-condition
(storage-condition simple-condition
)
713 ;;; a condition for use in stubs for operations which aren't supported
714 ;;; on some platforms
716 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
717 ;;; #-(or freebsd linux)
718 ;;; (defun load-foreign (&rest rest)
719 ;;; (error 'unsupported-operator :name 'load-foreign))
720 ;;; #+(or freebsd linux)
721 ;;; (defun load-foreign ... actual definition ...)
722 ;;; By signalling a standard condition in this case, we make it
723 ;;; possible for test code to distinguish between (1) intentionally
724 ;;; unimplemented and (2) unintentionally just screwed up somehow.
725 ;;; (Before this condition was defined, test code tried to deal with
726 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
727 ;;; sbcl-0.7.0, a package screwup left the definition of
728 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
729 ;;; architectures where it was supposed to be supported, and the
730 ;;; regression tests cheerfully passed because they assumed that
731 ;;; unFBOUNDPness meant they were running on an system which didn't
732 ;;; support the extension.)
733 (define-condition unsupported-operator
(simple-error) ())
735 ;;; (:ansi-cl :function remove)
736 ;;; (:ansi-cl :section (a b c))
737 ;;; (:ansi-cl :glossary "similar")
739 ;;; (:sbcl :node "...")
740 ;;; (:sbcl :variable *ed-functions*)
742 ;;; FIXME: this is not the right place for this.
743 (defun print-reference (reference stream
)
744 (ecase (car reference
)
746 (format stream
"AMOP")
748 (destructuring-bind (type data
) (cdr reference
)
750 (:readers
"Readers for ~:(~A~) Metaobjects"
751 (substitute #\
#\-
(symbol-name data
)))
753 (format stream
"Initialization of ~:(~A~) Metaobjects"
754 (substitute #\
#\-
(symbol-name data
))))
755 (:generic-function
(format stream
"Generic Function ~S" data
))
756 (:function
(format stream
"Function ~S" data
))
757 (:section
(format stream
"Section ~{~D~^.~}" data
)))))
759 (format stream
"The ANSI Standard")
761 (destructuring-bind (type data
) (cdr reference
)
763 (:function
(format stream
"Function ~S" data
))
764 (:special-operator
(format stream
"Special Operator ~S" data
))
765 (:macro
(format stream
"Macro ~S" data
))
766 (:section
(format stream
"Section ~{~D~^.~}" data
))
767 (:glossary
(format stream
"Glossary entry for ~S" data
))
768 (:type
(format stream
"Type ~S" data
))
769 (:system-class
(format stream
"System Class ~S" data
))
770 (:issue
(format stream
"writeup for Issue ~A" data
)))))
772 (format stream
"The SBCL Manual")
774 (destructuring-bind (type data
) (cdr reference
)
776 (:node
(format stream
"Node ~S" data
))
777 (:variable
(format stream
"Variable ~S" data
))
778 (:function
(format stream
"Function ~S" data
)))))
779 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
781 (define-condition reference-condition
()
782 ((references :initarg
:references
:reader reference-condition-references
)))
783 (defvar *print-condition-references
* t
)
785 (define-condition simple-reference-error
(reference-condition simple-error
)
788 (define-condition simple-reference-warning
(reference-condition simple-warning
)
791 (define-condition arguments-out-of-domain-error
792 (arithmetic-error reference-condition
)
795 ;; per CLHS: "The consequences are unspecified if functions are ...
796 ;; multiply defined in the same file." so we are within reason to do any
797 ;; unspecified behavior at compile-time and/or time, but the compiler was
798 ;; annoyingly mum about genuinely inadvertent duplicate macro definitions.
799 ;; Redefinition is henceforth a style-warning, and for compatibility it does
800 ;; not cause the ERRORP value from COMPILE-TIME to be T.
801 ;; Nor do we cite section 3.2.2.3 as the governing prohibition.
802 (defun report-duplicate-definition (condition stream
)
803 (format stream
"~@<Duplicate definition for ~S found in one file.~@:>"
804 (slot-value condition
'name
)))
806 (define-condition duplicate-definition
(reference-condition warning
)
807 ((name :initarg
:name
:reader duplicate-definition-name
))
808 (:report report-duplicate-definition
)
809 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
810 ;; To my thinking, DUPLICATE-DEFINITION should be the ancestor condition,
811 ;; and not fatal. But changing the meaning of that concept would be a bad idea,
812 ;; so instead there is a new condition for the softer variant, which does not
813 ;; inherit from the former.
814 (define-condition same-file-redefinition-warning
(style-warning)
815 ;; Slot readers aren't proper generic functions until CLOS is built,
816 ;; so this doesn't get a reader because you can't pick the same name,
817 ;; and it wouldn't do any good to pick a different name that nothing knows.
818 ((name :initarg
:name
))
819 (:report report-duplicate-definition
))
821 (define-condition constant-modified
(reference-condition warning
)
822 ((fun-name :initarg
:fun-name
:reader constant-modified-fun-name
))
823 (:report
(lambda (c s
)
824 (format s
"~@<Destructive function ~S called on ~
826 (constant-modified-fun-name c
))))
827 (:default-initargs
:references
(list '(:ansi-cl
:special-operator quote
)
828 '(:ansi-cl
:section
(3 2 2 3)))))
830 (define-condition package-at-variance
(reference-condition simple-warning
)
832 (:default-initargs
:references
(list '(:ansi-cl
:macro defpackage
)
833 '(:sbcl
:variable
*on-package-variance
*))))
835 (define-condition package-at-variance-error
(reference-condition simple-condition
838 (:default-initargs
:references
(list '(:ansi-cl
:macro defpackage
))))
840 (define-condition defconstant-uneql
(reference-condition error
)
841 ((name :initarg
:name
:reader defconstant-uneql-name
)
842 (old-value :initarg
:old-value
:reader defconstant-uneql-old-value
)
843 (new-value :initarg
:new-value
:reader defconstant-uneql-new-value
))
845 (lambda (condition stream
)
847 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
848 (defconstant-uneql-name condition
)
849 (defconstant-uneql-old-value condition
)
850 (defconstant-uneql-new-value condition
))))
851 (:default-initargs
:references
(list '(:ansi-cl
:macro defconstant
)
852 '(:sbcl
:node
"Idiosyncrasies"))))
854 (define-condition array-initial-element-mismatch
855 (reference-condition simple-warning
)
859 '(:ansi-cl
:function make-array
)
860 '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
))))
862 (define-condition type-warning
(reference-condition simple-warning
)
864 (:default-initargs
:references
(list '(:sbcl
:node
"Handling of Types"))))
865 (define-condition type-style-warning
(reference-condition simple-style-warning
)
867 (:default-initargs
:references
(list '(:sbcl
:node
"Handling of Types"))))
869 (define-condition local-argument-mismatch
(reference-condition simple-warning
)
871 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
873 (define-condition format-args-mismatch
(reference-condition)
875 (:default-initargs
:references
(list '(:ansi-cl
:section
(22 3 10 2)))))
877 (define-condition format-too-few-args-warning
878 (format-args-mismatch simple-warning
)
880 (define-condition format-too-many-args-warning
881 (format-args-mismatch simple-style-warning
)
884 (define-condition implicit-generic-function-warning
(style-warning)
885 ((name :initarg
:name
:reader implicit-generic-function-name
))
887 (lambda (condition stream
)
888 (format stream
"~@<Implicitly creating new generic function ~
889 ~/sb-impl::print-symbol-with-prefix/.~:@>"
890 (implicit-generic-function-name condition
)))))
892 (define-condition extension-failure
(reference-condition simple-error
)
895 (define-condition structure-initarg-not-keyword
896 (reference-condition simple-style-warning
)
898 (:default-initargs
:references
(list '(:ansi-cl
:section
(2 4 8 13)))))
903 (define-condition package-lock-violation
(package-error
906 ((current-package :initform
*package
*
907 :reader package-lock-violation-in-package
))
909 (lambda (condition stream
)
910 (let ((control (simple-condition-format-control condition
))
911 (error-package (package-name
912 (package-error-package condition
)))
913 (current-package (package-name
914 (package-lock-violation-in-package condition
))))
915 (format stream
"~@<Lock on package ~A violated~@[~{ when ~?~}~] ~
916 while in package ~A.~:@>"
919 (list control
(simple-condition-format-arguments condition
)))
921 ;; no :default-initargs -- reference-stuff provided by the
922 ;; signalling form in target-package.lisp
924 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
925 when a package-lock is violated."))
927 (define-condition package-locked-error
(package-lock-violation) ()
929 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
930 signalled when an operation on a package violates a package lock."))
932 (define-condition symbol-package-locked-error
(package-lock-violation)
933 ((symbol :initarg
:symbol
:reader package-locked-error-symbol
))
935 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
936 signalled when an operation on a symbol violates a package lock. The
937 symbol that caused the violation is accessed by the function
938 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
942 (define-condition undefined-alien-error
(cell-error) ()
944 (lambda (condition stream
)
945 (if (slot-boundp condition
'name
)
946 (format stream
"Undefined alien: ~S" (cell-error-name condition
))
947 (format stream
"Undefined alien symbol.")))))
949 (define-condition undefined-alien-variable-error
(undefined-alien-error) ()
951 (lambda (condition stream
)
952 (declare (ignore condition
))
953 (format stream
"Attempt to access an undefined alien variable."))))
955 (define-condition undefined-alien-function-error
(undefined-alien-error) ()
957 (lambda (condition stream
)
958 (if (and (slot-boundp condition
'name
)
959 (cell-error-name condition
))
960 (format stream
"The alien function ~s is undefined."
961 (cell-error-name condition
))
962 (format stream
"Attempt to call an undefined alien function.")))))
965 ;;;; various other (not specified by ANSI) CONDITIONs
967 ;;;; These might logically belong in other files; they're here, after
968 ;;;; setup of CONDITION machinery, only because that makes it easier to
969 ;;;; get cold init to work.
971 ;;; OAOOM warning: see cross-condition.lisp
972 (define-condition encapsulated-condition
(condition)
973 ((condition :initarg
:condition
:reader encapsulated-condition
)))
975 ;;; KLUDGE: a condition for floating point errors when we can't or
976 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
977 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
978 ;;; know how but the old code was broken by the conversion to POSIX
979 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
981 ;;; FIXME: Perhaps this should also be a base class for all
982 ;;; floating point exceptions?
983 (define-condition floating-point-exception
(arithmetic-error)
984 ((flags :initarg
:traps
986 :reader floating-point-exception-traps
))
987 (:report
(lambda (condition stream
)
989 "An arithmetic error ~S was signalled.~%"
991 (let ((traps (floating-point-exception-traps condition
)))
994 "Trapping conditions are: ~%~{ ~S~^~}~%"
997 "No traps are enabled? How can this be?"
1000 (define-condition invalid-array-index-error
(type-error)
1001 ((array :initarg
:array
:reader invalid-array-index-error-array
)
1002 (axis :initarg
:axis
:reader invalid-array-index-error-axis
))
1004 (lambda (condition stream
)
1005 (let ((array (invalid-array-index-error-array condition
)))
1006 (format stream
"Invalid index ~W for ~@[axis ~W of ~]~S, ~
1007 should be a non-negative integer below ~W."
1008 (type-error-datum condition
)
1009 (when (> (array-rank array
) 1)
1010 (invalid-array-index-error-axis condition
))
1012 ;; Extract the bound from (INTEGER 0 (BOUND))
1013 (caaddr (type-error-expected-type condition
)))))))
1015 (define-condition invalid-array-error
(reference-condition type-error
) ()
1017 (lambda (condition stream
)
1018 (let ((*print-array
* nil
))
1020 "~@<Displaced array originally of type ~
1021 ~/sb!impl:print-type-specifier/ has been invalidated ~
1022 due its displaced-to array ~S having become too small ~
1023 to hold it: the displaced array's dimensions have all ~
1024 been set to zero to trap accesses to it.~:@>"
1025 (type-error-expected-type condition
)
1026 (array-displacement (type-error-datum condition
))))))
1029 (list '(:ansi-cl
:function adjust-array
))))
1031 (define-condition index-too-large-error
(type-error)
1034 (lambda (condition stream
)
1036 "The index ~S is too large."
1037 (type-error-datum condition
)))))
1039 (define-condition bounding-indices-bad-error
(reference-condition type-error
)
1040 ((object :reader bounding-indices-bad-object
:initarg
:object
))
1042 (lambda (condition stream
)
1043 (let* ((datum (type-error-datum condition
))
1046 (object (bounding-indices-bad-object condition
)))
1050 "The bounding indices ~S and ~S are bad ~
1051 for a sequence of length ~S."
1052 start end
(length object
)))
1054 ;; from WITH-ARRAY-DATA
1056 "The START and END parameters ~S and ~S are ~
1057 bad for an array of total size ~S."
1058 start end
(array-total-size object
)))))))
1061 (list '(:ansi-cl
:glossary
"bounding index designator")
1062 '(:ansi-cl
:issue
"SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1064 (define-condition nil-array-accessed-error
(reference-condition type-error
)
1066 (:report
(lambda (condition stream
)
1067 (declare (ignore condition
))
1069 "An attempt to access an array of element-type ~
1070 NIL was made. Congratulations!")))
1072 :references
(list '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
)
1073 '(:ansi-cl
:section
(15 1 2 1))
1074 '(:ansi-cl
:section
(15 1 2 2)))))
1076 (define-condition namestring-parse-error
(parse-error)
1077 ((complaint :reader namestring-parse-error-complaint
:initarg
:complaint
)
1078 (args :reader namestring-parse-error-args
:initarg
:args
:initform nil
)
1079 (namestring :reader namestring-parse-error-namestring
:initarg
:namestring
)
1080 (offset :reader namestring-parse-error-offset
:initarg
:offset
))
1082 (lambda (condition stream
)
1084 "parse error in namestring: ~?~% ~A~% ~V@T^"
1085 (namestring-parse-error-complaint condition
)
1086 (namestring-parse-error-args condition
)
1087 (namestring-parse-error-namestring condition
)
1088 (namestring-parse-error-offset condition
)))))
1090 (define-condition simple-package-error
(simple-condition package-error
) ())
1092 (define-condition simple-reader-package-error
(simple-reader-error package-error
) ())
1094 (define-condition reader-eof-error
(end-of-file)
1095 ((context :reader reader-eof-error-context
:initarg
:context
))
1097 (lambda (condition stream
)
1099 "unexpected end of file on ~S ~A"
1100 (stream-error-stream condition
)
1101 (reader-eof-error-context condition
)))))
1103 (define-condition reader-impossible-number-error
(simple-reader-error)
1104 ((error :reader reader-impossible-number-error-error
:initarg
:error
))
1106 (lambda (condition stream
)
1107 (let ((error-stream (stream-error-stream condition
)))
1109 "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1110 (sb!impl
::file-position-or-nil-for-error error-stream
) error-stream
1111 (simple-condition-format-control condition
)
1112 (simple-condition-format-arguments condition
)
1113 (reader-impossible-number-error-error condition
))))))
1115 (define-condition standard-readtable-modified-error
(reference-condition error
)
1116 ((operation :initarg
:operation
:reader standard-readtable-modified-operation
))
1117 (:report
(lambda (condition stream
)
1118 (format stream
"~S would modify the standard readtable."
1119 (standard-readtable-modified-operation condition
))))
1120 (:default-initargs
:references
`((:ansi-cl
:section
(2 1 1 2))
1121 (:ansi-cl
:glossary
"standard readtable"))))
1123 (define-condition standard-pprint-dispatch-table-modified-error
1124 (reference-condition error
)
1125 ((operation :initarg
:operation
1126 :reader standard-pprint-dispatch-table-modified-operation
))
1127 (:report
(lambda (condition stream
)
1128 (format stream
"~S would modify the standard pprint dispatch table."
1129 (standard-pprint-dispatch-table-modified-operation
1132 :references
`((:ansi-cl
:glossary
"standard pprint dispatch table"))))
1134 (define-condition timeout
(serious-condition)
1135 ((seconds :initarg
:seconds
:initform nil
:reader timeout-seconds
))
1136 (:report
(lambda (condition stream
)
1137 (format stream
"Timeout occurred~@[ after ~A seconds~]."
1138 (timeout-seconds condition
)))))
1140 (define-condition io-timeout
(stream-error timeout
)
1141 ((direction :reader io-timeout-direction
:initarg
:direction
))
1143 (lambda (condition stream
)
1144 (declare (type stream stream
))
1146 "I/O timeout while doing ~(~A~) on ~S."
1147 (io-timeout-direction condition
)
1148 (stream-error-stream condition
)))))
1150 (define-condition deadline-timeout
(timeout) ()
1151 (:report
(lambda (condition stream
)
1152 (format stream
"A deadline was reached after ~A seconds."
1153 (timeout-seconds condition
)))))
1155 (define-condition declaration-type-conflict-error
(reference-condition
1159 :format-control
"Symbol ~/sb-impl:print-symbol-with-prefix/ cannot ~
1160 be both the name of a type and the name of a ~
1162 :references
(list '(:ansi-cl
:section
(3 8 21)))))
1164 ;;; Single stepping conditions
1166 (define-condition step-condition
()
1167 ((form :initarg
:form
:reader step-condition-form
))
1169 (:documentation
"Common base class of single-stepping conditions.
1170 STEP-CONDITION-FORM holds a string representation of the form being
1173 (setf (fdocumentation 'step-condition-form
'function
)
1174 "Form associated with the STEP-CONDITION.")
1176 (define-condition step-form-condition
(step-condition)
1177 ((args :initarg
:args
:reader step-condition-args
))
1179 (lambda (condition stream
)
1180 (let ((*print-circle
* t
)
1182 (*print-readably
* nil
))
1184 "Evaluating call:~%~< ~@;~A~:>~%~
1185 ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%"
1186 (list (step-condition-form condition
))
1187 (eq (step-condition-args condition
) :unknown
)
1188 (step-condition-args condition
)))))
1189 (:documentation
"Condition signalled by code compiled with
1190 single-stepping information when about to execute a form.
1191 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1192 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1193 holds the source-path to the original form within that file or NIL.
1194 Associated with this condition are always the restarts STEP-INTO,
1195 STEP-NEXT, and STEP-CONTINUE."))
1197 (define-condition step-result-condition
(step-condition)
1198 ((result :initarg
:result
:reader step-condition-result
)))
1200 (setf (fdocumentation 'step-condition-result
'function
)
1201 "Return values associated with STEP-VALUES-CONDITION as a list,
1202 or the variable value associated with STEP-VARIABLE-CONDITION.")
1204 (define-condition step-values-condition
(step-result-condition)
1206 (:documentation
"Condition signalled by code compiled with
1207 single-stepping information after executing a form.
1208 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1209 the values returned by the form as a list. No associated restarts."))
1211 (define-condition step-finished-condition
(step-condition)
1214 (lambda (condition stream
)
1215 (declare (ignore condition
))
1216 (format stream
"Returning from STEP")))
1217 (:documentation
"Condition signaled when STEP returns."))
1219 ;;; A knob for muffling warnings, mostly for use while loading files.
1220 (defvar *muffled-warnings
* 'uninteresting-redefinition
1221 "A type that ought to specify a subtype of WARNING. Whenever a
1222 warning is signaled, if the warning is of this type and is not
1223 handled by any other handler, it will be muffled.")
1225 ;;; Various STYLE-WARNING signaled in the system.
1226 ;; For the moment, we're only getting into the details for function
1227 ;; redefinitions, but other redefinitions could be done later
1229 (define-condition redefinition-warning
(style-warning)
1232 :reader redefinition-warning-name
)
1234 :initarg
:new-location
1235 :reader redefinition-warning-new-location
)))
1237 (define-condition function-redefinition-warning
(redefinition-warning)
1239 :initarg
:new-function
1240 :reader function-redefinition-warning-new-function
)))
1242 (define-condition redefinition-with-defun
(function-redefinition-warning)
1244 (:report
(lambda (warning stream
)
1245 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1247 (redefinition-warning-name warning
)))))
1249 (define-condition redefinition-with-defmacro
(function-redefinition-warning)
1251 (:report
(lambda (warning stream
)
1252 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1254 (redefinition-warning-name warning
)))))
1256 (define-condition redefinition-with-defgeneric
(redefinition-warning)
1258 (:report
(lambda (warning stream
)
1259 (format stream
"redefining ~/sb-impl::print-symbol-with-prefix/ ~
1261 (redefinition-warning-name warning
)))))
1263 (define-condition redefinition-with-defmethod
(redefinition-warning)
1264 ((qualifiers :initarg
:qualifiers
1265 :reader redefinition-with-defmethod-qualifiers
)
1266 (specializers :initarg
:specializers
1267 :reader redefinition-with-defmethod-specializers
)
1268 (new-location :initarg
:new-location
1269 :reader redefinition-with-defmethod-new-location
)
1270 (old-method :initarg
:old-method
1271 :reader redefinition-with-defmethod-old-method
))
1272 (:report
(lambda (warning stream
)
1273 (format stream
"redefining ~S~{ ~S~} ~S in DEFMETHOD"
1274 (redefinition-warning-name warning
)
1275 (redefinition-with-defmethod-qualifiers warning
)
1276 (redefinition-with-defmethod-specializers warning
)))))
1278 ;;;; Deciding which redefinitions are "interesting".
1280 (defun function-file-namestring (function)
1282 (when (typep function
'sb
!eval
:interpreted-function
)
1283 (return-from function-file-namestring
1284 (sb!c
:definition-source-location-namestring
1285 (sb!eval
:interpreted-function-source-location function
))))
1287 (when (typep function
'sb
!interpreter
:interpreted-function
)
1288 (return-from function-file-namestring
1289 (awhen (sb!interpreter
:fun-source-location function
)
1290 (sb!c
:definition-source-location-namestring it
))))
1291 (let* ((fun (%fun-fun function
))
1292 (code (fun-code-header fun
))
1293 (debug-info (%code-debug-info code
))
1294 (debug-source (when debug-info
1295 (sb!c
::debug-info-source debug-info
)))
1296 (namestring (when debug-source
1297 (sb!c
::debug-source-namestring debug-source
))))
1300 (defun interesting-function-redefinition-warning-p (warning old
)
1301 (let ((new (function-redefinition-warning-new-function warning
))
1302 (source-location (redefinition-warning-new-location warning
)))
1304 ;; compiled->interpreted is interesting.
1305 (and (typep old
'compiled-function
)
1306 (typep new
'(not compiled-function
)))
1307 ;; fin->regular is interesting except for interpreted->compiled.
1308 (and (typep new
'(not funcallable-instance
))
1309 (typep old
'(and funcallable-instance
1310 #!+sb-fasteval
(not sb
!interpreter
:interpreted-function
)
1311 #!+sb-eval
(not sb
!eval
:interpreted-function
))))
1312 ;; different file or unknown location is interesting.
1313 (let* ((old-namestring (function-file-namestring old
))
1315 (or (function-file-namestring new
)
1316 (when source-location
1317 (sb!c
::definition-source-location-namestring source-location
)))))
1318 (and (or (not old-namestring
)
1319 (not new-namestring
)
1320 (not (string= old-namestring new-namestring
))))))))
1322 (setf (info :function
:predicate-truth-constraint
1323 'uninteresting-ordinary-function-redefinition-p
) 'warning
)
1324 (defun uninteresting-ordinary-function-redefinition-p (warning)
1326 (typep warning
'redefinition-with-defun
)
1328 (let ((name (redefinition-warning-name warning
)))
1329 (not (interesting-function-redefinition-warning-p
1330 warning
(or (fdefinition name
) (macro-function name
)))))))
1332 (setf (info :function
:predicate-truth-constraint
1333 'uninteresting-macro-redefinition-p
) 'warning
)
1334 (defun uninteresting-macro-redefinition-p (warning)
1336 (typep warning
'redefinition-with-defmacro
)
1338 (let ((name (redefinition-warning-name warning
)))
1339 (not (interesting-function-redefinition-warning-p
1340 warning
(or (macro-function name
) (fdefinition name
)))))))
1342 (setf (info :function
:predicate-truth-constraint
1343 'uninteresting-generic-function-redefinition-p
) 'warning
)
1344 (defun uninteresting-generic-function-redefinition-p (warning)
1346 (typep warning
'redefinition-with-defgeneric
)
1347 ;; Can't use the shared logic above, since GF's don't get a "new"
1348 ;; definition -- rather the FIN-FUNCTION is set.
1349 (let* ((name (redefinition-warning-name warning
))
1350 (old (fdefinition name
))
1351 (old-location (when (typep old
'generic-function
)
1352 (sb!pcl
::definition-source old
)))
1353 (old-namestring (when old-location
1354 (sb!c
:definition-source-location-namestring old-location
)))
1355 (new-location (redefinition-warning-new-location warning
))
1356 (new-namestring (when new-location
1357 (sb!c
:definition-source-location-namestring new-location
))))
1360 (string= old-namestring new-namestring
)))))
1362 (setf (info :function
:predicate-truth-constraint
1363 'uninteresting-method-redefinition-p
) 'warning
)
1364 (defun uninteresting-method-redefinition-p (warning)
1366 (typep warning
'redefinition-with-defmethod
)
1367 ;; Can't use the shared logic above, since GF's don't get a "new"
1368 ;; definition -- rather the FIN-FUNCTION is set.
1369 (let* ((old-method (redefinition-with-defmethod-old-method warning
))
1370 (old-location (sb!pcl
::definition-source old-method
))
1371 (old-namestring (when old-location
1372 (sb!c
:definition-source-location-namestring old-location
)))
1373 (new-location (redefinition-warning-new-location warning
))
1374 (new-namestring (when new-location
1375 (sb!c
:definition-source-location-namestring new-location
))))
1378 (string= new-namestring old-namestring
)))))
1380 (deftype uninteresting-redefinition
()
1381 '(or (satisfies uninteresting-ordinary-function-redefinition-p
)
1382 (satisfies uninteresting-macro-redefinition-p
)
1383 (satisfies uninteresting-generic-function-redefinition-p
)
1384 (satisfies uninteresting-method-redefinition-p
)))
1386 (define-condition redefinition-with-deftransform
(redefinition-warning)
1387 ((transform :initarg
:transform
1388 :reader redefinition-with-deftransform-transform
))
1389 (:report
(lambda (warning stream
)
1390 (format stream
"Overwriting ~S"
1391 (redefinition-with-deftransform-transform warning
)))))
1393 ;;; Various other STYLE-WARNINGS
1394 (define-condition dubious-asterisks-around-variable-name
1395 (style-warning simple-condition
)
1397 (:report
(lambda (warning stream
)
1398 (format stream
"~@?, even though the name follows~@
1399 the usual naming convention (names like *FOO*) for special variables"
1400 (simple-condition-format-control warning
)
1401 (simple-condition-format-arguments warning
)))))
1403 (define-condition asterisks-around-lexical-variable-name
1404 (dubious-asterisks-around-variable-name)
1407 (define-condition asterisks-around-constant-variable-name
1408 (dubious-asterisks-around-variable-name)
1411 ;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
1412 ;; subclasses of ERROR above having to do with undefined aliens.
1413 (define-condition undefined-alien-style-warning
(style-warning)
1414 ((symbol :initarg
:symbol
:reader undefined-alien-symbol
))
1415 (:report
(lambda (warning stream
)
1416 (format stream
"Undefined alien: ~S"
1417 (undefined-alien-symbol warning
)))))
1419 #!+(or sb-eval sb-fasteval
)
1420 (define-condition lexical-environment-too-complex
(style-warning)
1421 ((form :initarg
:form
:reader lexical-environment-too-complex-form
)
1422 (lexenv :initarg
:lexenv
:reader lexical-environment-too-complex-lexenv
))
1423 (:report
(lambda (warning stream
)
1425 "~@<Native lexical environment too complex for ~
1426 SB-EVAL to evaluate ~S, falling back to ~
1427 SIMPLE-EVAL-IN-LEXENV. Lexenv: ~S~:@>"
1428 (lexical-environment-too-complex-form warning
)
1429 (lexical-environment-too-complex-lexenv warning
)))))
1431 ;; If the interpreter is in use (and the REPL is interpreted),
1432 ;; it's easy to accidentally make the macroexpand-hook an interpreted
1433 ;; function. So MACROEXPAND-1 is a little more careful,
1434 ;; and might signal this, instead of only EVAL being able to signal it.
1435 (define-condition macroexpand-hook-type-error
(type-error)
1437 (:report
(lambda (condition stream
)
1438 (format stream
"The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~S"
1439 (type-error-datum condition
)))))
1441 ;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
1442 (define-condition character-decoding-error-in-comment
(style-warning)
1443 ((stream :initarg
:stream
:reader decoding-error-in-comment-stream
)
1444 (position :initarg
:position
:reader decoding-error-in-comment-position
))
1445 (:report
(lambda (warning stream
)
1447 "Character decoding error in a ~A-comment at ~
1448 position ~A reading source stream ~A, ~
1450 (decoding-error-in-comment-macro warning
)
1451 (decoding-error-in-comment-position warning
)
1452 (decoding-error-in-comment-stream warning
)))))
1454 (define-condition character-decoding-error-in-macro-char-comment
1455 (character-decoding-error-in-comment)
1456 ((char :initform
#\
; :initarg :char
1457 :reader character-decoding-error-in-macro-char-comment-char
)))
1459 (define-condition character-decoding-error-in-dispatch-macro-char-comment
1460 (character-decoding-error-in-comment)
1461 ;; ANSI doesn't give a way for a reader function invoked by a
1462 ;; dispatch macro character to determine which dispatch character
1463 ;; was used, so if a user wants to signal one of these from a custom
1464 ;; comment reader, he'll have to supply the :DISP-CHAR himself.
1465 ((disp-char :initform
#\
# :initarg
:disp-char
1466 :reader character-decoding-error-in-macro-char-comment-disp-char
)
1467 (sub-char :initarg
:sub-char
1468 :reader character-decoding-error-in-macro-char-comment-sub-char
)))
1470 (defun decoding-error-in-comment-macro (warning)
1472 (character-decoding-error-in-macro-char-comment
1473 (character-decoding-error-in-macro-char-comment-char warning
))
1474 (character-decoding-error-in-dispatch-macro-char-comment
1477 (character-decoding-error-in-macro-char-comment-disp-char warning
)
1478 (character-decoding-error-in-macro-char-comment-sub-char warning
)))))
1480 (define-condition deprecated-eval-when-situations
(style-warning)
1481 ((situations :initarg
:situations
1482 :reader deprecated-eval-when-situations-situations
))
1483 (:report
(lambda (warning stream
)
1484 (format stream
"using deprecated EVAL-WHEN situation names~{ ~S~}"
1485 (deprecated-eval-when-situations-situations warning
)))))
1487 (define-condition proclamation-mismatch
(condition)
1488 ((kind :initarg
:kind
:reader proclamation-mismatch-kind
)
1489 (description :initarg
:description
:reader proclamation-mismatch-description
:initform nil
)
1490 (name :initarg
:name
:reader proclamation-mismatch-name
)
1491 (old :initarg
:old
:reader proclamation-mismatch-old
)
1492 (new :initarg
:new
:reader proclamation-mismatch-new
))
1494 (lambda (condition stream
)
1496 "~@<The new ~A proclamation for~@[ ~A~] ~
1497 ~/sb!impl:print-symbol-with-prefix/~
1498 ~@:_~2@T~/sb!impl:print-type-specifier/~@:_~
1499 does not match the old ~4:*~A~3* proclamation~
1500 ~@:_~2@T~/sb!impl:print-type-specifier/~@:>"
1501 (proclamation-mismatch-kind condition
)
1502 (proclamation-mismatch-description condition
)
1503 (proclamation-mismatch-name condition
)
1504 (proclamation-mismatch-new condition
)
1505 (proclamation-mismatch-old condition
)))))
1507 (define-condition type-proclamation-mismatch
(proclamation-mismatch)
1509 (:default-initargs
:kind
'type
))
1511 (define-condition type-proclamation-mismatch-warning
(style-warning
1512 type-proclamation-mismatch
)
1515 (define-condition ftype-proclamation-mismatch
(proclamation-mismatch)
1517 (:default-initargs
:kind
'ftype
))
1519 (define-condition ftype-proclamation-mismatch-warning
(style-warning
1520 ftype-proclamation-mismatch
)
1523 (define-condition ftype-proclamation-mismatch-error
(error
1524 ftype-proclamation-mismatch
)
1526 (:default-initargs
:kind
'ftype
:description
"known function"))
1529 ;;;; deprecation conditions
1531 (define-condition deprecation-condition
(reference-condition)
1532 ((namespace :initarg
:namespace
1533 :reader deprecation-condition-namespace
)
1534 (name :initarg
:name
1535 :reader deprecation-condition-name
)
1536 (replacements :initarg
:replacements
1537 :reader deprecation-condition-replacements
)
1538 (software :initarg
:software
1539 :reader deprecation-condition-software
)
1540 (version :initarg
:version
1541 :reader deprecation-condition-version
)
1542 (runtime-error :initarg
:runtime-error
1543 :reader deprecation-condition-runtime-error
1546 :namespace
(missing-arg)
1548 :replacements
(missing-arg)
1549 :software
(missing-arg)
1550 :version
(missing-arg)
1551 :references
'((:sbcl
:node
"Deprecation Conditions")))
1553 "Superclass for deprecation-related error and warning
1556 (defmethod print-object ((condition deprecation-condition
) stream
)
1557 (flet ((print-it (stream)
1558 (print-deprecation-message
1559 (deprecation-condition-namespace condition
)
1560 (deprecation-condition-name condition
)
1561 (deprecation-condition-software condition
)
1562 (deprecation-condition-version condition
)
1563 (deprecation-condition-replacements condition
)
1566 (print-unreadable-object (condition stream
:type t
)
1568 (print-it stream
))))
1570 (macrolet ((define-deprecation-warning
1571 (name superclass check-runtime-error format-string
1572 &optional documentation
)
1574 (define-condition ,name
(,superclass deprecation-condition
)
1576 ,@(when documentation
1577 `((:documentation
,documentation
))))
1579 (defmethod print-object :after
((condition ,name
) stream
)
1580 (when (and (not *print-escape
*)
1581 ,@(when check-runtime-error
1582 `((deprecation-condition-runtime-error condition
))))
1583 (format stream
,format-string
1584 (deprecation-condition-software condition
)
1585 (deprecation-condition-name condition
)))))))
1587 ;; PRINT-SYMBOL-WITH-PREFIX is spelled using its target package name,
1588 ;; not its cold package name, because these methods aren't unsable until
1589 ;; warm load. (!CALL-A-METHOD does not understand method qualifiers)
1590 (define-deprecation-warning early-deprecation-warning style-warning nil
1591 "~%~@<~:@_In future~@[ ~A~] versions ~
1592 ~/sb-impl:print-symbol-with-prefix/ will signal a full warning ~
1593 at compile-time.~:@>"
1594 "This warning is signaled when the use of a variable,
1595 function, type, etc. in :EARLY deprecation is detected at
1596 compile-time. The use will work at run-time with no warning or
1599 (define-deprecation-warning late-deprecation-warning warning t
1600 "~%~@<~:@_In future~@[ ~A~] versions ~
1601 ~/sb-impl:print-symbol-with-prefix/ will signal a runtime ~
1603 "This warning is signaled when the use of a variable,
1604 function, type, etc. in :LATE deprecation is detected at
1605 compile-time. The use will work at run-time with no warning or
1608 (define-deprecation-warning final-deprecation-warning warning t
1609 "~%~@<~:@_~*An error will be signaled at runtime for ~
1610 ~/sb-impl:print-symbol-with-prefix/.~:@>"
1611 "This warning is signaled when the use of a variable,
1612 function, type, etc. in :FINAL deprecation is detected at
1613 compile-time. An error will be signaled at run-time."))
1615 (define-condition deprecation-error
(error deprecation-condition
)
1618 "This error is signaled at run-time when an attempt is made to use
1619 a thing that is in :FINAL deprecation, i.e. call a function or access
1622 ;;;; restart definitions
1624 (define-condition abort-failure
(control-error) ()
1626 "An ABORT restart was found that failed to transfer control dynamically."))
1628 (defun abort (&optional condition
)
1629 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1631 (invoke-restart (find-restart-or-control-error 'abort condition
))
1632 ;; ABORT signals an error in case there was a restart named ABORT
1633 ;; that did not transfer control dynamically. This could happen with
1635 (error 'abort-failure
))
1637 (defun muffle-warning (&optional condition
)
1638 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1639 CONTROL-ERROR if none exists."
1640 (invoke-restart (find-restart-or-control-error 'muffle-warning condition
)))
1642 (defun try-restart (name condition
&rest arguments
)
1643 (let ((restart (find-restart name condition
)))
1645 (apply #'invoke-restart restart arguments
))))
1647 (macrolet ((define-nil-returning-restart (name args doc
)
1648 `(defun ,name
(,@args
&optional condition
)
1650 (try-restart ',name condition
,@args
))))
1651 (define-nil-returning-restart continue
()
1652 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1653 (define-nil-returning-restart store-value
(value)
1654 "Transfer control and VALUE to a restart named STORE-VALUE, or
1655 return NIL if none exists.")
1656 (define-nil-returning-restart use-value
(value)
1657 "Transfer control and VALUE to a restart named USE-VALUE, or
1658 return NIL if none exists.")
1659 (define-nil-returning-restart print-unreadably
()
1660 "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or
1661 return NIL if none exists."))
1663 ;;; single-stepping restarts
1665 (macrolet ((def (name doc
)
1666 `(defun ,name
(condition)
1668 (invoke-restart (find-restart-or-control-error ',name condition
)))))
1670 "Transfers control to the STEP-CONTINUE restart associated with
1671 the condition, continuing execution without stepping. Signals a
1672 CONTROL-ERROR if the restart does not exist.")
1674 "Transfers control to the STEP-NEXT restart associated with the
1675 condition, executing the current form without stepping and continuing
1676 stepping with the next form. Signals CONTROL-ERROR is the restart does
1679 "Transfers control to the STEP-INTO restart associated with the
1680 condition, stepping into the current form. Signals a CONTROL-ERROR is
1681 the restart does not exist."))
1683 ;;; Compiler macro magic
1685 (define-condition compiler-macro-keyword-problem
()
1686 ((argument :initarg
:argument
:reader compiler-macro-keyword-argument
))
1687 (:report
(lambda (condition stream
)
1688 (format stream
"~@<Argument ~S in keyword position is not ~
1689 a self-evaluating symbol, preventing compiler-macro ~
1691 (compiler-macro-keyword-argument condition
)))))
1693 ;; After (or if) we deem this the optimal name for this condition,
1694 ;; it should be exported from SB-EXT so that people can muffle it.
1695 (define-condition sb
!c
:inlining-dependency-failure
(simple-style-warning) ())
1697 (/show0
"condition.lisp end of file")