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-class (:include slot-class
)
25 (:constructor bare-make-condition-class
))
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")
47 (defun make-condition-class (&rest rest
)
48 (apply #'bare-make-condition-class
49 (rename-key-args '((:name
:%name
)) rest
)))
51 (/show0
"condition.lisp 53")
55 (!defstruct-with-alternate-metaclass condition
56 :slot-names
(actual-initargs assigned-slots
)
57 :boa-constructor %make-condition-object
58 :superclass-name instance
59 :metaclass-name condition-class
60 :metaclass-constructor make-condition-class
63 (defun make-condition-object (actual-initargs)
64 (%make-condition-object actual-initargs nil
))
66 (defstruct (condition-slot (:copier nil
))
67 (name (missing-arg) :type symbol
)
68 ;; list of all applicable initargs
69 (initargs (missing-arg) :type list
)
70 ;; names of reader and writer functions
71 (readers (missing-arg) :type list
)
72 (writers (missing-arg) :type list
)
73 ;; true if :INITFORM was specified
74 (initform-p (missing-arg) :type
(member t nil
))
75 ;; If this is a function, call it with no args. Otherwise, it's the
77 (initform (missing-arg) :type t
)
78 ;; allocation of this slot, or NIL until defaulted
79 (allocation nil
:type
(member :instance
:class nil
))
80 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
81 (cell nil
:type
(or cons null
)))
83 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
84 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
85 ;;; have themselves listed in their CPLs. This behavior is inherited
86 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
87 ;;; figured out whether it's right. -- WHN 19990612
88 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
89 (/show0
"condition.lisp 103")
90 (let ((condition-class (locally
91 ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS for
92 ;; constant class names which creates fast but
93 ;; non-cold-loadable, non-compact code. In this
94 ;; context, we'd rather have compact, cold-loadable
95 ;; code. -- WHN 19990928
96 (declare (notinline sb
!xc
:find-class
))
97 (sb!xc
:find-class
'condition
))))
98 (setf (condition-class-cpl condition-class
)
99 (list condition-class
)))
100 (/show0
"condition.lisp 103"))
102 (setf (condition-class-report (locally
103 ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS
104 ;; for constant class names which creates fast
105 ;; but non-cold-loadable, non-compact code. In
106 ;; this context, we'd rather have compact,
107 ;; cold-loadable code. -- WHN 19990928
108 (declare (notinline sb
!xc
:find-class
))
109 (find-class '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
121 (sb!xc
:find-class x
)))
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 #'class-layout cpl
)))))
135 (not (mismatch (layout-inherits olayout
) new-inherits
)))
137 (make-layout :class
(make-undefined-class 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-class-cpl (sb!xc
:class-of x
))
159 (error "no REPORT? shouldn't happen!"))
160 (let ((report (condition-class-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-class-cpl class
)))
172 (let ((default-initargs (condition-class-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-class-cpl condition-class
)
191 (error "There is no slot named ~S in ~S."
192 slot-name condition-class
))
193 (dolist (slot (condition-class-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-class-class-slots
199 (layout-class (%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-class (%instance-layout condition
))))
207 (dolist (cslot (condition-class-class-slots class
))
208 (when (eq (condition-slot-name cslot
) name
)
209 (return-from condition-reader-function
210 (car (condition-slot-cell cslot
)))))
212 (let ((val (getf (condition-assigned-slots condition
) name
213 *empty-condition-slot
*)))
214 (if (eq val
*empty-condition-slot
*)
215 (let ((actual-initargs (condition-actual-initargs condition
))
216 (slot (find-condition-class-slot class name
)))
218 (error "missing slot ~S of ~S" name condition
))
219 (dolist (initarg (condition-slot-initargs slot
))
220 (let ((val (getf actual-initargs
222 *empty-condition-slot
*)))
223 (unless (eq val
*empty-condition-slot
*)
224 (return-from condition-reader-function
225 (setf (getf (condition-assigned-slots condition
)
228 (setf (getf (condition-assigned-slots condition
) name
)
229 (find-slot-default class slot
)))
234 (defun make-condition (thing &rest args
)
236 "Make an instance of a condition object using the specified initargs."
237 ;; Note: ANSI specifies no exceptional situations in this function.
238 ;; signalling simple-type-error would not be wrong.
239 (let* ((thing (if (symbolp thing
)
240 (sb!xc
:find-class thing
)
242 (class (typecase thing
243 (condition-class thing
)
245 (error 'simple-type-error
247 :expected-type
'condition-class
248 :format-control
"~S is not a condition class."
249 :format-arguments
(list thing
)))
251 (error 'simple-type-error
253 :expected-type
'condition-class
254 :format-control
"bad thing for class argument:~% ~S"
255 :format-arguments
(list thing
)))))
256 (res (make-condition-object args
)))
257 (setf (%instance-layout res
) (class-layout class
))
258 ;; Set any class slots with initargs present in this call.
259 (dolist (cslot (condition-class-class-slots class
))
260 (dolist (initarg (condition-slot-initargs cslot
))
261 (let ((val (getf args initarg
*empty-condition-slot
*)))
262 (unless (eq val
*empty-condition-slot
*)
263 (setf (car (condition-slot-cell cslot
)) val
)))))
264 ;; Default any slots with non-constant defaults now.
265 (dolist (hslot (condition-class-hairy-slots class
))
266 (when (dolist (initarg (condition-slot-initargs hslot
) t
)
267 (unless (eq (getf args initarg
*empty-condition-slot
*)
268 *empty-condition-slot
*)
270 (setf (getf (condition-assigned-slots res
) (condition-slot-name hslot
))
271 (find-slot-default class hslot
))))
275 ;;;; DEFINE-CONDITION
277 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
278 (defun %compiler-define-condition
(name direct-supers layout
)
279 (multiple-value-bind (class old-layout
)
280 (insured-find-class name
#'condition-class-p
#'make-condition-class
)
281 (setf (layout-class layout
) class
)
282 (setf (class-direct-superclasses class
)
283 (mapcar #'sb
!xc
:find-class direct-supers
))
284 (cond ((not old-layout
)
285 (register-layout layout
))
286 ((not *type-system-initialized
*)
287 (setf (layout-class old-layout
) class
)
288 (setq layout old-layout
)
289 (unless (eq (class-layout class
) layout
)
290 (register-layout layout
)))
291 ((redefine-layout-warning "current"
294 (layout-length layout
)
295 (layout-inherits layout
)
296 (layout-depthoid layout
))
297 (register-layout layout
:invalidate t
))
298 ((not (class-layout class
))
299 (register-layout layout
)))
301 (setf (layout-info layout
)
303 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
304 ;; names which creates fast but non-cold-loadable, non-compact
305 ;; code. In this context, we'd rather have compact, cold-loadable
306 ;; code. -- WHN 19990928
307 (declare (notinline sb
!xc
:find-class
))
308 (layout-info (class-layout (sb!xc
:find-class
'condition
)))))
310 (setf (sb!xc
:find-class name
) class
)
312 ;; Initialize CPL slot.
313 (setf (condition-class-cpl class
)
314 (remove-if-not #'condition-class-p
315 (std-compute-class-precedence-list class
))))
320 ;;; Compute the effective slots of CLASS, copying inherited slots and
321 ;;; destructively modifying direct slots.
323 ;;; FIXME: It'd be nice to explain why it's OK to destructively modify
324 ;;; direct slots. Presumably it follows from the semantics of
325 ;;; inheritance and redefinition of conditions, but finding the cite
326 ;;; and documenting it here would be good. (Or, if this is not in fact
327 ;;; ANSI-compliant, fixing it would also be good.:-)
328 (defun compute-effective-slots (class)
329 (collect ((res (copy-list (condition-class-slots class
))))
330 (dolist (sclass (condition-class-cpl class
))
331 (dolist (sslot (condition-class-slots sclass
))
332 (let ((found (find (condition-slot-name sslot
) (res))))
334 (setf (condition-slot-initargs found
)
335 (union (condition-slot-initargs found
)
336 (condition-slot-initargs sslot
)))
337 (unless (condition-slot-initform-p found
)
338 (setf (condition-slot-initform-p found
)
339 (condition-slot-initform-p sslot
))
340 (setf (condition-slot-initform found
)
341 (condition-slot-initform sslot
)))
342 (unless (condition-slot-allocation found
)
343 (setf (condition-slot-allocation found
)
344 (condition-slot-allocation sslot
))))
346 (res (copy-structure sslot
)))))))
349 (defun %define-condition
(name slots documentation report default-initargs
)
350 (let ((class (sb!xc
:find-class name
)))
351 (setf (condition-class-slots class
) slots
)
352 (setf (condition-class-report class
) report
)
353 (setf (condition-class-default-initargs class
) default-initargs
)
354 (setf (fdocumentation name
'type
) documentation
)
358 ;; Set up reader and writer functions.
359 (let ((name (condition-slot-name slot
)))
360 (dolist (reader (condition-slot-readers slot
))
361 (setf (fdefinition reader
)
363 (condition-reader-function condition name
))))
364 (dolist (writer (condition-slot-writers slot
))
365 (setf (fdefinition writer
)
366 (lambda (new-value condition
)
367 (condition-writer-function condition new-value name
))))))
369 ;; Compute effective slots and set up the class and hairy slots
370 ;; (subsets of the effective slots.)
371 (let ((eslots (compute-effective-slots class
))
374 (mapcar #'condition-class-default-initargs
375 (condition-class-cpl class
)))))
376 (dolist (slot eslots
)
377 (ecase (condition-slot-allocation slot
)
379 (unless (condition-slot-cell slot
)
380 (setf (condition-slot-cell slot
)
381 (list (if (condition-slot-initform-p slot
)
382 (let ((initform (condition-slot-initform slot
)))
383 (if (functionp initform
)
386 *empty-condition-slot
*))))
387 (push slot
(condition-class-class-slots class
)))
389 (setf (condition-slot-allocation slot
) :instance
)
390 (when (or (functionp (condition-slot-initform slot
))
391 (dolist (initarg (condition-slot-initargs slot
) nil
)
392 (when (functionp (getf e-def-initargs initarg
))
394 (push slot
(condition-class-hairy-slots class
))))))))
397 (defmacro define-condition
(name (&rest parent-types
) (&rest slot-specs
)
400 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
401 Define NAME as a condition type. This new type inherits slots and its
402 report function from the specified PARENT-TYPEs. A slot spec is a list of:
403 (slot-name :reader <rname> :initarg <iname> {Option Value}*
405 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
406 and :TYPE and the overall options :DEFAULT-INITARGS and
407 [type] :DOCUMENTATION are also allowed.
409 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
410 a string or a two-argument lambda or function name. If a function, the
411 function is called with the condition and stream to report the condition.
412 If a string, the string is printed.
414 Condition types are classes, but (as allowed by ANSI and not as described in
415 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
416 SLOT-VALUE may not be used on condition objects."
417 (let* ((parent-types (or parent-types
'(condition)))
418 (layout (find-condition-layout name parent-types
))
421 (default-initargs ()))
423 (all-readers nil append
)
424 (all-writers nil append
))
425 (dolist (spec slot-specs
)
426 (when (keywordp spec
)
427 (warn "Keyword slot name indicates probable syntax error:~% ~S"
429 (let* ((spec (if (consp spec
) spec
(list spec
)))
430 (slot-name (first spec
))
431 (allocation :instance
)
437 (do ((options (rest spec
) (cddr options
)))
439 (unless (and (consp options
) (consp (cdr options
)))
440 (error "malformed condition slot spec:~% ~S." spec
))
441 (let ((arg (second options
)))
442 (case (first options
)
443 (:reader
(readers arg
))
444 (:writer
(writers arg
))
447 (writers `(setf ,arg
)))
450 (error "more than one :INITFORM in ~S" spec
))
453 (:initarg
(initargs arg
))
455 (setq allocation arg
))
458 (error "unknown slot option:~% ~S" (first options
))))))
460 (all-readers (readers))
461 (all-writers (writers))
462 (slots `(make-condition-slot
464 :initargs
',(initargs)
467 :initform-p
',initform-p
469 ,(if (constantp initform
)
471 `#'(lambda () ,initform
)))))))
473 (dolist (option options
)
474 (unless (consp option
)
475 (error "bad option:~% ~S" option
))
477 (:documentation
(setq documentation
(second option
)))
479 (let ((arg (second option
)))
482 `#'(lambda (condition stream
)
483 (declare (ignore condition
))
484 (write-string ,arg stream
))
485 `#'(lambda (condition stream
)
486 (funcall #',arg condition stream
))))))
488 (do ((initargs (rest option
) (cddr initargs
)))
490 (let ((val (second initargs
)))
491 (setq default-initargs
492 (list* `',(first initargs
)
496 default-initargs
)))))
498 (error "unknown option: ~S" (first option
)))))
501 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
502 (%compiler-define-condition
',name
',parent-types
',layout
))
504 (declaim (ftype (function (t) t
) ,@(all-readers)))
505 (declaim (ftype (function (t t
) t
) ,@(all-writers)))
507 (%define-condition
',name
511 (list ,@default-initargs
))))))
513 ;;;; DESCRIBE on CONDITIONs
515 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
516 ;;; eventually (once we get CLOS up and running so that we can define
518 (defun describe-condition (condition stream
)
520 "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
524 (condition-actual-initargs condition
)
525 (condition-assigned-slots condition
))))
527 ;;;; various CONDITIONs specified by ANSI
529 (define-condition serious-condition
(condition) ())
531 (define-condition error
(serious-condition) ())
533 (define-condition warning
(condition) ())
534 (define-condition style-warning
(warning) ())
536 (defun simple-condition-printer (condition stream
)
539 (simple-condition-format-control condition
)
540 (simple-condition-format-arguments condition
)))
542 (define-condition simple-condition
()
543 ((format-control :reader simple-condition-format-control
544 :initarg
:format-control
)
545 (format-arguments :reader simple-condition-format-arguments
546 :initarg
:format-arguments
548 (:report simple-condition-printer
))
550 (define-condition simple-warning
(simple-condition warning
) ())
552 (define-condition simple-error
(simple-condition error
) ())
554 (define-condition storage-condition
(serious-condition) ())
556 (define-condition type-error
(error)
557 ((datum :reader type-error-datum
:initarg
:datum
)
558 (expected-type :reader type-error-expected-type
:initarg
:expected-type
))
560 (lambda (condition stream
)
562 "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
563 (type-error-datum condition
)
564 (type-error-expected-type condition
)))))
566 (define-condition simple-type-error
(simple-condition type-error
) ())
568 (define-condition program-error
(error) ())
569 (define-condition parse-error
(error) ())
570 (define-condition control-error
(error) ())
571 (define-condition stream-error
(error)
572 ((stream :reader stream-error-stream
:initarg
:stream
)))
574 (define-condition end-of-file
(stream-error) ()
576 (lambda (condition stream
)
579 (stream-error-stream condition
)))))
581 (define-condition file-error
(error)
582 ((pathname :reader file-error-pathname
:initarg
:pathname
))
584 (lambda (condition stream
)
585 (format stream
"error on file ~S" (file-error-pathname condition
)))))
587 (define-condition package-error
(error)
588 ((package :reader package-error-package
:initarg
:package
)))
590 (define-condition cell-error
(error)
591 ((name :reader cell-error-name
:initarg
:name
)))
593 (define-condition unbound-variable
(cell-error) ()
595 (lambda (condition stream
)
597 "The variable ~S is unbound."
598 (cell-error-name condition
)))))
600 (define-condition undefined-function
(cell-error) ()
602 (lambda (condition stream
)
604 "The function ~S is undefined."
605 (cell-error-name condition
)))))
607 (define-condition arithmetic-error
(error)
608 ((operation :reader arithmetic-error-operation
611 (operands :reader arithmetic-error-operands
613 (:report
(lambda (condition stream
)
615 "arithmetic error ~S signalled"
617 (when (arithmetic-error-operation condition
)
619 "~%Operation was ~S, operands ~S."
620 (arithmetic-error-operation condition
)
621 (arithmetic-error-operands condition
))))))
623 (define-condition division-by-zero
(arithmetic-error) ())
624 (define-condition floating-point-overflow
(arithmetic-error) ())
625 (define-condition floating-point-underflow
(arithmetic-error) ())
626 (define-condition floating-point-inexact
(arithmetic-error) ())
627 (define-condition floating-point-invalid-operation
(arithmetic-error) ())
629 (define-condition print-not-readable
(error)
630 ((object :reader print-not-readable-object
:initarg
:object
))
632 (lambda (condition stream
)
633 (let ((obj (print-not-readable-object condition
))
635 (format stream
"~S cannot be printed readably." obj
)))))
637 (define-condition reader-error
(parse-error stream-error
)
639 :reader reader-error-format-control
640 :initarg
:format-control
)
642 :reader reader-error-format-arguments
643 :initarg
:format-arguments
646 (lambda (condition stream
)
647 (let ((error-stream (stream-error-stream condition
)))
648 (format stream
"READER-ERROR ~@[at ~W ~]on ~S:~%~?"
649 (file-position error-stream
) error-stream
650 (reader-error-format-control condition
)
651 (reader-error-format-arguments condition
))))))
653 ;;;; various other (not specified by ANSI) CONDITIONs
655 ;;;; These might logically belong in other files; they're here, after
656 ;;;; setup of CONDITION machinery, only because that makes it easier to
657 ;;;; get cold init to work.
659 ;;; KLUDGE: a condition for floating point errors when we can't or
660 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
661 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
662 ;;; know how but the old code was broken by the conversion to POSIX
663 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
665 ;;; FIXME: Perhaps this should also be a base class for all
666 ;;; floating point exceptions?
667 (define-condition floating-point-exception
(arithmetic-error)
668 ((flags :initarg
:traps
670 :reader floating-point-exception-traps
))
671 (:report
(lambda (condition stream
)
673 "An arithmetic error ~S was signalled.~%"
675 (let ((traps (floating-point-exception-traps condition
)))
678 "Trapping conditions are: ~%~{ ~S~^~}~%"
681 "No traps are enabled? How can this be?"
684 (define-condition index-too-large-error
(type-error)
687 (lambda (condition stream
)
689 "The index ~S is too large."
690 (type-error-datum condition
)))))
692 ;;; Out-of-range &KEY END arguments are similar to, but off by one
693 ;;; from out-of-range indices into the sequence.
694 (define-condition index-too-large-error
(type-error)
697 (lambda (condition stream
)
699 "The end-of-sequence specifier ~S is too large."
700 (type-error-datum condition
)))))
702 (define-condition io-timeout
(stream-error)
703 ((direction :reader io-timeout-direction
:initarg
:direction
))
705 (lambda (condition stream
)
706 (declare (type stream stream
))
708 "I/O timeout ~(~A~)ing ~S"
709 (io-timeout-direction condition
)
710 (stream-error-stream condition
)))))
712 (define-condition namestring-parse-error
(parse-error)
713 ((complaint :reader namestring-parse-error-complaint
:initarg
:complaint
)
714 (args :reader namestring-parse-error-args
:initarg
:args
:initform nil
)
715 (namestring :reader namestring-parse-error-namestring
:initarg
:namestring
)
716 (offset :reader namestring-parse-error-offset
:initarg
:offset
))
718 (lambda (condition stream
)
720 "parse error in namestring: ~?~% ~A~% ~V@T^"
721 (namestring-parse-error-complaint condition
)
722 (namestring-parse-error-args condition
)
723 (namestring-parse-error-namestring condition
)
724 (namestring-parse-error-offset condition
)))))
726 (define-condition simple-package-error
(simple-condition package-error
) ())
728 (define-condition reader-package-error
(reader-error) ())
730 (define-condition reader-eof-error
(end-of-file)
731 ((context :reader reader-eof-error-context
:initarg
:context
))
733 (lambda (condition stream
)
735 "unexpected end of file on ~S ~A"
736 (stream-error-stream condition
)
737 (reader-eof-error-context condition
)))))
739 (define-condition reader-impossible-number-error
(reader-error)
740 ((error :reader reader-impossible-number-error-error
:initarg
:error
))
742 (lambda (condition stream
)
743 (let ((error-stream (stream-error-stream condition
)))
744 (format stream
"READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
745 (file-position error-stream
) error-stream
746 (reader-error-format-control condition
)
747 (reader-error-format-arguments condition
)
748 (reader-impossible-number-error-error condition
))))))
750 ;;;; special SBCL extension conditions
752 ;;; an error apparently caused by a bug in SBCL itself
754 ;;; Note that we don't make any serious effort to use this condition
755 ;;; for *all* errors in SBCL itself. E.g. type errors and array
756 ;;; indexing errors can occur in functions called from SBCL code, and
757 ;;; will just end up as ordinary TYPE-ERROR or invalid index error,
758 ;;; because the signalling code has no good way to know that the
759 ;;; underlying problem is a bug in SBCL. But in the fairly common case
760 ;;; that the signalling code does know that it's found a bug in SBCL,
761 ;;; this condition is appropriate, reusing boilerplate and helping
762 ;;; users to recognize it as an SBCL bug.
763 (define-condition bug
(simple-error)
766 (lambda (condition stream
)
769 (simple-condition-format-control condition
)
770 (simple-condition-format-arguments condition
)
771 "~@<This is probably a bug in SBCL itself. (Alternatively, ~
772 SBCL might have been corrupted by bad user code, e.g. by an ~
773 undefined Lisp operation like ~S, or by stray pointers from ~
774 alien code or from unsafe Lisp code; or there might be a bug ~
775 in the OS or hardware that SBCL is running on.) If it seems to ~
776 be a bug in SBCL itself, the maintainers would like to know ~
777 about it. Bug reports are welcome on the SBCL ~
778 mailing lists, which you can find at ~
779 <http://sbcl.sourceforge.net/>.~:@>"
780 '((fmakunbound 'compile
))))))
781 (defun bug (format-control &rest format-arguments
)
783 :format-control format-control
784 :format-arguments format-arguments
))
786 ;;; a condition for use in stubs for operations which aren't supported
787 ;;; on some platforms
789 ;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like
790 ;;; #-(or freebsd linux)
791 ;;; (defun load-foreign (&rest rest)
792 ;;; (error 'unsupported-operator :name 'load-foreign))
793 ;;; #+(or freebsd linux)
794 ;;; (defun load-foreign ... actual definition ...)
795 ;;; By signalling a standard condition in this case, we make it
796 ;;; possible for test code to distinguish between (1) intentionally
797 ;;; unimplemented and (2) unintentionally just screwed up somehow.
798 ;;; (Before this condition was defined, test code tried to deal with
799 ;;; this by checking for FBOUNDP, but that didn't work reliably. In
800 ;;; sbcl-0.7.0, a a package screwup left the definition of
801 ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
802 ;;; architectures where it was supposed to be supported, and the
803 ;;; regression tests cheerfully passed because they assumed that
804 ;;; unFBOUNDPness meant they were running on an system which didn't
805 ;;; support the extension.)
806 (define-condition unsupported-operator
(cell-error) ()
808 (lambda (condition stream
)
810 "unsupported on this platform (OS, CPU, whatever): ~S"
811 (cell-error-name condition
)))))
813 ;;;; restart definitions
815 (define-condition abort-failure
(control-error) ()
817 "An ABORT restart was found that failed to transfer control dynamically."))
819 (defun abort (&optional condition
)
821 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
823 (invoke-restart (find-restart 'abort condition
))
824 ;; ABORT signals an error in case there was a restart named ABORT
825 ;; that did not transfer control dynamically. This could happen with
827 (error 'abort-failure
))
829 (defun muffle-warning (&optional condition
)
831 "Transfer control to a restart named MUFFLE-WARNING, signalling a
832 CONTROL-ERROR if none exists."
833 (invoke-restart (find-restart 'muffle-warning condition
)))
835 (macrolet ((define-nil-returning-restart (name args doc
)
836 #!-sb-doc
(declare (ignore doc
))
837 `(defun ,name
(,@args
&optional condition
)
839 ;; FIXME: Perhaps this shared logic should be pulled out into
840 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
841 (when (find-restart ',name condition
)
842 (invoke-restart ',name
,@args
)))))
843 (define-nil-returning-restart continue
()
844 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
845 (define-nil-returning-restart store-value
(value)
846 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
848 (define-nil-returning-restart use-value
(value)
849 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
852 (/show0
"condition.lisp end of file")