From 6f7128b46e9ca91de777f61e8623bf5d997b2987 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 16 Jun 2004 21:00:23 +0000 Subject: [PATCH] 0.8.11.15: Fix bug 276. Woo yay. Now we can be evil in DEFMETHODs again. ... also log a couple more HaibleMOPBugs --- BUGS | 123 +++++++++++++++++++++++++++++++++++++++++++----- NEWS | 3 ++ src/pcl/boot.lisp | 34 ++++++++----- tests/clos.impure.lisp | 10 ++++ version.lisp-expr | 2 +- 5 files changed, 147 insertions(+), 25 deletions(-) diff --git a/BUGS b/BUGS index 31e0925..0971576 100644 --- a/BUGS +++ b/BUGS @@ -965,14 +965,6 @@ WORKAROUND: (fixed in 0.8.2.51, but a test case would be good) -276: - (defmethod fee ((x fixnum)) - (setq x (/ x 2)) - x) - (fee 1) => type error - - (taken from CLOCC) - 278: a. (defun foo () @@ -1325,13 +1317,13 @@ WORKAROUND: (let ((tsos (make-string-output-stream)) (ssos (make-string-output-stream))) (let ((*print-circle* t) - (*trace-output* tsos) - (*standard-output* ssos)) + (*trace-output* tsos) + (*standard-output* ssos)) (prin1 *tangle* *standard-output*)) (let ((string (get-output-stream-string ssos))) (unless (string= string "(#1=[FOO 4] #S(BAR) #1#)") ;; In sbcl-0.8.10.48 STRING was "(#1=[FOO 4] #2# #1#)".:-( - (error "oops: ~S" string)))) + (error "oops: ~S" string))))) It might be straightforward to fix this by turning the *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* variables into per-stream slots, but (1) it would probably be sort of messy faking @@ -1458,3 +1450,112 @@ WORKAROUND: Fixing this should also fix a subset of #328 -- update the description with a new test-case then. + +337: MAKE-METHOD and user-defined method classes + (reported by Bruno Haible sbcl-devel 2004-06-11) + + In the presence of + +(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 lambdalist (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 (SB-PCL:METHOD-FUNCTION + (FIRST NEXT-METHODS-LIST)) + NEW-ARGUMENTS (REST NEXT-METHODS-LIST))))) + (APPLY #'(LAMBDA ,unspecialized-lambdalist ,@body) ARGUMENTS))))) + ',name))) + + (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))))) + (test-um03 17)) + works, but + + a.(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))) + (test-um10 17)) + fails with a type error, and + + b.(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))) + (test-um12 17)) + fails with NO-APPLICABLE-METHOD. + +338: "MOP specializers as type specifiers" + (reported by Bruno Haible sbcl-devel 2004-06-11) + + ANSI 7.6.2 says: + Because every valid parameter specializer is also a valid type + specifier, the function typep can be used during method selection + to determine whether an argument satisfies a parameter + specializer. + + however, SBCL's EQL specializers are not type specifiers: + (defmethod foo ((x (eql 4.0))) 3.0) + (typep 1 (first (sb-pcl:method-specializers *))) + gives an error. diff --git a/NEWS b/NEWS index f7e4284..ceda5b4 100644 --- a/NEWS +++ b/NEWS @@ -2530,6 +2530,9 @@ changes in sbcl-0.8.12 relative to sbcl-0.8.11: * the compiler no longer emits efficiency notes for (FUNCALL X) when the type of X is uncertain under default optimization settings. + * fixed bug 276: mutating a binding of a specialized parameter to a + method to something that is not TYPEP the specializer is now + possible. * fixed bugs 45d and 118: DOUBLE-FLOAT[-NEGATIVE]-EPSILON now exhibit the required behaviour on the x86 platform. (thanks to Peter van Eynde, Eric Marsden and Bruno Haible) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 40c13b4..e3d3488 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -502,7 +502,6 @@ bootstrapping. (declare (ignore env)) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) - (declare (ignore parameters)) (multiple-value-bind (real-body declarations documentation) (parse-body body) (values `(lambda ,unspecialized-lambda-list @@ -670,8 +669,9 @@ bootstrapping. ;; it can avoid run-time type dispatch overhead, ;; which can be a huge win for Python.) ;; - ;; FIXME: Perhaps these belong in - ;; ADD-METHOD-DECLARATIONS instead of here? + ;; KLUDGE: when I tried moving these to + ;; ADD-METHOD-DECLARATIONS, things broke. No idea + ;; why. -- CSR, 2004-06-16 ,@(mapcar #'parameter-specializer-declaration-in-defmethod parameters specializers))) @@ -717,7 +717,8 @@ bootstrapping. ((eq p '&aux) (return nil)))))) (multiple-value-bind - (walked-lambda call-next-method-p closurep next-method-p-p) + (walked-lambda call-next-method-p closurep + next-method-p-p setq-p) (walk-method-lambda method-lambda required-parameters env @@ -758,6 +759,7 @@ bootstrapping. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p + :setq-p ,setq-p ;; we need to pass this along ;; so that NO-NEXT-METHOD can ;; be given a suitable METHOD @@ -820,8 +822,9 @@ bootstrapping. (or ,cnm-args ,',method-args)))) (next-method-p-body () `(not (null .next-method.))) - (with-rebound-original-args ((call-next-method-p) &body body) - (declare (ignore call-next-method-p)) + (with-rebound-original-args ((call-next-method-p setq-p) + &body body) + (declare (ignore call-next-method-p setq-p)) `(let () ,@body))) ,@body)) @@ -1114,8 +1117,8 @@ bootstrapping. `(,rest-arg))))))) (next-method-p-body () `(not (null ,',next-method-call))) - (with-rebound-original-args ((cnm-p) &body body) - (if cnm-p + (with-rebound-original-args ((cnm-p setq-p) &body body) + (if (or cnm-p setq-p) `(let ,',rebindings (declare (ignorable ,@',all-params)) ,@body) @@ -1123,11 +1126,11 @@ bootstrapping. ,@body))) (defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p + ((&key call-next-method-p next-method-p-p setq-p closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) (null applyp)) + (null closurep) (null applyp) (null setq-p)) `(let () ,@body)) (t `(call-next-method-bind @@ -1139,7 +1142,7 @@ bootstrapping. ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) - (with-rebound-original-args (,call-next-method-p) + (with-rebound-original-args (,call-next-method-p ,setq-p) ,@body)))))) (defmacro bind-args ((lambda-list args) &body body) @@ -1231,8 +1234,9 @@ bootstrapping. ; should be in the method definition (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD ; was seen in the body of a method - (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P + (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P ; should be in the method definition + (setq-p nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used @@ -1247,6 +1251,9 @@ bootstrapping. ((eq (car form) 'next-method-p) (setq next-method-p-p t) form) + ((eq (car form) 'setq) + (setq setq-p t) + form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p t) @@ -1283,7 +1290,8 @@ bootstrapping. (values walked-lambda call-next-method-p closurep - next-method-p-p))))) + next-method-p-p + setq-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 9c179fc..28ab7ae 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -811,5 +811,15 @@ (assert (equal (aref v 0) '(number 1 2))) (assert (equal (aref v 1) '(t 1 2)))) +;;; BUG 276: declarations and mutation. +(defmethod fee ((x fixnum)) + (setq x (/ x 2)) + x) +(assert (= (fee 1) 1/2)) +(defmethod fum ((x fixnum)) + (setf x (/ x 2)) + x) +(assert (= (fum 3) 3/2)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index a1c66db..f2d33a9 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.8.11.14" +"0.8.11.15" -- 1.7.10.4