master: Faster keyword argument checking in CLOS

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