From: Christophe Rhodes <csr21@cantab.net>
Date: Sun, 5 Jan 2014 20:41:01 +0000 (+0000)
Subject: deal with keyword argument checking
X-Git-Tag: els2014-submission~16
X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=e3834a3e58f7d2571a4ec2dbe58086a825287819;p=specializable.git

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 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))))
diff --git a/specializable.lisp b/specializable.lisp
index b74d73f..5a0c096 100644
--- 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)))