get the protocol more right

Include some generic function arguments for specialization in protocol
functions involving generalizers.  (Otherwise there are some cases where
it's not possible to define methods not in violation of the rules about
specializers applicable to instances of not-standard classes.)

Adjust the CONS-SPECIALIZER example to suit, and include an extra test
case which shows of method-combination as well as the new ability to
have multiple applicable methods with class specializers.

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
index c0ec716a3d51f8c0aeb82aab703836d3aaeffce9..3922a6abd59c09c4f6daf1321fd3f129bd8a621b 100644 (file)
--- a/cons-specializer.lisp
+++ b/cons-specializer.lisp
@@ -21,40 +21,41 @@
   (typecase arg
     ((cons symbol) (car arg))
     (t (call-next-method))))
-;;; FIXME: it looks like these protocol functions should have the GF
-;;; as an argument, since generalizer-of-using-class does
-(defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
   (if (eql (%car specializer) thing)
       (values t t)
       (values nil t)))
-;;; FIXME: yes, definitely need the gf!
-(defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
-  (specializer-accepts-generalizer-p specializer (find-class 'cons)))
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
+  (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
 
-;;; this one might not need the GF
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
   (and (consp obj)
        (eql (car obj) (%car specializer))))
-;;; but this one does: it doesn't look like it here, but at issue is
-;;; who is responsible for the SPECIALIZER< method for two distinct
-;;; user-defined specializers.  Also consider a symbol generalizer
-;;; being used to compare two class specializers.
-(defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
+
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
   (declare (ignore generalizer))
   (if (eql (%car s1) (%car s2))
       '=
       nil))
-(defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
   (declare (ignore generalizer))
   '<)
-(defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
   (declare (ignore generalizer))
   '>)
-(defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
-  (ecase (specializer< s2 s1 generalizer)
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
+  (ecase (specializer< gf s2 s1 generalizer)
     ((<) '>)
     ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
+  (specializer< gf s1 s2 (find-class 'cons)))
 \f
+;;; tests / examples
 (eval
  '(progn
    (defgeneric walk (form)
@@ -74,3 +75,22 @@
    (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
    (assert (equal (walk '(quote bar)) 'bar))
    (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
+
+(eval
+ '(progn
+   (defgeneric multiple-class-specializers (x)
+     (:generic-function-class cons-generic-function)
+     (:method-combination list))
+   (defmethod multiple-class-specializers list ((x t)) 't)
+   (defmethod multiple-class-specializers list ((x cons)) 'cons)
+   (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
+   (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
+   (defmethod multiple-class-specializers list ((x list)) 'list)
+   (defmethod multiple-class-specializers list ((x null)) 'null)
+   (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
+
+   (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
+   (assert (equal (multiple-class-specializers t) '(t)))
+   (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
+   (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
+   (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))

diff --git a/specializable.lisp b/specializable.lisp
index 2c8ebc5864c2b9a4381d1e100405471a1db64bf3..c9f34adbae1669883e6dadd3a0871cbedf8ca916 100644 (file)
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -150,23 +150,16 @@
 (defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
   (class-of object))
 
-(defgeneric specializer-accepts-generalizer-p (specializer generalizer))
-(defmethod specializer-accepts-generalizer-p ((specializer class) (generalizer class))
-  ;; does the specializer's object have the -same- class as the the actual
-  ;; argument?
+(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
+(defmethod specializer-accepts-generalizer-p
+    ((gf specializable-generic-function) (specializer class) (generalizer class))
   (if (subtypep generalizer specializer)
-      ;; definitive: this method matches all instances of this class
       (values t t)
-      ;; definitive: this method doesn't match instances of this class
       (values nil t)))
 (defmethod specializer-accepts-generalizer-p
-    ((specializer sb-mop:eql-specializer) (generalizer class))
-  ;; does the specializer's object have the -same- class as the actual
-  ;; argument?
+    ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
   (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
-      ;; not definitive, since the actual object might differ
       (values t nil)
-      ;; definitely not the same object
       (values nil t)))
 
 (defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
@@ -177,7 +170,7 @@
     (flet ((filter (method)
              (every (lambda (s g)
                       (multiple-value-bind (acceptsp definitivep)
-                          (specializer-accepts-generalizer-p s g)
+                          (specializer-accepts-generalizer-p gf s g)
                         (unless definitivep
                           (setf result-definitive-p nil))
                         acceptsp))
@@ -213,12 +206,10 @@
        (method-more-specific-p gf m1 m2 generalizers)))))
 
 (defun method-more-specific-p (gf method1 method2 generalizers)
-  ;; differs from closette
-  (declare (ignore gf))
   ;; FIXME: argument precedence order
   (block nil
     (mapc #'(lambda (spec1 spec2 generalizer)
-             (ecase (specializer< spec1 spec2 generalizer)
+             (ecase (specializer< gf spec1 spec2 generalizer)
                (< (return t))
                (=)
                ((nil > /=) (return nil))))
@@ -228,8 +219,9 @@
     nil))
 
 ;; new, not in closette
-(defgeneric specializer< (s1 s2 generalizer))
-(defmethod specializer< ((s1 class) (s2 class) (generalizer class))
+(defgeneric specializer< (gf s1 s2 generalizer))
+(defmethod specializer<
+    ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
   (if (eq s1 s2)
       '=
       (let ((cpl (sb-mop:class-precedence-list generalizer)))
@@ -237,14 +229,14 @@
            '<
            nil))))
 (defmethod specializer<
-    ((s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
+    ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
   (declare (ignore generalizer))
   (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
       '=
       nil))
-(defmethod specializer< ((s1 sb-mop:eql-specializer) (s2 class) generalizer)
+(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
   (declare (ignore generalizer))
   '<)
-(defmethod specializer< ((c1 class) (c2 sb-mop:eql-specializer) generalizer)
+(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
   (declare (ignore generalizer))
   '>)