Re: [Sbcl-devel] [Sbcl-commits] master: Improve conformance with CLHS 7.6.5

[Stas Boukarev]

(shared-initialize (make-instance (defclass x () ())) nil :a)

no longer checks for odd &keys.

On Sun, Oct 22, 2023 at 4:50 PM crhodes via Sbcl-commits <sbcl-c...@lists.sourceforge.net> wrote:

The branch "master" has been updated in SBCL:
       via  ba76af0b22aa45508a229d2dfb6a29226f0df022 (commit)
      from  29e21314064cc951ba139c1fcd1c52fee788f9c3 (commit)

- Log -----------------------------------------------------------------
commit ba76af0b22aa45508a229d2dfb6a29226f0df022
Author: Christophe Rhodes <cs...@cantab.net>
Date:   Sun Oct 22 14:30:25 2023 +0100

    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                     |  6 ++++
 src/pcl/combin.lisp      | 37 ++++++++++-------------
 src/pcl/dfun.lisp        |  4 +++
 tests/clos.impure.lisp   | 51 ++++++++++++++++++++++++++++++--
 tests/mop-34.impure.lisp | 77 ++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 152 insertions(+), 23 deletions(-)

diff --git a/NEWS b/NEWS
index 6ac441741..af2fb6eda 100644
--- a/NEWS
+++ b/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
diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 08f1940b8..a8f1adeb8 100644
--- a/src/pcl/combin.lisp
+++ b/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.
-           (let ((call-method
-                  `(call-method ,(first (primary)) ,(rest (primary)))))
-             (if (gf-requires-emf-keyword-checks generic-function)
-                 (multiple-value-bind (valid-keys keyargs-start)
-                     (compute-applicable-keywords generic-function applicable-methods)
-                   `(let ((.valid-keys. ',valid-keys)
-                          (.keyargs-start. ',keyargs-start))
-                      (check-applicable-keywords)
-                      ,call-method))
-                 call-method)))
+           ;; perform argument checks.  We still return the bare
+           ;; CALL-METHOD, but the caller is responsible for ensuring
+           ;; that keyword applicability is checked if this is a fast
+           ;; method function used in an effective method.  (See
+           ;; WRAP-WITH-APPLICABLE-KEYWORD-CHECK below).
+           `(call-method ,(first (primary)) ,(rest (primary))))
           (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
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index b33ac7a8a..2bce1886b 100644
--- a/src/pcl/dfun.lisp
+++ b/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)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index ab4007b91..4e69009bf 100644
--- a/tests/clos.impure.lisp
+++ b/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))
diff --git a/tests/mop-34.impure.lisp b/tests/mop-34.impure.lisp
new file mode 100644
index 000000000..34431c3e2
--- /dev/null
+++ b/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))))

-----------------------------------------------------------------------


hooks/post-receive
--
SBCL

_______________________________________________
Sbcl-commits mailing list
Sbcl-c...@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits

[Christophe Rhodes]

Stas Boukarev <stas...@gmail.com> writes:

> (shared-initialize (make-instance (defclass x () ())) nil :a)
> no longer checks for odd &keys.

Thanks. I've pushed a fix for this, after some time being confused
about the fact that I ran ansi-tests on (what I thought was) my change,
and some more time being confused about all the different places where
things are cached in PCL.

Christophe


_______________________________________________
Sbcl-devel mailing list
Sbcl-...@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel

[Douglas Katzman via Sbcl-devel]

I think this change is responsible for some errors such as below, but I'm not sure how/when/why. I have no self-contained reproducer yet.

; in: LAMBDA (#:G97)

;     (SB-PCL::%NO-PRIMARY-METHOD #:G97 SB-PCL::.ARGS.)

;

; caught WARNING:

;   undefined variable: SB-PCL::.ARGS.

;

; compilation unit finished

;   Undefined variable:

;     SB-PCL::.ARGS.

;   caught 1 WARNING condition

Unhandled UNBOUND-VARIABLE in thread #<SB-THREAD:THREAD tid=1996595 "main thread" RUNNING

                                        {1001110003}>:

  The variable SB-PCL::.ARGS. is unbound.

The code in 'combin' says something about it -

 ;; FIXME: The way that we arrange for .ARGS. to be bound
;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
;; recognizing any form whose operator is %NO-PRIMARY-METHOD
;; as magical, and carefully surrounding it with a
;; LAMBDA form which binds .ARGS.

Maybe the problem is sensitive to *evaluator-mode* now and/or whether sb-fasteval is in use?

[Douglas Katzman via Sbcl-devel]

more info:

Frames 0 and 1 (omitted) in the attached trace are the effect of SB-INT:ENCAPSULATE on NOTE-UNDEFINED-NAME.

PCL-COMPILE at frame 33 received this lambda expression:
(LAMBDA (#:G97)
  (DECLARE (OPTIMIZE (SB-C:STORE-SOURCE-FORM 0)))
  #'(SB-INT:NAMED-LAMBDA (SB-PCL::EMF BAZEL.MAIN:EXECUTE-COMMAND)
        (SB-PCL::.PV. SB-PCL::.NEXT-METHOD-CALL. SB-PCL::.ARG0. SB-INT:&MORE
         SB-PCL::.DFUN-MORE-CONTEXT. SB-PCL::.DFUN-MORE-COUNT.)
      (DECLARE (IGNORE SB-PCL::.PV. SB-PCL::.NEXT-METHOD-CALL.))
      (LET ((SB-PCL::.VALID-KEYS. 'T) (SB-PCL::.KEYARGS-START. '0))
        (SB-PCL::CHECK-APPLICABLE-KEYWORDS SB-PCL::.KEYARGS-START.
                                           SB-PCL::.VALID-KEYS.
                                           SB-PCL::.DFUN-MORE-CONTEXT.
                                           SB-PCL::.DFUN-MORE-COUNT.)
        (SB-PCL::%NO-PRIMARY-METHOD #:G97 SB-PCL::.ARGS.))))

From the backtrace, it does not appear that the compiler believes that SB-PCL::%NO-PRIMARY-METHOD is anything but an ordinary function. (viz, frames 5 and 3 are for compiling a full call passing a random global var)

[Christophe Rhodes]

Thanks. I read some (more) code on the way home and I think I can see
how this happens, and how to work around it with yet more scattered
logic.

I suppose one question for post-release (assuming that my workaround
actually works around the problem) might be: if we are in a situation
where there is no applicable primary method (or, for that matter,
invalid qualifiers in applicable methods, because the case will be the
same) for a generic function with keyword arguments, which would we
expect to happen first, the keyword check or the
no-applicable-primary-method check? Answers might need to refer to the
density of higher beings near the top of a pointy thing.

Christophe

[Christophe Rhodes]

Christophe Rhodes <cs...@cantab.net> writes:

> Thanks. I read some (more) code on the way home and I think I can see
> how this happens, and how to work around it with yet more scattered
> logic.
>
> I suppose one question for post-release (assuming that my workaround
> actually works around the problem) might be: if we are in a situation
> where there is no applicable primary method (or, for that matter,
> invalid qualifiers in applicable methods, because the case will be the
> same) for a generic function with keyword arguments, which would we
> expect to happen first, the keyword check or the
> no-applicable-primary-method check? Answers might need to refer to the
> density of higher beings near the top of a pointy thing.

I committed something relatively safe this morning that should restore
workingness, even if it's not very elegant; it introduces more
special-casing, and doesn't solve the underlying problem.

I had a go this evening at solving the underlying problem, and came up
with three iterations, which I've put up at
<https://github.com/csrhodes/sbcl/tree/no-primary-method>. The three
commits build on each other, but each of them could be an end-point; I
*think* the third is the best, but I am open to other opinions (and
would be very happy to receive test reports for any of them, because
they do rearrange the innards of PCL, its bootstrap, and the behaviour
of some widely-used internal functions a bit.)

Christophe