From: Christophe Rhodes Date: Tue, 29 Oct 2002 10:02:28 +0000 (+0000) Subject: 0.7.9.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=920f9a94cc0512d7fbab3f1578e8b71485b18b00;p=sbcl.git 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 --- 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 --- 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 --- 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 "~@" + generic-function + method + args)) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index e58c9d5..7dac4bc 100644 --- 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 --- 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)))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index c420583..28728ea 100644 --- 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"