1.0.37.7: RETRY restart for NO-APPLICABLE-METHOD and NO-PRIMARY-METHOD

 Wrap calling the NO-FOO gf in a CALL-NO-FOO function which provides
 the restart.

 Can't do the same easily for NO-NEXT-METHOD, as return-value from
 CALL-NEXT-METHOD would get messed up.

diff --git a/NEWS b/NEWS
index 521281b..5ce534b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@ changes relative to sbcl-1.0.36:
     SB-THREAD:WAIT-ON-SEMAPHORE.
   * enhancement: *STANDARD-OUTPUT*, *STANDARD-INPUT*, and *ERROR-OUTPUT* are
     now bivalent.
+  * enhancement: errors from NO-APPLICABLE-METHOD and
+    NO-PRIMARY-METHOD now have a RETRY restart available to retry the
+    generic function call.
   * bug fix: correct restart text for the continuable error in MAKE-PACKAGE.
   * bug fix: a rare case of startup-time page table corruption.
 

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7022936..b102a87 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1001,9 +1001,25 @@ bootstrapping.
 (defun call-no-next-method (method-cell &rest args)
   (let ((method (car method-cell)))
     (aver method)
+    ;; Can't easily provide a RETRY restart here, as the return value here is
+    ;; for the method, not the generic function.
     (apply #'no-next-method (method-generic-function method)
            method args)))
 
+(defun call-no-applicable-method (gf args)
+  (restart-case
+          (apply #'no-applicable-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+
+(defun call-no-primary-method (gf args)
+  (restart-case
+      (apply #'no-primary-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 2f6a222..a60d6cf 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -236,7 +236,7 @@
            (declare (ignore .pv. .next-method-call.))
            (declare (ignorable .args.))
            (flet ((%no-primary-method (gf args)
-                    (apply #'no-primary-method gf args))
+                    (call-no-primary-method gf args))
                   (%invalid-qualifiers (gf combin method)
                     (invalid-qualifiers gf combin method)))
              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 8ec29bc..e90c550 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -904,7 +904,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (cond ((null methods)
            (values
             #'(lambda (&rest args)
-                (apply #'no-applicable-method gf args))
+                (call-no-applicable-method gf args))
             nil
             (no-methods-dfun-info)))
           ((setq type (final-accessor-dfun-type gf))
@@ -1668,7 +1668,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
       (lambda (method-alist wrappers)
         (declare (ignore method-alist wrappers))
         (lambda (&rest args)
-          (apply #'no-applicable-method gf args)))
+          (call-no-applicable-method gf args)))
       (let* ((key (car methods))
              (ht *effective-method-cache*)
              (ht-value (with-locked-hash-table (ht)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 30ceedd..bbbf499 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -783,7 +783,7 @@
           (let ((emf (get-effective-method-function generic-function
                                                     methods)))
             (invoke-emf emf args))
-          (apply #'no-applicable-method generic-function args)))))
+          (call-no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
   (loop (when (atom x) (return (eq x y)))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 6bb7e26..91eab01 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1805,4 +1805,33 @@
   (let ((callees (find-named-callees #'bar-520366)))
     (assert (equal (list #'quux-520366) callees))))
 
+(defgeneric no-applicable-method/retry (x))
+(defmethod no-applicable-method/retry ((x string))
+  "string")
+(with-test (:name :no-applicable-method/retry)
+  (assert (equal "cons"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-applicable-method/retry ((x cons))
+                                                "cons"))
+                                       (invoke-restart r))))))
+                   (no-applicable-method/retry (cons t t))))))
+
+(defgeneric no-primary-method/retry (x))
+(defmethod no-primary-method/retry :before (x) (assert x))
+(with-test (:name :no-primary-method/retry)
+  (assert (equal "ok!"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-primary-method/retry (x)
+                                                "ok!"))
+                                       (invoke-restart r))))))
+                   (no-primary-method/retry (cons t t))))))
+
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 1e96cdc..eb4a606 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.37.6"
+"1.0.37.7"