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
))))
271 ;;;; DEFINE-CONDITION
273 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
274 (defun %compiler-define-condition
(name direct-supers layout
275 all-readers all-writers
)
276 (with-single-package-locked-error
277 (:symbol name
"defining ~A as a condition")
278 (sb!xc
:proclaim
`(ftype (function (t) t
) ,@all-readers
))
279 (sb!xc
:proclaim
`(ftype (function (t t
) t
) ,@all-writers
))
280 (multiple-value-bind (class old-layout
)
281 (insured-find-classoid name
282 #'condition-classoid-p
283 #'make-condition-classoid
)
284 (setf (layout-classoid layout
) class
)
285 (setf (classoid-direct-superclasses class
)
286 (mapcar #'find-classoid direct-supers
))
287 (cond ((not old-layout
)
288 (register-layout layout
))
289 ((not *type-system-initialized
*)
290 (setf (layout-classoid old-layout
) class
)
291 (setq layout old-layout
)
292 (unless (eq (classoid-layout class
) layout
)
293 (register-layout layout
)))
294 ((redefine-layout-warning "current"
297 (layout-length layout
)
298 (layout-inherits layout
)
299 (layout-depthoid layout
))
300 (register-layout layout
:invalidate t
))
301 ((not (classoid-layout class
))
302 (register-layout layout
)))
304 (setf (layout-info layout
)
306 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
307 ;; names which creates fast but non-cold-loadable, non-compact
308 ;; code. In this context, we'd rather have compact, cold-loadable
309 ;; code. -- WHN 19990928
310 (declare (notinline find-classoid
))
311 (layout-info (classoid-layout (find-classoid 'condition
)))))
313 (setf (find-classoid name
) class
)
315 ;; Initialize CPL slot.
316 (setf (condition-classoid-cpl class
)
317 (remove-if-not #'condition-classoid-p
318 (std-compute-class-precedence-list class
)))))
322 ;;; Compute the effective slots of CLASS, copying inherited slots and
323 ;;; destructively modifying direct slots.
325 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
326 ;;; direct slots. Presumably it follows from the semantics of
327 ;;; inheritance and redefinition of conditions, but finding the cite
328 ;;; and documenting it here would be good. (Or, if this is not in fact
329 ;;; ANSI-compliant, fixing it would also be good.:-)
330 (defun compute-effective-slots (class)
331 (collect ((res (copy-list (condition-classoid-slots class
))))
332 (dolist (sclass (cdr (condition-classoid-cpl class
)))
333 (dolist (sslot (condition-classoid-slots sclass
))
334 (let ((found (find (condition-slot-name sslot
) (res)
335 :key
#'condition-slot-name
)))
337 (setf (condition-slot-initargs found
)
338 (union (condition-slot-initargs found
)
339 (condition-slot-initargs sslot
)))
340 (unless (condition-slot-initform-p found
)
341 (setf (condition-slot-initform-p found
)
342 (condition-slot-initform-p sslot
))
343 (setf (condition-slot-initform found
)
344 (condition-slot-initform sslot
)))
345 (unless (condition-slot-allocation found
)
346 (setf (condition-slot-allocation found
)
347 (condition-slot-allocation sslot
))))
349 (res (copy-structure sslot
)))))))
352 ;;; Early definitions of slot accessor creators.
354 ;;; Slot accessors must be generic functions, but ANSI does not seem
355 ;;; to specify any of them, and we cannot support it before end of
356 ;;; warm init. So we use ordinary functions inside SBCL, and switch to
357 ;;; GFs only at the end of building.
358 (declaim (notinline install-condition-slot-reader
359 install-condition-slot-writer
))
360 (defun install-condition-slot-reader (name condition slot-name
)
361 (declare (ignore condition
))
362 (setf (fdefinition name
)
364 (condition-reader-function condition slot-name
))))
365 (defun install-condition-slot-writer (name condition slot-name
)
366 (declare (ignore condition
))
367 (setf (fdefinition name
)
368 (lambda (new-value condition
)
369 (condition-writer-function condition new-value slot-name
))))
371 (defun %define-condition
(name parent-types layout slots documentation
372 report default-initargs all-readers all-writers
)
373 (with-single-package-locked-error
374 (:symbol name
"defining ~A as a condition")
375 (%compiler-define-condition name parent-types layout all-readers all-writers
)
376 (let ((class (find-classoid name
)))
377 (setf (condition-classoid-slots class
) slots
)
378 (setf (condition-classoid-report class
) report
)
379 (setf (condition-classoid-default-initargs class
) default-initargs
)
380 (setf (fdocumentation name
'type
) documentation
)
384 ;; Set up reader and writer functions.
385 (let ((slot-name (condition-slot-name slot
)))
386 (dolist (reader (condition-slot-readers slot
))
387 (install-condition-slot-reader reader name slot-name
))
388 (dolist (writer (condition-slot-writers slot
))
389 (install-condition-slot-writer writer name slot-name
))))
391 ;; Compute effective slots and set up the class and hairy slots
392 ;; (subsets of the effective slots.)
393 (let ((eslots (compute-effective-slots class
))
396 (mapcar #'condition-classoid-default-initargs
397 (condition-classoid-cpl class
)))))
398 (dolist (slot eslots
)
399 (ecase (condition-slot-allocation slot
)
401 (unless (condition-slot-cell slot
)
402 (setf (condition-slot-cell slot
)
403 (list (if (condition-slot-initform-p slot
)
404 (let ((initform (condition-slot-initform slot
)))
405 (if (functionp initform
)
408 *empty-condition-slot
*))))
409 (push slot
(condition-classoid-class-slots class
)))
411 (setf (condition-slot-allocation slot
) :instance
)
412 (when (or (functionp (condition-slot-initform slot
))
413 (dolist (initarg (condition-slot-initargs slot
) nil
)
414 (when (functionp (getf e-def-initargs initarg
))
416 (push slot
(condition-classoid-hairy-slots class
))))))))
419 (defmacro define-condition
(name (&rest parent-types
) (&rest slot-specs
)
422 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
423 Define NAME as a condition type. This new type inherits slots and its
424 report function from the specified PARENT-TYPEs. A slot spec is a list of:
425 (slot-name :reader <rname> :initarg <iname> {Option Value}*
427 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
428 and :TYPE and the overall options :DEFAULT-INITARGS and
429 [type] :DOCUMENTATION are also allowed.
431 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
432 a string or a two-argument lambda or function name. If a function, the
433 function is called with the condition and stream to report the condition.
434 If a string, the string is printed.
436 Condition types are classes, but (as allowed by ANSI and not as described in
437 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
438 SLOT-VALUE may not be used on condition objects."
439 (let* ((parent-types (or parent-types
'(condition)))
440 (layout (find-condition-layout name parent-types
))
443 (default-initargs ()))
445 (all-readers nil append
)
446 (all-writers nil append
))
447 (dolist (spec slot-specs
)
448 (when (keywordp spec
)
449 (warn "Keyword slot name indicates probable syntax error:~% ~S"
451 (let* ((spec (if (consp spec
) spec
(list spec
)))
452 (slot-name (first spec
))
453 (allocation :instance
)
460 (do ((options (rest spec
) (cddr options
)))
462 (unless (and (consp options
) (consp (cdr options
)))
463 (error "malformed condition slot spec:~% ~S." spec
))
464 (let ((arg (second options
)))
465 (case (first options
)
466 (:reader
(readers arg
))
467 (:writer
(writers arg
))
470 (writers `(setf ,arg
)))
473 (error "more than one :INITFORM in ~S" spec
))
476 (:initarg
(initargs arg
))
478 (setq allocation arg
))
481 (error "more than one :DOCUMENTATION in ~S" spec
))
482 (unless (stringp arg
)
483 (error "slot :DOCUMENTATION argument is not a string: ~S"
485 (setq documentation arg
))
488 (error "unknown slot option:~% ~S" (first options
))))))
490 (all-readers (readers))
491 (all-writers (writers))
492 (slots `(make-condition-slot
494 :initargs
',(initargs)
497 :initform-p
',initform-p
498 :documentation
',documentation
500 ,(if (constantp initform
)
502 `#'(lambda () ,initform
)))))))
504 (dolist (option options
)
505 (unless (consp option
)
506 (error "bad option:~% ~S" option
))
508 (:documentation
(setq documentation
(second option
)))
510 (let ((arg (second option
)))
513 `#'(lambda (condition stream
)
514 (declare (ignore condition
))
515 (write-string ,arg stream
))
516 `#'(lambda (condition stream
)
517 (funcall #',arg condition stream
))))))
519 (do ((initargs (rest option
) (cddr initargs
)))
521 (let ((val (second initargs
)))
522 (setq default-initargs
523 (list* `',(first initargs
)
527 default-initargs
)))))
529 (error "unknown option: ~S" (first option
)))))
532 (eval-when (:compile-toplevel
)
533 (%compiler-define-condition
',name
',parent-types
',layout
534 ',(all-readers) ',(all-writers)))
535 (eval-when (:load-toplevel
:execute
)
536 (%define-condition
',name
542 (list ,@default-initargs
)
544 ',(all-writers)))))))
546 ;;;; DESCRIBE on CONDITIONs
548 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
549 ;;; eventually (once we get CLOS up and running so that we can define
551 (defun describe-condition (condition stream
)
553 "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%"
557 (condition-actual-initargs condition
)
558 (condition-assigned-slots condition
))))
560 ;;;; various CONDITIONs specified by ANSI
562 (define-condition serious-condition
(condition) ())
564 (define-condition error
(serious-condition) ())
566 (define-condition warning
(condition) ())
567 (define-condition style-warning
(warning) ())
569 (defun simple-condition-printer (condition stream
)
572 (simple-condition-format-control condition
)
573 (simple-condition-format-arguments condition
)))
575 (define-condition simple-condition
()
576 ((format-control :reader simple-condition-format-control
577 :initarg
:format-control
578 :type format-control
)
579 (format-arguments :reader simple-condition-format-arguments
580 :initarg
:format-arguments
583 (:report simple-condition-printer
))
585 (define-condition simple-warning
(simple-condition warning
) ())
587 (define-condition simple-error
(simple-condition error
) ())
589 ;;; not specified by ANSI, but too useful not to have around.
590 (define-condition simple-style-warning
(simple-condition style-warning
) ())
592 (define-condition storage-condition
(serious-condition) ())
594 (define-condition type-error
(error)
595 ((datum :reader type-error-datum
:initarg
:datum
)
596 (expected-type :reader type-error-expected-type
:initarg
:expected-type
))
598 (lambda (condition stream
)
600 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
601 (type-error-datum condition
)
602 (type-error-expected-type condition
)))))
604 (define-condition simple-type-error
(simple-condition type-error
) ())
606 (define-condition program-error
(error) ())
607 (define-condition parse-error
(error) ())
608 (define-condition control-error
(error) ())
609 (define-condition stream-error
(error)
610 ((stream :reader stream-error-stream
:initarg
:stream
)))
612 (define-condition end-of-file
(stream-error) ()
614 (lambda (condition stream
)
617 (stream-error-stream condition
)))))
619 (define-condition file-error
(error)
620 ((pathname :reader file-error-pathname
:initarg
:pathname
))
622 (lambda (condition stream
)
623 (format stream
"error on file ~S" (file-error-pathname condition
)))))
625 (define-condition package-error
(error)
626 ((package :reader package-error-package
:initarg
:package
)))
628 (define-condition cell-error
(error)
629 ((name :reader cell-error-name
:initarg
:name
)))
631 (define-condition unbound-variable
(cell-error) ()
633 (lambda (condition stream
)
635 "The variable ~S is unbound."
636 (cell-error-name condition
)))))
638 (define-condition undefined-function
(cell-error) ()
640 (lambda (condition stream
)
642 "The function ~S is undefined."
643 (cell-error-name condition
)))))
645 (define-condition special-form-function
(undefined-function) ()
647 (lambda (condition stream
)
649 "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S."
650 (cell-error-name condition
)))))
652 (define-condition arithmetic-error
(error)
653 ((operation :reader arithmetic-error-operation
656 (operands :reader arithmetic-error-operands
658 (:report
(lambda (condition stream
)
660 "arithmetic error ~S signalled"
662 (when (arithmetic-error-operation condition
)
664 "~%Operation was ~S, operands ~S."
665 (arithmetic-error-operation condition
)
666 (arithmetic-error-operands condition
))))))
668 (define-condition division-by-zero
(arithmetic-error) ())
669 (define-condition floating-point-overflow
(arithmetic-error) ())
670 (define-condition floating-point-underflow
(arithmetic-error) ())
671 (define-condition floating-point-inexact
(arithmetic-error) ())
672 (define-condition floating-point-invalid-operation
(arithmetic-error) ())
674 (define-condition print-not-readable
(error)
675 ((object :reader print-not-readable-object
:initarg
:object
))
677 (lambda (condition stream
)
678 (let ((obj (print-not-readable-object condition
))
680 (format stream
"~S cannot be printed readably." obj
)))))
682 (define-condition reader-error
(parse-error stream-error
)
684 :reader reader-error-format-control
685 :initarg
:format-control
)
687 :reader reader-error-format-arguments
688 :initarg
:format-arguments
691 (lambda (condition stream
)
692 (let* ((error-stream (stream-error-stream condition
))
693 (pos (file-position error-stream
)))
696 (< pos sb
!xc
:array-dimension-limit
)
697 ;; KLUDGE: lseek() (which is what FILE-POSITION
698 ;; reduces to on file-streams) is undefined on
699 ;; "some devices", which in practice means that it
700 ;; can claim to succeed on /dev/stdin on Darwin
701 ;; and Solaris. This is obviously bad news,
702 ;; because the READ-SEQUENCE below will then
703 ;; block, not complete, and the report will never
704 ;; be printed. As a workaround, we exclude
705 ;; interactive streams from this attempt to report
706 ;; positions. -- CSR, 2003-08-21
707 (not (interactive-stream-p error-stream
))
708 (file-position error-stream
:start
))
711 :element-type
(stream-element-type error-stream
))))
712 (when (= pos
(read-sequence string error-stream
))
713 (setq lineno
(1+ (count #\Newline string
))
715 (or (position #\Newline string
:from-end t
) -
1)
717 (file-position error-stream pos
))
719 "READER-ERROR ~@[at ~W ~]~
720 ~@[(line ~W~]~@[, column ~W) ~]~
722 pos lineno colno error-stream
723 (reader-error-format-control condition
)
724 (reader-error-format-arguments condition
)))))))
726 ;;;; special SBCL extension conditions
728 ;;; an error apparently caused by a bug in SBCL itself
730 ;;; Note that we don't make any serious effort to use this condition
731 ;;; for *all* errors in SBCL itself. E.g. type errors and array
732 ;;; indexing errors can occur in functions called from SBCL code, and
733 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
734 ;;; because the signalling code has no good way to know that the
735 ;;; underlying problem is a bug in SBCL. But in the fairly common case
736 ;;; that the signalling code does know that it's found a bug in SBCL,
737 ;;; this condition is appropriate, reusing boilerplate and helping
738 ;;; users to recognize it as an SBCL bug.
739 (define-condition bug
(simple-error)
742 (lambda (condition stream
)
745 (simple-condition-format-control condition
)
746 (simple-condition-format-arguments condition
)
747 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
748 SBCL might have been corrupted by bad user code, e.g. by an ~
749 undefined Lisp operation like ~S, or by stray pointers from ~
750 alien code or from unsafe Lisp code; or there might be a bug ~
751 in the OS or hardware that SBCL is running on.) If it seems to ~
752 be a bug in SBCL itself, the maintainers would like to know ~
753 about it. Bug reports are welcome on the SBCL ~
754 mailing lists, which you can find at ~
755 <http://sbcl.sourceforge.net/>.~:@>"
756 '((fmakunbound 'compile
))))))
758 ;;; a condition for use in stubs for operations which aren't supported
759 ;;; on some platforms
761 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
762 ;;; #-(or freebsd linux)
763 ;;; (defun load-foreign (&rest rest)
764 ;;; (error 'unsupported-operator :name 'load-foreign))
765 ;;; #+(or freebsd linux)
766 ;;; (defun load-foreign ... actual definition ...)
767 ;;; By signalling a standard condition in this case, we make it
768 ;;; possible for test code to distinguish between (1) intentionally
769 ;;; unimplemented and (2) unintentionally just screwed up somehow.
770 ;;; (Before this condition was defined, test code tried to deal with
771 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
772 ;;; sbcl-0.7.0, a a package screwup left the definition of
773 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
774 ;;; architectures where it was supposed to be supported, and the
775 ;;; regression tests cheerfully passed because they assumed that
776 ;;; unFBOUNDPness meant they were running on an system which didn't
777 ;;; support the extension.)
778 (define-condition unsupported-operator
(cell-error) ()
780 (lambda (condition stream
)
782 "unsupported on this platform (OS, CPU, whatever): ~S"
783 (cell-error-name condition
)))))
785 ;;; (:ansi-cl :function remove)
786 ;;; (:ansi-cl :section (a b c))
787 ;;; (:ansi-cl :glossary "similar")
789 ;;; (:sbcl :node "...")
790 ;;; (:sbcl :variable *ed-functions*)
792 ;;; FIXME: this is not the right place for this.
793 (defun print-reference (reference stream
)
794 (ecase (car reference
)
796 (format stream
"AMOP")
798 (destructuring-bind (type data
) (cdr reference
)
800 (:generic-function
(format stream
"Generic Function ~S" data
))
801 (:section
(format stream
"Section ~{~D~^.~}" data
)))))
803 (format stream
"The ANSI Standard")
805 (destructuring-bind (type data
) (cdr reference
)
807 (:function
(format stream
"Function ~S" data
))
808 (:special-operator
(format stream
"Special Operator ~S" data
))
809 (:macro
(format stream
"Macro ~S" data
))
810 (:section
(format stream
"Section ~{~D~^.~}" data
))
811 (:glossary
(format stream
"Glossary entry for ~S" data
))
812 (:issue
(format stream
"writeup for Issue ~A" data
)))))
814 (format stream
"The SBCL Manual")
816 (destructuring-bind (type data
) (cdr reference
)
818 (:node
(format stream
"Node ~S" data
))
819 (:variable
(format stream
"Variable ~S" data
))
820 (:function
(format stream
"Function ~S" data
)))))
821 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
823 (define-condition reference-condition
()
824 ((references :initarg
:references
:reader reference-condition-references
)))
825 (defvar *print-condition-references
* t
)
826 (def!method print-object
:around
((o reference-condition
) s
)
828 (unless (or *print-escape
* *print-readably
*)
829 (when *print-condition-references
*
830 (format s
"~&See also:~%")
831 (pprint-logical-block (s nil
:per-line-prefix
" ")
832 (do* ((rs (reference-condition-references o
) (cdr rs
))
833 (r (car rs
) (car rs
)))
835 (print-reference r s
)
836 (unless (null (cdr rs
))
839 (define-condition duplicate-definition
(reference-condition warning
)
840 ((name :initarg
:name
:reader duplicate-definition-name
))
841 (:report
(lambda (c s
)
842 (format s
"~@<Duplicate definition for ~S found in ~
844 (duplicate-definition-name c
))))
845 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
847 (define-condition package-at-variance
(reference-condition simple-warning
)
849 (:default-initargs
:references
(list '(:ansi-cl
:macro defpackage
))))
851 (define-condition defconstant-uneql
(reference-condition error
)
852 ((name :initarg
:name
:reader defconstant-uneql-name
)
853 (old-value :initarg
:old-value
:reader defconstant-uneql-old-value
)
854 (new-value :initarg
:new-value
:reader defconstant-uneql-new-value
))
856 (lambda (condition stream
)
858 "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
859 (defconstant-uneql-name condition
)
860 (defconstant-uneql-old-value condition
)
861 (defconstant-uneql-new-value condition
))))
862 (:default-initargs
:references
(list '(:ansi-cl
:macro defconstant
)
863 '(:sbcl
:node
"Idiosyncrasies"))))
865 (define-condition array-initial-element-mismatch
866 (reference-condition simple-warning
)
870 '(:ansi-cl
:function make-array
)
871 '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
))))
873 (define-condition displaced-to-array-too-small-error
874 (reference-condition simple-error
)
877 :references
(list '(:ansi-cl
:function adjust-array
))))
879 (define-condition type-warning
(reference-condition simple-warning
)
881 (:default-initargs
:references
(list '(:sbcl
:node
"Handling of Types"))))
883 (define-condition local-argument-mismatch
(reference-condition simple-warning
)
885 (:default-initargs
:references
(list '(:ansi-cl
:section
(3 2 2 3)))))
887 (define-condition format-args-mismatch
(reference-condition)
889 (:default-initargs
:references
(list '(:ansi-cl
:section
(22 3 10 2)))))
891 (define-condition format-too-few-args-warning
892 (format-args-mismatch simple-warning
)
894 (define-condition format-too-many-args-warning
895 (format-args-mismatch simple-style-warning
)
898 (define-condition extension-failure
(reference-condition simple-error
)
904 (define-condition package-lock-violation
(reference-condition package-error
)
905 ((format-control :initform nil
:initarg
:format-control
906 :reader package-error-format-control
)
907 (format-arguments :initform nil
:initarg
:format-arguments
908 :reader package-error-format-arguments
))
910 (lambda (condition stream
)
911 (let ((control (package-error-format-control condition
)))
913 (apply #'format stream
914 (format nil
"~~@<Lock on package ~A violated when ~A.~~:@>"
915 (package-name (package-error-package condition
))
917 (package-error-format-arguments condition
))
918 (format stream
"~@<Lock on package ~A violated.~:@>"
919 (package-name (package-error-package condition
)))))))
920 ;; no :default-initargs -- reference-stuff provided by the
921 ;; 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) ()
930 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
931 signalled when an operation on a package violates a package lock."))
933 (define-condition symbol-package-locked-error
(package-lock-violation)
934 ((symbol :initarg
:symbol
:reader package-locked-error-symbol
))
937 "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
938 signalled when an operation on a symbol violates a package lock. The
939 symbol that caused the violation is accessed by the function
940 SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
944 ;;;; various other (not specified by ANSI) CONDITIONs
946 ;;;; These might logically belong in other files; they're here, after
947 ;;;; setup of CONDITION machinery, only because that makes it easier to
948 ;;;; get cold init to work.
950 ;;; OAOOM warning: see cross-condition.lisp
951 (define-condition encapsulated-condition
(condition)
952 ((condition :initarg
:condition
:reader encapsulated-condition
)))
954 (define-condition values-type-error
(type-error)
957 (lambda (condition stream
)
959 "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
960 (type-error-datum condition
)
961 (type-error-expected-type condition
)))))
963 ;;; KLUDGE: a condition for floating point errors when we can't or
964 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
965 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
966 ;;; know how but the old code was broken by the conversion to POSIX
967 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
969 ;;; FIXME: Perhaps this should also be a base class for all
970 ;;; floating point exceptions?
971 (define-condition floating-point-exception
(arithmetic-error)
972 ((flags :initarg
:traps
974 :reader floating-point-exception-traps
))
975 (:report
(lambda (condition stream
)
977 "An arithmetic error ~S was signalled.~%"
979 (let ((traps (floating-point-exception-traps condition
)))
982 "Trapping conditions are: ~%~{ ~S~^~}~%"
985 "No traps are enabled? How can this be?"
988 (define-condition index-too-large-error
(type-error)
991 (lambda (condition stream
)
993 "The index ~S is too large."
994 (type-error-datum condition
)))))
996 (define-condition bounding-indices-bad-error
(reference-condition type-error
)
997 ((object :reader bounding-indices-bad-object
:initarg
:object
))
999 (lambda (condition stream
)
1000 (let* ((datum (type-error-datum condition
))
1003 (object (bounding-indices-bad-object condition
)))
1007 "The bounding indices ~S and ~S are bad ~
1008 for a sequence of length ~S."
1009 start end
(length object
)))
1011 ;; from WITH-ARRAY-DATA
1013 "The START and END parameters ~S and ~S are ~
1014 bad for an array of total size ~S."
1015 start end
(array-total-size object
)))))))
1018 (list '(:ansi-cl
:glossary
"bounding index designator")
1019 '(:ansi-cl
:issue
"SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
1021 (define-condition nil-array-accessed-error
(reference-condition type-error
)
1023 (:report
(lambda (condition stream
)
1024 (declare (ignore condition
))
1026 "An attempt to access an array of element-type ~
1027 NIL was made. Congratulations!")))
1029 :references
(list '(:ansi-cl
:function sb
!xc
:upgraded-array-element-type
)
1030 '(:ansi-cl
:section
(15 1 2 1))
1031 '(:ansi-cl
:section
(15 1 2 2)))))
1033 (define-condition io-timeout
(stream-error)
1034 ((direction :reader io-timeout-direction
:initarg
:direction
))
1036 (lambda (condition stream
)
1037 (declare (type stream stream
))
1039 "I/O timeout ~(~A~)ing ~S"
1040 (io-timeout-direction condition
)
1041 (stream-error-stream condition
)))))
1043 (define-condition namestring-parse-error
(parse-error)
1044 ((complaint :reader namestring-parse-error-complaint
:initarg
:complaint
)
1045 (args :reader namestring-parse-error-args
:initarg
:args
:initform nil
)
1046 (namestring :reader namestring-parse-error-namestring
:initarg
:namestring
)
1047 (offset :reader namestring-parse-error-offset
:initarg
:offset
))
1049 (lambda (condition stream
)
1051 "parse error in namestring: ~?~% ~A~% ~V@T^"
1052 (namestring-parse-error-complaint condition
)
1053 (namestring-parse-error-args condition
)
1054 (namestring-parse-error-namestring condition
)
1055 (namestring-parse-error-offset condition
)))))
1057 (define-condition simple-package-error
(simple-condition package-error
) ())
1059 (define-condition reader-package-error
(reader-error) ())
1061 (define-condition reader-eof-error
(end-of-file)
1062 ((context :reader reader-eof-error-context
:initarg
:context
))
1064 (lambda (condition stream
)
1066 "unexpected end of file on ~S ~A"
1067 (stream-error-stream condition
)
1068 (reader-eof-error-context condition
)))))
1070 (define-condition reader-impossible-number-error
(reader-error)
1071 ((error :reader reader-impossible-number-error-error
:initarg
:error
))
1073 (lambda (condition stream
)
1074 (let ((error-stream (stream-error-stream condition
)))
1075 (format stream
"READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
1076 (file-position error-stream
) error-stream
1077 (reader-error-format-control condition
)
1078 (reader-error-format-arguments condition
)
1079 (reader-impossible-number-error-error condition
))))))
1081 (define-condition timeout
(serious-condition) ())
1083 ;;;; restart definitions
1085 (define-condition abort-failure
(control-error) ()
1087 "An ABORT restart was found that failed to transfer control dynamically."))
1089 (defun abort (&optional condition
)
1091 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
1093 (invoke-restart (find-restart-or-control-error 'abort condition
))
1094 ;; ABORT signals an error in case there was a restart named ABORT
1095 ;; that did not transfer control dynamically. This could happen with
1097 (error 'abort-failure
))
1099 (defun muffle-warning (&optional condition
)
1101 "Transfer control to a restart named MUFFLE-WARNING, signalling a
1102 CONTROL-ERROR if none exists."
1103 (invoke-restart (find-restart-or-control-error 'muffle-warning condition
)))
1105 (macrolet ((define-nil-returning-restart (name args doc
)
1106 #!-sb-doc
(declare (ignore doc
))
1107 `(defun ,name
(,@args
&optional condition
)
1109 ;; FIXME: Perhaps this shared logic should be pulled out into
1110 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
1111 (let ((restart (find-restart ',name condition
)))
1113 (invoke-restart restart
,@args
))))))
1114 (define-nil-returning-restart continue
()
1115 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
1116 (define-nil-returning-restart store-value
(value)
1117 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
1119 (define-nil-returning-restart use-value
(value)
1120 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
1123 (/show0
"condition.lisp end of file")