[Sbcl-commits] CVS: sbcl BUGS,1.402,1.403 NEWS,1.568,1.569 version.lisp-expr,1.1666,1.1667

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8895

Modified Files:
	BUGS NEWS version.lisp-expr 
Log Message:
0.8.11.15:
	Fix bug 276.  Woo yay.  Now we can be evil in DEFMETHODs again.
	... also log a couple more HaibleMOPBugs


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.402
retrieving revision 1.403
diff -u -d -r1.402 -r1.403
--- BUGS	10 Jun 2004 15:47:53 -0000	1.402
+++ BUGS	16 Jun 2004 21:00:23 -0000	1.403
@@ -965,14 +965,6 @@
 
   (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 @@
     (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 @@
 
   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.

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.568
retrieving revision 1.569
diff -u -d -r1.568 -r1.569
--- NEWS	16 Jun 2004 13:21:36 -0000	1.568
+++ NEWS	16 Jun 2004 21:00:23 -0000	1.569
@@ -2530,6 +2530,9 @@
   * 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)

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.1666
retrieving revision 1.1667
diff -u -d -r1.1666 -r1.1667
--- version.lisp-expr	16 Jun 2004 20:28:45 -0000	1.1666
+++ version.lisp-expr	16 Jun 2004 21:00:23 -0000	1.1667
@@ -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"