From: Christophe Rhodes Date: Sat, 5 Aug 2006 12:32:34 +0000 (+0000) Subject: 0.9.15.12: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=500fae719e1d6e138aff44a711941baab63bd405;p=sbcl.git 0.9.15.12: Fix longstanding Haiblebug "method combination types that make use of MAKE-METHOD don't work with user-defined method classes" (sbcl-devel 2004-06-11) ... in a cheating way; special-case the second argument to call-method, which probably isn't completely MOP-friendly but does seem to play nice with the test cases I can construct that don't change the semantics of call-method. ... test cases from Pascal Costanza and Bruno Haible --- diff --git a/NEWS b/NEWS index ddbcf78..1478cfb 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,9 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: * bug fix: improved the handling of type declarations and the detection of violations for keyword arguments with non-constant defaults. + * bug fix: use of MAKE-METHOD in method combination now works even + in the presence of user-defined method classes. (reported by + Bruno Haible and Pascal Costanza) changes in sbcl-0.9.15 relative to sbcl-0.9.14: * added support for the ucs-2 external format. (contributed by Ivan diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 759e710..cfce81d 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -135,8 +135,39 @@ :next-method-call next :arg-info arg-info)) (if real-mf-p - (make-method-call :function mf - :call-method-args cm-args) + (flet ((frob-cm-arg (arg) + (if (if (listp arg) + (eq (car arg) :early-method) + (method-p arg)) + arg + (if (and (consp arg) (eq (car arg) 'make-method)) + (make-instance 'standard-method + :specializers nil ; XXX + :qualifiers nil + :fast-function (fast-method-call-function + (make-effective-method-function + gf (cadr arg) method-alist wrappers))) + arg)))) + (make-method-call :function mf + ;; FIXME: this is wrong. Very wrong. + ;; It assumes that the only place that + ;; can have make-method calls is in + ;; the list structure of the second + ;; argument to CALL-METHOD, but AMOP + ;; says that CALL-METHOD can be more + ;; complicated if + ;; COMPUTE-EFFECTIVE-METHOD (and + ;; presumably MAKE-METHOD-LAMBDA) is + ;; adjusted to match. + ;; + ;; On the other hand, it's a start, + ;; because without this calls to + ;; MAKE-METHOD in method combination + ;; where one of the methods is of a + ;; user-defined class don't work at + ;; all. -- CSR, 2006-08-05 + :call-method-args (cons (mapcar #'frob-cm-arg (car cm-args)) + (cdr cm-args)))) mf)))) (defun make-effective-method-function-simple1 diff --git a/tests/mop-20.impure-cload.lisp b/tests/mop-20.impure-cload.lisp new file mode 100644 index 0000000..8f1a6af --- /dev/null +++ b/tests/mop-20.impure-cload.lisp @@ -0,0 +1,149 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; this file tests that user-defined methods can be used in +;;; combination (ahem) with hairy bits of method-combination. + +(defpackage "MOP-20" + (:use "CL" "SB-MOP")) + +(in-package "MOP-20") + +;;; Simple test case from Pascal Costanza +(defgeneric test (arg) + (:method (arg) (format t "~D" arg) arg)) + +(defun define-around-test () + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + #'test (class-prototype (generic-function-method-class #'test)) + '(lambda (arg) (call-next-method)) ()) + (let ((method (apply #'make-instance + (generic-function-method-class #'test) + :qualifiers '(:around) + :lambda-list '(arg) + :specializers (list (find-class 't)) + :function (compile nil method-lambda) + method-args))) + (add-method #'test method)))) + +(defun run-test () + (define-around-test) + (test 42)) + +(assert (string= (with-output-to-string (*standard-output*) + (assert (= (run-test) 42))) + "42")) + +;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel +;;; 2004-06-11). First the setup. +(defclass user-method (standard-method) (myslot)) + +(defmacro def-user-method (name &rest rest) + (let* ((lambdalist-position (position-if #'listp rest)) + (qualifiers (subseq rest 0 lambdalist-position)) + (lambdalist (elt rest lambdalist-position)) + (body (subseq rest (+ lambdalist-position 1))) + (required-part + (subseq lambdalist 0 + (or (position-if #'(lambda (x) + (member x lambda-list-keywords)) + lambdalist) + (length lambdalist)))) + (specializers + (mapcar #'find-class + (mapcar #'(lambda (x) (if (consp x) (second x) 't)) + required-part))) + (unspecialized-required-part + (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part)) + (unspecialized-lambdalist + (append unspecialized-required-part + (subseq required-part (length required-part))))) + `(progn + (add-method #',name + (make-instance 'user-method + :qualifiers ',qualifiers + :lambda-list ',unspecialized-lambdalist + :specializers ',specializers + :function + + #'(lambda (arguments next-methods-list) + (flet ((next-method-p () next-methods-list) + (call-next-method (&rest new-arguments) + (unless new-arguments (setq new-arguments arguments)) + (if (null next-methods-list) + (error "no next method for arguments ~:s" arguments) + (funcall (method-function (first next-methods-list)) + new-arguments (rest next-methods-list))))) + (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments))))) + ',name))) + +;;; this one has always worked, as it does not involve MAKE-METHOD in +;;; its effective method. +(progn + (defgeneric test-um03 (x)) + (defmethod test-um03 ((x integer)) + (list* 'integer x (not (null (next-method-p))) (call-next-method))) + (def-user-method test-um03 ((x rational)) + (list* 'rational x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um03 ((x real)) + (list 'real x (not (null (next-method-p))))) + (assert (equal (test-um03 17) '(integer 17 t rational 17 t real 17 nil)))) + +;;; these two used to fail in slightly different ways +(progn + (defgeneric test-um10 (x)) + (defmethod test-um10 ((x integer)) + (list* 'integer x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um10 ((x rational)) + (list* 'rational x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um10 ((x real)) + (list 'real x (not (null (next-method-p))))) + (defmethod test-um10 :after ((x real))) + (def-user-method test-um10 :around ((x integer)) + (list* 'around-integer x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um10 :around ((x rational)) + (list* 'around-rational x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um10 :around ((x real)) + (list* 'around-real x (not (null (next-method-p))) (call-next-method))) + (assert (equal (test-um10 17) + '(around-integer 17 t + around-rational 17 t + around-real 17 t + integer 17 t + rational 17 t + real 17 nil)))) + +(progn + (defgeneric test-um12 (x)) + (defmethod test-um12 ((x integer)) + (list* 'integer x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um12 ((x rational)) + (list* 'rational x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um12 ((x real)) + (list 'real x (not (null (next-method-p))))) + (defmethod test-um12 :after ((x real))) + (defmethod test-um12 :around ((x integer)) + (list* 'around-integer x (not (null (next-method-p))) (call-next-method))) + (defmethod test-um12 :around ((x rational)) + (list* 'around-rational x (not (null (next-method-p))) (call-next-method))) + (def-user-method test-um12 :around ((x real)) + (list* 'around-real x (not (null (next-method-p))) (call-next-method))) + (assert (equal (test-um12 17) + '(around-integer 17 t + around-rational 17 t + around-real 17 t + integer 17 t + rational 17 t + real 17 nil)))) diff --git a/version.lisp-expr b/version.lisp-expr index cacd653..b004c9f 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.15.11" +"0.9.15.12"