deal with keyword argument checking

it was actually mostly done internally to PCL, in the effective method
computation.  However, for probably tedious historical reasons, the
way that this is actually implemented involves binding a magical
special variable at the point that the effective method form is turned
into code, which we weren't doing.  Now we are.

Include a test case.

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
index 4540b5f195fbaa41b4d6fb8374739313c638ec20..38be99d129176cf17d711b5507706e23b50aed3e 100644 (file)
--- 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))))

diff --git a/specializable.lisp b/specializable.lisp
index b74d73fdd506347aa61dd14de4b71f94ecbfe70e..5a0c09606cef65dce583e9e8052074cd1015584d 100644 (file)
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -122,7 +122,7 @@
 
 ;;; FIXME: in some kind of order, the discriminating function needs to handle:
 ;;; - argument count checking;
-;;; - keyword argument validity;
+;;; - DONE (in effective method) keyword argument validity;
 ;;; - DONE flushing the emf cache on method addition/removal
 ;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
 ;;; - cache thread-safety.
@@ -145,16 +145,17 @@
       (compute-applicable-methods-using-generalizers gf generalizers)
     (if definitivep
        (let* ((emfun
-               (compute-effective-method-function gf applicable-methods))
+                (compute-effective-method-function gf applicable-methods))
                (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
          (setf (gethash keys (emf-table gf)) emfun)
          (sb-pcl::invoke-emf emfun args))
-       (sb-pcl::invoke-emf (compute-effective-method-function
+        (sb-pcl::invoke-emf (compute-effective-method-function
                              gf (sb-mop:compute-applicable-methods gf args))
                             args))))
 
 (defun compute-effective-method-function (gf methods)
   (let* ((mc (sb-mop:generic-function-method-combination gf))
+         (sb-pcl::*applicable-methods* methods)
          (em (sb-mop:compute-effective-method gf mc methods)))
     (sb-pcl::make-effective-method-function gf em)))