X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=d92a9785ad433831dc9f56cafd50c4606aa14945;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=72ca0f04ae96f1912e76118253579f319a38f053;hpb=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;p=sbcl.git diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 72ca0f0..d92a978 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -11,528 +11,280 @@ ;;;; files for more information. (in-package "SB!KERNEL") - -;;;; restarts -;;; a list of lists of restarts -(defvar *restart-clusters* '()) +(defun muffle-warning-p (warning) + (declare (special *muffled-warnings*)) + (typep warning *muffled-warnings*)) + +(defun initial-handler-clusters () + `(((warning . ,#'(lambda (warning) + (when (muffle-warning-p warning) + (muffle-warning warning))))))) -;;; an ALIST (condition . restarts) which records the restarts currently -;;; associated with Condition -(defvar *condition-restarts* ()) +;;; an alist with elements of the form +;;; +;;; (CONDITION . (HANDLER1 HANDLER2 ...)) +;;; +;;; Recently established handlers are added at the beginning of the +;;; list. Elements to the left of the alist take precedence over +;;; elements to the right. +(defvar *handler-clusters* (initial-handler-clusters)) + +;;; a list of lists of currently active RESTART instances. maintained +;;; by RESTART-BIND. +(defvar *restart-clusters* '()) -(defstruct (restart (:copier nil) (:predicate nil)) +(declaim (inline restart-test-function + restart-associated-conditions + (setf restart-associated-conditions))) +(defstruct (restart (:constructor make-restart + ;; Having TEST-FUNCTION at the end allows + ;; to not replicate its default value in RESTART-BIND. + (name function + &optional report-function + interactive-function + test-function)) + (:copier nil) (:predicate nil)) (name (missing-arg) :type symbol :read-only t) - function - report-function - interactive-function - (test-function #'(lambda (cond) (declare (ignore cond)) t))) + (function (missing-arg) :type function :read-only t) + (report-function nil :type (or null function) :read-only t) + (interactive-function nil :type (or null function) :read-only t) + (test-function (lambda (cond) (declare (ignore cond)) t) :type function :read-only t) + ;; the list of conditions which are currently associated to the + ;; restart. maintained by WITH-CONDITION-RESTARTS in a neither + ;; thread- nor interrupt-safe way. This should not be a problem + ;; however, since safe uses of restarts have to assume dynamic + ;; extent. + (associated-conditions '() :type list)) + +#!-sb-fluid (declaim (freeze-type restart)) + (def!method print-object ((restart restart) stream) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t) - (prin1 (restart-name restart) stream)) + (prin1 (restart-name restart) stream)) (restart-report restart stream))) -(defun compute-restarts (&optional condition) - #!+sb-doc - "Return a list of all the currently active restarts ordered from most - recently established to less recently established. If Condition is - specified, then only restarts associated with Condition (or with no - condition) will be returned." - (let ((associated ()) - (other ())) - (dolist (alist *condition-restarts*) - (if (eq (car alist) condition) - (setq associated (cdr alist)) - (setq other (append (cdr alist) other)))) - (collect ((res)) - (dolist (restart-cluster *restart-clusters*) - (dolist (restart restart-cluster) - (when (and (or (not condition) - (member restart associated) - (not (member restart other))) - (funcall (restart-test-function restart) condition)) - (res restart)))) - (res)))) - #!+sb-doc (setf (fdocumentation 'restart-name 'function) "Return the name of the given restart object.") (defun restart-report (restart stream) (funcall (or (restart-report-function restart) - (let ((name (restart-name restart))) - #'(lambda (stream) - (if name (format stream "~S" name) - (format stream "~S" restart))))) - stream)) + (lambda (stream) + (format stream "~S" (or (restart-name restart) + restart)))) + stream)) -(defmacro with-condition-restarts (condition-form restarts-form &body body) - #!+sb-doc - "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* - Evaluates the Forms in a dynamic environment where the restarts in the list - Restarts-Form are associated with the condition returned by Condition-Form. - This allows FIND-RESTART, etc., to recognize restarts that are not related - to the error currently being debugged. See also RESTART-CASE." - (let ((n-cond (gensym))) - `(let ((*condition-restarts* - (cons (let ((,n-cond ,condition-form)) - (cons ,n-cond - (append ,restarts-form - (cdr (assoc ,n-cond *condition-restarts*))))) - *condition-restarts*))) - ,@body))) +(defvar *restart-test-stack* nil) + +;; Call FUNCTION with all restarts in the current dynamic environment, +;; 1) that are associated to CONDITION (when CONDITION is NIL, all +;; restarts are processed) +;; 2) and for which the restart test returns non-NIL for CONDITION. +;; When CALL-TEST-P is non-NIL, all restarts are processed. +(defun map-restarts (function &optional condition (call-test-p t)) + ;; FIXME: if MAP-RESTARTS is internal, we could require the FUNCTION + ;; argument to be of type FUNCTION. + (let ((function (coerce function 'function)) + (stack *restart-test-stack*)) + (dolist (restart-cluster *restart-clusters*) + (dolist (restart restart-cluster) + (when (and (or (not condition) + (null (restart-associated-conditions restart)) + (memq condition (restart-associated-conditions restart))) + ;; A call to COMPUTE-RESTARTS -- from an error, + ;; from user code, whatever -- inside the test + ;; function would cause infinite recursion here, so + ;; we disable each restart using + ;; *restart-test-stack* for the duration of the + ;; test call. + (not (memq restart stack)) + (or (not call-test-p) + (let ((*restart-test-stack* (cons restart stack))) + (declare (truly-dynamic-extent *restart-test-stack*)) + (funcall (restart-test-function restart) condition)))) + (funcall function restart)))))) -(defmacro restart-bind (bindings &body forms) +(defun compute-restarts (&optional condition) #!+sb-doc - "Executes forms in a dynamic context where the given restart bindings are - in effect. Users probably want to use RESTART-CASE. When clauses contain - the same restart name, FIND-RESTART will find the first such clause." - `(let ((*restart-clusters* - (cons (list - ,@(mapcar #'(lambda (binding) - (unless (or (car binding) - (member :report-function - binding - :test #'eq)) - (warn "Unnamed restart does not have a ~ - report function: ~S" - binding)) - `(make-restart :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) - ,@forms)) + "Return a list of all the currently active restarts ordered from most recently +established to less recently established. If CONDITION is specified, then only +restarts associated with CONDITION (or with no condition) will be returned." + (collect ((result)) + (map-restarts (lambda (restart) (result restart)) condition) + (result))) + +(defun %find-restart (identifier &optional condition (call-test-p t)) + (flet ((eq-restart-p (restart) + (when (eq identifier restart) + (return-from %find-restart restart))) + (named-restart-p (restart) + (when (eq identifier (restart-name restart)) + (return-from %find-restart restart)))) + ;; TODO Question for reviewer: does the compiler infer this dx + ;; automatically? + (declare (truly-dynamic-extent #'eq-restart-p #'named-restart-p)) + (if (typep identifier 'restart) + ;; TODO Questions for reviewer: + ;; + ;; The code under #+previous-... below breaks the abstraction + ;; introduced by MAP-RESTARTS, but is about twice as + ;; fast as #+equivalent-... . Also, it is a common case due to + ;; + ;; (INVOKE-RESTART RESTART) + ;; -> (FIND-RESTART-OR-CONTROL-ERROR RESTART) + ;; -> (FIND-RESTART RESTART) + ;; + ;; However, both #+previous-... and #+equivalent-... may be + ;; wrong altogether because of + ;; https://bugs.launchpad.net/sbcl/+bug/774410: + ;; The behavior expected in that report can be achieved by the + ;; following line (which is, of course, the slowest of all + ;; possibilities): + (map-restarts #'eq-restart-p condition call-test-p) + + #+equivalent-to-previous-sbcl-behavior--faster-but-see-bug-774410 + (map-restarts #'eq-restart-p nil nil) -(defun find-restart (name &optional condition) + #+previous-behavior--fastest-but-see-bug-774410 + (and (find-if (lambda (cluster) (find identifier cluster)) *restart-clusters*) + identifier) + + (map-restarts #'named-restart-p condition call-test-p)))) + +(defun find-restart (identifier &optional condition) #!+sb-doc - "Return the first restart named NAME. If NAME names a restart, the restart - is returned if it is currently active. If no such restart is found, NIL is - returned. It is an error to supply NIL as a name. If CONDITION is specified - and not NIL, then only restarts associated with that condition (or with no - condition) will be returned." - (find-if #'(lambda (x) - (or (eq x name) - (eq (restart-name x) name))) - (compute-restarts condition))) + "Return the first restart identified by IDENTIFIER. If IDENTIFIER is a symbol, +then the innermost applicable restart with that name is returned. If IDENTIFIER +is a restart, it is returned if it is currently active. Otherwise NIL is +returned. If CONDITION is specified and not NIL, then only restarts associated +with that condition (or with no condition) will be returned." + ;; Calls MAP-RESTARTS such that restart test functions are + ;; respected. + (%find-restart identifier condition)) + +;;; helper for the various functions which are ANSI-spec'ed to do +;;; something with a restart or signal CONTROL-ERROR if there is none +(defun find-restart-or-control-error (identifier &optional condition (call-test-p t)) + (or (%find-restart identifier condition call-test-p) + (error 'simple-control-error + :format-control "No restart ~S is active~@[ for ~S~]." + :format-arguments (list identifier condition)))) (defun invoke-restart (restart &rest values) #!+sb-doc "Calls the function associated with the given restart, passing any given arguments. If the argument restart is not a restart or a currently active - non-nil restart name, then a control-error is signalled." + non-nil restart name, then a CONTROL-ERROR is signalled." (/show "entering INVOKE-RESTART" restart) - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'simple-control-error - :format-control "Restart ~S is not active." - :format-arguments (list restart))) - (/show (restart-name real-restart)) + ;; The following code calls MAP-RESTARTS (through + ;; FIND-RESTART-OR-CONTROL-ERROR -> %FIND-RESTART) such that restart + ;; test functions are respected when RESTART is a symbol, but not + ;; when RESTART is a RESTART instance. + ;; + ;; Without disabling test functions for the RESTART instance case, + ;; the following problem would arise: + ;; + ;; (restart-case + ;; (handler-bind + ;; ((some-condition (lambda (c) + ;; (invoke-restart (find-restart 'foo c)) ; a) + ;; (invoke-restart 'foo) ; b) + ;; ))) + ;; (signal 'some-condition)) + ;; (foo () + ;; :test (lambda (c) (typep c 'some-condition)))) + ;; + ;; In case a), INVOKE-RESTART receives the RESTART instance, but + ;; cannot supply the condition instance needed by the test. In case + ;; b) INVOKE-RESTART calls FIND-RESTART, but again cannot supply the + ;; condition instance. As a result, the restart would be impossible + ;; the invoke. + (let ((real-restart (find-restart-or-control-error + restart nil (symbolp restart)))) (apply (restart-function real-restart) values))) +(defun interactive-restart-arguments (real-restart) + (let ((interactive-function (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) + '()))) + (defun invoke-restart-interactively (restart) #!+sb-doc "Calls the function associated with the given restart, prompting for any necessary arguments. If the argument restart is not a restart or a - currently active non-nil restart name, then a control-error is signalled." - (/show "entering INVOKE-RESTART-INTERACTIVELY" restart) - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'simple-control-error - :format-control "Restart ~S is not active." - :format-arguments (list restart))) - (/show (restart-name real-restart)) - (/show0 "falling through to APPLY of RESTART-FUNCTION") - (apply (restart-function real-restart) - (let ((interactive-function - (restart-interactive-function real-restart))) - (if interactive-function - (funcall interactive-function) - '()))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) -;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if -;;; appropriate. Gross, but it's what the book seems to say... -(defun munge-restart-case-expression (expression data) - (let ((exp (macroexpand expression))) - (if (consp exp) - (let* ((name (car exp)) - (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) - (if (member name '(signal error cerror warn)) - (once-only ((n-cond `(coerce-to-condition - ,(first args) - (list ,@(rest args)) - ',(case name - (warn 'simple-warning) - (signal 'simple-condition) - (t 'simple-error)) - ',name))) - `(with-condition-restarts - ,n-cond - (list ,@(mapcar (lambda (da) - `(find-restart ',(nth 0 da))) - data)) - ,(if (eq name 'cerror) - `(cerror ,(second expression) ,n-cond) - `(,name ,n-cond)))) - expression)) - expression))) -) ; EVAL-WHEN - -;;; FIXME: I did a fair amount of rearrangement of this code in order to -;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. -(defmacro restart-case (expression &body clauses) - #!+sb-doc - "(RESTART-CASE form - {(case-name arg-list {keyword value}* body)}*) - The form is evaluated in a dynamic context where the clauses have special - meanings as points to which control may be transferred (see INVOKE-RESTART). - When clauses contain the same case-name, FIND-RESTART will find the first - such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or - macroexpands into such) then the signalled condition will be associated with - the new restarts." - (flet ((transform-keywords (&key report interactive test) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (when test - (setq result (list* `#',test - :test-function - result))) - (nreverse result))) - (parse-keyword-pairs (list keys) - (do ((l list (cddr l)) - (k '() (list* (cadr l) (car l) k))) - ((or (null l) (not (member (car l) keys))) - (values (nreverse k) l))))) - (let ((block-tag (gensym)) - (temp-var (gensym)) - (data - (macrolet (;; KLUDGE: This started as an old DEFMACRO - ;; WITH-KEYWORD-PAIRS general utility, which was used - ;; only in this one place in the code. It was translated - ;; literally into this MACROLET in order to avoid some - ;; cross-compilation bootstrap problems. It would almost - ;; certainly be clearer, and it would certainly be more - ;; concise, to do a more idiomatic translation, merging - ;; this with the TRANSFORM-KEYWORDS logic above. - ;; -- WHN 19990925 - (with-keyword-pairs ((names expression) &body forms) - (let ((temp (member '&rest names))) - (unless (= (length temp) 2) - (error "&REST keyword is ~:[missing~;misplaced~]." - temp)) - (let* ((key-vars (ldiff names temp)) - (keywords (mapcar #'keywordicate key-vars)) - (key-var (gensym)) - (rest-var (cadr temp))) - `(multiple-value-bind (,key-var ,rest-var) - (parse-keyword-pairs ,expression ',keywords) - (let ,(mapcar (lambda (var keyword) - `(,var (getf ,key-var - ,keyword))) - key-vars keywords) - ,@forms)))))) - (mapcar (lambda (clause) - (with-keyword-pairs ((report interactive test - &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive - :test test) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses)))) - `(block ,block-tag - (let ((,temp-var nil)) - (tagbody - (restart-bind - ,(mapcar #'(lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) - data) - (return-from ,block-tag - ,(munge-restart-case-expression expression data))) - ,@(mapcan #'(lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply #'(lambda ,bvl ,@body) - ,temp-var))))) - data))))))) - -(defmacro with-simple-restart ((restart-name format-string - &rest format-arguments) - &body forms) - #!+sb-doc - "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) - body) - If restart-name is not invoked, then all values returned by forms are - returned. If control is transferred to this restart, it immediately - returns the values nil and t." - `(restart-case - ;; If there's just one body form, then don't use PROGN. This allows - ;; RESTART-CASE to "see" calls to ERROR, etc. - ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) - (,restart-name () - :report (lambda (stream) - (format stream ,format-string ,@format-arguments)) - (values nil t)))) + currently active non-NIL restart name, then a CONTROL-ERROR is signalled." + (let* ((real-restart (find-restart-or-control-error restart)) + (args (interactive-restart-arguments real-restart))) + (apply (restart-function real-restart) args))) -;;;; HANDLER-BIND - -(defvar *handler-clusters* nil) - -(defmacro handler-bind (bindings &body forms) - #!+sb-doc - "(HANDLER-BIND ( {(type handler)}* ) body) - Executes body in a dynamic context where the given handler bindings are - in effect. Each handler must take the condition being signalled as an - argument. The bindings are searched first to last in the event of a - signalled condition." - (let ((member-if (member-if (lambda (x) - (not (proper-list-of-length-p x 2))) - bindings))) - (when member-if - (error "ill-formed handler binding: ~S" (first member-if)))) - `(let ((*handler-clusters* - (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - (multiple-value-prog1 - (progn - ,@forms) - ;; Wait for any float exceptions. - #!+x86 (float-wait)))) - -;;;; HANDLER-CASE - -(defmacro handler-case (form &rest clauses) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :no-error. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one - var specification." - - ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH - ;; operations, which seems like an ugly way to handle lexical - ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch - ;; (included below this form, but #+NIL'ed out) to switch over to - ;; RETURN-FROM, which seems like basically a better idea. - ;; Unfortunately when using his patch, this reasonable code - ;; (DEFUN FOO1I () - ;; (IF (NOT (IGNORE-ERRORS - ;; (MAKE-PATHNAME :HOST "FOO" - ;; :DIRECTORY "!BLA" - ;; :NAME "BAR"))) - ;; (PRINT "OK") - ;; (ERROR "NOTUNLESSNOT"))) - ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK" - ;; instead). I think this may not be a bug in MNA's patch, but - ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM) - ;; but whatever the reason. (I noticed this problem in - ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point. - ;; The problem also occurs at least in sbcl-0.6.12.59 and - ;; sbcl-0.6.13.) -- WHN - ;; - ;; Note also: I think the old nested THROW/CATCH version became - ;; easier to read once I converted it to use DESTRUCTURING-BIND and - ;; mnemonic names, and it would probably be a useful to do that to - ;; the RETURN-FROM version when/if it's adopted. - (let ((no-error-clause (assoc ':no-error clauses))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ;; FIXME: What if there's more than one :NO-ERROR - ;; clause? The code here and above doesn't seem - ;; either to remove both of them or to signal - ;; a good error, so it's probably wrong. - ,@(remove no-error-clause clauses))))))) - (let ((var (gensym "HC-VAR-")) - (outer-tag (gensym "OUTER-HC-TAG-")) - (inner-tag (gensym "INNER-HC-TAG-")) - (tag-var (gensym "HC-TAG-VAR-")) - (tagged-clauses (mapcar (lambda (clause) - (cons (gensym "HC-TAG-") clause)) - clauses))) - `(let ((,outer-tag (cons nil nil)) - (,inner-tag (cons nil nil)) - ,var ,tag-var) - ;; FIXME: should be (DECLARE (IGNORABLE ,VAR)) - ,var ;ignoreable - (catch ,outer-tag - (catch ,inner-tag - (throw ,outer-tag - (handler-bind - ,(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore body)) - `(,typespec - (lambda (temp) - ,(if args - `(setq ,var temp) - '(declare (ignore temp))) - (setf ,tag-var ',tag) - (/show "THROWing INNER-TAG from HANDLER-BIND closure for" ',typespec) - (throw ,inner-tag nil))))) - tagged-clauses) - ,form))) - (case ,tag-var - ,@(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore typespec)) - `(,tag - ,@(if args - (destructuring-bind (arg) args - `((let ((,arg ,var)) - ,@body))) - body)))) - tagged-clauses))))))) - #+nil ; MNA's patched version -- see FIXME above - (let ((no-error-clause (assoc ':no-error cases))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call (lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - (declare (ignorable ,var)) - (tagbody - (handler-bind - ,(mapcar (lambda (annotated-case) - (list (cadr annotated-case) - `(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #!-x86 ,form - #!+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (float-wait)))) - ,@(mapcan - (lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - ((not (cdr body)) - (car body)) - (t - `(progn ,@body))))))) - annotated-cases)))))))) - -;;;; helper functions for restartable error handling which couldn't be -;;;; defined 'til now 'cause they use the RESTART-CASE macro - -(defun assert-error (assertion places datum &rest arguments) +(defun assert-error (assertion args-and-values places datum &rest arguments) (let ((cond (if datum - (coerce-to-condition datum - arguments - 'simple-error - 'error) - (make-condition 'simple-error - :format-control "The assertion ~S failed." - :format-arguments (list assertion))))) + (coerce-to-condition + datum arguments 'simple-error 'error) + (make-condition + 'simple-error + :format-control "~@" + :format-arguments (list assertion args-and-values))))) (restart-case - (error cond) + (error cond) (continue () - :report (lambda (stream) - (format stream "Retry assertion") - (if places - (format stream - " with new value~P for ~{~S~^, ~}." - (length places) - places) - (format stream "."))) - nil)))) + :report (lambda (stream) + (format stream "Retry assertion") + (if places + (format stream " with new value~P for ~{~S~^, ~}." + (length places) places) + (format stream "."))) + nil)))) ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros ;;; and by CHECK-TYPE. -(defun read-evaluated-form () - (format *query-io* "~&Type a form to be evaluated:~%") +(defun read-evaluated-form (&optional (prompt-control nil promptp) + &rest prompt-args) + (apply #'format *query-io* + (if promptp prompt-control "~&Type a form to be evaluated: ") + prompt-args) + (finish-output *query-io*) (list (eval (read *query-io*)))) (defun check-type-error (place place-value type type-string) - (let ((cond (if type-string - (make-condition 'simple-type-error - :datum place - :expected-type type - :format-control - "The value of ~S is ~S, which is not ~A." - :format-arguments (list place - place-value - type-string)) - (make-condition 'simple-type-error - :datum place - :expected-type type - :format-control - "The value of ~S is ~S, which is not of type ~S." - :format-arguments (list place - place-value - type))))) - (restart-case (error cond) + (let ((condition + (make-condition + 'simple-type-error + :datum place-value + :expected-type type + :format-control + "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]." + :format-arguments (list place place-value type-string type)))) + (restart-case (error condition) (store-value (value) - :report (lambda (stream) - (format stream "Supply a new value for ~S." place)) - :interactive read-evaluated-form - value)))) + :report (lambda (stream) + (format stream "Supply a new value for ~S." place)) + :interactive read-evaluated-form + value)))) + +(defun case-failure (name value keys) + (error 'case-failure + :name name + :datum value + :expected-type (if (eq name 'ecase) + `(member ,@keys) + `(or ,@keys)) + :possibilities keys)) (defun case-body-error (name keyform keyform-value expected-type keys) (restart-case (error 'case-failure - :name name - :datum keyform-value - :expected-type expected-type - :possibilities keys) + :name name + :datum keyform-value + :expected-type expected-type + :possibilities keys) (store-value (value) :report (lambda (stream) - (format stream "Supply a new value for ~S." keyform)) + (format stream "Supply a new value for ~S." keyform)) :interactive read-evaluated-form value)))