From 307d00a6ceb31b461b49c9a8873dcb4bf451fba7 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 13 Dec 2013 00:01:56 +0000 Subject: [PATCH] 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. --- cons-specializer.lisp | 52 ++++++++++++++++++++++++++++++------------- specializable.lisp | 32 ++++++++++---------------- 2 files changed, 48 insertions(+), 36 deletions(-) diff --git a/cons-specializer.lisp b/cons-specializer.lisp index c0ec716..3922a6a 100644 --- 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))) +;;; 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 2c8ebc5..c9f34ad 100644 --- 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)) '>) -- 2.30.2