1 ;;;; stuff originally from CMU CL's error.lisp which can or should
2 ;;;; come late (mostly related to the CONDITION class itself)
4 ;;;; FIXME: should perhaps be called condition.lisp, or moved into
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
16 (in-package "SB!KERNEL")
18 ;;;; the CONDITION class
20 (/show0 "late-target-error.lisp 20")
22 (eval-when (:compile-toplevel :load-toplevel :execute)
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 (defun make-condition-class (&rest rest)
46 (apply #'bare-make-condition-class
47 (rename-key-args '((:name :%name)) rest)))
52 (:constructor make-condition-object (actual-initargs))
53 (:alternate-metaclass instance
59 ;; actual initargs supplied to MAKE-CONDITION
60 (actual-initargs (required-argument) :type list)
61 ;; plist mapping slot names to any values that were assigned or
62 ;; defaulted after creation
63 (assigned-slots () :type list))
65 (defstruct (condition-slot (:copier nil))
66 (name (required-argument) :type symbol)
67 ;; list of all applicable initargs
68 (initargs (required-argument) :type list)
69 ;; names of reader and writer functions
70 (readers (required-argument) :type list)
71 (writers (required-argument) :type list)
72 ;; true if :INITFORM was specified
73 (initform-p (required-argument) :type (member t nil))
74 ;; If this is a function, call it with no args. Otherwise, it's the
76 (initform (required-argument) :type t)
77 ;; allocation of this slot, or NIL until defaulted
78 (allocation nil :type (member :instance :class nil))
79 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
80 (cell nil :type (or cons null)))
82 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
83 ;; the appropriate initialization value for the CPL slot of a
84 ;; CONDITION, calculated by looking at the INHERITS information in
85 ;; the LAYOUT of the CONDITION
86 (defun condition-class-cpl-from-layout (condition)
87 (declare (type condition condition))
88 (let* ((class (sb!xc:find-class condition))
89 (layout (class-layout class))
90 (superset (map 'list #'identity (layout-inherits layout))))
91 (delete-if (lambda (superclass)
92 (not (typep superclass 'condition-class)))
95 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
96 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
97 ;;; have themselves listed in their CPLs. This behavior is inherited
98 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
99 ;;; figured out whether it's right. -- WHN 19990612
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (let ((condition-class (locally
102 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
103 ;; constant class names which creates fast but
104 ;; non-cold-loadable, non-compact code. In this
105 ;; context, we'd rather have compact, cold-loadable
106 ;; code. -- WHN 19990928
107 (declare (notinline sb!xc:find-class))
108 (sb!xc:find-class 'condition))))
109 (setf (condition-class-cpl condition-class)
110 (list condition-class))))
112 (setf (condition-class-report (locally
113 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
114 ;; for constant class names which creates fast
115 ;; but non-cold-loadable, non-compact code. In
116 ;; this context, we'd rather have compact,
117 ;; cold-loadable code. -- WHN 19990928
118 (declare (notinline sb!xc:find-class))
119 (find-class 'condition)))
120 #'(lambda (cond stream)
121 (format stream "Condition ~S was signalled." (type-of cond))))
123 (eval-when (:compile-toplevel :load-toplevel :execute)
125 (defun find-condition-layout (name parent-types)
126 (let* ((cpl (remove-duplicates
129 (mapcar #'(lambda (x)
131 (sb!xc:find-class x)))
133 (cond-layout (info :type :compiler-layout 'condition))
134 (olayout (info :type :compiler-layout name))
136 (concatenate 'simple-vector
137 (layout-inherits cond-layout)
138 (mapcar #'class-layout cpl))))
140 (not (mismatch (layout-inherits olayout) new-inherits)))
142 (make-layout :class (make-undefined-class name)
143 :inherits new-inherits
145 :length (layout-length cond-layout)))))
149 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
150 ;;; Condition reporting is mediated through the PRINT-OBJECT method
151 ;;; for the condition type in question, with *PRINT-ESCAPE* always
152 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
153 ;;; a condition type C is equivalent to:
154 ;;; (defmethod print-object ((x c) stream)
155 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
156 ;;; The current code doesn't seem to quite match that.
157 (def!method print-object ((x condition) stream)
159 (print-unreadable-object (x stream :type t :identity t))
160 ;; KLUDGE: A comment from CMU CL here said
161 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
162 ;; superclasses in define-condition call!
163 (dolist (class (condition-class-cpl (sb!xc:class-of x))
164 (error "no REPORT? shouldn't happen!"))
165 (let ((report (condition-class-report class)))
167 (return (funcall report x stream)))))))
169 ;;;; slots of CONDITION objects
171 (defvar *empty-condition-slot* '(empty))
173 (defun find-slot-default (class slot)
174 (let ((initargs (condition-slot-initargs slot))
175 (cpl (condition-class-cpl class)))
177 (let ((default-initargs (condition-class-default-initargs class)))
178 (dolist (initarg initargs)
179 (let ((val (getf default-initargs initarg *empty-condition-slot*)))
180 (unless (eq val *empty-condition-slot*)
181 (return-from find-slot-default
186 (if (condition-slot-initform-p slot)
187 (let ((initform (condition-slot-initform slot)))
188 (if (functionp initform)
191 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
193 (defun find-condition-class-slot (condition-class slot-name)
195 (condition-class-cpl condition-class)
196 (error "There is no slot named ~S in ~S."
197 slot-name condition-class))
198 (dolist (slot (condition-class-slots sclass))
199 (when (eq (condition-slot-name slot) slot-name)
200 (return-from find-condition-class-slot slot)))))
202 (defun condition-writer-function (condition new-value name)
203 (dolist (cslot (condition-class-class-slots
204 (layout-class (%instance-layout condition)))
205 (setf (getf (condition-assigned-slots condition) name)
207 (when (eq (condition-slot-name cslot) name)
208 (return (setf (car (condition-slot-cell cslot)) new-value)))))
210 (defun condition-reader-function (condition name)
211 (let ((class (layout-class (%instance-layout condition))))
212 (dolist (cslot (condition-class-class-slots class))
213 (when (eq (condition-slot-name cslot) name)
214 (return-from condition-reader-function
215 (car (condition-slot-cell cslot)))))
217 (let ((val (getf (condition-assigned-slots condition) name
218 *empty-condition-slot*)))
219 (if (eq val *empty-condition-slot*)
220 (let ((actual-initargs (condition-actual-initargs condition))
221 (slot (find-condition-class-slot class name)))
223 (error "missing slot ~S of ~S" name condition))
224 (dolist (initarg (condition-slot-initargs slot))
225 (let ((val (getf actual-initargs
227 *empty-condition-slot*)))
228 (unless (eq val *empty-condition-slot*)
229 (return-from condition-reader-function
230 (setf (getf (condition-assigned-slots condition)
233 (setf (getf (condition-assigned-slots condition) name)
234 (find-slot-default class slot)))
239 (defun make-condition (thing &rest args)
241 "Make an instance of a condition object using the specified initargs."
242 ;; Note: ANSI specifies no exceptional situations in this function.
243 ;; signalling simple-type-error would not be wrong.
244 (let* ((thing (if (symbolp thing)
245 (sb!xc:find-class thing)
247 (class (typecase thing
248 (condition-class thing)
250 (error 'simple-type-error
252 :expected-type 'condition-class
253 :format-control "~S is not a condition class."
254 :format-arguments (list thing)))
256 (error 'simple-type-error
258 :expected-type 'condition-class
259 :format-control "bad thing for class argument:~% ~S"
260 :format-arguments (list thing)))))
261 (res (make-condition-object args)))
262 (setf (%instance-layout res) (class-layout class))
263 ;; Set any class slots with initargs present in this call.
264 (dolist (cslot (condition-class-class-slots class))
265 (dolist (initarg (condition-slot-initargs cslot))
266 (let ((val (getf args initarg *empty-condition-slot*)))
267 (unless (eq val *empty-condition-slot*)
268 (setf (car (condition-slot-cell cslot)) val)))))
269 ;; Default any slots with non-constant defaults now.
270 (dolist (hslot (condition-class-hairy-slots class))
271 (when (dolist (initarg (condition-slot-initargs hslot) t)
272 (unless (eq (getf args initarg *empty-condition-slot*)
273 *empty-condition-slot*)
275 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
276 (find-slot-default class hslot))))
280 ;;;; DEFINE-CONDITION
282 (eval-when (:compile-toplevel :load-toplevel :execute)
283 (defun %compiler-define-condition (name direct-supers layout)
284 (multiple-value-bind (class old-layout)
285 (insured-find-class name #'condition-class-p #'make-condition-class)
286 (setf (layout-class layout) class)
287 (setf (class-direct-superclasses class)
288 (mapcar #'sb!xc:find-class direct-supers))
289 (cond ((not old-layout)
290 (register-layout layout))
291 ((not *type-system-initialized*)
292 (setf (layout-class old-layout) class)
293 (setq layout old-layout)
294 (unless (eq (class-layout class) layout)
295 (register-layout layout)))
296 ((redefine-layout-warning "current"
299 (layout-length layout)
300 (layout-inherits layout)
301 (layout-depthoid layout))
302 (register-layout layout :invalidate t))
303 ((not (class-layout class))
304 (register-layout layout)))
306 (setf (layout-info layout)
308 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
309 ;; names which creates fast but non-cold-loadable, non-compact
310 ;; code. In this context, we'd rather have compact, cold-loadable
311 ;; code. -- WHN 19990928
312 (declare (notinline sb!xc:find-class))
313 (layout-info (class-layout (sb!xc:find-class 'condition)))))
315 (setf (sb!xc:find-class name) class)
317 ;; Initialize CPL slot from layout.
320 (let ((inherits (layout-inherits layout)))
321 (do ((i (1- (length inherits)) (1- i)))
323 (let ((super (sb!xc:find-class
325 (layout-class (svref inherits i))))))
326 (when (typep super 'condition-class)
328 (setf (condition-class-cpl class) (cpl))))
334 ;;; Compute the effective slots of class, copying inherited slots and
335 ;;; side-effecting direct slots.
336 (defun compute-effective-slots (class)
337 (collect ((res (copy-list (condition-class-slots class))))
338 (dolist (sclass (condition-class-cpl class))
339 (dolist (sslot (condition-class-slots sclass))
340 (let ((found (find (condition-slot-name sslot) (res)
343 (setf (condition-slot-initargs found)
344 (union (condition-slot-initargs found)
345 (condition-slot-initargs sslot)))
346 (unless (condition-slot-initform-p found)
347 (setf (condition-slot-initform-p found)
348 (condition-slot-initform-p sslot))
349 (setf (condition-slot-initform found)
350 (condition-slot-initform sslot)))
351 (unless (condition-slot-allocation found)
352 (setf (condition-slot-allocation found)
353 (condition-slot-allocation sslot))))
355 (res (copy-structure sslot)))))))
358 (defun %define-condition (name slots documentation report default-initargs)
359 (let ((class (sb!xc:find-class name)))
360 (setf (condition-class-slots class) slots)
361 (setf (condition-class-report class) report)
362 (setf (condition-class-default-initargs class) default-initargs)
363 (setf (fdocumentation name 'type) documentation)
367 ;; Set up reader and writer functions.
368 (let ((name (condition-slot-name slot)))
369 (dolist (reader (condition-slot-readers slot))
370 (setf (fdefinition reader)
371 #'(lambda (condition)
372 (condition-reader-function condition name))))
373 (dolist (writer (condition-slot-writers slot))
374 (setf (fdefinition writer)
375 #'(lambda (new-value condition)
376 (condition-writer-function condition new-value name))))))
378 ;; Compute effective slots and set up the class and hairy slots
379 ;; (subsets of the effective slots.)
380 (let ((eslots (compute-effective-slots class))
383 (mapcar #'condition-class-default-initargs
384 (condition-class-cpl class)))))
385 (dolist (slot eslots)
386 (ecase (condition-slot-allocation slot)
388 (unless (condition-slot-cell slot)
389 (setf (condition-slot-cell slot)
390 (list (if (condition-slot-initform-p slot)
391 (let ((initform (condition-slot-initform slot)))
392 (if (functionp initform)
395 *empty-condition-slot*))))
396 (push slot (condition-class-class-slots class)))
398 (setf (condition-slot-allocation slot) :instance)
399 (when (or (functionp (condition-slot-initform slot))
400 (dolist (initarg (condition-slot-initargs slot) nil)
401 (when (functionp (getf e-def-initargs initarg))
403 (push slot (condition-class-hairy-slots class))))))))
406 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
409 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
410 Define NAME as a condition type. This new type inherits slots and its
411 report function from the specified PARENT-TYPEs. A slot spec is a list of:
412 (slot-name :reader <rname> :initarg <iname> {Option Value}*
414 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
415 and :TYPE and the overall options :DEFAULT-INITARGS and
416 [type] :DOCUMENTATION are also allowed.
418 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
419 a string or a two-argument lambda or function name. If a function, the
420 function is called with the condition and stream to report the condition.
421 If a string, the string is printed.
423 Condition types are classes, but (as allowed by ANSI and not as described in
424 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
425 SLOT-VALUE may not be used on condition objects."
426 (let* ((parent-types (or parent-types '(condition)))
427 (layout (find-condition-layout name parent-types))
430 (default-initargs ()))
432 (all-readers nil append)
433 (all-writers nil append))
434 (dolist (spec slot-specs)
435 (when (keywordp spec)
436 (warn "Keyword slot name indicates probable syntax error:~% ~S"
438 (let* ((spec (if (consp spec) spec (list spec)))
439 (slot-name (first spec))
440 (allocation :instance)
446 (do ((options (rest spec) (cddr options)))
448 (unless (and (consp options) (consp (cdr options)))
449 (error "malformed condition slot spec:~% ~S." spec))
450 (let ((arg (second options)))
451 (case (first options)
452 (:reader (readers arg))
453 (:writer (writers arg))
456 (writers `(setf ,arg)))
459 (error "more than one :INITFORM in ~S" spec))
462 (:initarg (initargs arg))
464 (setq allocation arg))
467 (error "unknown slot option:~% ~S" (first options))))))
469 (all-readers (readers))
470 (all-writers (writers))
471 (slots `(make-condition-slot
473 :initargs ',(initargs)
476 :initform-p ',initform-p
478 ,(if (constantp initform)
480 `#'(lambda () ,initform)))))))
482 (dolist (option options)
483 (unless (consp option)
484 (error "bad option:~% ~S" option))
486 (:documentation (setq documentation (second option)))
488 (let ((arg (second option)))
491 `#'(lambda (condition stream)
492 (declare (ignore condition))
493 (write-string ,arg stream))
494 `#'(lambda (condition stream)
495 (funcall #',arg condition stream))))))
497 (do ((initargs (rest option) (cddr initargs)))
499 (let ((val (second initargs)))
500 (setq default-initargs
501 (list* `',(first initargs)
505 default-initargs)))))
507 (error "unknown option: ~S" (first option)))))
510 (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
514 (eval-when (:compile-toplevel :load-toplevel :execute)
515 (%compiler-define-condition ',name ',parent-types ',layout))
517 (declaim (ftype (function (t) t) ,@(all-readers)))
518 (declaim (ftype (function (t t) t) ,@(all-writers)))
520 (%define-condition ',name
524 (list ,@default-initargs))))))
526 ;;;; DESCRIBE on CONDITIONs
528 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
529 ;;; eventually (once we get CLOS up and running so that we can define
531 (defun describe-condition (condition stream)
533 "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
537 (condition-actual-initargs condition)
538 (condition-assigned-slots condition))))
540 ;;;; various CONDITIONs specified by ANSI
542 (define-condition serious-condition (condition) ())
544 (define-condition error (serious-condition) ())
546 (define-condition warning (condition) ())
547 (define-condition style-warning (warning) ())
549 (defun simple-condition-printer (condition stream)
550 (apply #'format stream (simple-condition-format-control condition)
551 (simple-condition-format-arguments condition)))
553 (define-condition simple-condition ()
554 ((format-control :reader simple-condition-format-control
555 :initarg :format-control)
556 (format-arguments :reader simple-condition-format-arguments
557 :initarg :format-arguments
559 (:report simple-condition-printer))
561 (define-condition simple-warning (simple-condition warning) ())
563 (defun print-simple-error (condition stream)
565 "~&~@<error in function ~S: ~3I~:_~?~:>"
566 (condition-function-name condition)
567 (simple-condition-format-control condition)
568 (simple-condition-format-arguments condition)))
570 (define-condition simple-error (simple-condition error) ()
571 ;; This is the condition type used by ERROR and CERROR when
572 ;; a format-control string is supplied as the first argument.
573 (:report print-simple-error))
575 (define-condition storage-condition (serious-condition) ())
577 ;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data
578 ;;; on an ad hoc basis, for some conditions and not others? Why not
579 ;;; standardize it somehow? perhaps by making the debugger report it?
581 (define-condition type-error (error)
582 ((datum :reader type-error-datum :initarg :datum)
583 (expected-type :reader type-error-expected-type :initarg :expected-type))
585 (lambda (condition stream)
587 "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
588 (condition-function-name condition)
589 (type-error-datum condition)
590 (type-error-expected-type condition)))))
592 (define-condition program-error (error) ())
593 (define-condition parse-error (error) ())
594 (define-condition control-error (error) ())
595 (define-condition stream-error (error)
596 ((stream :reader stream-error-stream :initarg :stream)))
598 (define-condition end-of-file (stream-error) ()
600 (lambda (condition stream)
603 (stream-error-stream condition)))))
605 (define-condition file-error (error)
606 ((pathname :reader file-error-pathname :initarg :pathname))
608 (lambda (condition stream)
610 "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
611 (condition-function-name condition)
612 (serious-condition-format-control condition)
613 (serious-condition-format-arguments condition)))))
615 (define-condition package-error (error)
616 ((package :reader package-error-package :initarg :package)))
618 (define-condition cell-error (error)
619 ((name :reader cell-error-name :initarg :name)))
621 (define-condition unbound-variable (cell-error) ()
623 (lambda (condition stream)
625 "error in ~S: The variable ~S is unbound."
626 (condition-function-name condition)
627 (cell-error-name condition)))))
629 (define-condition undefined-function (cell-error) ()
631 (lambda (condition stream)
633 "error in ~S: The function ~S is undefined."
634 (condition-function-name condition)
635 (cell-error-name condition)))))
637 (define-condition arithmetic-error (error)
638 ((operation :reader arithmetic-error-operation
641 (operands :reader arithmetic-error-operands
643 (:report (lambda (condition stream)
645 "arithmetic error ~S signalled"
647 (when (arithmetic-error-operation condition)
649 "~%Operation was ~S, operands ~S."
650 (arithmetic-error-operation condition)
651 (arithmetic-error-operands condition))))))
653 (define-condition division-by-zero (arithmetic-error) ())
654 (define-condition floating-point-overflow (arithmetic-error) ())
655 (define-condition floating-point-underflow (arithmetic-error) ())
656 (define-condition floating-point-inexact (arithmetic-error) ())
657 (define-condition floating-point-invalid-operation (arithmetic-error) ())
659 (define-condition print-not-readable (error)
660 ((object :reader print-not-readable-object :initarg :object))
662 (lambda (condition stream)
663 (let ((obj (print-not-readable-object condition))
665 (format stream "~S cannot be printed readably." obj)))))
667 (define-condition reader-error (parse-error stream-error)
668 ;; FIXME: Do we need FORMAT-CONTROL and FORMAT-ARGUMENTS when
669 ;; we have an explicit :REPORT function? I thought we didn't..
671 :reader reader-error-format-control
672 :initarg :format-control)
674 :reader reader-error-format-arguments
675 :initarg :format-arguments
678 (lambda (condition stream)
679 (let ((error-stream (stream-error-stream condition)))
680 (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
681 (file-position error-stream) error-stream
682 (reader-error-format-control condition)
683 (reader-error-format-arguments condition))))))
685 ;;;; various other (not specified by ANSI) CONDITIONs
687 ;;;; These might logically belong in other files; they're here, after
688 ;;;; setup of CONDITION machinery, only because that makes it easier to
689 ;;;; get cold init to work.
691 ;;; KLUDGE: a condition for floating point errors when we can't or
692 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
693 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
694 ;;; know how but the old code was broken by the conversion to POSIX
695 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
697 ;;; FIXME: Perhaps this should also be a base class for all
698 ;;; floating point exceptions?
699 (define-condition floating-point-exception (arithmetic-error)
700 ((flags :initarg :traps
702 :reader floating-point-exception-traps))
703 (:report (lambda (condition stream)
705 "An arithmetic error ~S was signalled.~%"
707 (let ((traps (floating-point-exception-traps condition)))
710 "Trapping conditions are: ~%~{ ~S~^~}~%"
713 "No traps are enabled? How can this be?"
716 (define-condition index-too-large-error (type-error)
719 (lambda (condition stream)
721 "error in ~S: ~S: index too large"
722 (condition-function-name condition)
723 (type-error-datum condition)))))
725 (define-condition io-timeout (stream-error)
726 ((direction :reader io-timeout-direction :initarg :direction))
728 (lambda (condition stream)
729 (declare (type stream stream))
731 "IO-TIMEOUT ~(~A~)ing ~S"
732 (io-timeout-direction condition)
733 (stream-error-stream condition)))))
735 (define-condition namestring-parse-error (parse-error)
736 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
737 (arguments :reader namestring-parse-error-arguments :initarg :arguments
739 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
740 (offset :reader namestring-parse-error-offset :initarg :offset))
742 (lambda (condition stream)
744 "parse error in namestring: ~?~% ~A~% ~V@T^"
745 (namestring-parse-error-complaint condition)
746 (namestring-parse-error-arguments condition)
747 (namestring-parse-error-namestring condition)
748 (namestring-parse-error-offset condition)))))
750 (define-condition simple-package-error (simple-condition package-error) ())
752 (define-condition reader-package-error (reader-error) ())
754 (define-condition reader-eof-error (end-of-file)
755 ((context :reader reader-eof-error-context :initarg :context))
757 (lambda (condition stream)
759 "unexpected EOF on ~S ~A"
760 (stream-error-stream condition)
761 (reader-eof-error-context condition)))))
763 ;;;; restart definitions
765 (define-condition abort-failure (control-error) ()
767 "An ABORT restart was found that failed to transfer control dynamically."))
769 (defun abort (&optional condition)
771 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
773 (invoke-restart (find-restart 'abort condition))
774 ;; ABORT signals an error in case there was a restart named ABORT
775 ;; that did not transfer control dynamically. This could happen with
777 (error 'abort-failure))
779 (defun muffle-warning (&optional condition)
781 "Transfer control to a restart named MUFFLE-WARNING, signalling a
782 CONTROL-ERROR if none exists."
783 (invoke-restart (find-restart 'muffle-warning condition)))
785 (macrolet ((define-nil-returning-restart (name args doc)
786 #!-sb-doc (declare (ignore doc))
787 `(defun ,name (,@args &optional condition)
789 ;; FIXME: Perhaps this shared logic should be pulled out into
790 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
791 (when (find-restart ',name condition)
792 (invoke-restart ',name ,@args)))))
793 (define-nil-returning-restart continue ()
794 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
795 (define-nil-returning-restart store-value (value)
796 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
798 (define-nil-returning-restart use-value (value)
799 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
802 (/show0 "late-target-error.lisp end of file")