0.7.9.10:

	Implement NO-NEXT-METHOD (following Gerd Moellmann on cmucl-imp
		in message 86vg5rryqn.fsf@gerd.free-bsd.org
		entomotomy reference: no-next-method-unimplemented)
	... add a comment in boot.lisp describing coupling of %METHOD-NAME
		declaration to NO-NEXT-METHOD implementation

diff --git a/NEWS b/NEWS
index 3958d23..7076991 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1349,6 +1349,9 @@ changes in sbcl-0.7.9 relative to sbcl-0.7.8:
   * minor incompatible change: PCL now records the pathname of a file
     in which methods and the like are defined, rather than its
     truename.
+  * more systematization and improvement of CLOS and MOP conformance
+    in PCL (thanks to Gerd Moellman and Pierre Mai):
+    ** NO-NEXT-METHOD is now implemented;
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index b1a6537..559b3ea 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -515,6 +515,13 @@ bootstrapping.
                 ;; another declaration (e.g. %BLOCK-NAME), so that
                 ;; our method debug names are free to have any format,
                 ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
+                ;;
+                ;; Further, as of sbcl-0.7.9.10, the code to
+                ;; implement NO-NEXT-METHOD is coupled to the form of
+                ;; this declaration; see the definition of
+                ;; CALL-NO-NEXT-METHOD (and the passing of
+                ;; METHOD-NAME-DECLARATION arguments around the
+                ;; various CALL-NEXT-METHOD logic).
                 (declare (%method-name (,name
                                         ,@qualifiers
                                         ,specializers)))
@@ -726,6 +733,14 @@ bootstrapping.
                                        :call-next-method-p
                                        ,call-next-method-p
                                        :next-method-p-p ,next-method-p-p
+                                       ;; we need to pass this along
+                                       ;; so that NO-NEXT-METHOD can
+                                       ;; be given a suitable METHOD
+                                       ;; argument; we need the
+                                       ;; QUALIFIERS and SPECIALIZERS
+                                       ;; inside the declaration to
+                                       ;; give to FIND-METHOD.
+                                       :method-name-declaration ,name-decl
                                        :closurep ,closurep
                                        :applyp ,applyp)
                          ,@walked-declarations
@@ -769,18 +784,32 @@ bootstrapping.
                       (,',next-methods (cdr ,',next-methods)))
                   .next-method. ,',next-methods
                   ,@body))
-             (call-next-method-body (cnm-args)
+             (call-next-method-body (method-name-declaration cnm-args)
                `(if .next-method.
                     (funcall (if (std-instance-p .next-method.)
                                  (method-function .next-method.)
                                  .next-method.) ; for early methods
                              (or ,cnm-args ,',method-args)
                              ,',next-methods)
-                    (error "no next method")))
+                    (apply #'call-no-next-method ',method-name-declaration
+                           (or ,cnm-args ,',method-args))))
              (next-method-p-body ()
                `(not (null .next-method.))))
      ,@body))
 
+(defun call-no-next-method (method-name-declaration &rest args)
+  (destructuring-bind (name) method-name-declaration
+    (destructuring-bind (name &rest qualifiers-and-specializers) name
+      ;; KLUDGE: inefficient traversal, but hey.  This should only
+      ;; happen on the slow error path anyway.
+      (let* ((qualifiers (butlast qualifiers-and-specializers))
+            (specializers (car (last qualifiers-and-specializers)))
+            (method (find-method (gdefinition name) qualifiers specializers)))
+       (apply #'no-next-method
+              (method-generic-function method)
+              method
+              args)))))
+
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
@@ -1011,7 +1040,7 @@ bootstrapping.
                   ,emf))
              (call-next-method-bind (&body body)
                `(let () ,@body))
-             (call-next-method-body (cnm-args)
+             (call-next-method-body (method-name-declaration cnm-args)
                `(if ,',next-method-call
                  ,(locally
                    ;; This declaration suppresses a "deleting
@@ -1039,13 +1068,22 @@ bootstrapping.
                                        ,cnm-args)
                             ,call)
                            ,call))))
-                 (error "no next method")))
+                ,(if (and (null ',rest-arg)
+                          (consp cnm-args)
+                          (eq (car cnm-args) 'list))
+                     `(call-no-next-method ',method-name-declaration
+                                           ,@(cdr cnm-args))
+                     `(call-no-next-method ',method-name-declaration
+                                           ,@',args
+                                           ,@',(when rest-arg
+                                                     `(,rest-arg))))))
              (next-method-p-body ()
                `(not (null ,',next-method-call))))
     ,@body))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p closurep applyp)
+    ((&key call-next-method-p next-method-p-p
+          closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
              (null closurep)
@@ -1057,7 +1095,8 @@ bootstrapping.
         ;; (else APPLYP would be true).
         `(call-next-method-bind
            (macrolet ((call-next-method (&rest cnm-args)
-                        `(call-next-method-body ,(when cnm-args
+                        `(call-next-method-body ,',method-name-declaration
+                                                ,(when cnm-args
                                                    `(list ,@cnm-args))))
                       (next-method-p ()
                         `(next-method-p-body)))
@@ -1065,8 +1104,10 @@ bootstrapping.
        (t
         `(call-next-method-bind
            (flet (,@(and call-next-method-p
-                         '((call-next-method (&rest cnm-args)
-                             (call-next-method-body cnm-args))))
+                         `((call-next-method (&rest cnm-args)
+                            (call-next-method-body
+                             ,method-name-declaration
+                             cnm-args))))
                   ,@(and next-method-p-p
                          '((next-method-p ()
                              (next-method-p-body)))))

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index ec2a19a..c1d9651 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -626,3 +626,11 @@
          ~I~_when called with arguments ~2I~_~S.~:>"
         generic-function
         args))
+
+(defmethod no-next-method ((generic-function standard-generic-function)
+                          (method standard-method) &rest args)
+  (error "~@<There is no next method for the generic function ~2I~_~S~
+         ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
+        generic-function
+        method
+        args))

diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp
index e58c9d5..7dac4bc 100644 (file)
--- a/src/pcl/generic-functions.lisp
+++ b/src/pcl/generic-functions.lisp
@@ -488,6 +488,8 @@
 
 (defgeneric no-applicable-method (generic-function &rest args))
 
+(defgeneric no-next-method (generic-function method &rest args))
+
 (defgeneric reader-method-class (class direct-slot &rest initargs))
 
 (defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index ef478bf..ffdbd3b 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -318,6 +318,14 @@
                          (declare (special y))))
   (assert-program-error (defgeneric bogus-declaration2 (x)
                          (declare (notinline concatenate)))))
+;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next
+;;; method.
+(defmethod no-next-method-test ((x integer)) (call-next-method))
+(assert (null (ignore-errors (no-next-method-test 1))))
+(defmethod no-next-method ((g (eql #'no-next-method-test)) m &rest args)
+  'success)
+(assert (eq (no-next-method-test 1) 'success))
+(assert (null (ignore-errors (no-next-method-test 'foo))))
 \f
 ;;;; success
 

diff --git a/version.lisp-expr b/version.lisp-expr
index c420583..28728ea 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.9"
+"0.7.9.10"