Re: master: Faster keyword argument checking in CLOS

"It is not permitted to supply a keyword argument to a function using
a name that is not a symbol.

If this situation occurs in a safe call, an error of type
program-error must be signaled unless keyword argument checking is
suppressed as described in Section 3.4.1.4.1 (Suppressing Keyword
Argument Checking)"

On Sun, May 10, 2026 at 12:23 AM Charles Zhang via Sbcl-commits
<[email protected]> wrote:
>
> But what’s with the removed tests and the ansi test failure?
>
> On Saturday, May 9, 2026, 11:19 PM, stassats via Sbcl-commits <[email protected]> wrote:
>
> The branch "master" has been updated in SBCL:
>       via  c7921a02d8b8ff95914108b2395069bdc7f299aa (commit)
>       from  9ce4f6ccc4a20abe3161ab68ac60d0f654611f25 (commit)
>
> - Log -----------------------------------------------------------------
> commit c7921a02d8b8ff95914108b2395069bdc7f299aa
> Author: Stas Boukarev <[email protected]>
> Date:  Sat May 9 22:49:45 2026 +0300
>
>     Faster keyword argument checking in CLOS
>
>     Copy what convert-more-entry is doing and inline it.
> ---
> src/pcl/combin.lisp    | 68 +++++++++++++++++++++-----------------------------
> src/pcl/fngen.lisp    |  3 ++-
> tests/ansi-tests.sh    |  2 +-
> tests/clos.impure.lisp |  4 ---
> 4 files changed, 32 insertions(+), 45 deletions(-)
>
> diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
> index 6037c651a..7fd56f15e 100644
> --- a/src/pcl/combin.lisp
> +++ b/src/pcl/combin.lisp
> @@ -576,46 +576,36 @@
>         (aver any-keyp)
>         (values (if allowp t keys) nopt)))))
>
> -(defun check-applicable-keywords (start valid-keys more-context more-count)
> -  (let ((allow-other-keys-seen nil)
> -        (allow-other-keys nil)
> -        (i start))
> -    (declare (type index i more-count)
> -            (optimize speed))
> -    (flet ((current-value ()
> -            (sb-c::%more-arg more-context i)))
> -      (declare (inline current-value))
> -      (collect ((invalid))
> -        (loop
> -          (when (>= i more-count)
> -            (when (and (invalid) (not allow-other-keys))
> -              (%program-error "~@<invalid keyword argument~P: ~
> -                                ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
> -                              (length (invalid)) (invalid) valid-keys))
> -            (return))
> -          (let ((key (current-value)))
> -            (incf i)
> -            (cond
> -              ((not (symbolp key))
> -                (%program-error "~@<keyword argument not a symbol: ~S.~@:>"
> -                                key))
> -              ((= i more-count)
> -                (sb-c::%odd-key-args-error))
> -              ((eq key :allow-other-keys)
> -                ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
> -                (unless allow-other-keys-seen
> -                  (setq allow-other-keys-seen t
> -                        allow-other-keys (current-value))))
> -              ((eq t valid-keys))
> -              ((not (memq key valid-keys)) (invalid key))))
> -          (incf i))))))
> -
> (defun wrap-with-applicable-keyword-check (effective valid-keys keyargs-start)
> -  `(let ((.valid-keys. ',valid-keys)
> -        (.keyargs-start. ',keyargs-start))
> -    (multiple-value-bind (.more-context. .more-count.) (sb-c::%rest-context .rest.)
> -      (check-applicable-keywords
> -      .keyargs-start. .valid-keys. .more-context. .more-count.))
> +  `(progn
> +    (multiple-value-bind (more-context more-count) (sb-c::%rest-context .rest.)
> +      (declare (ignorable more-context))
> +      ;; Similar to what SB-C::CONVERT-MORE-ENTRY does
> +      (let ((count (- more-count ,keyargs-start)))
> +        (when ,(if (zerop keyargs-start)
> +                    `(oddp count)
> +                    `(and (plusp count)
> +                          (oddp count)))
> +          (sb-c::%odd-key-args-error)))
> +      ,@(unless (eq valid-keys t)
> +          (let ((restart (sb-c:make-restart-location)))
> +            `((let (allowp
> +                    (lose (make-unbound-marker))
> +                    (index more-count))
> +                (declare (index index))
> +                (loop until (<= index ,keyargs-start)
> +                      do (decf (truly-the index index) 2)
> +                          (let ((key (sb-c::%more-arg more-context index)))
> +                            (case key
> +                              (,(remove :allow-other-keys valid-keys))
> +                              (:allow-other-keys
> +                              (setf allowp (sb-c::%more-arg more-context (1+ index))))
> +                              (t
> +                              (setf lose key)))))
> +                (if (or (unbound-marker-p lose)
> +                        allowp)
> +                    (sb-c::restart-point ,restart)
> +                    (sb-c::%unknown-key-arg-error lose ,restart)))))))
>       ,effective))
>
> ;;;; the STANDARD method combination type. This is coded by hand
> diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp
> index 6eb140875..60d2b060a 100644
> --- a/src/pcl/fngen.lisp
> +++ b/src/pcl/fngen.lisp
> @@ -97,7 +97,8 @@
>
> (defun default-constantp (form)
>   (and (constantp form)
> -      (not (typep (constant-form-value form) '(or symbol fixnum cons layout)))))
> +      (not (typep (constant-form-value form) '(or symbol fixnum cons layout
> +                                                sb-c::restart-location)))))
>
> (defun default-test-converter (form)
>   (if (default-constantp form)
> diff --git a/tests/ansi-tests.sh b/tests/ansi-tests.sh
> index fb8dc92ce..6e807d0e3 100755
> --- a/tests/ansi-tests.sh
> +++ b/tests/ansi-tests.sh
> @@ -56,7 +56,7 @@ rm -fr sandbox/scratch
>   "SUBSTITUTE-IF.FOLD.3" "SUBSTITUTE-IF.FOLD.2" "SUBSTITUTE-IF.FOLD.1"
>   "SUBSTITUTE.FOLD.4" "SUBSTITUTE.FOLD.3" "SUBSTITUTE.FOLD.2"
>   "SUBSTITUTE.FOLD.1"  "SUBSTITUTE-IF-NOT.FOLD.3"
> - "MISC.598" "IMAGPART.4"
> + "MISC.598" "IMAGPART.4" "SHARED-INITIALIZE.ERROR.4"
>   (append #+x86 (list "CIS.4")
>           #+(or arm riscv (and arm64 (not darwin)))
>             (list "EXP.ERROR.4" "EXP.ERROR.5" "EXP.ERROR.6" "EXP.ERROR.7" "EXPT.ERROR.4"
> diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
> index af142e6e9..f8e25dd69 100644
> --- a/tests/clos.impure.lisp
> +++ b/tests/clos.impure.lisp
> @@ -1352,10 +1352,6 @@
>   (assert-error (shared-initialize (make-instance 'shared-initialize-keyword-check) nil :a)
>                 program-error))
>
> -(with-test (:name (:check-keyword-args shared-initialize :non-keyword :error))
> -  (assert-error (shared-initialize (make-instance 'shared-initialize-keyword-check) nil '(abc) 1)
> -                program-error))
> -
> ;;; verify that we can still detect no primary methods and invalid qualifiers
>
> (defmethod gf-with-keys-and-no-primary-method :around ((x integer) &key b)
>
> -----------------------------------------------------------------------
>
>
> hooks/post-receive
> --
> SBCL
>
>
> _______________________________________________
> Sbcl-commits mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits
>
> _______________________________________________
> Sbcl-commits mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits


_______________________________________________
Sbcl-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sbcl-commits