Re: master: Faster keyword argument checking in CLOS
Charles Zhang via Sbcl-commits <[email protected]> Sat, 9 May 2026 21:22:42 +0000 (UTC)
| Newsgroups | gmane.lisp.steel-bank.cvs,gmane.lisp.steel-bank.devel |
|---|---|
| Message-ID | <[email protected]> |
--===============6989891037250813333== Content-Type: multipart/alternative; boundary="----=_Part_256312_634398517.1778361762251" Content-Length: 24564 ------=_Part_256312_634398517.1778361762251 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable But what=E2=80=99s with the removed tests and the ansi test failure? On Saturday, May 9, 2026, 11:19 PM, stassats via Sbcl-commits <sbcl-commits= @lists.sourceforge.net> wrote: The branch "master" has been updated in SBCL: =C2=A0 =C2=A0 =C2=A0 via=C2=A0 c7921a02d8b8ff95914108b2395069bdc7f299aa (co= mmit) =C2=A0 =C2=A0 =C2=A0 from=C2=A0 9ce4f6ccc4a20abe3161ab68ac60d0f654611f25 (c= ommit) - Log ----------------------------------------------------------------- commit c7921a02d8b8ff95914108b2395069bdc7f299aa Author: Stas Boukarev <[email protected]> Date:=C2=A0 Sat May 9 22:49:45 2026 +0300 =C2=A0 =C2=A0 Faster keyword argument checking in CLOS =C2=A0 =C2=A0=20 =C2=A0 =C2=A0 Copy what convert-more-entry is doing and inline it. --- src/pcl/combin.lisp=C2=A0 =C2=A0 | 68 +++++++++++++++++++++---------------= -------------- src/pcl/fngen.lisp=C2=A0 =C2=A0 |=C2=A0 3 ++- tests/ansi-tests.sh=C2=A0 =C2=A0 |=C2=A0 2 +- tests/clos.impure.lisp |=C2=A0 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 @@ =C2=A0 =C2=A0 =C2=A0 =C2=A0 (aver any-keyp) =C2=A0 =C2=A0 =C2=A0 =C2=A0 (values (if allowp t keys) nopt))))) =20 -(defun check-applicable-keywords (start valid-keys more-context more-count= ) -=C2=A0 (let ((allow-other-keys-seen nil) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 (allow-other-keys nil) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 (i start)) -=C2=A0 =C2=A0 (declare (type index i more-count) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (optimize speed)) -=C2=A0 =C2=A0 (flet ((current-value () -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (sb-c::%more-arg more-context i)= )) -=C2=A0 =C2=A0 =C2=A0 (declare (inline current-value)) -=C2=A0 =C2=A0 =C2=A0 (collect ((invalid)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 (loop -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (when (>=3D i more-count) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (when (and (invalid) (not allow-= other-keys)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (%program-error "~@<inval= id keyword argument~P: ~ -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ~{~S~^, ~} (valid keys are ~{~S~^, ~= }).~@:>" -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (length (invalid)) (invalid) valid-keys)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (return)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (let ((key (current-value))) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (incf i) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (cond -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ((not (symbolp key)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (%program-error "~= @<keyword argument not a symbol: ~S.~@:>" -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 key)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ((=3D i more-count) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (sb-c::%odd-key-ar= gs-error)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ((eq key :allow-other-key= s) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ;; only the leftmo= st :ALLOW-OTHER-KEYS has any effect -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (unless allow-othe= r-keys-seen -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (setq allow= -other-keys-seen t -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 allow-other-keys (current-value)))) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ((eq t valid-keys)) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 ((not (memq key valid-key= s)) (invalid key)))) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (incf i)))))) - (defun wrap-with-applicable-keyword-check (effective valid-keys keyargs-st= art) -=C2=A0 `(let ((.valid-keys. ',valid-keys) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 (.keyargs-start. ',keyargs-start)) -=C2=A0 =C2=A0 (multiple-value-bind (.more-context. .more-count.) (sb-c::%r= est-context .rest.) -=C2=A0 =C2=A0 =C2=A0 (check-applicable-keywords -=C2=A0 =C2=A0 =C2=A0 .keyargs-start. .valid-keys. .more-context. .more-cou= nt.)) +=C2=A0 `(progn +=C2=A0 =C2=A0 (multiple-value-bind (more-context more-count) (sb-c::%rest-= context .rest.) +=C2=A0 =C2=A0 =C2=A0 (declare (ignorable more-context)) +=C2=A0 =C2=A0 =C2=A0 ;; Similar to what SB-C::CONVERT-MORE-ENTRY does +=C2=A0 =C2=A0 =C2=A0 (let ((count (- more-count ,keyargs-start))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 (when ,(if (zerop keyargs-start) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 `(od= dp count) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 `(an= d (plusp count) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 (oddp count))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (sb-c::%odd-key-args-error))) +=C2=A0 =C2=A0 =C2=A0 ,@(unless (eq valid-keys t) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (let ((restart (sb-c:make-restart-locat= ion))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 `((let (allowp +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (los= e (make-unbound-marker)) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (ind= ex more-count)) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (declare (index in= dex)) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (loop until (<=3D = index ,keyargs-start) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 do (decf (truly-the index index) 2) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 (let ((key (sb-c::%more-arg more-context index))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 (case key +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (,(remove :allow-other-keys valid-keys)) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (:allow-other-keys +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (setf allowp (sb-c::%more-arg more-context = (1+ index)))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (t +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (setf lose key))))) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (if (or (unbound-m= arker-p lose) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 allowp) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (sb-= c::restart-point ,restart) +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (sb-= c::%unknown-key-arg-error lose ,restart))))))) =C2=A0 =C2=A0 =C2=A0 ,effective)) =20 ;;;; 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 @@ =20 (defun default-constantp (form) =C2=A0 (and (constantp form) -=C2=A0 =C2=A0 =C2=A0 (not (typep (constant-form-value form) '(or symbol fi= xnum cons layout))))) +=C2=A0 =C2=A0 =C2=A0 (not (typep (constant-form-value form) '(or symbol fi= xnum cons layout +=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2= =A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 = =C2=A0 =C2=A0 =C2=A0 sb-c::restart-location))))) =20 (defun default-test-converter (form) =C2=A0 (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 =C2=A0 "SUBSTITUTE-IF.FOLD.3" "SUBSTITUTE-IF.FOLD.2" "SUBSTITUTE-IF.FOLD.1" =C2=A0 "SUBSTITUTE.FOLD.4" "SUBSTITUTE.FOLD.3" "SUBSTITUTE.FOLD.2" =C2=A0 "SUBSTITUTE.FOLD.1"=C2=A0 "SUBSTITUTE-IF-NOT.FOLD.3" - "MISC.598" "IMAGPART.4" + "MISC.598" "IMAGPART.4" "SHARED-INITIALIZE.ERROR.4" =C2=A0 (append #+x86 (list "CIS.4") =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 #+(or arm riscv (and arm64 (not darwin))= ) =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 (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 @@ =C2=A0 (assert-error (shared-initialize (make-instance 'shared-initialize-k= eyword-check) nil :a) =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 program-error)) =20 -(with-test (:name (:check-keyword-args shared-initialize :non-keyword :err= or)) -=C2=A0 (assert-error (shared-initialize (make-instance 'shared-initialize-= keyword-check) nil '(abc) 1) -=C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 =C2=A0 program-error)) - ;;; verify that we can still detect no primary methods and invalid qualifi= ers =20 (defmethod gf-with-keys-and-no-primary-method :around ((x integer) &key b) ----------------------------------------------------------------------- hooks/post-receive --=20 SBCL _______________________________________________ Sbcl-commits mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-commits ------=_Part_256312_634398517.1778361762251 Content-Type: text/html; charset=UTF-8 Content-Transfer-Encoding: quoted-printable <html xmlns=3D"http://www.w3.org/1999/xhtml" xmlns:v=3D"urn:schemas-microso= ft-com:vml" xmlns:o=3D"urn:schemas-microsoft-com:office:office"><head><!--[= if gte mso 9]><xml><o:OfficeDocumentSettings><o:AllowPNG/><o:PixelsPerInch>= 96</o:PixelsPerInch></o:OfficeDocumentSettings></xml><![endif]--></head><bo= dy> But what=E2=80=99s with the removed tests and the ansi test failure?<br><br= ><p class=3D"yahoo-quoted-begin" style=3D"font-size: 15px; padding-top: 15p= x; margin-top: 0">On Saturday, May 9, 2026, 11:19 PM, stassats via Sbcl-com= mits <[email protected]> wrote:</p><blockquote class= =3D"iosymail"><div dir=3D"ltr">The branch "master" has been updated in SBCL= :<br></div><div dir=3D"ltr"> via c7921a02d8b8ff9= 5914108b2395069bdc7f299aa (commit)<br></div><div dir=3D"ltr"> = from 9ce4f6ccc4a20abe3161ab68ac60d0f654611f25 (commit)<br></di= v><div dir=3D"ltr"><br></div><div dir=3D"ltr">- Log -----------------------= ------------------------------------------<br></div><div dir=3D"ltr">commit= c7921a02d8b8ff95914108b2395069bdc7f299aa<br></div><div dir=3D"ltr">Author:= Stas Boukarev <<a ymailto=3D"mailto:[email protected]" href=3D"mailto:= [email protected]">[email protected]</a>><br></div><div dir=3D"ltr">Da= te: Sat May 9 22:49:45 2026 +0300<br></div><div dir=3D"ltr"><br></di= v><div dir=3D"ltr"> Faster keyword argument checking in CLOS<b= r></div><div dir=3D"ltr"> <br></div><div dir=3D"ltr"> &n= bsp; Copy what convert-more-entry is doing and inline it.<br></div><div dir= =3D"ltr">---<br></div><div dir=3D"ltr"> src/pcl/combin.lisp | = 68 +++++++++++++++++++++-----------------------------<br></div><div dir=3D"= ltr"> src/pcl/fngen.lisp | 3 ++-<br></div><div dir=3D"l= tr"> tests/ansi-tests.sh | 2 +-<br></div><div dir=3D"ltr= "> tests/clos.impure.lisp | 4 ---<br></div><div dir=3D"ltr"> 4 files = changed, 32 insertions(+), 45 deletions(-)<br></div><div dir=3D"ltr"><br></= div><div dir=3D"ltr">diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp= <br></div><div dir=3D"ltr">index 6037c651a..7fd56f15e 100644<br></div><div = dir=3D"ltr">--- a/src/pcl/combin.lisp<br></div><div dir=3D"ltr">+++ b/src/p= cl/combin.lisp<br></div><div dir=3D"ltr">@@ -576,46 +576,36 @@<br></div><di= v dir=3D"ltr"> (aver any-keyp)<br></div><div di= r=3D"ltr"> (values (if allowp t keys) nopt)))))= <br></div><div dir=3D"ltr"> <br></div><div dir=3D"ltr">-(defun check-applic= able-keywords (start valid-keys more-context more-count)<br></div><div dir= =3D"ltr">- (let ((allow-other-keys-seen nil)<br></div><div dir=3D"ltr= ">- (allow-other-keys nil)<br></div><div dir=3D"= ltr">- (i start))<br></div><div dir=3D"ltr">-&nb= sp; (declare (type index i more-count)<br></div><div dir=3D"ltr">-&n= bsp; (optimize speed))<br></div><div di= r=3D"ltr">- (flet ((current-value ()<br></div><div dir=3D"ltr"= >- (sb-c::%more-arg more-context = i)))<br></div><div dir=3D"ltr">- (declare (inline curre= nt-value))<br></div><div dir=3D"ltr">- (collect ((inval= id))<br></div><div dir=3D"ltr">- (loop<br></div>= <div dir=3D"ltr">- (when (>=3D i more= -count)<br></div><div dir=3D"ltr">-  = ; (when (and (invalid) (not allow-other-keys))<br></div><div dir=3D"ltr">-= (%program-error "~@<in= valid keyword argument~P: ~<br></div><div dir=3D"ltr">- = &nbs= p; ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"<br></div><= div dir=3D"ltr">- &n= bsp; (length (invalid)) (invalid= ) valid-keys))<br></div><div dir=3D"ltr">-  = ; (return))<br></div><div dir=3D"ltr">- = (let ((key (current-value)))<br></div><div dir=3D"ltr">- &nbs= p; (incf i)<br></div><div dir=3D"ltr">- = (cond<br></div><div dir=3D"ltr">- = ((not (symbolp key))<br></div><= div dir=3D"ltr">- (%= program-error "~@<keyword argument not a symbol: ~S.~@:>"<br></div><d= iv dir=3D"ltr">- &nb= sp; key))<br></div><div di= r=3D"ltr">- ((=3D i more-c= ount)<br></div><div dir=3D"ltr">- = (sb-c::%odd-key-args-error))<br></div><div dir=3D"ltr">- = ; ((eq key :allow-other-keys)<br= ></div><div dir=3D"ltr">- &= nbsp; ;; only the leftmost :ALLOW-OTHER-KEYS has any effect<br></div><div d= ir=3D"ltr">- (unless= allow-other-keys-seen<br></div><div dir=3D"ltr">- &nbs= p; (setq allow-other-keys-seen t<br></di= v><div dir=3D"ltr">- = allow-other-keys (current-value))))<br></div><= div dir=3D"ltr">- ((eq t v= alid-keys))<br></div><div dir=3D"ltr">- &= nbsp; ((not (memq key valid-keys)) (invalid key))))<br></div><div d= ir=3D"ltr">- (incf i))))))<br></div><div= dir=3D"ltr">-<br></div><div dir=3D"ltr"> (defun wrap-with-applicable-keywo= rd-check (effective valid-keys keyargs-start)<br></div><div dir=3D"ltr">-&n= bsp; `(let ((.valid-keys. ',valid-keys)<br></div><div dir=3D"ltr">- &= nbsp; (.keyargs-start. ',keyargs-start))<br></div><div dir= =3D"ltr">- (multiple-value-bind (.more-context. .more-count.)= (sb-c::%rest-context .rest.)<br></div><div dir=3D"ltr">- &nbs= p; (check-applicable-keywords<br></div><div dir=3D"ltr">- &nbs= p; .keyargs-start. .valid-keys. .more-context. .more-count.))<br></div><di= v dir=3D"ltr">+ `(progn<br></div><div dir=3D"ltr">+ (mu= ltiple-value-bind (more-context more-count) (sb-c::%rest-context .rest.)<br= ></div><div dir=3D"ltr">+ (declare (ignorable more-con= text))<br></div><div dir=3D"ltr">+ ;; Similar to what = SB-C::CONVERT-MORE-ENTRY does<br></div><div dir=3D"ltr">+ &nbs= p; (let ((count (- more-count ,keyargs-start)))<br></div><div dir=3D"ltr">= + (when ,(if (zerop keyargs-start)<br></div><di= v dir=3D"ltr">+ &nbs= p; `(oddp count)<br></div><div dir=3D"ltr">+ &nb= sp; `(and (plusp count)<br></div>= <div dir=3D"ltr">+ &= nbsp; (oddp count)))<br></div><div dir=3D"ltr">= + (sb-c::%odd-key-args-error)))<br></div= ><div dir=3D"ltr">+ ,@(unless (eq valid-keys t)<br></d= iv><div dir=3D"ltr">+ (let ((restart (sb= -c:make-restart-location)))<br></div><div dir=3D"ltr">+ = `((let (allowp<br></div><div dir=3D"ltr">+ &nb= sp; (lose (make-un= bound-marker))<br></div><div dir=3D"ltr">+  = ; (index more-count))<br></div><div dir= =3D"ltr">+ (declare= (index index))<br></div><div dir=3D"ltr">+ &nbs= p; (loop until (<=3D index ,keyargs-start)<br></di= v><div dir=3D"ltr">+ = do (decf (truly-the index index) 2)<br></div><div di= r=3D"ltr">+ &= nbsp; (let ((key (sb-c::%more-arg more-context index))= )<br></div><div dir=3D"ltr">+ &nbs= p; (case key<br></div><div= dir=3D"ltr">+  = ; (,(remove :allow-other-keys val= id-keys))<br></div><div dir=3D"ltr">+ &nb= sp; (:allow-= other-keys<br></div><div dir=3D"ltr">+ &n= bsp; (setf = allowp (sb-c::%more-arg more-context (1+ index))))<br></div><div dir=3D"ltr= ">+ &n= bsp; (t<br></div><div dir=3D"ltr">+  = ; &nb= sp; (setf lose key)))))<br></div><div dir=3D"ltr">+ &n= bsp; (if (or (unbound-marker-p l= ose)<br></div><div dir=3D"ltr">+ &= nbsp; allowp)<br></div><div dir=3D"ltr"= >+ (s= b-c::restart-point ,restart)<br></div><div dir=3D"ltr">+  = ; (sb-c::%unknown-key-arg= -error lose ,restart)))))))<br></div><div dir=3D"ltr"> = ,effective))<br></div><div dir=3D"ltr"> =0C<br></div><div dir=3D"ltr"> ;;;;= the STANDARD method combination type. This is coded by hand<br></div><div = dir=3D"ltr">diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp<br></div><= div dir=3D"ltr">index 6eb140875..60d2b060a 100644<br></div><div dir=3D"ltr"= >--- a/src/pcl/fngen.lisp<br></div><div dir=3D"ltr">+++ b/src/pcl/fngen.lis= p<br></div><div dir=3D"ltr">@@ -97,7 +97,8 @@<br></div><div dir=3D"ltr"> <b= r></div><div dir=3D"ltr"> (defun default-constantp (form)<br></div><div dir= =3D"ltr"> (and (constantp form)<br></div><div dir=3D"ltr">- &n= bsp; (not (typep (constant-form-value form) '(or symbol fixnum cons= layout)))))<br></div><div dir=3D"ltr">+ (not (typep (= constant-form-value form) '(or symbol fixnum cons layout<br></div><div dir= =3D"ltr">+ &n= bsp; = sb-c::restart-location)))))<br></div><div dir= =3D"ltr"> <br></div><div dir=3D"ltr"> (defun default-test-converter (form)<= br></div><div dir=3D"ltr"> (if (default-constantp form)<br></div><di= v dir=3D"ltr">diff --git a/tests/ansi-tests.sh b/tests/ansi-tests.sh<br></d= iv><div dir=3D"ltr">index fb8dc92ce..6e807d0e3 100755<br></div><div dir=3D"= ltr">--- a/tests/ansi-tests.sh<br></div><div dir=3D"ltr">+++ b/tests/ansi-t= ests.sh<br></div><div dir=3D"ltr">@@ -56,7 +56,7 @@ rm -fr sandbox/scratch<= br></div><div dir=3D"ltr"> "SUBSTITUTE-IF.FOLD.3" "SUBSTITUTE-IF.FOLD= .2" "SUBSTITUTE-IF.FOLD.1"<br></div><div dir=3D"ltr"> "SUBSTITUTE.FOL= D.4" "SUBSTITUTE.FOLD.3" "SUBSTITUTE.FOLD.2"<br></div><div dir=3D"ltr">&nbs= p; "SUBSTITUTE.FOLD.1" "SUBSTITUTE-IF-NOT.FOLD.3"<br></div><div dir= =3D"ltr">- "MISC.598" "IMAGPART.4"<br></div><div dir=3D"ltr">+ "MISC.598" "= IMAGPART.4" "SHARED-INITIALIZE.ERROR.4"<br></div><div dir=3D"ltr"> (a= ppend #+x86 (list "CIS.4")<br></div><div dir=3D"ltr"> &= nbsp; #+(or arm riscv (and arm64 (not darwin)))<br></div><div dir=3D= "ltr"> (list "EXP.ERROR.4" "EXP.ER= ROR.5" "EXP.ERROR.6" "EXP.ERROR.7" "EXPT.ERROR.4"<br></div><div dir=3D"ltr"= >diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp<br></div><div= dir=3D"ltr">index af142e6e9..f8e25dd69 100644<br></div><div dir=3D"ltr">--= - a/tests/clos.impure.lisp<br></div><div dir=3D"ltr">+++ b/tests/clos.impur= e.lisp<br></div><div dir=3D"ltr">@@ -1352,10 +1352,6 @@<br></div><div dir= =3D"ltr"> (assert-error (shared-initialize (make-instance 'shared-in= itialize-keyword-check) nil :a)<br></div><div dir=3D"ltr"> &nb= sp; program-error))<br></div><div dir= =3D"ltr"> <br></div><div dir=3D"ltr">-(with-test (:name (:check-keyword-arg= s shared-initialize :non-keyword :error))<br></div><div dir=3D"ltr">- = (assert-error (shared-initialize (make-instance 'shared-initialize-keyword= -check) nil '(abc) 1)<br></div><div dir=3D"ltr">-  = ; program-error))<br></div><div dir=3D"ltr">-<b= r></div><div dir=3D"ltr"> ;;; verify that we can still detect no primary me= thods and invalid qualifiers<br></div><div dir=3D"ltr"> <br></div><div dir= =3D"ltr"> (defmethod gf-with-keys-and-no-primary-method :around ((x integer= ) &key b)<br></div><div dir=3D"ltr"><br></div><div dir=3D"ltr">--------= ---------------------------------------------------------------<br></div><d= iv dir=3D"ltr"><br></div><div dir=3D"ltr"><br></div><div dir=3D"ltr">hooks/= post-receive<br></div><div dir=3D"ltr">-- <br></div><div dir=3D"ltr">SBCL<b= r></div><div dir=3D"ltr"><br></div><div dir=3D"ltr"><br></div><div dir=3D"l= tr">_______________________________________________<br></div><div dir=3D"lt= r">Sbcl-commits mailing list<br></div><div dir=3D"ltr"><a ymailto=3D"mailto= :[email protected]" href=3D"mailto:[email protected]= ceforge.net">[email protected]</a><br></div><div dir=3D"lt= r"><a href=3D"https://lists.sourceforge.net/lists/listinfo/sbcl-commits" ta= rget=3D"_blank">https://lists.sourceforge.net/lists/listinfo/sbcl-commits</= a><br></div><blockquote></blockquote></blockquote> </body></html> ------=_Part_256312_634398517.1778361762251-- --===============6989891037250813333== Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline --===============6989891037250813333== Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Sbcl-commits mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-commits --===============6989891037250813333==--