From 3fdb572dad102d87f196f39a680967874025682e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 16 Jun 2005 09:05:03 +0000 Subject: [PATCH] 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.) --- NEWS | 6 ++- src/pcl/combin.lisp | 4 +- tests/clos.impure.lisp | 106 ++++++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 114 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index b6a6b06..1408337 100644 --- 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 --- 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 --- 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)))) + +;;; 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 --- 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" -- 1.7.10.4