X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=f7d43cb555831ef19ac63080ceb5318d7d47fa6b;hb=b44ca02cb963446ef23fec989786462ce88bca84;hp=fc611083ae92f9546cd45583057592ca5582e283;hpb=5579e97941f14d5f13a7090054a2a4f419e04252;p=sbcl.git diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index fc61108..f7d43cb 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -30,7 +30,7 @@ (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) @@ -40,20 +40,21 @@ specified, then only restarts associated with CONDITION (or with no condition) will be returned." (let ((associated ()) - (other ())) + (other ())) (dolist (alist *condition-restarts*) (if (eq (car alist) condition) - (setq associated (cdr alist)) - (setq other (append (cdr alist) other)))) + (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)))) + (dolist (restart restart-cluster) + (when (and (or (not condition) + (member restart associated) + (not (member restart other))) + (or (not condition) + (funcall (restart-test-function restart) + condition))) + (res restart)))) (res)))) #!+sb-doc @@ -62,11 +63,11 @@ (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)) + (let ((name (restart-name restart))) + (lambda (stream) + (if name (format stream "~S" name) + (format stream "~S" restart))))) + stream)) (defun find-restart (name &optional condition) #!+sb-doc @@ -82,59 +83,59 @@ (eq (restart-name x) name))) restarts))) -(defun find-restart-or-lose (restart-designator) - (let ((real-restart (find-restart restart-designator))) - (unless real-restart +;;; 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) + (or (find-restart identifier condition) (error 'simple-control-error - :format-control "Restart ~S is not active." - :format-arguments (list restart-designator))) - real-restart)) + :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-or-lose restart))) + (let ((real-restart (find-restart-or-control-error 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) - '()))) + (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." - (let* ((real-restart (find-restart-or-lose restart)) - (args (interactive-restart-arguments real-restart))) + 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))) (defun assert-error (assertion 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 "The assertion ~S failed." + :format-arguments (list assertion))))) (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 @@ -144,39 +145,30 @@ (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-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)))