1 ;;;; stuff originally from CMU CL's error.lisp which can or should
2 ;;;; come late (mostly related to the CONDITION class itself)
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!KERNEL")
16 ;;;; miscellaneous support utilities
18 ;;; Signalling an error when trying to print an error condition is
19 ;;; generally a PITA, so whatever the failure encountered when
20 ;;; wondering about FILE-POSITION within a condition printer, 'tis
21 ;;; better silently to give up than to try to complain.
22 (defun file-position-or-nil-for-error (stream)
23 ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but
24 ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem
25 ;; absolutely unambiguously to prohibit errors when, e.g., STREAM
26 ;; has been closed so that FILE-POSITION is a nonsense question. So
27 ;; my (WHN) impression is that the conservative approach is to
28 ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew
29 ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd,
30 ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the
31 ;; time an error was reported.)
32 (ignore-errors (file-position stream)))
34 ;;;; the CONDITION class
36 (/show0 "condition.lisp 20")
38 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (/show0 "condition.lisp 24")
42 (def!struct (condition-classoid (:include slot-classoid)
43 (:constructor make-condition-classoid))
44 ;; list of CONDITION-SLOT structures for the direct slots of this
46 (slots nil :type list)
47 ;; list of CONDITION-SLOT structures for all of the effective class
48 ;; slots of this class
49 (class-slots nil :type list)
50 ;; report function or NIL
51 (report nil :type (or function null))
52 ;; list of alternating initargs and initforms
53 (default-initargs () :type list)
54 ;; class precedence list as a list of CLASS objects, with all
55 ;; non-CONDITION classes removed
57 ;; a list of all the effective instance allocation slots of this
58 ;; class that have a non-constant initform or default-initarg.
59 ;; Values for these slots must be computed in the dynamic
60 ;; environment of MAKE-CONDITION.
61 (hairy-slots nil :type list))
63 (/show0 "condition.lisp 49")
67 (!defstruct-with-alternate-metaclass condition
68 :slot-names (actual-initargs assigned-slots)
69 :boa-constructor %make-condition-object
70 :superclass-name instance
71 :metaclass-name condition-classoid
72 :metaclass-constructor make-condition-classoid
75 (defun make-condition-object (actual-initargs)
76 (%make-condition-object actual-initargs nil))
78 (defstruct (condition-slot (:copier nil))
79 (name (missing-arg) :type symbol)
80 ;; list of all applicable initargs
81 (initargs (missing-arg) :type list)
82 ;; names of reader and writer functions
83 (readers (missing-arg) :type list)
84 (writers (missing-arg) :type list)
85 ;; true if :INITFORM was specified
86 (initform-p (missing-arg) :type (member t nil))
87 ;; If this is a function, call it with no args. Otherwise, it's the
89 (initform (missing-arg) :type t)
90 ;; allocation of this slot, or NIL until defaulted
91 (allocation nil :type (member :instance :class nil))
92 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
93 (cell nil :type (or cons null))
95 (documentation nil :type (or string null)))
97 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
98 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
99 ;;; have themselves listed in their CPLs. This behavior is inherited
100 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
101 ;;; figured out whether it's right. -- WHN 19990612
102 (eval-when (:compile-toplevel :load-toplevel :execute)
103 (/show0 "condition.lisp 103")
104 (let ((condition-class (locally
105 ;; KLUDGE: There's a DEFTRANSFORM
106 ;; FIND-CLASSOID for constant class names
107 ;; which creates fast but
108 ;; non-cold-loadable, non-compact code. In
109 ;; this context, we'd rather have compact,
110 ;; cold-loadable code. -- WHN 19990928
111 (declare (notinline find-classoid))
112 (find-classoid 'condition))))
113 (setf (condition-classoid-cpl condition-class)
114 (list condition-class)))
115 (/show0 "condition.lisp 103"))
117 (setf (condition-classoid-report (locally
118 ;; KLUDGE: There's a DEFTRANSFORM
119 ;; FIND-CLASSOID for constant class
120 ;; names which creates fast but
121 ;; non-cold-loadable, non-compact
122 ;; code. In this context, we'd
123 ;; rather have compact,
124 ;; cold-loadable code. -- WHN
126 (declare (notinline find-classoid))
127 (find-classoid 'condition)))
128 (lambda (cond stream)
129 (format stream "Condition ~S was signalled." (type-of cond))))
131 (eval-when (:compile-toplevel :load-toplevel :execute)
133 (defun find-condition-layout (name parent-types)
134 (let* ((cpl (remove-duplicates
138 (condition-classoid-cpl
141 (cond-layout (info :type :compiler-layout 'condition))
142 (olayout (info :type :compiler-layout name))
143 ;; FIXME: Does this do the right thing in case of multiple
144 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
145 ;; it obvious what ANSI intends to be done in the case of
146 ;; multiple inheritance, so it's not actually clear what the
149 (order-layout-inherits (concatenate 'simple-vector
150 (layout-inherits cond-layout)
151 (mapcar #'classoid-layout cpl)))))
153 (not (mismatch (layout-inherits olayout) new-inherits)))
155 (make-layout :classoid (make-undefined-classoid name)
156 :inherits new-inherits
158 :length (layout-length cond-layout)))))
162 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
163 ;;; Condition reporting is mediated through the PRINT-OBJECT method
164 ;;; for the condition type in question, with *PRINT-ESCAPE* always
165 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
166 ;;; a condition type C is equivalent to:
167 ;;; (defmethod print-object ((x c) stream)
168 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
169 ;;; The current code doesn't seem to quite match that.
170 (def!method print-object ((x condition) stream)
172 (print-unreadable-object (x stream :type t :identity t))
173 ;; KLUDGE: A comment from CMU CL here said
174 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
175 ;; superclasses in define-condition call!
176 (dolist (class (condition-classoid-cpl (classoid-of x))
177 (error "no REPORT? shouldn't happen!"))
178 (let ((report (condition-classoid-report class)))
180 (return (funcall report x stream)))))))
182 ;;;; slots of CONDITION objects
184 (defvar *empty-condition-slot* '(empty))
186 (defun find-slot-default (class slot)
187 (let ((initargs (condition-slot-initargs slot))
188 (cpl (condition-classoid-cpl class)))
190 (let ((default-initargs (condition-classoid-default-initargs class)))
191 (dolist (initarg initargs)
192 (let ((val (getf default-initargs initarg *empty-condition-slot*)))
193 (unless (eq val *empty-condition-slot*)
194 (return-from find-slot-default
199 (if (condition-slot-initform-p slot)
200 (let ((initform (condition-slot-initform slot)))
201 (if (functionp initform)
204 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
206 (defun find-condition-class-slot (condition-class slot-name)
208 (condition-classoid-cpl condition-class)
209 (error "There is no slot named ~S in ~S."
210 slot-name condition-class))
211 (dolist (slot (condition-classoid-slots sclass))
212 (when (eq (condition-slot-name slot) slot-name)
213 (return-from find-condition-class-slot slot)))))
215 (defun condition-writer-function (condition new-value name)
216 (dolist (cslot (condition-classoid-class-slots
217 (layout-classoid (%instance-layout condition)))
218 (setf (getf (condition-assigned-slots condition) name)
220 (when (eq (condition-slot-name cslot) name)
221 (return (setf (car (condition-slot-cell cslot)) new-value)))))
223 (defun condition-reader-function (condition name)
224 (let ((class (layout-classoid (%instance-layout condition))))
225 (dolist (cslot (condition-classoid-class-slots class))
226 (when (eq (condition-slot-name cslot) name)
227 (return-from condition-reader-function
228 (car (condition-slot-cell cslot)))))
229 (let ((val (getf (condition-assigned-slots condition) name
230 *empty-condition-slot*)))
231 (if (eq val *empty-condition-slot*)
232 (let ((actual-initargs (condition-actual-initargs condition))
233 (slot (find-condition-class-slot class name)))
235 (error "missing slot ~S of ~S" name condition))
236 (do ((initargs actual-initargs (cddr initargs)))
238 (setf (getf (condition-assigned-slots condition) name)
239 (find-slot-default class slot)))
240 (when (member (car initargs) (condition-slot-initargs slot))
241 (return-from condition-reader-function
242 (setf (getf (condition-assigned-slots condition)
249 (defun make-condition (thing &rest args)
251 "Make an instance of a condition object using the specified initargs."
252 ;; Note: ANSI specifies no exceptional situations in this function.
253 ;; signalling simple-type-error would not be wrong.
254 (let* ((thing (or (and (symbolp thing) (find-classoid thing nil))
256 (class (typecase thing
257 (condition-classoid thing)
259 (error 'simple-type-error
261 :expected-type 'condition-class
262 :format-control "~S is not a condition class."
263 :format-arguments (list thing)))
265 (error 'simple-type-error
267 :expected-type 'condition-class
268 :format-control "bad thing for class argument:~% ~S"
269 :format-arguments (list thing)))))
270 (res (make-condition-object args)))
271 (setf (%instance-layout res) (classoid-layout class))
272 ;; Set any class slots with initargs present in this call.
273 (dolist (cslot (condition-classoid-class-slots class))
274 (dolist (initarg (condition-slot-initargs cslot))
275 (let ((val (getf args initarg *empty-condition-slot*)))
276 (unless (eq val *empty-condition-slot*)
277 (setf (car (condition-slot-cell cslot)) val)))))
278 ;; Default any slots with non-constant defaults now.
279 (dolist (hslot (condition-classoid-hairy-slots class))
280 (when (dolist (initarg (condition-slot-initargs hslot) t)
281 (unless (eq (getf args initarg *empty-condition-slot*)
282 *empty-condition-slot*)
284 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
285 (find-slot-default class hslot))))
288 ;;;; DEFINE-CONDITION
290 (eval-when (:compile-toplevel :load-toplevel :execute)
291 (defun %compiler-define-condition (name direct-supers layout
292 all-readers all-writers)
293 (with-single-package-locked-error
294 (:symbol name "defining ~A as a condition")
295 (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
296 (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
297 (multiple-value-bind (class old-layout)
298 (insured-find-classoid name
299 #'condition-classoid-p
300 #'make-condition-classoid)
301 (setf (layout-classoid layout) class)
302 (setf (classoid-direct-superclasses class)
303 (mapcar #'find-classoid direct-supers))
304 (cond ((not old-layout)
305 (register-layout layout))
306 ((not *type-system-initialized*)
307 (setf (layout-classoid old-layout) class)
308 (setq layout old-layout)
309 (unless (eq (classoid-layout class) layout)
310 (register-layout layout)))
311 ((redefine-layout-warning "current"
314 (layout-length layout)
315 (layout-inherits layout)
316 (layout-depthoid layout))
317 (register-layout layout :invalidate t))
318 ((not (classoid-layout class))
319 (register-layout layout)))
321 (setf (layout-info layout)
323 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
324 ;; names which creates fast but non-cold-loadable, non-compact
325 ;; code. In this context, we'd rather have compact, cold-loadable
326 ;; code. -- WHN 19990928
327 (declare (notinline find-classoid))
328 (layout-info (classoid-layout (find-classoid 'condition)))))
330 (setf (find-classoid name) class)
332 ;; Initialize CPL slot.
333 (setf (condition-classoid-cpl class)
334 (remove-if-not #'condition-classoid-p
335 (std-compute-class-precedence-list class)))))
339 ;;; Compute the effective slots of CLASS, copying inherited slots and
340 ;;; destructively modifying direct slots.
342 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
343 ;;; direct slots. Presumably it follows from the semantics of
344 ;;; inheritance and redefinition of conditions, but finding the cite
345 ;;; and documenting it here would be good. (Or, if this is not in fact
346 ;;; ANSI-compliant, fixing it would also be good.:-)
347 (defun compute-effective-slots (class)
348 (collect ((res (copy-list (condition-classoid-slots class))))
349 (dolist (sclass (cdr (condition-classoid-cpl class)))
350 (dolist (sslot (condition-classoid-slots sclass))
351 (let ((found (find (condition-slot-name sslot) (res)
352 :key #'condition-slot-name)))
354 (setf (condition-slot-initargs found)
355 (union (condition-slot-initargs found)
356 (condition-slot-initargs sslot)))
357 (unless (condition-slot-initform-p found)
358 (setf (condition-slot-initform-p found)
359 (condition-slot-initform-p sslot))
360 (setf (condition-slot-initform found)
361 (condition-slot-initform sslot)))
362 (unless (condition-slot-allocation found)
363 (setf (condition-slot-allocation found)
364 (condition-slot-allocation sslot))))
366 (res (copy-structure sslot)))))))
369 ;;; Early definitions of slot accessor creators.
371 ;;; Slot accessors must be generic functions, but ANSI does not seem
372 ;;; to specify any of them, and we cannot support it before end of
373 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
374 ;;; GFs only at the end of building.
375 (declaim (notinline install-condition-slot-reader
376 install-condition-slot-writer))
377 (defun install-condition-slot-reader (name condition slot-name)
378 (declare (ignore condition))
379 (setf (fdefinition name)
381 (condition-reader-function condition slot-name))))
382 (defun install-condition-slot-writer (name condition slot-name)
383 (declare (ignore condition))
384 (setf (fdefinition name)
385 (lambda (new-value condition)
386 (condition-writer-function condition new-value slot-name))))
388 (defun %define-condition (name parent-types layout slots documentation
389 report default-initargs all-readers all-writers)
390 (with-single-package-locked-error
391 (:symbol name "defining ~A as a condition")
392 (%compiler-define-condition name parent-types layout all-readers all-writers)
393 (let ((class (find-classoid name)))
394 (setf (condition-classoid-slots class) slots)
395 (setf (condition-classoid-report class) report)
396 (setf (condition-classoid-default-initargs class) default-initargs)
397 (setf (fdocumentation name 'type) documentation)
401 ;; Set up reader and writer functions.
402 (let ((slot-name (condition-slot-name slot)))
403 (dolist (reader (condition-slot-readers slot))
404 (install-condition-slot-reader reader name slot-name))
405 (dolist (writer (condition-slot-writers slot))
406 (install-condition-slot-writer writer name slot-name))))
408 ;; Compute effective slots and set up the class and hairy slots
409 ;; (subsets of the effective slots.)
410 (let ((eslots (compute-effective-slots class))
413 (mapcar #'condition-classoid-default-initargs
414 (condition-classoid-cpl class)))))
415 (dolist (slot eslots)
416 (ecase (condition-slot-allocation slot)
418 (unless (condition-slot-cell slot)
419 (setf (condition-slot-cell slot)
420 (list (if (condition-slot-initform-p slot)
421 (let ((initform (condition-slot-initform slot)))
422 (if (functionp initform)
425 *empty-condition-slot*))))
426 (push slot (condition-classoid-class-slots class)))
428 (setf (condition-slot-allocation slot) :instance)
429 (when (or (functionp (condition-slot-initform slot))
430 (dolist (initarg (condition-slot-initargs slot) nil)
431 (when (functionp (getf e-def-initargs initarg))
433 (push slot (condition-classoid-hairy-slots class))))))))
436 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
439 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
440 Define NAME as a condition type. This new type inherits slots and its
441 report function from the specified PARENT-TYPEs. A slot spec is a list of:
442 (slot-name :reader <rname> :initarg <iname> {Option Value}*
444 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
445 and :TYPE and the overall options :DEFAULT-INITARGS and
446 [type] :DOCUMENTATION are also allowed.
448 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
449 a string or a two-argument lambda or function name. If a function, the
450 function is called with the condition and stream to report the condition.
451 If a string, the string is printed.
453 Condition types are classes, but (as allowed by ANSI and not as described in
454 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
455 SLOT-VALUE may not be used on condition objects."
456 (let* ((parent-types (or parent-types '(condition)))
457 (layout (find-condition-layout name parent-types))
460 (default-initargs ()))
462 (all-readers nil append)
463 (all-writers nil append))
464 (dolist (spec slot-specs)
465 (when (keywordp spec)
466 (warn "Keyword slot name indicates probable syntax error:~% ~S"
468 (let* ((spec (if (consp spec) spec (list spec)))
469 (slot-name (first spec))
470 (allocation :instance)
477 (do ((options (rest spec) (cddr options)))
479 (unless (and (consp options) (consp (cdr options)))
480 (error "malformed condition slot spec:~% ~S." spec))
481 (let ((arg (second options)))
482 (case (first options)
483 (:reader (readers arg))
484 (:writer (writers arg))
487 (writers `(setf ,arg)))
490 (error "more than one :INITFORM in ~S" spec))
493 (:initarg (initargs arg))
495 (setq allocation arg))
498 (error "more than one :DOCUMENTATION in ~S" spec))
499 (unless (stringp arg)
500 (error "slot :DOCUMENTATION argument is not a string: ~S"
502 (setq documentation arg))
505 (error "unknown slot option:~% ~S" (first options))))))
507 (all-readers (readers))
508 (all-writers (writers))
509 (slots `(make-condition-slot
511 :initargs ',(initargs)
514 :initform-p ',initform-p
515 :documentation ',documentation
517 ,(if (constantp initform)
519 `#'(lambda () ,initform)))))))
521 (dolist (option options)
522 (unless (consp option)
523 (error "bad option:~% ~S" option))
525 (:documentation (setq documentation (second option)))
527 (let ((arg (second option)))
530 `#'(lambda (condition stream)
531 (declare (ignore condition))
532 (write-string ,arg stream))
533 `#'(lambda (condition stream)
534 (funcall #',arg condition stream))))))
536 (do ((initargs (rest option) (cddr initargs)))
538 (let ((val (second initargs)))
539 (setq default-initargs
540 (list* `',(first initargs)
544 default-initargs)))))
546 (error "unknown option: ~S" (first option)))))
549 (eval-when (:compile-toplevel)
550 (%compiler-define-condition ',name ',parent-types ',layout
551 ',(all-readers) ',(all-writers)))
552 (eval-when (:load-toplevel :execute)
553 (%define-condition ',name
559 (list ,@default-initargs)
561 ',(all-writers)))))))
563 ;;;; DESCRIBE on CONDITIONs
565 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
566 ;;; eventually (once we get CLOS up and running so that we can define
568 (defun describe-condition (condition stream)
570 "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%"
574 (condition-actual-initargs condition)
575 (condition-assigned-slots condition))))
577 ;;;; various CONDITIONs specified by ANSI
579 (define-condition serious-condition (condition) ())
581 (define-condition error (serious-condition) ())
583 (define-condition warning (condition) ())
584 (define-condition style-warning (warning) ())
586 (defun simple-condition-printer (condition stream)
589 (simple-condition-format-control condition)
590 (simple-condition-format-arguments condition)))
592 (define-condition simple-condition ()
593 ((format-control :reader simple-condition-format-control
594 :initarg :format-control
595 :type format-control)
596 (format-arguments :reader simple-condition-format-arguments
597 :initarg :format-arguments
600 (:report simple-condition-printer))
602 (define-condition simple-warning (simple-condition warning) ())
604 (define-condition simple-error (simple-condition error) ())
606 ;;; not specified by ANSI, but too useful not to have around.
607 (define-condition simple-style-warning (simple-condition style-warning) ())
609 (define-condition storage-condition (serious-condition) ())
611 (define-condition type-error (error)
612 ((datum :reader type-error-datum :initarg :datum)
613 (expected-type :reader type-error-expected-type :initarg :expected-type))
615 (lambda (condition stream)
617 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
618 (type-error-datum condition)
619 (type-error-expected-type condition)))))
621 (define-condition simple-type-error (simple-condition type-error) ())
623 (define-condition program-error (error) ())
624 (define-condition parse-error (error) ())
625 (define-condition control-error (error) ())
626 (define-condition stream-error (error)
627 ((stream :reader stream-error-stream :initarg :stream)))
629 (define-condition end-of-file (stream-error) ()
631 (lambda (condition stream)
634 (stream-error-stream condition)))))
636 (define-condition file-error (error)
637 ((pathname :reader file-error-pathname :initarg :pathname))
639 (lambda (condition stream)
640 (format stream "error on file ~S" (file-error-pathname condition)))))
642 (define-condition package-error (error)
643 ((package :reader package-error-package :initarg :package)))
645 (define-condition cell-error (error)
646 ((name :reader cell-error-name :initarg :name)))
648 (define-condition unbound-variable (cell-error) ()
650 (lambda (condition stream)
652 "The variable ~S is unbound."
653 (cell-error-name condition)))))
655 (define-condition undefined-function (cell-error) ()
657 (lambda (condition stream)
659 "The function ~S is undefined."
660 (cell-error-name condition)))))
662 (define-condition special-form-function (undefined-function) ()
664 (lambda (condition stream)
666 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
667 (cell-error-name condition)))))
669 (define-condition arithmetic-error (error)
670 ((operation :reader arithmetic-error-operation
673 (operands :reader arithmetic-error-operands
675 (:report (lambda (condition stream)
677 "arithmetic error ~S signalled"
679 (when (arithmetic-error-operation condition)
681 "~%Operation was ~S, operands ~S."
682 (arithmetic-error-operation condition)
683 (arithmetic-error-operands condition))))))
685 (define-condition division-by-zero (arithmetic-error) ())
686 (define-condition floating-point-overflow (arithmetic-error) ())
687 (define-condition floating-point-underflow (arithmetic-error) ())
688 (define-condition floating-point-inexact (arithmetic-error) ())
689 (define-condition floating-point-invalid-operation (arithmetic-error) ())
691 (define-condition print-not-readable (error)
692 ((object :reader print-not-readable-object :initarg :object))
694 (lambda (condition stream)
695 (let ((obj (print-not-readable-object condition))
697 (format stream "~S cannot be printed readably." obj)))))
699 (define-condition reader-error (parse-error stream-error)
701 :reader reader-error-format-control
702 :initarg :format-control)
704 :reader reader-error-format-arguments
705 :initarg :format-arguments
708 (lambda (condition stream)
709 (let* ((error-stream (stream-error-stream condition))
710 (pos (file-position-or-nil-for-error error-stream)))
713 (< pos sb!xc:array-dimension-limit)
714 ;; KLUDGE: lseek() (which is what FILE-POSITION
715 ;; reduces to on file-streams) is undefined on
716 ;; "some devices", which in practice means that it
717 ;; can claim to succeed on /dev/stdin on Darwin
718 ;; and Solaris. This is obviously bad news,
719 ;; because the READ-SEQUENCE below will then
720 ;; block, not complete, and the report will never
721 ;; be printed. As a workaround, we exclude
722 ;; interactive streams from this attempt to report
723 ;; positions. -- CSR, 2003-08-21
724 (not (interactive-stream-p error-stream))
725 (file-position error-stream :start))
728 :element-type (stream-element-type
730 (when (= pos (read-sequence string error-stream))
731 (setq lineno (1+ (count #\Newline string))
733 (or (position #\Newline string :from-end t) -1)
735 (file-position-or-nil-for-error error-stream pos))
737 "READER-ERROR ~@[at ~W ~]~
738 ~@[(line ~W~]~@[, column ~W) ~]~
740 pos lineno colno error-stream
741 (reader-error-format-control condition)
742 (reader-error-format-arguments condition)))))))
744 ;;;; special SBCL extension conditions
746 ;;; an error apparently caused by a bug in SBCL itself
748 ;;; Note that we don't make any serious effort to use this condition
749 ;;; for *all* errors in SBCL itself. E.g. type errors and array
750 ;;; indexing errors can occur in functions called from SBCL code, and
751 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
752 ;;; because the signalling code has no good way to know that the
753 ;;; underlying problem is a bug in SBCL. But in the fairly common case
754 ;;; that the signalling code does know that it's found a bug in SBCL,
755 ;;; this condition is appropriate, reusing boilerplate and helping
756 ;;; users to recognize it as an SBCL bug.
757 (define-condition bug (simple-error)
760 (lambda (condition stream)
763 (simple-condition-format-control condition)
764 (simple-condition-format-arguments condition)
765 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
766 SBCL might have been corrupted by bad user code, e.g. by an ~
767 undefined Lisp operation like ~S, or by stray pointers from ~
768 alien code or from unsafe Lisp code; or there might be a bug ~
769 in the OS or hardware that SBCL is running on.) If it seems to ~
770 be a bug in SBCL itself, the maintainers would like to know ~
771 about it. Bug reports are welcome on the SBCL ~
772 mailing lists, which you can find at ~
773 <http://sbcl.sourceforge.net/>.~:@>"
774 '((fmakunbound 'compile))))))
776 ;;; a condition for use in stubs for operations which aren't supported
777 ;;; on some platforms
779 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
780 ;;; #-(or freebsd linux)
781 ;;; (defun load-foreign (&rest rest)
782 ;;; (error 'unsupported-operator :name 'load-foreign))
783 ;;; #+(or freebsd linux)
784 ;;; (defun load-foreign ... actual definition ...)
785 ;;; By signalling a standard condition in this case, we make it
786 ;;; possible for test code to distinguish between (1) intentionally
787 ;;; unimplemented and (2) unintentionally just screwed up somehow.
788 ;;; (Before this condition was defined, test code tried to deal with
789 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
790 ;;; sbcl-0.7.0, a a package screwup left the definition of
791 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
792 ;;; architectures where it was supposed to be supported, and the
793 ;;; regression tests cheerfully passed because they assumed that
794 ;;; unFBOUNDPness meant they were running on an system which didn't
795 ;;; support the extension.)
796 (define-condition unsupported-operator (simple-error) ())
799 ;;; (:ansi-cl :function remove)
800 ;;; (:ansi-cl :section (a b c))
801 ;;; (:ansi-cl :glossary "similar")
803 ;;; (:sbcl :node "...")
804 ;;; (:sbcl :variable *ed-functions*)
806 ;;; FIXME: this is not the right place for this.
807 (defun print-reference (reference stream)
808 (ecase (car reference)
810 (format stream "AMOP")
812 (destructuring-bind (type data) (cdr reference)
814 (:generic-function (format stream "Generic Function ~S" data))
815 (:section (format stream "Section ~{~D~^.~}" data)))))
817 (format stream "The ANSI Standard")
819 (destructuring-bind (type data) (cdr reference)
821 (:function (format stream "Function ~S" data))
822 (:special-operator (format stream "Special Operator ~S" data))
823 (:macro (format stream "Macro ~S" data))
824 (:section (format stream "Section ~{~D~^.~}" data))
825 (:glossary (format stream "Glossary entry for ~S" data))
826 (:issue (format stream "writeup for Issue ~A" data)))))
828 (format stream "The SBCL Manual")
830 (destructuring-bind (type data) (cdr reference)
832 (:node (format stream "Node ~S" data))
833 (:variable (format stream "Variable ~S" data))
834 (:function (format stream "Function ~S" data)))))
835 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
837 (define-condition reference-condition ()
838 ((references :initarg :references :reader reference-condition-references)))
839 (defvar *print-condition-references* t)
840 (def!method print-object :around ((o reference-condition) s)
842 (unless (or *print-escape* *print-readably*)
843 (when (and *print-condition-references*
844 (reference-condition-references o))
845 (format s "~&See also:~%")
846 (pprint-logical-block (s nil :per-line-prefix " ")
847 (do* ((rs (reference-condition-references o) (cdr rs))
848 (r (car rs) (car rs)))
850 (print-reference r s)
851 (unless (null (cdr rs))
854 (define-condition duplicate-definition (reference-condition warning)
855 ((name :initarg :name :reader duplicate-definition-name))
856 (:report (lambda (c s)
857 (format s "~@<Duplicate definition for ~S found in ~
859 (duplicate-definition-name c))))
860 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
862 (define-condition package-at-variance (reference-condition simple-warning)
864 (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
866 (define-condition defconstant-uneql (reference-condition error)
867 ((name :initarg :name :reader defconstant-uneql-name)
868 (old-value :initarg :old-value :reader defconstant-uneql-old-value)
869 (new-value :initarg :new-value :reader defconstant-uneql-new-value))
871 (lambda (condition stream)
873 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
874 (defconstant-uneql-name condition)
875 (defconstant-uneql-old-value condition)
876 (defconstant-uneql-new-value condition))))
877 (:default-initargs :references (list '(:ansi-cl :macro defconstant)
878 '(:sbcl :node "Idiosyncrasies"))))
880 (define-condition array-initial-element-mismatch
881 (reference-condition simple-warning)
885 '(:ansi-cl :function make-array)
886 '(:ansi-cl :function sb!xc:upgraded-array-element-type))))
888 (define-condition displaced-to-array-too-small-error
889 (reference-condition simple-error)
892 :references (list '(:ansi-cl :function adjust-array))))
894 (define-condition type-warning (reference-condition simple-warning)
896 (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
898 (define-condition local-argument-mismatch (reference-condition simple-warning)
900 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
902 (define-condition format-args-mismatch (reference-condition)
904 (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2)))))
906 (define-condition format-too-few-args-warning
907 (format-args-mismatch simple-warning)
909 (define-condition format-too-many-args-warning
910 (format-args-mismatch simple-style-warning)
913 (define-condition extension-failure (reference-condition simple-error)
919 (define-condition package-lock-violation (reference-condition package-error)
920 ((format-control :initform nil :initarg :format-control
921 :reader package-error-format-control)
922 (format-arguments :initform nil :initarg :format-arguments
923 :reader package-error-format-arguments))
925 (lambda (condition stream)
926 (let ((control (package-error-format-control condition)))
928 (apply #'format stream
929 (format nil "~~@<Lock on package ~A violated when ~A.~~:@>"
930 (package-name (package-error-package condition))
932 (package-error-format-arguments condition))
933 (format stream "~@<Lock on package ~A violated.~:@>"
934 (package-name (package-error-package condition)))))))
935 ;; no :default-initargs -- reference-stuff provided by the
936 ;; signalling form in target-package.lisp
939 "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
940 when a package-lock is violated."))
942 (define-condition package-locked-error (package-lock-violation) ()
945 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
946 signalled when an operation on a package violates a package lock."))
948 (define-condition symbol-package-locked-error (package-lock-violation)
949 ((symbol :initarg :symbol :reader package-locked-error-symbol))
952 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
953 signalled when an operation on a symbol violates a package lock. The
954 symbol that caused the violation is accessed by the function
955 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
959 (define-condition undefined-alien-error (error) ()
961 (lambda (condition stream)
962 (declare (ignore condition))
963 (format stream "Attempt to access an undefined alien value."))))
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 (define-condition values-type-error (type-error)
978 (lambda (condition stream)
980 "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
981 (type-error-datum condition)
982 (type-error-expected-type condition)))))
984 ;;; KLUDGE: a condition for floating point errors when we can't or
985 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
986 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
987 ;;; know how but the old code was broken by the conversion to POSIX
988 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
990 ;;; FIXME: Perhaps this should also be a base class for all
991 ;;; floating point exceptions?
992 (define-condition floating-point-exception (arithmetic-error)
993 ((flags :initarg :traps
995 :reader floating-point-exception-traps))
996 (:report (lambda (condition stream)
998 "An arithmetic error ~S was signalled.~%"
1000 (let ((traps (floating-point-exception-traps condition)))
1003 "Trapping conditions are: ~%~{ ~S~^~}~%"
1006 "No traps are enabled? How can this be?"
1009 (define-condition index-too-large-error (type-error)
1012 (lambda (condition stream)
1014 "The index ~S is too large."
1015 (type-error-datum condition)))))
1017 (define-condition bounding-indices-bad-error (reference-condition type-error)
1018 ((object :reader bounding-indices-bad-object :initarg :object))
1020 (lambda (condition stream)
1021 (let* ((datum (type-error-datum condition))
1024 (object (bounding-indices-bad-object condition)))
1028 "The bounding indices ~S and ~S are bad ~
1029 for a sequence of length ~S."
1030 start end (length object)))
1032 ;; from WITH-ARRAY-DATA
1034 "The START and END parameters ~S and ~S are ~
1035 bad for an array of total size ~S."
1036 start end (array-total-size object)))))))
1039 (list '(:ansi-cl :glossary "bounding index designator")
1040 '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1042 (define-condition nil-array-accessed-error (reference-condition type-error)
1044 (:report (lambda (condition stream)
1045 (declare (ignore condition))
1047 "An attempt to access an array of element-type ~
1048 NIL was made. Congratulations!")))
1050 :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type)
1051 '(:ansi-cl :section (15 1 2 1))
1052 '(:ansi-cl :section (15 1 2 2)))))
1054 (define-condition io-timeout (stream-error)
1055 ((direction :reader io-timeout-direction :initarg :direction))
1057 (lambda (condition stream)
1058 (declare (type stream stream))
1060 "I/O timeout ~(~A~)ing ~S"
1061 (io-timeout-direction condition)
1062 (stream-error-stream condition)))))
1064 (define-condition namestring-parse-error (parse-error)
1065 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
1066 (args :reader namestring-parse-error-args :initarg :args :initform nil)
1067 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
1068 (offset :reader namestring-parse-error-offset :initarg :offset))
1070 (lambda (condition stream)
1072 "parse error in namestring: ~?~% ~A~% ~V@T^"
1073 (namestring-parse-error-complaint condition)
1074 (namestring-parse-error-args condition)
1075 (namestring-parse-error-namestring condition)
1076 (namestring-parse-error-offset condition)))))
1078 (define-condition simple-package-error (simple-condition package-error) ())
1080 (define-condition reader-package-error (reader-error) ())
1082 (define-condition reader-eof-error (end-of-file)
1083 ((context :reader reader-eof-error-context :initarg :context))
1085 (lambda (condition stream)
1087 "unexpected end of file on ~S ~A"
1088 (stream-error-stream condition)
1089 (reader-eof-error-context condition)))))
1091 (define-condition reader-impossible-number-error (reader-error)
1092 ((error :reader reader-impossible-number-error-error :initarg :error))
1094 (lambda (condition stream)
1095 (let ((error-stream (stream-error-stream condition)))
1096 (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1097 (file-position-or-nil-for-error error-stream) error-stream
1098 (reader-error-format-control condition)
1099 (reader-error-format-arguments condition)
1100 (reader-impossible-number-error-error condition))))))
1102 (define-condition timeout (serious-condition) ())
1104 ;;; Single stepping conditions
1106 (define-condition step-condition ()
1107 ((form :initarg :form :reader step-condition-form))
1109 (:documentation "Common base class of single-stepping conditions.
1110 STEP-CONDITION-FORM holds a string representation of the form being
1114 (setf (fdocumentation 'step-condition-form 'function)
1115 "Form associated with the STEP-CONDITION.")
1117 (define-condition step-form-condition (step-condition)
1118 ((source-path :initarg :source-path :reader step-condition-source-path)
1119 (pathname :initarg :pathname :reader step-condition-pathname))
1121 (:documentation "Condition signalled by code compiled with
1122 single-stepping information when about to execute a form.
1123 STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
1124 pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
1125 holds the source-path to the original form within that file or NIL.
1126 Associated with this condition are always the restarts STEP-INTO,
1127 STEP-NEXT, and STEP-CONTINUE."))
1130 (setf (fdocumentation 'step-condition-source-path 'function)
1131 "Source-path of the original form associated with the
1132 STEP-FORM-CONDITION or NIL."
1133 (fdocumentation 'step-condition-pathname 'function)
1134 "Pathname of the original source-file associated with the
1135 STEP-FORM-CONDITION or NIL.")
1137 (define-condition step-result-condition (step-condition)
1138 ((result :initarg :result :reader step-condition-result)))
1141 (setf (fdocumentation 'step-condition-result 'function)
1142 "Return values associated with STEP-VALUES-CONDITION as a list,
1143 or the variable value associated with STEP-VARIABLE-CONDITION.")
1145 (define-condition step-values-condition (step-result-condition)
1148 (:documentation "Condition signalled by code compiled with
1149 single-stepping information after executing a form.
1150 STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
1151 the values returned by the form as a list. No associated restarts."))
1153 (define-condition step-variable-condition (step-result-condition)
1156 (:documentation "Condition signalled by code compiled with
1157 single-stepping information when referencing a variable.
1158 STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds
1159 the value of the variable. No associated restarts."))
1162 ;;;; restart definitions
1164 (define-condition abort-failure (control-error) ()
1166 "An ABORT restart was found that failed to transfer control dynamically."))
1168 (defun abort (&optional condition)
1170 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1172 (invoke-restart (find-restart-or-control-error 'abort condition))
1173 ;; ABORT signals an error in case there was a restart named ABORT
1174 ;; that did not transfer control dynamically. This could happen with
1176 (error 'abort-failure))
1178 (defun muffle-warning (&optional condition)
1180 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1181 CONTROL-ERROR if none exists."
1182 (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
1184 (macrolet ((define-nil-returning-restart (name args doc)
1185 #!-sb-doc (declare (ignore doc))
1186 `(defun ,name (,@args &optional condition)
1188 ;; FIXME: Perhaps this shared logic should be pulled out into
1189 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
1190 (let ((restart (find-restart ',name condition)))
1192 (invoke-restart restart ,@args))))))
1193 (define-nil-returning-restart continue ()
1194 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1195 (define-nil-returning-restart store-value (value)
1196 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
1198 (define-nil-returning-restart use-value (value)
1199 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
1202 ;;; single-stepping restarts
1204 (macrolet ((def (name doc)
1205 #!-sb-doc (declare (ignore doc))
1206 `(defun ,name (condition)
1208 (invoke-restart (find-restart-or-control-error ',name condition)))))
1210 "Transfers control to the STEP-CONTINUE restart associated with
1211 the condition, continuing execution without stepping. Signals a
1212 CONTROL-ERROR if the restart does not exist.")
1214 "Transfers control to the STEP-NEXT restart associated with the
1215 condition, executing the current form without stepping and continuing
1216 stepping with the next form. Signals CONTROL-ERROR is the restart does
1219 "Transfers control to the STEP-INTO restart associated with the
1220 condition, stepping into the current form. Signals a CONTROL-ERROR is
1221 the restart does not exist."))
1223 (/show0 "condition.lisp end of file")