0.9.1.44:

	Fix for CALL-METHOD / RESTART-CASE interaction.
	... patch from Gerd Moellmann cmucl-imp 2005-06-04
	... (Bruno's test case is quite neat.)

diff --git a/NEWS b/NEWS
index b6a6b06..1408337 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,8 +15,10 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1:
   * dynamic space size on PPC has been increased to 768Mb. (thanks to
     Cyrus Harmon)
   * SB-MOP:ENSURE-CLASS-USING-CLASS now accepts a class as the
-    :METACLASS argument in addition to a class name. (reported by
-    Bruno Haible for CMUCL, patch for CMUCL by Gerd Moellman)
+    :METACLASS argument in addition to a class name.  (reported by
+    Bruno Haible for CMUCL, patch for CMUCL by Gerd Moellmann)
+  * RESTART-CASE can now be wrapped around CALL-METHOD forms.
+    (reported by Bruno Haible; patch from Gerd Moellmann)
   * bug fix: sbcl runtime can now be compiled with gcc4 (thanks to 
     Sascha Wilde)
   * bug fix: more cleanups to the floating point exception handling on

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index a4d72a4..28b5618 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -222,7 +222,9 @@
 
 (defmacro call-method (&rest args)
   (declare (ignore args))
-  `(error "~S outside of a effective method form" 'call-method))
+  ;; the PROGN is here to defend against premature macroexpansion by
+  ;; RESTART-CASE.
+  `(progn (error "~S outside of a effective method form" 'call-method)))
 
 (defun make-effective-method-list-fun-type
     (generic-function form method-alist-p wrappers-p)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 05b8f87..dfcb369 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1062,6 +1062,112 @@
   (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol))
     (assert (not val))
     (assert (typep err 'error))))
+\f
+;;; RESTART-CASE and CALL-METHOD
+
+;;; from Bruno Haible
+
+(defun rc-cm/prompt-for-new-values ()
+  (format *debug-io* "~&New values: ")
+  (finish-output *debug-io*)
+  (list (read *debug-io*)))
+
+(defun rc-cm/add-method-restarts (form method)
+  (let ((block (gensym))
+       (tag (gensym)))
+    `(block ,block
+      (tagbody
+        ,tag
+        (return-from ,block
+          (restart-case ,form
+            (method-redo ()
+              :report (lambda (stream)
+                        (format stream "Try calling ~S again." ,method))
+              (go ,tag))
+            (method-return (l)
+              :report (lambda (stream)
+                        (format stream "Specify return values for ~S call."
+                                ,method))
+              :interactive (lambda () (rc-cm/prompt-for-new-values))
+              (return-from ,block (values-list l)))))))))
+
+(defun rc-cm/convert-effective-method (efm)
+  (if (consp efm)
+      (if (eq (car efm) 'call-method)
+         (let ((method-list (third efm)))
+           (if (or (typep (first method-list) 'method) (rest method-list))
+               ;; Reduce the case of multiple methods to a single one.
+               ;; Make the call to the next-method explicit.
+               (rc-cm/convert-effective-method
+                `(call-method ,(second efm)
+                  ((make-method
+                    (call-method ,(first method-list) ,(rest method-list))))))
+               ;; Now the case of at most one method.
+               (if (typep (second efm) 'method)
+                   ;; Wrap the method call in a RESTART-CASE.
+                   (rc-cm/add-method-restarts
+                    (cons (rc-cm/convert-effective-method (car efm))
+                          (rc-cm/convert-effective-method (cdr efm)))
+                    (second efm))
+                   ;; Normal recursive processing.
+                   (cons (rc-cm/convert-effective-method (car efm))
+                         (rc-cm/convert-effective-method (cdr efm))))))
+         (cons (rc-cm/convert-effective-method (car efm))
+               (rc-cm/convert-effective-method (cdr efm))))
+      efm))
+
+(define-method-combination standard-with-restarts ()
+  ((around (:around))
+   (before (:before))
+   (primary () :required t)
+   (after (:after)))
+  (flet ((call-methods-sequentially (methods)
+          (mapcar #'(lambda (method)
+                      `(call-method ,method))
+                  methods)))
+    (let ((form (if (or before after (rest primary))
+                    `(multiple-value-prog1
+                       (progn
+                         ,@(call-methods-sequentially before)
+                         (call-method ,(first primary) ,(rest primary)))
+                     ,@(call-methods-sequentially (reverse after)))
+                    `(call-method ,(first primary)))))
+      (when around
+       (setq form
+             `(call-method ,(first around)
+               (,@(rest around) (make-method ,form)))))
+      (rc-cm/convert-effective-method form))))
+
+(defgeneric rc-cm/testgf16 (x)
+  (:method-combination standard-with-restarts))
+(defclass rc-cm/testclass16a () ())
+(defclass rc-cm/testclass16b (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16c (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16d (rc-cm/testclass16b rc-cm/testclass16c) ())
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16a))
+  (list 'a
+        (not (null (find-restart 'method-redo)))
+        (not (null (find-restart 'method-return)))))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16b))
+  (cons 'b (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16c))
+  (cons 'c (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16d))
+  (cons 'd (call-next-method)))
+(assert (equal (rc-cm/testgf16 (make-instance 'rc-cm/testclass16d))
+              '(d b c a t t)))
+
+;;; test case from Gerd Moellmann
+(define-method-combination r-c/c-m-1 ()
+  ((primary () :required t))
+  `(restart-case (call-method ,(first primary))
+     ()))
+
+(defgeneric r-c/c-m-1-gf ()
+  (:method-combination r-c/c-m-1)
+  (:method () nil))
+
+(assert (null (r-c/c-m-1-gf)))
 
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 7be7e18..80ed899 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".)
-"0.9.1.43"
+"0.9.1.44"