X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=cons-specializer.lisp;fp=cons-specializer.lisp;h=38be99d129176cf17d711b5507706e23b50aed3e;hp=4540b5f195fbaa41b4d6fb8374739313c638ec20;hb=e3834a3e58f7d2571a4ec2dbe58086a825287819;hpb=3ad29ae97f2b75c730b7df5af55c73e316b17606

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
index 4540b5f..38be99d 100644
--- a/cons-specializer.lisp
+++ b/cons-specializer.lisp
@@ -16,9 +16,9 @@
     ((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))
@@ -96,3 +96,35 @@
    (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))))