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 slot-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 alternating initargs and initforms
35 (default-initargs () :type list)
36 ;; class precedence list as a list of CLASS objects, with all
37 ;; non-CONDITION classes removed
39 ;; a list of all the effective instance allocation slots of this
40 ;; class that have a non-constant initform or default-initarg.
41 ;; Values for these slots must be computed in the dynamic
42 ;; environment of MAKE-CONDITION.
43 (hairy-slots nil :type list))
45 (/show0 "condition.lisp 49")
49 (!defstruct-with-alternate-metaclass condition
50 :slot-names (actual-initargs assigned-slots)
51 :boa-constructor %make-condition-object
52 :superclass-name instance
53 :metaclass-name condition-classoid
54 :metaclass-constructor make-condition-classoid
57 (defun make-condition-object (actual-initargs)
58 (%make-condition-object actual-initargs nil))
60 (defstruct (condition-slot (:copier nil))
61 (name (missing-arg) :type symbol)
62 ;; list of all applicable initargs
63 (initargs (missing-arg) :type list)
64 ;; names of reader and writer functions
65 (readers (missing-arg) :type list)
66 (writers (missing-arg) :type list)
67 ;; true if :INITFORM was specified
68 (initform-p (missing-arg) :type (member t nil))
69 ;; If this is a function, call it with no args. Otherwise, it's the
71 (initform (missing-arg) :type t)
72 ;; allocation of this slot, or NIL until defaulted
73 (allocation nil :type (member :instance :class nil))
74 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
75 (cell nil :type (or cons null))
77 (documentation nil :type (or string null)))
79 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
80 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
81 ;;; have themselves listed in their CPLs. This behavior is inherited
82 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
83 ;;; figured out whether it's right. -- WHN 19990612
84 (eval-when (:compile-toplevel :load-toplevel :execute)
85 (/show0 "condition.lisp 103")
86 (let ((condition-class (locally
87 ;; KLUDGE: There's a DEFTRANSFORM
88 ;; FIND-CLASSOID for constant class names
89 ;; which creates fast but
90 ;; non-cold-loadable, non-compact code. In
91 ;; this context, we'd rather have compact,
92 ;; cold-loadable code. -- WHN 19990928
93 (declare (notinline find-classoid))
94 (find-classoid 'condition))))
95 (setf (condition-classoid-cpl condition-class)
96 (list condition-class)))
97 (/show0 "condition.lisp 103"))
99 (setf (condition-classoid-report (locally
100 ;; KLUDGE: There's a DEFTRANSFORM
101 ;; FIND-CLASSOID for constant class
102 ;; names which creates fast but
103 ;; non-cold-loadable, non-compact
104 ;; code. In this context, we'd
105 ;; rather have compact,
106 ;; cold-loadable code. -- WHN
108 (declare (notinline find-classoid))
109 (find-classoid 'condition)))
110 (lambda (cond stream)
111 (format stream "Condition ~S was signalled." (type-of cond))))
113 (eval-when (:compile-toplevel :load-toplevel :execute)
115 (defun find-condition-layout (name parent-types)
116 (let* ((cpl (remove-duplicates
120 (condition-classoid-cpl
123 (cond-layout (info :type :compiler-layout 'condition))
124 (olayout (info :type :compiler-layout name))
125 ;; FIXME: Does this do the right thing in case of multiple
126 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
127 ;; it obvious what ANSI intends to be done in the case of
128 ;; multiple inheritance, so it's not actually clear what the
131 (order-layout-inherits (concatenate 'simple-vector
132 (layout-inherits cond-layout)
133 (mapcar #'classoid-layout cpl)))))
135 (not (mismatch (layout-inherits olayout) new-inherits)))
137 (make-layout :classoid (make-undefined-classoid name)
138 :inherits new-inherits
140 :length (layout-length cond-layout)))))
144 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
145 ;;; Condition reporting is mediated through the PRINT-OBJECT method
146 ;;; for the condition type in question, with *PRINT-ESCAPE* always
147 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
148 ;;; a condition type C is equivalent to:
149 ;;; (defmethod print-object ((x c) stream)
150 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
151 ;;; The current code doesn't seem to quite match that.
152 (def!method print-object ((x condition) stream)
154 (print-unreadable-object (x stream :type t :identity t))
155 ;; KLUDGE: A comment from CMU CL here said
156 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
157 ;; superclasses in define-condition call!
158 (dolist (class (condition-classoid-cpl (classoid-of x))
159 (error "no REPORT? shouldn't happen!"))
160 (let ((report (condition-classoid-report class)))
162 (return (funcall report x stream)))))))
164 ;;;; slots of CONDITION objects
166 (defvar *empty-condition-slot* '(empty))
168 (defun find-slot-default (class slot)
169 (let ((initargs (condition-slot-initargs slot))
170 (cpl (condition-classoid-cpl class)))
172 (let ((default-initargs (condition-classoid-default-initargs class)))
173 (dolist (initarg initargs)
174 (let ((val (getf default-initargs initarg *empty-condition-slot*)))
175 (unless (eq val *empty-condition-slot*)
176 (return-from find-slot-default
181 (if (condition-slot-initform-p slot)
182 (let ((initform (condition-slot-initform slot)))
183 (if (functionp initform)
186 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
188 (defun find-condition-class-slot (condition-class slot-name)
190 (condition-classoid-cpl condition-class)
191 (error "There is no slot named ~S in ~S."
192 slot-name condition-class))
193 (dolist (slot (condition-classoid-slots sclass))
194 (when (eq (condition-slot-name slot) slot-name)
195 (return-from find-condition-class-slot slot)))))
197 (defun condition-writer-function (condition new-value name)
198 (dolist (cslot (condition-classoid-class-slots
199 (layout-classoid (%instance-layout condition)))
200 (setf (getf (condition-assigned-slots condition) name)
202 (when (eq (condition-slot-name cslot) name)
203 (return (setf (car (condition-slot-cell cslot)) new-value)))))
205 (defun condition-reader-function (condition name)
206 (let ((class (layout-classoid (%instance-layout condition))))
207 (dolist (cslot (condition-classoid-class-slots class))
208 (when (eq (condition-slot-name cslot) name)
209 (return-from condition-reader-function
210 (car (condition-slot-cell cslot)))))
211 (let ((val (getf (condition-assigned-slots condition) name
212 *empty-condition-slot*)))
213 (if (eq val *empty-condition-slot*)
214 (let ((actual-initargs (condition-actual-initargs condition))
215 (slot (find-condition-class-slot class name)))
217 (error "missing slot ~S of ~S" name condition))
218 (do ((initargs actual-initargs (cddr initargs)))
220 (setf (getf (condition-assigned-slots condition) name)
221 (find-slot-default class slot)))
222 (when (member (car initargs) (condition-slot-initargs slot))
223 (return-from condition-reader-function
224 (setf (getf (condition-assigned-slots condition)
231 (defun make-condition (thing &rest args)
233 "Make an instance of a condition object using the specified initargs."
234 ;; Note: ANSI specifies no exceptional situations in this function.
235 ;; signalling simple-type-error would not be wrong.
236 (let* ((thing (if (symbolp thing)
237 (find-classoid thing)
239 (class (typecase thing
240 (condition-classoid thing)
242 (error 'simple-type-error
244 :expected-type 'condition-class
245 :format-control "~S is not a condition class."
246 :format-arguments (list thing)))
248 (error 'simple-type-error
250 :expected-type 'condition-class
251 :format-control "bad thing for class argument:~% ~S"
252 :format-arguments (list thing)))))
253 (res (make-condition-object args)))
254 (setf (%instance-layout res) (classoid-layout class))
255 ;; Set any class slots with initargs present in this call.
256 (dolist (cslot (condition-classoid-class-slots class))
257 (dolist (initarg (condition-slot-initargs cslot))
258 (let ((val (getf args initarg *empty-condition-slot*)))
259 (unless (eq val *empty-condition-slot*)
260 (setf (car (condition-slot-cell cslot)) val)))))
261 ;; Default any slots with non-constant defaults now.
262 (dolist (hslot (condition-classoid-hairy-slots class))
263 (when (dolist (initarg (condition-slot-initargs hslot) t)
264 (unless (eq (getf args initarg *empty-condition-slot*)
265 *empty-condition-slot*)
267 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
268 (find-slot-default class hslot))))
272 ;;;; DEFINE-CONDITION
274 (eval-when (:compile-toplevel :load-toplevel :execute)
275 (defun %compiler-define-condition (name direct-supers layout
276 all-readers all-writers)
277 (with-single-package-locked-error
278 (:symbol name "defining ~A as a condition")
279 (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
280 (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
281 (multiple-value-bind (class old-layout)
282 (insured-find-classoid name
283 #'condition-classoid-p
284 #'make-condition-classoid)
285 (setf (layout-classoid layout) class)
286 (setf (classoid-direct-superclasses class)
287 (mapcar #'find-classoid direct-supers))
288 (cond ((not old-layout)
289 (register-layout layout))
290 ((not *type-system-initialized*)
291 (setf (layout-classoid old-layout) class)
292 (setq layout old-layout)
293 (unless (eq (classoid-layout class) layout)
294 (register-layout layout)))
295 ((redefine-layout-warning "current"
298 (layout-length layout)
299 (layout-inherits layout)
300 (layout-depthoid layout))
301 (register-layout layout :invalidate t))
302 ((not (classoid-layout class))
303 (register-layout layout)))
305 (setf (layout-info layout)
307 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
308 ;; names which creates fast but non-cold-loadable, non-compact
309 ;; code. In this context, we'd rather have compact, cold-loadable
310 ;; code. -- WHN 19990928
311 (declare (notinline find-classoid))
312 (layout-info (classoid-layout (find-classoid 'condition)))))
314 (setf (find-classoid name) class)
316 ;; Initialize CPL slot.
317 (setf (condition-classoid-cpl class)
318 (remove-if-not #'condition-classoid-p
319 (std-compute-class-precedence-list class)))))
323 ;;; Compute the effective slots of CLASS, copying inherited slots and
324 ;;; destructively modifying direct slots.
326 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
327 ;;; direct slots. Presumably it follows from the semantics of
328 ;;; inheritance and redefinition of conditions, but finding the cite
329 ;;; and documenting it here would be good. (Or, if this is not in fact
330 ;;; ANSI-compliant, fixing it would also be good.:-)
331 (defun compute-effective-slots (class)
332 (collect ((res (copy-list (condition-classoid-slots class))))
333 (dolist (sclass (cdr (condition-classoid-cpl class)))
334 (dolist (sslot (condition-classoid-slots sclass))
335 (let ((found (find (condition-slot-name sslot) (res)
336 :key #'condition-slot-name)))
338 (setf (condition-slot-initargs found)
339 (union (condition-slot-initargs found)
340 (condition-slot-initargs sslot)))
341 (unless (condition-slot-initform-p found)
342 (setf (condition-slot-initform-p found)
343 (condition-slot-initform-p sslot))
344 (setf (condition-slot-initform found)
345 (condition-slot-initform sslot)))
346 (unless (condition-slot-allocation found)
347 (setf (condition-slot-allocation found)
348 (condition-slot-allocation sslot))))
350 (res (copy-structure sslot)))))))
353 ;;; Early definitions of slot accessor creators.
355 ;;; Slot accessors must be generic functions, but ANSI does not seem
356 ;;; to specify any of them, and we cannot support it before end of
357 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
358 ;;; GFs only at the end of building.
359 (declaim (notinline install-condition-slot-reader
360 install-condition-slot-writer))
361 (defun install-condition-slot-reader (name condition slot-name)
362 (declare (ignore condition))
363 (setf (fdefinition name)
365 (condition-reader-function condition slot-name))))
366 (defun install-condition-slot-writer (name condition slot-name)
367 (declare (ignore condition))
368 (setf (fdefinition name)
369 (lambda (new-value condition)
370 (condition-writer-function condition new-value slot-name))))
372 (defun %define-condition (name parent-types layout slots documentation
373 report default-initargs all-readers all-writers)
374 (with-single-package-locked-error
375 (:symbol name "defining ~A as a condition")
376 (%compiler-define-condition name parent-types layout all-readers all-writers)
377 (let ((class (find-classoid name)))
378 (setf (condition-classoid-slots class) slots)
379 (setf (condition-classoid-report class) report)
380 (setf (condition-classoid-default-initargs class) default-initargs)
381 (setf (fdocumentation name 'type) documentation)
385 ;; Set up reader and writer functions.
386 (let ((slot-name (condition-slot-name slot)))
387 (dolist (reader (condition-slot-readers slot))
388 (install-condition-slot-reader reader name slot-name))
389 (dolist (writer (condition-slot-writers slot))
390 (install-condition-slot-writer writer name slot-name))))
392 ;; Compute effective slots and set up the class and hairy slots
393 ;; (subsets of the effective slots.)
394 (let ((eslots (compute-effective-slots class))
397 (mapcar #'condition-classoid-default-initargs
398 (condition-classoid-cpl class)))))
399 (dolist (slot eslots)
400 (ecase (condition-slot-allocation slot)
402 (unless (condition-slot-cell slot)
403 (setf (condition-slot-cell slot)
404 (list (if (condition-slot-initform-p slot)
405 (let ((initform (condition-slot-initform slot)))
406 (if (functionp initform)
409 *empty-condition-slot*))))
410 (push slot (condition-classoid-class-slots class)))
412 (setf (condition-slot-allocation slot) :instance)
413 (when (or (functionp (condition-slot-initform slot))
414 (dolist (initarg (condition-slot-initargs slot) nil)
415 (when (functionp (getf e-def-initargs initarg))
417 (push slot (condition-classoid-hairy-slots class))))))))
420 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
423 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
424 Define NAME as a condition type. This new type inherits slots and its
425 report function from the specified PARENT-TYPEs. A slot spec is a list of:
426 (slot-name :reader <rname> :initarg <iname> {Option Value}*
428 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
429 and :TYPE and the overall options :DEFAULT-INITARGS and
430 [type] :DOCUMENTATION are also allowed.
432 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
433 a string or a two-argument lambda or function name. If a function, the
434 function is called with the condition and stream to report the condition.
435 If a string, the string is printed.
437 Condition types are classes, but (as allowed by ANSI and not as described in
438 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
439 SLOT-VALUE may not be used on condition objects."
440 (let* ((parent-types (or parent-types '(condition)))
441 (layout (find-condition-layout name parent-types))
444 (default-initargs ()))
446 (all-readers nil append)
447 (all-writers nil append))
448 (dolist (spec slot-specs)
449 (when (keywordp spec)
450 (warn "Keyword slot name indicates probable syntax error:~% ~S"
452 (let* ((spec (if (consp spec) spec (list spec)))
453 (slot-name (first spec))
454 (allocation :instance)
461 (do ((options (rest spec) (cddr options)))
463 (unless (and (consp options) (consp (cdr options)))
464 (error "malformed condition slot spec:~% ~S." spec))
465 (let ((arg (second options)))
466 (case (first options)
467 (:reader (readers arg))
468 (:writer (writers arg))
471 (writers `(setf ,arg)))
474 (error "more than one :INITFORM in ~S" spec))
477 (:initarg (initargs arg))
479 (setq allocation arg))
482 (error "more than one :DOCUMENTATION in ~S" spec))
483 (unless (stringp arg)
484 (error "slot :DOCUMENTATION argument is not a string: ~S"
486 (setq documentation arg))
489 (error "unknown slot option:~% ~S" (first options))))))
491 (all-readers (readers))
492 (all-writers (writers))
493 (slots `(make-condition-slot
495 :initargs ',(initargs)
498 :initform-p ',initform-p
499 :documentation ',documentation
501 ,(if (constantp initform)
503 `#'(lambda () ,initform)))))))
505 (dolist (option options)
506 (unless (consp option)
507 (error "bad option:~% ~S" option))
509 (:documentation (setq documentation (second option)))
511 (let ((arg (second option)))
514 `#'(lambda (condition stream)
515 (declare (ignore condition))
516 (write-string ,arg stream))
517 `#'(lambda (condition stream)
518 (funcall #',arg condition stream))))))
520 (do ((initargs (rest option) (cddr initargs)))
522 (let ((val (second initargs)))
523 (setq default-initargs
524 (list* `',(first initargs)
528 default-initargs)))))
530 (error "unknown option: ~S" (first option)))))
533 (eval-when (:compile-toplevel)
534 (%compiler-define-condition ',name ',parent-types ',layout
535 ',(all-readers) ',(all-writers)))
536 (eval-when (:load-toplevel :execute)
537 (%define-condition ',name
543 (list ,@default-initargs)
545 ',(all-writers)))))))
547 ;;;; DESCRIBE on CONDITIONs
549 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
550 ;;; eventually (once we get CLOS up and running so that we can define
552 (defun describe-condition (condition stream)
554 "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%"
558 (condition-actual-initargs condition)
559 (condition-assigned-slots condition))))
561 ;;;; various CONDITIONs specified by ANSI
563 (define-condition serious-condition (condition) ())
565 (define-condition error (serious-condition) ())
567 (define-condition warning (condition) ())
568 (define-condition style-warning (warning) ())
570 (defun simple-condition-printer (condition stream)
573 (simple-condition-format-control condition)
574 (simple-condition-format-arguments condition)))
576 (define-condition simple-condition ()
577 ((format-control :reader simple-condition-format-control
578 :initarg :format-control
579 :type format-control)
580 (format-arguments :reader simple-condition-format-arguments
581 :initarg :format-arguments
584 (:report simple-condition-printer))
586 (define-condition simple-warning (simple-condition warning) ())
588 (define-condition simple-error (simple-condition error) ())
590 ;;; not specified by ANSI, but too useful not to have around.
591 (define-condition simple-style-warning (simple-condition style-warning) ())
593 (define-condition storage-condition (serious-condition) ())
595 (define-condition type-error (error)
596 ((datum :reader type-error-datum :initarg :datum)
597 (expected-type :reader type-error-expected-type :initarg :expected-type))
599 (lambda (condition stream)
601 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
602 (type-error-datum condition)
603 (type-error-expected-type condition)))))
605 (define-condition simple-type-error (simple-condition type-error) ())
607 (define-condition program-error (error) ())
608 (define-condition parse-error (error) ())
609 (define-condition control-error (error) ())
610 (define-condition stream-error (error)
611 ((stream :reader stream-error-stream :initarg :stream)))
613 (define-condition end-of-file (stream-error) ()
615 (lambda (condition stream)
618 (stream-error-stream condition)))))
620 (define-condition file-error (error)
621 ((pathname :reader file-error-pathname :initarg :pathname))
623 (lambda (condition stream)
624 (format stream "error on file ~S" (file-error-pathname condition)))))
626 (define-condition package-error (error)
627 ((package :reader package-error-package :initarg :package)))
629 (define-condition cell-error (error)
630 ((name :reader cell-error-name :initarg :name)))
632 (define-condition unbound-variable (cell-error) ()
634 (lambda (condition stream)
636 "The variable ~S is unbound."
637 (cell-error-name condition)))))
639 (define-condition undefined-function (cell-error) ()
641 (lambda (condition stream)
643 "The function ~S is undefined."
644 (cell-error-name condition)))))
646 (define-condition special-form-function (undefined-function) ()
648 (lambda (condition stream)
650 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
651 (cell-error-name condition)))))
653 (define-condition arithmetic-error (error)
654 ((operation :reader arithmetic-error-operation
657 (operands :reader arithmetic-error-operands
659 (:report (lambda (condition stream)
661 "arithmetic error ~S signalled"
663 (when (arithmetic-error-operation condition)
665 "~%Operation was ~S, operands ~S."
666 (arithmetic-error-operation condition)
667 (arithmetic-error-operands condition))))))
669 (define-condition division-by-zero (arithmetic-error) ())
670 (define-condition floating-point-overflow (arithmetic-error) ())
671 (define-condition floating-point-underflow (arithmetic-error) ())
672 (define-condition floating-point-inexact (arithmetic-error) ())
673 (define-condition floating-point-invalid-operation (arithmetic-error) ())
675 (define-condition print-not-readable (error)
676 ((object :reader print-not-readable-object :initarg :object))
678 (lambda (condition stream)
679 (let ((obj (print-not-readable-object condition))
681 (format stream "~S cannot be printed readably." obj)))))
683 (define-condition reader-error (parse-error stream-error)
685 :reader reader-error-format-control
686 :initarg :format-control)
688 :reader reader-error-format-arguments
689 :initarg :format-arguments
692 (lambda (condition stream)
693 (let* ((error-stream (stream-error-stream condition))
694 (pos (file-position error-stream)))
697 (< pos sb!xc:array-dimension-limit)
698 ;; KLUDGE: lseek() (which is what FILE-POSITION
699 ;; reduces to on file-streams) is undefined on
700 ;; "some devices", which in practice means that it
701 ;; can claim to succeed on /dev/stdin on Darwin
702 ;; and Solaris. This is obviously bad news,
703 ;; because the READ-SEQUENCE below will then
704 ;; block, not complete, and the report will never
705 ;; be printed. As a workaround, we exclude
706 ;; interactive streams from this attempt to report
707 ;; positions. -- CSR, 2003-08-21
708 (not (interactive-stream-p error-stream))
709 (file-position error-stream :start))
712 :element-type (stream-element-type error-stream))))
713 (when (= pos (read-sequence string error-stream))
714 (setq lineno (1+ (count #\Newline string))
716 (or (position #\Newline string :from-end t) -1)
718 (file-position error-stream pos))
720 "READER-ERROR ~@[at ~W ~]~
721 ~@[(line ~W~]~@[, column ~W) ~]~
723 pos lineno colno error-stream
724 (reader-error-format-control condition)
725 (reader-error-format-arguments condition)))))))
727 ;;;; special SBCL extension conditions
729 ;;; an error apparently caused by a bug in SBCL itself
731 ;;; Note that we don't make any serious effort to use this condition
732 ;;; for *all* errors in SBCL itself. E.g. type errors and array
733 ;;; indexing errors can occur in functions called from SBCL code, and
734 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
735 ;;; because the signalling code has no good way to know that the
736 ;;; underlying problem is a bug in SBCL. But in the fairly common case
737 ;;; that the signalling code does know that it's found a bug in SBCL,
738 ;;; this condition is appropriate, reusing boilerplate and helping
739 ;;; users to recognize it as an SBCL bug.
740 (define-condition bug (simple-error)
743 (lambda (condition stream)
746 (simple-condition-format-control condition)
747 (simple-condition-format-arguments condition)
748 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
749 SBCL might have been corrupted by bad user code, e.g. by an ~
750 undefined Lisp operation like ~S, or by stray pointers from ~
751 alien code or from unsafe Lisp code; or there might be a bug ~
752 in the OS or hardware that SBCL is running on.) If it seems to ~
753 be a bug in SBCL itself, the maintainers would like to know ~
754 about it. Bug reports are welcome on the SBCL ~
755 mailing lists, which you can find at ~
756 <http://sbcl.sourceforge.net/>.~:@>"
757 '((fmakunbound 'compile))))))
759 ;;; a condition for use in stubs for operations which aren't supported
760 ;;; on some platforms
762 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
763 ;;; #-(or freebsd linux)
764 ;;; (defun load-foreign (&rest rest)
765 ;;; (error 'unsupported-operator :name 'load-foreign))
766 ;;; #+(or freebsd linux)
767 ;;; (defun load-foreign ... actual definition ...)
768 ;;; By signalling a standard condition in this case, we make it
769 ;;; possible for test code to distinguish between (1) intentionally
770 ;;; unimplemented and (2) unintentionally just screwed up somehow.
771 ;;; (Before this condition was defined, test code tried to deal with
772 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
773 ;;; sbcl-0.7.0, a a package screwup left the definition of
774 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
775 ;;; architectures where it was supposed to be supported, and the
776 ;;; regression tests cheerfully passed because they assumed that
777 ;;; unFBOUNDPness meant they were running on an system which didn't
778 ;;; support the extension.)
779 (define-condition unsupported-operator (cell-error) ()
781 (lambda (condition stream)
783 "unsupported on this platform (OS, CPU, whatever): ~S"
784 (cell-error-name condition)))))
786 ;;; (:ansi-cl :function remove)
787 ;;; (:ansi-cl :section (a b c))
788 ;;; (:ansi-cl :glossary "similar")
790 ;;; (:sbcl :node "...")
791 ;;; (:sbcl :variable *ed-functions*)
793 ;;; FIXME: this is not the right place for this.
794 (defun print-reference (reference stream)
795 (ecase (car reference)
797 (format stream "The ANSI Standard")
799 (destructuring-bind (type data) (cdr reference)
801 (:function (format stream "Function ~S" data))
802 (:special-operator (format stream "Special Operator ~S" data))
803 (:macro (format stream "Macro ~S" data))
804 (:section (format stream "Section ~{~D~^.~}" data))
805 (:glossary (format stream "Glossary entry for ~S" data))
806 (:issue (format stream "writeup for Issue ~A" data)))))
808 (format stream "The SBCL Manual")
810 (destructuring-bind (type data) (cdr reference)
812 (:node (format stream "Node ~S" data))
813 (:variable (format stream "Variable ~S" data)))))
814 ;; FIXME: other documents (e.g. AMOP, Franz documentation :-)
816 (define-condition reference-condition ()
817 ((references :initarg :references :reader reference-condition-references)))
818 (defvar *print-condition-references* t)
819 (def!method print-object :around ((o reference-condition) s)
821 (unless (or *print-escape* *print-readably*)
822 (when *print-condition-references*
823 (format s "~&See also:~%")
824 (pprint-logical-block (s nil :per-line-prefix " ")
825 (do* ((rs (reference-condition-references o) (cdr rs))
826 (r (car rs) (car rs)))
828 (print-reference r s)
829 (unless (null (cdr rs))
832 (define-condition duplicate-definition (reference-condition warning)
833 ((name :initarg :name :reader duplicate-definition-name))
834 (:report (lambda (c s)
835 (format s "~@<Duplicate definition for ~S found in ~
837 (duplicate-definition-name c))))
838 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
840 (define-condition package-at-variance (reference-condition simple-warning)
842 (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
844 (define-condition defconstant-uneql (reference-condition error)
845 ((name :initarg :name :reader defconstant-uneql-name)
846 (old-value :initarg :old-value :reader defconstant-uneql-old-value)
847 (new-value :initarg :new-value :reader defconstant-uneql-new-value))
849 (lambda (condition stream)
851 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
852 (defconstant-uneql-name condition)
853 (defconstant-uneql-old-value condition)
854 (defconstant-uneql-new-value condition))))
855 (:default-initargs :references (list '(:ansi-cl :macro defconstant)
856 '(:sbcl :node "Idiosyncrasies"))))
858 (define-condition array-initial-element-mismatch
859 (reference-condition simple-warning)
863 '(:ansi-cl :function make-array)
864 '(:ansi-cl :function sb!xc:upgraded-array-element-type))))
866 (define-condition displaced-to-array-too-small-error
867 (reference-condition simple-error)
870 :references (list '(:ansi-cl :function adjust-array))))
872 (define-condition type-warning (reference-condition simple-warning)
874 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
876 (define-condition local-argument-mismatch (reference-condition simple-warning)
878 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
880 (define-condition format-args-mismatch (reference-condition)
882 (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2)))))
884 (define-condition format-too-few-args-warning
885 (format-args-mismatch simple-warning)
887 (define-condition format-too-many-args-warning
888 (format-args-mismatch simple-style-warning)
891 (define-condition extension-failure (reference-condition simple-error)
897 (define-condition package-lock-violation (reference-condition package-error)
898 ((format-control :initform nil :initarg :format-control
899 :reader package-error-format-control)
900 (format-arguments :initform nil :initarg :format-arguments
901 :reader package-error-format-arguments))
903 (lambda (condition stream)
904 (let ((control (package-error-format-control condition))
905 (*print-pretty* nil))
907 (format stream "Package lock on ~S violated when ~?."
908 (package-error-package condition)
910 (package-error-format-arguments condition))
911 (format stream "Package lock on ~S violated."
912 (package-error-package condition))))))
913 ;; no :default-initargs -- reference-stuff provided by the
914 ;; signalling form in target-package.lisp
917 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
918 when a package-lock is violated."))
920 (define-condition package-locked-error (package-lock-violation) ()
923 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
924 signalled when an operation on a package violates a package lock."))
927 (define-condition symbol-package-locked-error (package-lock-violation)
928 ((symbol :initarg :symbol :reader package-locked-error-symbol))
931 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
932 signalled when an operation on a symbol violates a package lock. The
933 symbol that caused the violation is accessed by the function
934 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
938 ;;;; various other (not specified by ANSI) CONDITIONs
940 ;;;; These might logically belong in other files; they're here, after
941 ;;;; setup of CONDITION machinery, only because that makes it easier to
942 ;;;; get cold init to work.
944 (define-condition values-type-error (type-error)
947 (lambda (condition stream)
949 "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
950 (type-error-datum condition)
951 (type-error-expected-type condition)))))
953 ;;; KLUDGE: a condition for floating point errors when we can't or
954 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
955 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
956 ;;; know how but the old code was broken by the conversion to POSIX
957 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
959 ;;; FIXME: Perhaps this should also be a base class for all
960 ;;; floating point exceptions?
961 (define-condition floating-point-exception (arithmetic-error)
962 ((flags :initarg :traps
964 :reader floating-point-exception-traps))
965 (:report (lambda (condition stream)
967 "An arithmetic error ~S was signalled.~%"
969 (let ((traps (floating-point-exception-traps condition)))
972 "Trapping conditions are: ~%~{ ~S~^~}~%"
975 "No traps are enabled? How can this be?"
978 (define-condition index-too-large-error (type-error)
981 (lambda (condition stream)
983 "The index ~S is too large."
984 (type-error-datum condition)))))
986 (define-condition bounding-indices-bad-error (reference-condition type-error)
987 ((object :reader bounding-indices-bad-object :initarg :object))
989 (lambda (condition stream)
990 (let* ((datum (type-error-datum condition))
993 (object (bounding-indices-bad-object condition)))
997 "The bounding indices ~S and ~S are bad ~
998 for a sequence of length ~S."
999 start end (length object)))
1001 ;; from WITH-ARRAY-DATA
1003 "The START and END parameters ~S and ~S are ~
1004 bad for an array of total size ~S."
1005 start end (array-total-size object)))))))
1008 (list '(:ansi-cl :glossary "bounding index designator")
1009 '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1011 (define-condition nil-array-accessed-error (reference-condition type-error)
1013 (:report (lambda (condition stream)
1014 (declare (ignore condition))
1016 "An attempt to access an array of element-type ~
1017 NIL was made. Congratulations!")))
1019 :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type)
1020 '(:ansi-cl :section (15 1 2 1))
1021 '(:ansi-cl :section (15 1 2 2)))))
1023 (define-condition io-timeout (stream-error)
1024 ((direction :reader io-timeout-direction :initarg :direction))
1026 (lambda (condition stream)
1027 (declare (type stream stream))
1029 "I/O timeout ~(~A~)ing ~S"
1030 (io-timeout-direction condition)
1031 (stream-error-stream condition)))))
1033 (define-condition namestring-parse-error (parse-error)
1034 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
1035 (args :reader namestring-parse-error-args :initarg :args :initform nil)
1036 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
1037 (offset :reader namestring-parse-error-offset :initarg :offset))
1039 (lambda (condition stream)
1041 "parse error in namestring: ~?~% ~A~% ~V@T^"
1042 (namestring-parse-error-complaint condition)
1043 (namestring-parse-error-args condition)
1044 (namestring-parse-error-namestring condition)
1045 (namestring-parse-error-offset condition)))))
1047 (define-condition simple-package-error (simple-condition package-error) ())
1049 (define-condition reader-package-error (reader-error) ())
1051 (define-condition reader-eof-error (end-of-file)
1052 ((context :reader reader-eof-error-context :initarg :context))
1054 (lambda (condition stream)
1056 "unexpected end of file on ~S ~A"
1057 (stream-error-stream condition)
1058 (reader-eof-error-context condition)))))
1060 (define-condition reader-impossible-number-error (reader-error)
1061 ((error :reader reader-impossible-number-error-error :initarg :error))
1063 (lambda (condition stream)
1064 (let ((error-stream (stream-error-stream condition)))
1065 (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1066 (file-position error-stream) error-stream
1067 (reader-error-format-control condition)
1068 (reader-error-format-arguments condition)
1069 (reader-impossible-number-error-error condition))))))
1071 (define-condition timeout (serious-condition) ())
1073 ;;;; restart definitions
1075 (define-condition abort-failure (control-error) ()
1077 "An ABORT restart was found that failed to transfer control dynamically."))
1079 (defun abort (&optional condition)
1081 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1083 (invoke-restart (find-restart-or-control-error 'abort condition))
1084 ;; ABORT signals an error in case there was a restart named ABORT
1085 ;; that did not transfer control dynamically. This could happen with
1087 (error 'abort-failure))
1089 (defun muffle-warning (&optional condition)
1091 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1092 CONTROL-ERROR if none exists."
1093 (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1095 (macrolet ((define-nil-returning-restart (name args doc)
1096 #!-sb-doc (declare (ignore doc))
1097 `(defun ,name (,@args &optional condition)
1099 ;; FIXME: Perhaps this shared logic should be pulled out into
1100 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
1101 (let ((restart (find-restart ',name condition)))
1103 (invoke-restart restart ,@args))))))
1104 (define-nil-returning-restart continue ()
1105 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1106 (define-nil-returning-restart store-value (value)
1107 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
1109 (define-nil-returning-restart use-value (value)
1110 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
1113 (/show0 "condition.lisp end of file")