Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv2073/src/pcl
Modified Files:
boot.lisp combin.lisp dfun.lisp methods.lisp
Log Message:
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.
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.158
retrieving revision 1.159
diff -u -d -r1.158 -r1.159
--- boot.lisp 27 Feb 2010 16:22:57 -0000 1.158
+++ boot.lisp 28 Mar 2010 13:44:46 -0000 1.159
@@ -1001,9 +1001,25 @@
(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)
Index: combin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/combin.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- combin.lisp 15 Sep 2009 11:07:39 -0000 1.35
+++ combin.lisp 28 Mar 2010 13:44:46 -0000 1.36
@@ -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))
Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -d -r1.70 -r1.71
--- dfun.lisp 28 Mar 2010 12:16:03 -0000 1.70
+++ dfun.lisp 28 Mar 2010 13:44:46 -0000 1.71
@@ -904,7 +904,7 @@
(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 @@
(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)
Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -d -r1.91 -r1.92
--- methods.lisp 15 Sep 2009 11:07:39 -0000 1.91
+++ methods.lisp 28 Mar 2010 13:44:46 -0000 1.92
@@ -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)))
|