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!CONDITIONS")
21 ;;;; the CONDITION class
23 (eval-when (:compile-toplevel :load-toplevel :execute)
25 (def!struct (condition-class (:include slot-class)
26 (:constructor bare-make-condition-class))
27 ;; List of CONDITION-SLOT structures for the direct slots of this class.
28 (slots nil :type list)
29 ;; List of CONDITION-SLOT structures for all of the effective class slots of
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 ;; CPL as a list of class objects, with all non-condition classes removed.
38 ;; A list of all the effective instance allocation slots of this class that
39 ;; have a non-constant initform or default-initarg. Values for these slots
40 ;; must be computed in the dynamic 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 defaulted
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 a function, call it with no args. Otherwise, the actual value.
73 (initform (required-argument) :type t)
74 ;; Allocation of this slot. Nil only until defaulted.
75 (allocation nil :type (member :instance :class nil))
76 ;; If :class allocation, a cons whose car holds the value.
77 (cell nil :type (or cons null)))
79 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
80 ;; the appropriate initialization value for the CPL slot of a CONDITION,
81 ;; calculated by looking at the INHERITS information in the LAYOUT
83 (defun condition-class-cpl-from-layout (condition)
84 (declare (type condition condition))
85 (let* ((class (sb!xc:find-class condition))
86 (layout (class-layout class))
87 (superset (map 'list #'identity (layout-inherits layout))))
88 (delete-if (lambda (superclass)
89 (not (typep superclass 'condition-class)))
92 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed in its
93 ;;; CPL, while other classes derived from CONDITION-CLASS don't have themselves
94 ;;; listed in their CPLs. This behavior is inherited from CMU CL, and didn't
95 ;;; seem to be explained there, and I haven't figured out whether it's right.
97 (eval-when (:compile-toplevel :load-toplevel :execute)
98 (let ((condition-class (locally
99 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
100 ;; constant class names which creates fast but
101 ;; non-cold-loadable, non-compact code. In this
102 ;; context, we'd rather have compact, cold-loadable
103 ;; code. -- WHN 19990928
104 (declare (notinline sb!xc:find-class))
105 (sb!xc:find-class 'condition))))
106 (setf (condition-class-cpl condition-class)
107 (list condition-class))))
109 (setf (condition-class-report (locally
110 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
111 ;; for constant class names which creates fast
112 ;; but non-cold-loadable, non-compact code. In
113 ;; this context, we'd rather have compact,
114 ;; cold-loadable code. -- WHN 19990928
115 (declare (notinline sb!xc:find-class))
116 (find-class 'condition)))
117 #'(lambda (cond stream)
118 (format stream "Condition ~S was signalled." (type-of cond))))
120 (eval-when (:compile-toplevel :load-toplevel :execute)
122 (defun find-condition-layout (name parent-types)
123 (let* ((cpl (remove-duplicates
126 (mapcar #'(lambda (x)
128 (sb!xc:find-class x)))
130 (cond-layout (info :type :compiler-layout 'condition))
131 (olayout (info :type :compiler-layout name))
133 (concatenate 'simple-vector
134 (layout-inherits cond-layout)
135 (mapcar #'class-layout cpl))))
137 (not (mismatch (layout-inherits olayout) new-inherits)))
139 (make-layout :class (make-undefined-class name)
140 :inherits new-inherits
142 :length (layout-length cond-layout)))))
146 ;;; FIXME: ANSI's definition of DEFINE-CONDITION says
147 ;;; Condition reporting is mediated through the print-object method for
148 ;;; the condition type in question, with *print-escape* always being nil.
149 ;;; Specifying (:report report-name) in the definition of a condition
150 ;;; type C is equivalent to:
151 ;;; (defmethod print-object ((x c) stream)
152 ;;; (if *print-escape* (call-next-method) (report-name x stream)))
153 ;;; The current code doesn't seem to quite match that.
154 (def!method print-object ((x condition) stream)
156 (print-unreadable-object (x stream :type t :identity t))
157 ;; KLUDGE: A comment from CMU CL here said
158 ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
159 ;; superclasses in define-condition call!
160 (dolist (class (condition-class-cpl (sb!xc:class-of x))
161 (error "no REPORT? shouldn't happen!"))
162 (let ((report (condition-class-report class)))
164 (return (funcall report x stream)))))))
166 ;;;; slots of CONDITION objects
168 (defvar *empty-slot* '(empty))
170 (defun find-slot-default (class slot)
171 (let ((initargs (condition-slot-initargs slot))
172 (cpl (condition-class-cpl class)))
174 (let ((default-initargs (condition-class-default-initargs class)))
175 (dolist (initarg initargs)
176 (let ((val (getf default-initargs initarg *empty-slot*)))
177 (unless (eq val *empty-slot*)
178 (return-from find-slot-default
183 (if (condition-slot-initform-p slot)
184 (let ((initform (condition-slot-initform slot)))
185 (if (functionp initform)
188 (error "unbound condition slot: ~S" (condition-slot-name slot)))))
190 (defun find-slot (classes name)
191 (dolist (sclass classes nil)
192 (dolist (slot (condition-class-slots sclass))
193 (when (eq (condition-slot-name slot) name)
194 (return-from find-slot slot)))))
196 (defun condition-writer-function (condition new-value name)
197 (dolist (cslot (condition-class-class-slots
198 (layout-class (%instance-layout condition)))
199 (setf (getf (condition-assigned-slots condition) name)
201 (when (eq (condition-slot-name cslot) name)
202 (return (setf (car (condition-slot-cell cslot)) new-value)))))
204 (defun condition-reader-function (condition name)
205 (let ((class (layout-class (%instance-layout condition))))
206 (dolist (cslot (condition-class-class-slots class))
207 (when (eq (condition-slot-name cslot) name)
208 (return-from condition-reader-function
209 (car (condition-slot-cell cslot)))))
211 (let ((val (getf (condition-assigned-slots condition) name
213 (if (eq val *empty-slot*)
214 (let ((actual-initargs (condition-actual-initargs condition))
215 (slot (find-slot (condition-class-cpl class) name)))
216 (dolist (initarg (condition-slot-initargs slot))
217 (let ((val (getf actual-initargs initarg *empty-slot*)))
218 (unless (eq val *empty-slot*)
219 (return-from condition-reader-function
220 (setf (getf (condition-assigned-slots condition)
223 (setf (getf (condition-assigned-slots condition) name)
224 (find-slot-default class slot)))
229 (defun make-condition (thing &rest args)
231 "Make an instance of a condition object using the specified initargs."
232 ;; Note: ANSI specifies no exceptional situations in this function.
233 ;; signalling simple-type-error would not be wrong.
234 (let* ((thing (if (symbolp thing)
235 (sb!xc:find-class thing)
237 (class (typecase thing
238 (condition-class thing)
240 (error 'simple-type-error
242 :expected-type 'condition-class
243 :format-control "~S is not a condition class."
244 :format-arguments (list thing)))
246 (error 'simple-type-error
248 :expected-type 'condition-class
249 :format-control "bad thing for class arg:~% ~S"
250 :format-arguments (list thing)))))
251 (res (make-condition-object args)))
252 (setf (%instance-layout res) (class-layout class))
253 ;; Set any class slots with initargs present in this call.
254 (dolist (cslot (condition-class-class-slots class))
255 (dolist (initarg (condition-slot-initargs cslot))
256 (let ((val (getf args initarg *empty-slot*)))
257 (unless (eq val *empty-slot*)
258 (setf (car (condition-slot-cell cslot)) val)))))
259 ;; Default any slots with non-constant defaults now.
260 (dolist (hslot (condition-class-hairy-slots class))
261 (when (dolist (initarg (condition-slot-initargs hslot) t)
262 (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
264 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
265 (find-slot-default class hslot))))
269 ;;;; DEFINE-CONDITION
271 (eval-when (:compile-toplevel :load-toplevel :execute)
272 (defun %compiler-define-condition (name direct-supers layout)
273 (multiple-value-bind (class old-layout)
274 (insured-find-class name #'condition-class-p #'make-condition-class)
275 (setf (layout-class layout) class)
276 (setf (class-direct-superclasses class)
277 (mapcar #'sb!xc:find-class direct-supers))
278 (cond ((not old-layout)
279 (register-layout layout))
280 ((not *type-system-initialized*)
281 (setf (layout-class old-layout) class)
282 (setq layout old-layout)
283 (unless (eq (class-layout class) layout)
284 (register-layout layout)))
285 ((redefine-layout-warning "current"
288 (layout-length layout)
289 (layout-inherits layout)
290 (layout-depthoid layout))
291 (register-layout layout :invalidate t))
292 ((not (class-layout class))
293 (register-layout layout)))
295 (setf (layout-info layout)
297 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
298 ;; names which creates fast but non-cold-loadable, non-compact
299 ;; code. In this context, we'd rather have compact, cold-loadable
300 ;; code. -- WHN 19990928
301 (declare (notinline sb!xc:find-class))
302 (layout-info (class-layout (sb!xc:find-class 'condition)))))
304 (setf (sb!xc:find-class name) class)
306 ;; Initialize CPL slot from layout.
309 (let ((inherits (layout-inherits layout)))
310 (do ((i (1- (length inherits)) (1- i)))
312 (let ((super (sb!xc:find-class
314 (layout-class (svref inherits i))))))
315 (when (typep super 'condition-class)
317 (setf (condition-class-cpl class) (cpl))))
323 ;;; Compute the effective slots of class, copying inherited slots and
324 ;;; side-effecting direct slots.
325 (defun compute-effective-slots (class)
326 (collect ((res (copy-list (condition-class-slots class))))
327 (dolist (sclass (condition-class-cpl class))
328 (dolist (sslot (condition-class-slots sclass))
329 (let ((found (find (condition-slot-name sslot) (res)
332 (setf (condition-slot-initargs found)
333 (union (condition-slot-initargs found)
334 (condition-slot-initargs sslot)))
335 (unless (condition-slot-initform-p found)
336 (setf (condition-slot-initform-p found)
337 (condition-slot-initform-p sslot))
338 (setf (condition-slot-initform found)
339 (condition-slot-initform sslot)))
340 (unless (condition-slot-allocation found)
341 (setf (condition-slot-allocation found)
342 (condition-slot-allocation sslot))))
344 (res (copy-structure sslot)))))))
347 (defun %define-condition (name slots documentation report default-initargs)
348 (let ((class (sb!xc:find-class name)))
349 (setf (condition-class-slots class) slots)
350 (setf (condition-class-report class) report)
351 (setf (condition-class-default-initargs class) default-initargs)
352 (setf (fdocumentation name 'type) documentation)
356 ;; Set up reader and writer functions.
357 (let ((name (condition-slot-name slot)))
358 (dolist (reader (condition-slot-readers slot))
359 (setf (fdefinition reader)
360 #'(lambda (condition)
361 (condition-reader-function condition name))))
362 (dolist (writer (condition-slot-writers slot))
363 (setf (fdefinition writer)
364 #'(lambda (new-value condition)
365 (condition-writer-function condition new-value name))))))
367 ;; Compute effective slots and set up the class and hairy slots (subsets of
368 ;; the effective slots.)
369 (let ((eslots (compute-effective-slots class))
372 (mapcar #'condition-class-default-initargs
373 (condition-class-cpl class)))))
374 (dolist (slot eslots)
375 (ecase (condition-slot-allocation slot)
377 (unless (condition-slot-cell slot)
378 (setf (condition-slot-cell slot)
379 (list (if (condition-slot-initform-p slot)
380 (let ((initform (condition-slot-initform slot)))
381 (if (functionp initform)
385 (push slot (condition-class-class-slots class)))
387 (setf (condition-slot-allocation slot) :instance)
388 (when (or (functionp (condition-slot-initform slot))
389 (dolist (initarg (condition-slot-initargs slot) nil)
390 (when (functionp (getf e-def-initargs initarg))
392 (push slot (condition-class-hairy-slots class))))))))
395 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
398 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
399 Define NAME as a condition type. This new type inherits slots and its
400 report function from the specified PARENT-TYPEs. A slot spec is a list of:
401 (slot-name :reader <rname> :initarg <iname> {Option Value}*
403 The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
404 and :TYPE and the overall options :DEFAULT-INITARGS and
405 [type] :DOCUMENTATION are also allowed.
407 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
408 a string or a two-argument lambda or function name. If a function, the
409 function is called with the condition and stream to report the condition.
410 If a string, the string is printed.
412 Condition types are classes, but (as allowed by ANSI and not as described in
413 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
414 SLOT-VALUE may not be used on condition objects."
415 (let* ((parent-types (or parent-types '(condition)))
416 (layout (find-condition-layout name parent-types))
419 (default-initargs ()))
421 (all-readers nil append)
422 (all-writers nil append))
423 (dolist (spec slot-specs)
424 (when (keywordp spec)
425 (warn "Keyword slot name indicates probable syntax error:~% ~S"
427 (let* ((spec (if (consp spec) spec (list spec)))
428 (slot-name (first spec))
429 (allocation :instance)
435 (do ((options (rest spec) (cddr options)))
437 (unless (and (consp options) (consp (cdr options)))
438 (error "malformed condition slot spec:~% ~S." spec))
439 (let ((arg (second options)))
440 (case (first options)
441 (:reader (readers arg))
442 (:writer (writers arg))
445 (writers `(setf ,arg)))
448 (error "more than one :INITFORM in ~S" spec))
451 (:initarg (initargs arg))
453 (setq allocation arg))
456 (error "unknown slot option:~% ~S" (first options))))))
458 (all-readers (readers))
459 (all-writers (writers))
460 (slots `(make-condition-slot
462 :initargs ',(initargs)
465 :initform-p ',initform-p
467 ,(if (constantp initform)
469 `#'(lambda () ,initform)))))))
471 (dolist (option options)
472 (unless (consp option)
473 (error "bad option:~% ~S" option))
475 (:documentation (setq documentation (second option)))
477 (let ((arg (second option)))
480 `#'(lambda (condition stream)
481 (declare (ignore condition))
482 (write-string ,arg stream))
483 `#'(lambda (condition stream)
484 (funcall #',arg condition stream))))))
486 (do ((initargs (rest option) (cddr initargs)))
488 (let ((val (second initargs)))
489 (setq default-initargs
490 (list* `',(first initargs)
494 default-initargs)))))
496 (error "unknown option: ~S" (first option)))))
499 (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
503 (eval-when (:compile-toplevel :load-toplevel :execute)
504 (%compiler-define-condition ',name ',parent-types ',layout))
506 (declaim (ftype (function (t) t) ,@(all-readers)))
507 (declaim (ftype (function (t t) t) ,@(all-writers)))
509 (%define-condition ',name
513 (list ,@default-initargs))))))
515 ;;;; various CONDITIONs specified by ANSI
517 (define-condition serious-condition (condition)())
519 (define-condition error (serious-condition) ())
521 (define-condition warning (condition) ())
522 (define-condition style-warning (warning) ())
524 (defun simple-condition-printer (condition stream)
525 ;; FIXME: Why use APPLY instead of an ordinary form? To stop the optimizer
526 ;; from doing something?
527 (apply #'format stream (simple-condition-format-control condition)
528 (simple-condition-format-arguments condition)))
530 (define-condition simple-condition ()
531 ((format-control :reader simple-condition-format-control
532 :initarg :format-control)
533 (format-arguments :reader simple-condition-format-arguments
534 :initarg :format-arguments
536 (:report simple-condition-printer))
538 (define-condition simple-warning (simple-condition warning) ())
540 (defun print-simple-error (condition stream)
542 "~&~@<error in function ~S: ~3I~:_~?~:>"
543 (condition-function-name condition)
544 (simple-condition-format-control condition)
545 (simple-condition-format-arguments condition)))
547 (define-condition simple-error (simple-condition error) ()
548 ;; This is the condition type used by ERROR and CERROR when
549 ;; a format-control string is supplied as the first argument.
550 (:report print-simple-error))
552 (define-condition storage-condition (serious-condition) ())
554 ;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data on an
555 ;;; ad hoc basis, for some conditions and not others? Why not standardize
556 ;;; it somehow? perhaps by making the debugger report it?
558 (define-condition type-error (error)
559 ((datum :reader type-error-datum :initarg :datum)
560 (expected-type :reader type-error-expected-type :initarg :expected-type))
562 (lambda (condition stream)
564 "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
565 (condition-function-name condition)
566 (type-error-datum condition)
567 (type-error-expected-type condition)))))
569 (define-condition program-error (error) ())
570 (define-condition parse-error (error) ())
571 (define-condition control-error (error) ())
572 (define-condition stream-error (error)
573 ((stream :reader stream-error-stream :initarg :stream)))
575 (define-condition end-of-file (stream-error) ()
577 (lambda (condition stream)
580 (stream-error-stream condition)))))
582 (define-condition file-error (error)
583 ((pathname :reader file-error-pathname :initarg :pathname))
585 (lambda (condition stream)
587 "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
588 (condition-function-name condition)
589 (serious-condition-format-control condition)
590 (serious-condition-format-arguments condition)))))
592 (define-condition package-error (error)
593 ((package :reader package-error-package :initarg :package)))
595 (define-condition cell-error (error)
596 ((name :reader cell-error-name :initarg :name)))
598 (define-condition unbound-variable (cell-error) ()
600 (lambda (condition stream)
602 "error in ~S: The variable ~S is unbound."
603 (condition-function-name condition)
604 (cell-error-name condition)))))
606 (define-condition undefined-function (cell-error) ()
608 (lambda (condition stream)
610 "error in ~S: The function ~S is undefined."
611 (condition-function-name condition)
612 (cell-error-name condition)))))
614 (define-condition arithmetic-error (error)
615 ((operation :reader arithmetic-error-operation
618 (operands :reader arithmetic-error-operands
620 (:report (lambda (condition stream)
622 "arithmetic error ~S signalled"
624 (when (arithmetic-error-operation condition)
626 "~%Operation was ~S, operands ~S."
627 (arithmetic-error-operation condition)
628 (arithmetic-error-operands condition))))))
630 (define-condition division-by-zero (arithmetic-error) ())
631 (define-condition floating-point-overflow (arithmetic-error) ())
632 (define-condition floating-point-underflow (arithmetic-error) ())
633 (define-condition floating-point-inexact (arithmetic-error) ())
634 (define-condition floating-point-invalid-operation (arithmetic-error) ())
636 (define-condition print-not-readable (error)
637 ((object :reader print-not-readable-object :initarg :object))
639 (lambda (condition stream)
640 (let ((obj (print-not-readable-object condition))
642 (format stream "~S cannot be printed readably." obj)))))
644 (define-condition reader-error (parse-error stream-error)
646 :reader reader-error-format-control
647 :initarg :format-control)
649 :reader reader-error-format-arguments
650 :initarg :format-arguments
653 (lambda (condition stream)
654 (let ((error-stream (stream-error-stream condition)))
655 (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
656 (file-position error-stream) error-stream
657 (reader-error-format-control condition)
658 (reader-error-format-arguments condition))))))
660 ;;;; various other (not specified by ANSI) CONDITIONs
662 ;;;; These might logically belong in other files; they're here, after
663 ;;;; setup of CONDITION machinery, only because that makes it easier to
664 ;;;; get cold init to work.
666 ;;; KLUDGE: a condition for floating point errors when we can't or
667 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
668 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
669 ;;; know how but the old code was broken by the conversion to POSIX
670 ;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
672 ;;; FIXME: Perhaps this should also be a base class for all
673 ;;; floating point exceptions?
674 (define-condition floating-point-exception (arithmetic-error)
675 ((flags :initarg :traps
676 :reader floating-point-exception-traps))
677 (:report (lambda (condition stream)
679 "An arithmetic error ~S was signalled.~%"
681 (let ((traps (floating-point-exception-traps condition)))
684 "Trapping conditions are: ~%~{ ~S~^~}~%"
687 "No traps are enabled? How can this be?"
690 (define-condition index-too-large-error (type-error)
693 (lambda (condition stream)
695 "error in ~S: ~S: index too large"
696 (condition-function-name condition)
697 (type-error-datum condition)))))
699 (define-condition io-timeout (stream-error)
700 ((direction :reader io-timeout-direction :initarg :direction))
702 (lambda (condition stream)
703 (declare (type stream stream))
705 "IO-TIMEOUT ~(~A~)ing ~S"
706 (io-timeout-direction condition)
707 (stream-error-stream condition)))))
709 (define-condition namestring-parse-error (parse-error)
710 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
711 (arguments :reader namestring-parse-error-arguments :initarg :arguments
713 (namestring :reader namestring-parse-error-namestring :initarg :namestring)
714 (offset :reader namestring-parse-error-offset :initarg :offset))
715 (:report %print-namestring-parse-error))
717 (define-condition simple-package-error (simple-condition package-error) ())
719 (define-condition reader-package-error (reader-error) ())
721 (define-condition reader-eof-error (end-of-file)
722 ((context :reader reader-eof-error-context :initarg :context))
724 (lambda (condition stream)
726 "unexpected EOF on ~S ~A"
727 (stream-error-stream condition)
728 (reader-eof-error-context condition)))))
730 ;;;; restart definitions
732 (define-condition abort-failure (control-error) ()
734 "An ABORT restart was found that failed to transfer control dynamically."))
736 (defun abort (&optional condition)
738 "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
740 (invoke-restart (find-restart 'abort condition))
741 ;; ABORT signals an error in case there was a restart named abort that did
742 ;; not transfer control dynamically. This could happen with RESTART-BIND.
743 (error 'abort-failure))
745 (defun muffle-warning (&optional condition)
747 "Transfer control to a restart named MUFFLE-WARNING, signalling a
748 CONTROL-ERROR if none exists."
749 (invoke-restart (find-restart 'muffle-warning condition)))
751 (macrolet ((define-nil-returning-restart (name args doc)
752 #!-sb-doc (declare (ignore doc))
753 `(defun ,name (,@args &optional condition)
755 ;; FIXME: Perhaps this shared logic should be pulled out into
756 ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
757 (when (find-restart ',name condition)
758 (invoke-restart ',name ,@args)))))
759 (define-nil-returning-restart continue ()
760 "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
761 (define-nil-returning-restart store-value (value)
762 "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
764 (define-nil-returning-restart use-value (value)
765 "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if