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 (eval-when (:compile-toplevel :load-toplevel :execute)
22 (def!struct (condition-class (:include slot-class)
23 (:constructor bare-make-condition-class))
24 ;; list of CONDITION-SLOT structures for the direct slots of this
26 (slots nil :type list)
27 ;; list of CONDITION-SLOT structures for all of the effective class
28 ;; slots of this class
29 (class-slots nil :type list)
30 ;; report function or NIL
31 (report nil :type (or function null))
32 ;; list of alternating initargs and initforms
33 (default-initargs () :type list)
34 ;; class precedence list as a list of class objects, with all
35 ;; non-condition classes removed
37 ;; a list of all the effective instance allocation slots of this
38 ;; class that have a non-constant initform or default-initarg.
39 ;; Values for these slots must be computed in the dynamic
40 ;; environment of MAKE-CONDITION.
41 (hairy-slots nil :type list))
43 (defun make-condition-class (&rest rest)
44 (apply #'bare-make-condition-class
45 (rename-keyword-args '((:name :%name)) rest)))
50 (:constructor make-condition-object (actual-initargs))
51 (:alternate-metaclass instance
57 ;; actual initargs supplied to MAKE-CONDITION
58 (actual-initargs (required-argument) :type list)
59 ;; plist mapping slot names to any values that were assigned or
60 ;; defaulted after creation
61 (assigned-slots () :type list))
63 (defstruct condition-slot
64 (name (required-argument) :type symbol)
65 ;; list of all applicable initargs
66 (initargs (required-argument) :type list)
67 ;; names of reader and writer functions
68 (readers (required-argument) :type list)
69 (writers (required-argument) :type list)
70 ;; true if :INITFORM was specified
71 (initform-p (required-argument) :type (member t nil))
72 ;; If this is a function, call it with no args. Otherwise, it's the
74 (initform (required-argument) :type t)
75 ;; allocation of this slot, or NIL until defaulted
76 (allocation nil :type (member :instance :class nil))
77 ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
78 (cell nil :type (or cons null)))
80 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
81 ;; the appropriate initialization value for the CPL slot of a
82 ;; CONDITION, calculated by looking at the INHERITS information in
83 ;; the LAYOUT of the CONDITION
84 (defun condition-class-cpl-from-layout (condition)
85 (declare (type condition condition))
86 (let* ((class (sb!xc:find-class condition))
87 (layout (class-layout class))
88 (superset (map 'list #'identity (layout-inherits layout))))
89 (delete-if (lambda (superclass)
90 (not (typep superclass 'condition-class)))
93 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
94 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
95 ;;; have themselves listed in their CPLs. This behavior is inherited
96 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
97 ;;; figured out whether it's right. -- WHN 19990612
98 (eval-when (:compile-toplevel :load-toplevel :execute)
99 (let ((condition-class (locally
100 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
101 ;; constant class names which creates fast but
102 ;; non-cold-loadable, non-compact code. In this
103 ;; context, we'd rather have compact, cold-loadable
104 ;; code. -- WHN 19990928
105 (declare (notinline sb!xc:find-class))
106 (sb!xc:find-class 'condition))))
107 (setf (condition-class-cpl condition-class)
108 (list condition-class))))
110 (setf (condition-class-report (locally
111 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
112 ;; for constant class names which creates fast
113 ;; but non-cold-loadable, non-compact code. In
114 ;; this context, we'd rather have compact,
115 ;; cold-loadable code. -- WHN 19990928
116 (declare (notinline sb!xc:find-class))
117 (find-class 'condition)))
118 #'(lambda (cond stream)
119 (format stream "Condition ~S was signalled." (type-of cond))))
121 (eval-when (:compile-toplevel :load-toplevel :execute)
123 (defun find-condition-layout (name parent-types)
124 (let* ((cpl (remove-duplicates
127 (mapcar #'(lambda (x)
129 (sb!xc:find-class x)))
131 (cond-layout (info :type :compiler-layout 'condition))
132 (olayout (info :type :compiler-layout name))
134 (concatenate 'simple-vector
135 (layout-inherits cond-layout)
136 (mapcar #'class-layout cpl))))
138 (not (mismatch (layout-inherits olayout) new-inherits)))
140 (make-layout :class (make-undefined-class name)
141 :inherits new-inherits
143 :length (layout-length cond-layout)))))
147 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
148 ;;; Condition reporting is mediated through the PRINT-OBJECT method
149 ;;; for the condition type in question, with *PRINT-ESCAPE* always
150 ;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
151 ;;; a condition type C is equivalent to:
152 ;;; (defmethod print-object ((x c) stream)
153 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
154 ;;; The current code doesn't seem to quite match that.
155 (def!method print-object ((x condition) stream)
157 (print-unreadable-object (x stream :type t :identity t))
158 ;; KLUDGE: A comment from CMU CL here said
159 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
160 ;; superclasses in define-condition call!
161 (dolist (class (condition-class-cpl (sb!xc:class-of x))
162 (error "no REPORT? shouldn't happen!"))
163 (let ((report (condition-class-report class)))
165 (return (funcall report x stream)))))))
167 ;;;; slots of CONDITION objects
169 (defvar *empty-condition-slot* '(empty))
171 (defun find-slot-default (class slot)
172 (let ((initargs (condition-slot-initargs slot))
173 (cpl (condition-class-cpl class)))
175 (let ((default-initargs (condition-class-default-initargs class)))
176 (dolist (initarg initargs)
177 (let ((val (getf default-initargs initarg *empty-condition-slot*)))
178 (unless (eq val *empty-condition-slot*)
179 (return-from find-slot-default
184 (if (condition-slot-initform-p slot)
185 (let ((initform (condition-slot-initform slot)))
186 (if (functionp initform)
189 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
191 (defun find-condition-class-slot (condition-class slot-name)
193 (condition-class-cpl condition-class)
194 (error "There is no slot named ~S in ~S."
195 slot-name condition-class))
196 (dolist (slot (condition-class-slots sclass))
197 (when (eq (condition-slot-name slot) slot-name)
198 (return-from find-condition-class-slot slot)))))
200 (defun condition-writer-function (condition new-value name)
201 (dolist (cslot (condition-class-class-slots
202 (layout-class (%instance-layout condition)))
203 (setf (getf (condition-assigned-slots condition) name)
205 (when (eq (condition-slot-name cslot) name)
206 (return (setf (car (condition-slot-cell cslot)) new-value)))))
208 (defun condition-reader-function (condition name)
209 (let ((class (layout-class (%instance-layout condition))))
210 (dolist (cslot (condition-class-class-slots class))
211 (when (eq (condition-slot-name cslot) name)
212 (return-from condition-reader-function
213 (car (condition-slot-cell cslot)))))
215 (let ((val (getf (condition-assigned-slots condition) name
216 *empty-condition-slot*)))
217 (if (eq val *empty-condition-slot*)
218 (let ((actual-initargs (condition-actual-initargs condition))
219 (slot (find-condition-class-slot class name)))
220 (dolist (initarg (condition-slot-initargs slot))
221 (let ((val (getf actual-initargs
223 *empty-condition-slot*)))
224 (unless (eq val *empty-condition-slot*)
225 (return-from condition-reader-function
226 (setf (getf (condition-assigned-slots condition)
229 (setf (getf (condition-assigned-slots condition) name)
230 (find-slot-default class slot)))
235 (defun make-condition (thing &rest args)
237 "Make an instance of a condition object using the specified initargs."
238 ;; Note: ANSI specifies no exceptional situations in this function.
239 ;; signalling simple-type-error would not be wrong.
240 (let* ((thing (if (symbolp thing)
241 (sb!xc:find-class thing)
243 (class (typecase thing
244 (condition-class thing)
246 (error 'simple-type-error
248 :expected-type 'condition-class
249 :format-control "~S is not a condition class."
250 :format-arguments (list thing)))
252 (error 'simple-type-error
254 :expected-type 'condition-class
255 :format-control "bad thing for class argument:~% ~S"
256 :format-arguments (list thing)))))
257 (res (make-condition-object args)))
258 (setf (%instance-layout res) (class-layout class))
259 ;; Set any class slots with initargs present in this call.
260 (dolist (cslot (condition-class-class-slots class))
261 (dolist (initarg (condition-slot-initargs cslot))
262 (let ((val (getf args initarg *empty-condition-slot*)))
263 (unless (eq val *empty-condition-slot*)
264 (setf (car (condition-slot-cell cslot)) val)))))
265 ;; Default any slots with non-constant defaults now.
266 (dolist (hslot (condition-class-hairy-slots class))
267 (when (dolist (initarg (condition-slot-initargs hslot) t)
268 (unless (eq (getf args initarg *empty-condition-slot*)
269 *empty-condition-slot*)
271 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
272 (find-slot-default class hslot))))
276 ;;;; DEFINE-CONDITION
278 (eval-when (:compile-toplevel :load-toplevel :execute)
279 (defun %compiler-define-condition (name direct-supers layout)
280 (multiple-value-bind (class old-layout)
281 (insured-find-class name #'condition-class-p #'make-condition-class)
282 (setf (layout-class layout) class)
283 (setf (class-direct-superclasses class)
284 (mapcar #'sb!xc:find-class direct-supers))
285 (cond ((not old-layout)
286 (register-layout layout))
287 ((not *type-system-initialized*)
288 (setf (layout-class old-layout) class)
289 (setq layout old-layout)
290 (unless (eq (class-layout class) layout)
291 (register-layout layout)))
292 ((redefine-layout-warning "current"
295 (layout-length layout)
296 (layout-inherits layout)
297 (layout-depthoid layout))
298 (register-layout layout :invalidate t))
299 ((not (class-layout class))
300 (register-layout layout)))
302 (setf (layout-info layout)
304 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
305 ;; names which creates fast but non-cold-loadable, non-compact
306 ;; code. In this context, we'd rather have compact, cold-loadable
307 ;; code. -- WHN 19990928
308 (declare (notinline sb!xc:find-class))
309 (layout-info (class-layout (sb!xc:find-class 'condition)))))
311 (setf (sb!xc:find-class name) class)
313 ;; Initialize CPL slot from layout.
316 (let ((inherits (layout-inherits layout)))
317 (do ((i (1- (length inherits)) (1- i)))
319 (let ((super (sb!xc:find-class
321 (layout-class (svref inherits i))))))
322 (when (typep super 'condition-class)
324 (setf (condition-class-cpl class) (cpl))))
330 ;;; Compute the effective slots of class, copying inherited slots and
331 ;;; side-effecting direct slots.
332 (defun compute-effective-slots (class)
333 (collect ((res (copy-list (condition-class-slots class))))
334 (dolist (sclass (condition-class-cpl class))
335 (dolist (sslot (condition-class-slots sclass))
336 (let ((found (find (condition-slot-name sslot) (res)
339 (setf (condition-slot-initargs found)
340 (union (condition-slot-initargs found)
341 (condition-slot-initargs sslot)))
342 (unless (condition-slot-initform-p found)
343 (setf (condition-slot-initform-p found)
344 (condition-slot-initform-p sslot))
345 (setf (condition-slot-initform found)
346 (condition-slot-initform sslot)))
347 (unless (condition-slot-allocation found)
348 (setf (condition-slot-allocation found)
349 (condition-slot-allocation sslot))))
351 (res (copy-structure sslot)))))))
354 (defun %define-condition (name slots documentation report default-initargs)
355 (let ((class (sb!xc:find-class name)))
356 (setf (condition-class-slots class) slots)
357 (setf (condition-class-report class) report)
358 (setf (condition-class-default-initargs class) default-initargs)
359 (setf (fdocumentation name 'type) documentation)
363 ;; Set up reader and writer functions.
364 (let ((name (condition-slot-name slot)))
365 (dolist (reader (condition-slot-readers slot))
366 (setf (fdefinition reader)
367 #'(lambda (condition)
368 (condition-reader-function condition name))))
369 (dolist (writer (condition-slot-writers slot))
370 (setf (fdefinition writer)
371 #'(lambda (new-value condition)
372 (condition-writer-function condition new-value name))))))
374 ;; Compute effective slots and set up the class and hairy slots
375 ;; (subsets of the effective slots.)
376 (let ((eslots (compute-effective-slots class))
379 (mapcar #'condition-class-default-initargs
380 (condition-class-cpl class)))))
381 (dolist (slot eslots)
382 (ecase (condition-slot-allocation slot)
384 (unless (condition-slot-cell slot)
385 (setf (condition-slot-cell slot)
386 (list (if (condition-slot-initform-p slot)
387 (let ((initform (condition-slot-initform slot)))
388 (if (functionp initform)
391 *empty-condition-slot*))))
392 (push slot (condition-class-class-slots class)))
394 (setf (condition-slot-allocation slot) :instance)
395 (when (or (functionp (condition-slot-initform slot))
396 (dolist (initarg (condition-slot-initargs slot) nil)
397 (when (functionp (getf e-def-initargs initarg))
399 (push slot (condition-class-hairy-slots class))))))))
402 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
405 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
406 Define NAME as a condition type. This new type inherits slots and its
407 report function from the specified PARENT-TYPEs. A slot spec is a list of:
408 (slot-name :reader <rname> :initarg <iname> {Option Value}*
410 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
411 and :TYPE and the overall options :DEFAULT-INITARGS and
412 [type] :DOCUMENTATION are also allowed.
414 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
415 a string or a two-argument lambda or function name. If a function, the
416 function is called with the condition and stream to report the condition.
417 If a string, the string is printed.
419 Condition types are classes, but (as allowed by ANSI and not as described in
420 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
421 SLOT-VALUE may not be used on condition objects."
422 (let* ((parent-types (or parent-types '(condition)))
423 (layout (find-condition-layout name parent-types))
426 (default-initargs ()))
428 (all-readers nil append)
429 (all-writers nil append))
430 (dolist (spec slot-specs)
431 (when (keywordp spec)
432 (warn "Keyword slot name indicates probable syntax error:~% ~S"
434 (let* ((spec (if (consp spec) spec (list spec)))
435 (slot-name (first spec))
436 (allocation :instance)
442 (do ((options (rest spec) (cddr options)))
444 (unless (and (consp options) (consp (cdr options)))
445 (error "malformed condition slot spec:~% ~S." spec))
446 (let ((arg (second options)))
447 (case (first options)
448 (:reader (readers arg))
449 (:writer (writers arg))
452 (writers `(setf ,arg)))
455 (error "more than one :INITFORM in ~S" spec))
458 (:initarg (initargs arg))
460 (setq allocation arg))
463 (error "unknown slot option:~% ~S" (first options))))))
465 (all-readers (readers))
466 (all-writers (writers))
467 (slots `(make-condition-slot
469 :initargs ',(initargs)
472 :initform-p ',initform-p
474 ,(if (constantp initform)
476 `#'(lambda () ,initform)))))))
478 (dolist (option options)
479 (unless (consp option)
480 (error "bad option:~% ~S" option))
482 (:documentation (setq documentation (second option)))
484 (let ((arg (second option)))
487 `#'(lambda (condition stream)
488 (declare (ignore condition))
489 (write-string ,arg stream))
490 `#'(lambda (condition stream)
491 (funcall #',arg condition stream))))))
493 (do ((initargs (rest option) (cddr initargs)))
495 (let ((val (second initargs)))
496 (setq default-initargs
497 (list* `',(first initargs)
501 default-initargs)))))
503 (error "unknown option: ~S" (first option)))))
506 (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
510 (eval-when (:compile-toplevel :load-toplevel :execute)
511 (%compiler-define-condition ',name ',parent-types ',layout))
513 (declaim (ftype (function (t) t) ,@(all-readers)))
514 (declaim (ftype (function (t t) t) ,@(all-writers)))
516 (%define-condition ',name
520 (list ,@default-initargs))))))
522 ;;;; DESCRIBE on CONDITIONs
524 ;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
525 ;;; eventually (once we get CLOS up and running so that we can define
527 (defun describe-condition (condition stream)
529 "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
533 (condition-actual-initargs condition)
534 (condition-assigned-slots condition))))
536 ;;;; various CONDITIONs specified by ANSI
538 (define-condition serious-condition (condition) ())
540 (define-condition error (serious-condition) ())
542 (define-condition warning (condition) ())
543 (define-condition style-warning (warning) ())
545 (defun simple-condition-printer (condition stream)
546 (apply #'format stream (simple-condition-format-control condition)
547 (simple-condition-format-arguments condition)))
549 (define-condition simple-condition ()
550 ((format-control :reader simple-condition-format-control
551 :initarg :format-control)
552 (format-arguments :reader simple-condition-format-arguments
553 :initarg :format-arguments
555 (:report simple-condition-printer))
557 (define-condition simple-warning (simple-condition warning) ())
559 (defun print-simple-error (condition stream)
561 "~&~@<error in function ~S: ~3I~:_~?~:>"
562 (condition-function-name condition)
563 (simple-condition-format-control condition)
564 (simple-condition-format-arguments condition)))
566 (define-condition simple-error (simple-condition error) ()
567 ;; This is the condition type used by ERROR and CERROR when
568 ;; a format-control string is supplied as the first argument.
569 (:report print-simple-error))
571 (define-condition storage-condition (serious-condition) ())
573 ;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data
574 ;;; on an ad hoc basis, for some conditions and not others? Why not
575 ;;; standardize it somehow? perhaps by making the debugger report it?
577 (define-condition type-error (error)
578 ((datum :reader type-error-datum :initarg :datum)
579 (expected-type :reader type-error-expected-type :initarg :expected-type))
581 (lambda (condition stream)
583 "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
584 (condition-function-name condition)
585 (type-error-datum condition)
586 (type-error-expected-type condition)))))
588 (define-condition program-error (error) ())
589 (define-condition parse-error (error) ())
590 (define-condition control-error (error) ())
591 (define-condition stream-error (error)
592 ((stream :reader stream-error-stream :initarg :stream)))
594 (define-condition end-of-file (stream-error) ()
596 (lambda (condition stream)
599 (stream-error-stream condition)))))
601 (define-condition file-error (error)
602 ((pathname :reader file-error-pathname :initarg :pathname))
604 (lambda (condition stream)
606 "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
607 (condition-function-name condition)
608 (serious-condition-format-control condition)
609 (serious-condition-format-arguments condition)))))
611 (define-condition package-error (error)
612 ((package :reader package-error-package :initarg :package)))
614 (define-condition cell-error (error)
615 ((name :reader cell-error-name :initarg :name)))
617 (define-condition unbound-variable (cell-error) ()
619 (lambda (condition stream)
621 "error in ~S: The variable ~S is unbound."
622 (condition-function-name condition)
623 (cell-error-name condition)))))
625 (define-condition undefined-function (cell-error) ()
627 (lambda (condition stream)
629 "error in ~S: The function ~S is undefined."
630 (condition-function-name condition)
631 (cell-error-name condition)))))
633 (define-condition arithmetic-error (error)
634 ((operation :reader arithmetic-error-operation
637 (operands :reader arithmetic-error-operands
639 (:report (lambda (condition stream)
641 "arithmetic error ~S signalled"
643 (when (arithmetic-error-operation condition)
645 "~%Operation was ~S, operands ~S."
646 (arithmetic-error-operation condition)
647 (arithmetic-error-operands condition))))))
649 (define-condition division-by-zero (arithmetic-error) ())
650 (define-condition floating-point-overflow (arithmetic-error) ())
651 (define-condition floating-point-underflow (arithmetic-error) ())
652 (define-condition floating-point-inexact (arithmetic-error) ())
653 (define-condition floating-point-invalid-operation (arithmetic-error) ())
655 (define-condition print-not-readable (error)
656 ((object :reader print-not-readable-object :initarg :object))
658 (lambda (condition stream)
659 (let ((obj (print-not-readable-object condition))
661 (format stream "~S cannot be printed readably." obj)))))
663 (define-condition reader-error (parse-error stream-error)
664 ;; FIXME: Do we need FORMAT-CONTROL and FORMAT-ARGUMENTS when
665 ;; we have an explicit :REPORT function? I thought we didn't..
667 :reader reader-error-format-control
668 :initarg :format-control)
670 :reader reader-error-format-arguments
671 :initarg :format-arguments
674 (lambda (condition stream)
675 (let ((error-stream (stream-error-stream condition)))
676 (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
677 (file-position error-stream) error-stream
678 (reader-error-format-control condition)
679 (reader-error-format-arguments condition))))))
681 ;;;; various other (not specified by ANSI) CONDITIONs
683 ;;;; These might logically belong in other files; they're here, after
684 ;;;; setup of CONDITION machinery, only because that makes it easier to
685 ;;;; get cold init to work.
687 ;;; KLUDGE: a condition for floating point errors when we can't or
688 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
689 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
690 ;;; know how but the old code was broken by the conversion to POSIX
691 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
693 ;;; FIXME: Perhaps this should also be a base class for all
694 ;;; floating point exceptions?
695 (define-condition floating-point-exception (arithmetic-error)
696 ((flags :initarg :traps
698 :reader floating-point-exception-traps))
699 (:report (lambda (condition stream)
701 "An arithmetic error ~S was signalled.~%"
703 (let ((traps (floating-point-exception-traps condition)))
706 "Trapping conditions are: ~%~{ ~S~^~}~%"
709 "No traps are enabled? How can this be?"
712 (define-condition index-too-large-error (type-error)
715 (lambda (condition stream)
717 "error in ~S: ~S: index too large"
718 (condition-function-name condition)
719 (type-error-datum condition)))))
721 (define-condition io-timeout (stream-error)
722 ((direction :reader io-timeout-direction :initarg :direction))
724 (lambda (condition stream)
725 (declare (type stream stream))
727 "IO-TIMEOUT ~(~A~)ing ~S"
728 (io-timeout-direction condition)
729 (stream-error-stream condition)))))
731 (define-condition namestring-parse-error (parse-error)
732 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
733 (arguments :reader namestring-parse-error-arguments :initarg :arguments
735 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
736 (offset :reader namestring-parse-error-offset :initarg :offset))
738 (lambda (condition stream)
740 "parse error in namestring: ~?~% ~A~% ~V@T^"
741 (namestring-parse-error-complaint condition)
742 (namestring-parse-error-arguments condition)
743 (namestring-parse-error-namestring condition)
744 (namestring-parse-error-offset condition)))))
746 (define-condition simple-package-error (simple-condition package-error) ())
748 (define-condition reader-package-error (reader-error) ())
750 (define-condition reader-eof-error (end-of-file)
751 ((context :reader reader-eof-error-context :initarg :context))
753 (lambda (condition stream)
755 "unexpected EOF on ~S ~A"
756 (stream-error-stream condition)
757 (reader-eof-error-context condition)))))
759 ;;;; restart definitions
761 (define-condition abort-failure (control-error) ()
763 "An ABORT restart was found that failed to transfer control dynamically."))
765 (defun abort (&optional condition)
767 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
769 (invoke-restart (find-restart 'abort condition))
770 ;; ABORT signals an error in case there was a restart named ABORT
771 ;; that did not transfer control dynamically. This could happen with
773 (error 'abort-failure))
775 (defun muffle-warning (&optional condition)
777 "Transfer control to a restart named MUFFLE-WARNING, signalling a
778 CONTROL-ERROR if none exists."
779 (invoke-restart (find-restart 'muffle-warning condition)))
781 (macrolet ((define-nil-returning-restart (name args doc)
782 #!-sb-doc (declare (ignore doc))
783 `(defun ,name (,@args &optional condition)
785 ;; FIXME: Perhaps this shared logic should be pulled out into
786 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
787 (when (find-restart ',name condition)
788 (invoke-restart ',name ,@args)))))
789 (define-nil-returning-restart continue ()
790 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
791 (define-nil-returning-restart store-value (value)
792 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
794 (define-nil-returning-restart use-value (value)
795 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if