From e3834a3e58f7d2571a4ec2dbe58086a825287819 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 5 Jan 2014 20:41:01 +0000 Subject: [PATCH] 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. --- cons-specializer.lisp | 34 +++++++++++++++++++++++++++++++++- specializable.lisp | 7 ++++--- 2 files changed, 37 insertions(+), 4 deletions(-) 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))) -- 2.30.2