Improve conformance with CLHS 7.6.5

Prompted by a report by Daniel Kochmański: rework the keyword argument
checking in effective methods.  The checking needs to be inserted by
the caller of compute-effective-method; it should be orthogonal to the
effective method computation.  The fact that SBCL elides the checking in
the dispatch function, instead relying on the effective method
function to perform the check, is an implementation detail, and the
presence of the local pseudo-macro in the standard effective method
causes problems to particular custom uses of the MOP, for example the
very simple implementation of COMPUTE-DISCRIMINATING-FUNCTION in the
new test file.

As a (very welcome) side effect, this fixes the fact that we
apparently did not perform keyword applicability checking if there
were applicable auxiliary methods on the generic function.

NEWS

@@ -5,6 +5,12 @@ changes relative to sbcl-2.3.9:
     on all safety levels, not just those which it can prove are of sub-page
     sizes. It can do this because it now inserts code to check for stack
     overflow explicitly on higher safety levels.
+  * bug fix: calls to generic functions now detect erroneous keywords (in the
+    sense of CLHS 7.6.5) passed as arguments even when auxiliary methods are
+    applicable.
+  * bug fix: the standard method on SB-MOP:COMPUTE-EFFECTIVE-METHOD no longer
+    inserts calls to implementation-defined local macros.  (reported by Daniel
+    Kochmański)
 
 changes in sbcl-2.3.9 relative to sbcl-2.3.8:
   * enhancement: stack allocation via DYNAMIC-EXTENT now applies to all values

src/pcl/combin.lisp

@@ -55,7 +55,8 @@
 (defun make-effective-method-function1 (generic-function form
                                         method-alist-p wrappers-p)
   (if (and (listp form)
-           (eq (car form) 'call-method))
+           (eq (car form) 'call-method)
+           (not (gf-requires-emf-keyword-checks generic-function)))
       (make-effective-method-function-simple generic-function form)
       ;; We have some sort of `real' effective method. Go off and get a
       ;; compiled function for it. Most of the real hair here is done by
@@ -342,7 +343,6 @@
             generic-function form method-alist-p wrappers-p)
        (fast-method-call '.fast-call-method-list.)
        (t '.call-method-list.)))
-    (check-applicable-keywords 'check-applicable-keywords)
     (t (default-test-converter form))))
 
 ;;; CMUCL comment (2003-10-15):
@@ -368,12 +368,6 @@
        (values `(dolist (emf ,gensym nil)
                  ,(make-emf-call (length metatypes) applyp 'emf type))
                (list gensym))))
-    (check-applicable-keywords
-     (values `(check-applicable-keywords .keyargs-start.
-                                         .valid-keys.
-                                         .dfun-more-context.
-                                         .dfun-more-count.)
-             '()))
     (t
      (default-code-converter form))))
 
@@ -389,8 +383,6 @@
                            (make-effective-method-function-simple
                             generic-function form))
                          (cdr form)))))
-    (check-applicable-keywords
-     '())
     (t
      (default-constant-converter form))))
 
@@ -481,17 +473,12 @@
            ;; perform this checking in fast-method-functions given
            ;; that they are not solely used for effective method
            ;; functions, but also in combination, when they should not
-           ;; perform argument checks.
+           ;; perform argument checks.  We still return the bare
-           (let ((call-method
+           ;; CALL-METHOD, but the caller is responsible for ensuring
-                  `(call-method ,(first (primary)) ,(rest (primary)))))
+           ;; that keyword applicability is checked if this is a fast
-             (if (gf-requires-emf-keyword-checks generic-function)
+           ;; method function used in an effective method.  (See
-                 (multiple-value-bind (valid-keys keyargs-start)
+           ;; WRAP-WITH-APPLICABLE-KEYWORD-CHECK below).
-                     (compute-applicable-keywords generic-function applicable-methods)
+           `(call-method ,(first (primary)) ,(rest (primary))))
-                   `(let ((.valid-keys. ',valid-keys)
-                          (.keyargs-start. ',keyargs-start))
-                      (check-applicable-keywords)
-                      ,call-method))
-                 call-method)))
           (t
            (let ((main-effective-method
                    (if (or (before) (after))
@@ -636,6 +623,14 @@
                ((eq t valid-keys))
                ((not (memq key valid-keys)) (invalid key))))
            (incf i))))))
+
+(defun wrap-with-applicable-keyword-check (effective valid-keys keyargs-start)
+  (setf effective
+        `(let ((.valid-keys. ',valid-keys)
+               (.keyargs-start. ',keyargs-start))
+           (check-applicable-keywords
+            .keyargs-start. .valid-keys. .dfun-more-context. .dfun-more-count.)
+           ,effective)))
 
 ;;;; the STANDARD method combination type. This is coded by hand
 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping

src/pcl/dfun.lisp

@@ -1680,6 +1680,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     ((eq **boot-state** 'complete)
      (let* ((combin (generic-function-method-combination gf))
             (effective (compute-effective-method gf combin methods)))
+       (when (gf-requires-emf-keyword-checks gf)
+         (multiple-value-bind (valid-keys keyargs-start)
+             (compute-applicable-keywords gf methods)
+           (setf effective (wrap-with-applicable-keyword-check effective valid-keys keyargs-start))))
        (make-effective-method-function1
         gf effective method-alist-p wrappers-p)))
     ((eq (generic-function-name gf) 'make-specializer-form-using-class)

tests/clos.impure.lisp

@@ -1289,8 +1289,55 @@
   (assert-error (eqls1760987 3 :k2 5) program-error)
   (assert-error (eqls1760987 3 :k1 2 :k2 5) program-error)
   (assert-error (eqls1760987 3 :k4 2 :k2 5) program-error)
-  (assert-error (eqls1760987 3 :k1 2 :k3 3 :k2 5) program-error)
+  (assert-error (eqls1760987 3 :k1 2 :k3 3 :k2 5) program-error))
-  )
+
+;;; CLHS 7.6.5 should still hold in the presence of auxiliary methods
+(defgeneric gf-with-keys-to-check (a &key b)
+  (:method ((a integer) &key b) (declare (ignore b)) (1+ a))
+  (:method ((a string) &key b) (list a b))
+  (:method ((a symbol) &key b c) (declare (ignore b)) (list a c))
+  (:method :around ((a integer) &key b) (declare (ignore b)) (1+ (call-next-method))))
+
+(with-test (:name (:check-keyword-args :no-error))
+  (assert (= (gf-with-keys-to-check 1) 3))
+  (assert (= (gf-with-keys-to-check 1 :b 2) 3))
+  (assert (equal (gf-with-keys-to-check "a") '("a" nil)))
+  (assert (equal (gf-with-keys-to-check "a" :b 2) '("a" 2)))
+  (assert (equal (gf-with-keys-to-check 'a) '(a nil)))
+  (assert (equal (gf-with-keys-to-check 'a :b 2) '(a nil)))
+  (assert (equal (gf-with-keys-to-check 'a :c 2) '(a 2)))
+  (assert (equal (gf-with-keys-to-check 'a :b 2 :c 3) '(a 3))))
+
+(with-test (:name (:check-keyword-args :allow-other-keys :no-error))
+  (assert (= (gf-with-keys-to-check 1 :z 3 :allow-other-keys t) 3))
+  (assert (= (gf-with-keys-to-check 1 :b 2 :z 3 :allow-other-keys t) 3))
+  (assert (equal (gf-with-keys-to-check "a" :z 3 :allow-other-keys t) '("a" nil)))
+  (assert (equal (gf-with-keys-to-check "a" :b 2 :z 3 :allow-other-keys t) '("a" 2)))
+  (assert (equal (gf-with-keys-to-check 'a :z 3 :allow-other-keys t) '(a nil)))
+  (assert (equal (gf-with-keys-to-check 'a :b 2 :z 3 :allow-other-keys t) '(a nil)))
+  (assert (equal (gf-with-keys-to-check 'a :c 2 :z 3 :allow-other-keys t) '(a 2)))
+  (assert (equal (gf-with-keys-to-check 'a :b 2 :c 3 :allow-other-keys t) '(a 3))))
+
+(with-test (:name (:check-keyword-args :unmatched-keyword :error))
+  (assert-error (gf-with-keys-to-check 1 :z 3) program-error)
+  (assert-error (gf-with-keys-to-check 1 :b 2 :z 3) program-error)
+  (assert-error (gf-with-keys-to-check "a" :z 3) program-error)
+  (assert-error (gf-with-keys-to-check "a" :b 2 :z 3) program-error)
+  (assert-error (gf-with-keys-to-check 'a :z 3) program-error)
+  (assert-error (gf-with-keys-to-check 'a :b 2 :z 3) program-error)
+  (assert-error (gf-with-keys-to-check 'a :c 2 :z 3) program-error)
+  (assert-error (gf-with-keys-to-check 'a :b 2 :c 3 :z 4) program-error))
+
+(with-test (:name (:check-keyword-args :odd-keyword :error))
+  (assert-error (gf-with-keys-to-check 1 :b) program-error)
+  (assert-error (gf-with-keys-to-check 1 :b 2 :b) program-error)
+  (assert-error (gf-with-keys-to-check "a" :b) program-error)
+  (assert-error (gf-with-keys-to-check "a" :b 2 :b) program-error)
+  (assert-error (gf-with-keys-to-check 'a :b) program-error)
+  (assert-error (gf-with-keys-to-check 'a :b 2 :b) program-error)
+  (assert-error (gf-with-keys-to-check 'a :c 2 :b) program-error)
+  (assert-error (gf-with-keys-to-check 'a :b 2 :c 3 :b) program-error))
+
 ;;; class redefinition shouldn't give any warnings, in the usual case
 (defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
 (handler-bind ((warning #'error))

tests/mop-34.impure.lisp

@@ -0,0 +1,77 @@
+;;;; Ensuring that COMPUTE-EFFECTIVE-METHOD is usable
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defclass foo-generic-function (standard-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(defclass made-method (method)
+  ((function :initarg :function :reader sb-mop:method-function)))
+
+(defun make-made-method (form)
+  (let ((fun `(lambda (args next-methods)
+                (declare (sb-ext:disable-package-locks call-method))
+                (macrolet ((call-method (m nexts)
+                             (flet ((make-next (next)
+                                      (etypecase next
+                                        (method next)
+                                        ((cons (eql make-method)) (make-made-method (cadr next))))))
+                               `(funcall (sb-mop:method-function ,m) args ',(mapcar #'make-next nexts)))))
+                  (declare (sb-ext:enable-package-locks call-method))
+                  (declare (sb-ext:disable-package-locks call-next-method next-method-p))
+                  (flet ((next-method-p () (not (null next-methods)))
+                         (call-next-method (&rest args)
+                           (let ((next (car next-methods)))
+                             (if next
+                                 (funcall next args (cdr next-methods))
+                                 (error "no next method")))))
+                    (declare (ignorable #'next-method-p #'call-next-method))
+                    (declare (sb-ext:enable-package-locks call-next-method next-method-p))
+                    ,form)))))
+    (make-instance 'made-method :function (compile nil fun))))
+
+(defmethod sb-mop:compute-discriminating-function ((gf foo-generic-function))
+  (let* ((apo (sb-mop:generic-function-argument-precedence-order gf))
+         (nreq (length apo))
+         (combin (sb-mop:generic-function-method-combination gf)))
+    (lambda (&rest args)
+      (let* ((methods (sb-mop:compute-applicable-methods gf (subseq args 0 nreq)))
+             (effective-method (sb-mop:compute-effective-method gf combin methods)))
+        (let ((fun (compile nil `(lambda (args)
+                                   (declare (sb-ext:disable-package-locks call-method))
+                                   (macrolet ((call-method (m nexts)
+                                                (flet ((make-next (next)
+                                                         (etypecase next
+                                                           (method next)
+                                                           ((cons (eql make-method)) (make-made-method (cadr next))))))
+                                                  `(funcall (sb-mop:method-function ,m) args ',(mapcar #'make-next nexts)))))
+                                     (declare (sb-ext:enable-package-locks call-method))
+                                     ,effective-method)))))
+          (funcall fun args))))))
+
+(defgeneric foo (a &key b)
+  (:method ((a integer) &key b) (declare (ignore b)) (1+ a))
+  (:method ((a string) &key b) (list a b))
+  (:method ((a symbol) &key b c) (declare (ignore b)) (list a c))
+  (:method :around ((a integer) &key b) (declare (ignore b)) (1+ (call-next-method)))
+  (:generic-function-class foo-generic-function))
+
+(with-test (:name (:mop-34 sb-mop:compute-effective-method :interpretable))
+  (assert (= (foo 1) 3))
+  (assert (= (foo 1 :b 2) 3))
+  (assert (equal (foo "a") '("a" nil)))
+  (assert (equal (foo "a" :b 2) '("a" 2)))
+  (assert (equal (foo 'a) '(a nil)))
+  (assert (equal (foo 'a :b 2) '(a nil)))
+  (assert (equal (foo 'a :c 2) '(a 2)))
+  (assert (equal (foo 'a :b 2 :c 3) '(a 3))))