From 90c4b36715e7173e12fe4af1079a347b2e6fd14b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 28 Mar 2010 13:44:46 +0000 Subject: [PATCH] 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. --- NEWS | 3 +++ src/pcl/boot.lisp | 16 ++++++++++++++++ src/pcl/combin.lisp | 2 +- src/pcl/dfun.lisp | 4 ++-- src/pcl/methods.lisp | 2 +- tests/clos.impure.lisp | 29 +++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 53 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 521281b..5ce534b 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4