simplify parsing a bit

[specializable.git] / cons-specializer.lisp

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
index c0ec716a3d51f8c0aeb82aab703836d3aaeffce9..38be99d129176cf17d711b5507706e23b50aed3e 100644 (file)
--- a/cons-specializer.lisp
+++ b/cons-specializer.lisp
@@ -9,7 +9,6 @@
 
 (define-extended-specializer cons (gf car)
   (make-instance 'cons-specializer :car car))
 
 (define-extended-specializer cons (gf car)
   (make-instance 'cons-specializer :car car))

-

 (defmethod sb-pcl:unparse-specializer-using-class
     ((gf cons-generic-function) (specializer cons-specializer))
   `(cons ,(%car specializer)))
 (defmethod sb-pcl:unparse-specializer-using-class
     ((gf cons-generic-function) (specializer cons-specializer))
   `(cons ,(%car specializer)))


@@ -17,44 +16,48 @@
     ((s1 cons-specializer) (s2 cons-specializer))
   (eql (%car s1) (%car s2)))
 
     ((s1 cons-specializer) (s2 cons-specializer))
   (eql (%car s1) (%car s2)))
 

+;;; FIXME: make a proper generalizer
+(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
+  g)

 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
   (typecase arg
     ((cons symbol) (car arg))
     (t (call-next-method))))
 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
   (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)))
   (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))))
 (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))
   (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))
   '<)
   (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))
   '>)
   (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
 \f

+;;; tests / examples

 (eval
  '(progn
    (defgeneric walk (form)
 (eval
  '(progn
    (defgeneric walk (form)


@@ -74,3 +77,54 @@
    (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))))))
    (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)))))
+
+(eval
+ '(progn
+   (defgeneric keyword-args (x &key key1)
+     (:generic-function-class cons-generic-function))
+   (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
+   (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
+   (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
+              nil)
+   (assert (= (keyword-args 1) 2))
+   (assert (= (keyword-args 1 :key1 t) 2))
+   (assert (= (keyword-args 1 :key2 t) 2))
+   (assert (= (keyword-args 1 :key1 t :key2 t) 2))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
+   (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
+
+   (assert (= (keyword-args 1.0) 3.0))
+   (assert (= (keyword-args 1.0 :key1 t) 3.0))
+   (assert (= (keyword-args 1.0 :key3 t) 3.0))
+   (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
+   (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
+
+   (assert (= (keyword-args 1.0d0) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))