sbcl-commits — Automatic notification of CVS activity.

[Sbcl-commits] master: Fix a test for -sb-unicode

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  0dcc54ea2424be1363418f2e9ef078db7f7768a0 (commit)
      from  238b67eb23c1ffb965a4b54cd9247f2edf7631c4 (commit)

- Log -----------------------------------------------------------------
commit 0dcc54ea2424be1363418f2e9ef078db7f7768a0
Author: Stas Boukarev <sta...@gm...>
Date:   Sun Nov 2 05:27:23 2025 +0300

    Fix a test for -sb-unicode
---
 tests/type.pure.lisp | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 7e3d2aede..72774bed9 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1122,8 +1122,8 @@
   (assert (not (eq (specifier-type '(or (and simple-array (not (array double-float)))
                                      (simple-array * (*))))
                    (specifier-type 'simple-array))))
-  (assert (eq (specifier-type '(or (and vector (not (array t)) (not (array base-char)) (not (array character))) (vector character)))
-              (specifier-type '(and vector (not (array t)) (not (array base-char)))))))
+  (assert (eq (specifier-type '(or (and vector (not (array t)) (not (array fixnum)) (not (array character))) (vector character)))
+              (specifier-type '(and vector (not (array t)) (not (array fixnum)))))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Slightly relax requirement for literal string in extern-alien

[snuglas <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  238b67eb23c1ffb965a4b54cd9247f2edf7631c4 (commit)
      from  99e4c664ae18f3afe273d3bd43097f4621de17d0 (commit)

- Log -----------------------------------------------------------------
commit 238b67eb23c1ffb965a4b54cd9247f2edf7631c4
Author: Douglas Katzman <do...@go...>
Date:   Sat Nov 1 21:47:19 2025 -0400

    Slightly relax requirement for literal string in extern-alien
    
    There's no compelling reason to forbid computed constant strings.
    As a practical matter this helps craft foreign calls such as
     (alien-funcall (extern-alien (c++mangle "namespace" "staticMethod") ...))
    where the linkage name and argument signature are easy enough for Lisp to emit.
    Complicated arguments are a different matter entirely of course.
---
 src/code/target-alieneval.lisp |  3 ++-
 tests/alien.impure.lisp        | 10 ++++++++++
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 9619a915b..2170ac385 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -94,7 +94,8 @@ variable is undefined."
 (defmacro extern-alien (name type &environment env)
   "Access the alien variable named NAME, assuming it is of type TYPE.
 This is SETFable."
-  (let* ((alien-name (possibly-base-stringize
+  (let* ((name (if (and env (constantp name env)) (constant-form-value name env) name))
+         (alien-name (possibly-base-stringize
                       (etypecase name
                        (symbol (guess-alien-name-from-lisp-name name))
                        (string name))))
diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index 6eafd2a28..4e6ad47af 100644
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -601,6 +601,16 @@
     ;; Negative assertion that passing SIMPLE-BASE-STRING will never do a conversion
     (assert (not (has-call 'simple-base-string)))))
 
+(with-test (:name :not-quite-literal-alien-name :skipped-on (:not :unix))
+  ;; There are valid reasons for the first argument to EXTERN-ALIEN to be an expression
+  ;; producing a constant string such as through a global constant or a macro that selects
+  ;; a name based on environmental aspects such as compilation mode and/or foreign toolchain.
+  (let ((f (compile nil
+            '(lambda (s)
+              (macrolet ((something () "getenv"))
+                (alien-funcall (extern-alien (something) (function c-string c-string)) s))))))
+    (assert (string= (funcall f "SBCL_HOME") (sb-ext:posix-getenv "SBCL_HOME")))))
+
 (cl:in-package "SB-KERNEL")
 (test-util:with-test (:name :hash-consing)
   (assert (eq (parse-alien-type '(integer 9) nil)

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: ARRAY-COMPLEX-UNION2-TYPE-METHOD: handle more array negations.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  99e4c664ae18f3afe273d3bd43097f4621de17d0 (commit)
      from  8402122dc9c2dcb845832e8d22c00c2694779c01 (commit)

- Log -----------------------------------------------------------------
commit 99e4c664ae18f3afe273d3bd43097f4621de17d0
Author: Stas Boukarev <sta...@gm...>
Date:   Sun Nov 2 04:22:58 2025 +0300

    ARRAY-COMPLEX-UNION2-TYPE-METHOD: handle more array negations.
    
    Fixes lp#2130508
---
 src/code/type.lisp   | 135 ++++++++++++++++++++++++++-------------------------
 tests/type.pure.lisp |   4 +-
 2 files changed, 71 insertions(+), 68 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 10678dbe7..cec2307f0 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3652,73 +3652,74 @@ expansion happened."
                                                :element-type *wild-type*)
                             type1))))))
     (intersection-type
-     (cond (;; (or (and simple-array (not (array t)) (not vector)) (simple-array t))
-            ;; => (or (and simple-array (not vector)) (simple-array t))
-            (and (neq (array-type-complexp type2) :maybe)
-                 (let (not-type
-                       supertype)
-                   (loop for type in (intersection-type-types type1)
-                         if (negation-type-p type)
-                         do (when (csubtypep (negation-type-type type)
-                                             (change-array-type-complexp type2 :maybe))
-                              (setf not-type type))
-                         else if (and
-                                  (array-type-p type)
-                                  (eq (array-type-complexp type)
-                                      (array-type-complexp type2))
-                                  (csubtypep type2 type))
-                         do (setf supertype t))
-                   (when (and not-type supertype)
-                     (type-union (%type-intersection (remove not-type
-                                                             (intersection-type-types type1)))
-                                 type2)))))
-           ;; (or (and (not (array t)) (and vector (not simple-array))) (simple-array * (*)))
-           ;; => (and vector (not (and (array t) (not simple-array))))
-           ((and (neq (array-type-complexp type2) :maybe)
-                 (let (not-type
-                       supertype)
-                   (loop for type in (intersection-type-types type1)
-                         if (negation-type-p type)
-                         do (let ((negation-type (negation-type-type type)))
-                              (when (and (array-type-p negation-type)
-                                         (eq (array-type-complexp negation-type) :maybe)
-                                         (csubtypep negation-type
-                                                    (change-array-type type2 :dimensions '* :complexp :maybe)))
-                                (setf not-type negation-type)))
-                         else if (array-type-p type)
-                         do (let ((union (type-union type type2)))
-                              (when (and (array-type-p union)
-                                         (equal (array-type-dimensions union)
-                                                (array-type-dimensions type2)))
-                                (aver (not supertype))
-                                (setf supertype union))))
-                   (when (and not-type supertype)
-                     (type-intersection supertype
-                                        (make-negation-type
-                                         (change-array-type not-type :complexp (not (array-type-complexp type2)))))))))
-           (t
-            ;; This is the same as in the intersection-simple-union2-type-method,
-            ;; but it doesn't stop if type-union produces a new union type:
-            ;; (or (and vector (not (simple-array t))) simple-vector)
-            ;; => vector
-            (let (unions
-                  non-compound)
-              (do ((t1s (intersection-type-types type1) (cdr t1s)))
-                  ((null t1s))
-                (let ((union (or (type-union2 type2 (car t1s))
-                                 (return-from array-complex-union2-type-method))))
-                  (if (typep union '(or compound-type negation-type))
-                      (push union unions)
-                      (setf non-compound (if non-compound
-                                             (type-intersection non-compound union)
-                                             union)))))
-              (when non-compound
-                (loop for (union . more) on unions
-                      do (setf non-compound (type-intersection non-compound union))
-                      if (and more
-                              (typep non-compound '(or compound-type negation-type)))
-                      return nil
-                      finally (return non-compound)))))))))
+     (let ((t1s (intersection-type-types type1)))
+       (cond (;; (or (and simple-array (not (array t)) (not vector)) (simple-array t))
+              ;; => (or (and simple-array (not vector)) (simple-array t))
+              (and (let (not-type
+                         supertype)
+                     (loop for type in t1s
+                           if (negation-type-p type)
+                           do (when (csubtypep (negation-type-type type)
+                                               (change-array-type type2 :dimensions '* :complexp :maybe))
+                                (setf not-type type))
+                           else if (and
+                                    (array-type-p type)
+                                    (equal (array-type-dimensions type)
+                                           (array-type-dimensions type2))
+                                    (eq (array-type-complexp type)
+                                        (array-type-complexp type2))
+                                    (csubtypep type2 type))
+                           do (setf supertype t))
+                     (when (and not-type supertype)
+                       (type-union (%type-intersection (remove not-type
+                                                               (intersection-type-types type1)))
+                                   type2)))))
+             ;; (or (and (not (array t)) (and vector (not simple-array))) (simple-array * (*)))
+             ;; => (and vector (not (and (array t) (not simple-array))))
+             ((and (neq (array-type-complexp type2) :maybe)
+                   (let (not-type
+                         supertype)
+                     (loop for type in t1s
+                           if (negation-type-p type)
+                           do (let ((negation-type (negation-type-type type)))
+                                (when (and (array-type-p negation-type)
+                                           (eq (array-type-complexp negation-type) :maybe)
+                                           (csubtypep negation-type
+                                                      (change-array-type type2 :dimensions '* :complexp :maybe)))
+                                  (setf not-type negation-type)))
+                           else if (array-type-p type)
+                           do (let ((union (type-union type type2)))
+                                (when (and (array-type-p union)
+                                           (equal (array-type-dimensions union)
+                                                  (array-type-dimensions type2)))
+                                  (setf supertype union))))
+                     (when (and not-type supertype)
+                       (type-intersection supertype
+                                          (make-negation-type
+                                           (change-array-type not-type :complexp (not (array-type-complexp type2)))))))))
+             (t
+              ;; This is the same as in the intersection-simple-union2-type-method,
+              ;; but it doesn't stop if type-union produces a new union type:
+              ;; (or (and vector (not (simple-array t))) simple-vector)
+              ;; => vector
+              (let (unions
+                    non-compound)
+                (do ((t1s t1s (cdr t1s)))
+                    ((null t1s))
+                  (let ((union (or (type-union2 type2 (car t1s))
+                                   (return-from array-complex-union2-type-method))))
+                    (if (typep union '(or compound-type negation-type))
+                        (push union unions)
+                        (setf non-compound (if non-compound
+                                               (type-intersection non-compound union)
+                                               union)))))
+                (when non-compound
+                  (loop for (union . more) on unions
+                        do (setf non-compound (type-intersection non-compound union))
+                        if (and more
+                                (typep non-compound '(or compound-type negation-type)))
+                        return nil
+                        finally (return non-compound))))))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index dbdbc16f0..7e3d2aede 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1121,7 +1121,9 @@
               (specifier-type '(and vector (not (array t))))))
   (assert (not (eq (specifier-type '(or (and simple-array (not (array double-float)))
                                      (simple-array * (*))))
-                   (specifier-type 'simple-array)))))
+                   (specifier-type 'simple-array))))
+  (assert (eq (specifier-type '(or (and vector (not (array t)) (not (array base-char)) (not (array character))) (vector character)))
+              (specifier-type '(and vector (not (array t)) (not (array base-char)))))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: ARRAY-COMPLEX-UNION2-TYPE-METHOD: ensure dimensions match.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  8402122dc9c2dcb845832e8d22c00c2694779c01 (commit)
      from  7a1830863a1ac24c651ba843a68bc1ef0f0bef81 (commit)

- Log -----------------------------------------------------------------
commit 8402122dc9c2dcb845832e8d22c00c2694779c01
Author: Stas Boukarev <sta...@gm...>
Date:   Sun Nov 2 03:39:03 2025 +0300

    ARRAY-COMPLEX-UNION2-TYPE-METHOD: ensure dimensions match.
    
    Fixes lp#2130506
---
 src/code/type.lisp   | 4 +++-
 tests/type.pure.lisp | 5 ++++-
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 437c1dd40..10678dbe7 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3687,7 +3687,9 @@ expansion happened."
                                 (setf not-type negation-type)))
                          else if (array-type-p type)
                          do (let ((union (type-union type type2)))
-                              (when (array-type-p union)
+                              (when (and (array-type-p union)
+                                         (equal (array-type-dimensions union)
+                                                (array-type-dimensions type2)))
                                 (aver (not supertype))
                                 (setf supertype union))))
                    (when (and not-type supertype)
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 361721316..dbdbc16f0 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1118,7 +1118,10 @@
               (specifier-type '(and vector (not (and (array t) (not simple-array)))))))
   (assert (eq (specifier-type '(or (and (not (array t)) (and vector (not simple-array)))
                                 (and (not (array t)) (simple-array * (*)))))
-              (specifier-type '(and vector (not (array t)))))))
+              (specifier-type '(and vector (not (array t))))))
+  (assert (not (eq (specifier-type '(or (and simple-array (not (array double-float)))
+                                     (simple-array * (*))))
+                   (specifier-type 'simple-array)))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: More array-type union consistencies.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  7a1830863a1ac24c651ba843a68bc1ef0f0bef81 (commit)
      from  e95ce44479cb424c5c5ff90ed44033ffc7ceb382 (commit)

- Log -----------------------------------------------------------------
commit 7a1830863a1ac24c651ba843a68bc1ef0f0bef81
Author: Stas Boukarev <sta...@gm...>
Date:   Sat Nov 1 19:53:01 2025 +0300

    More array-type union consistencies.
    
    Fixes lp#2130457
---
 src/code/type.lisp   | 22 ++++++++++++++++++++++
 tests/type.pure.lisp |  9 ++++++++-
 2 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index e37d32651..437c1dd40 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3672,6 +3672,28 @@ expansion happened."
                      (type-union (%type-intersection (remove not-type
                                                              (intersection-type-types type1)))
                                  type2)))))
+           ;; (or (and (not (array t)) (and vector (not simple-array))) (simple-array * (*)))
+           ;; => (and vector (not (and (array t) (not simple-array))))
+           ((and (neq (array-type-complexp type2) :maybe)
+                 (let (not-type
+                       supertype)
+                   (loop for type in (intersection-type-types type1)
+                         if (negation-type-p type)
+                         do (let ((negation-type (negation-type-type type)))
+                              (when (and (array-type-p negation-type)
+                                         (eq (array-type-complexp negation-type) :maybe)
+                                         (csubtypep negation-type
+                                                    (change-array-type type2 :dimensions '* :complexp :maybe)))
+                                (setf not-type negation-type)))
+                         else if (array-type-p type)
+                         do (let ((union (type-union type type2)))
+                              (when (array-type-p union)
+                                (aver (not supertype))
+                                (setf supertype union))))
+                   (when (and not-type supertype)
+                     (type-intersection supertype
+                                        (make-negation-type
+                                         (change-array-type not-type :complexp (not (array-type-complexp type2)))))))))
            (t
             ;; This is the same as in the intersection-simple-union2-type-method,
             ;; but it doesn't stop if type-union produces a new union type:
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index ff7b7ebd3..361721316 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1111,7 +1111,14 @@
            (specifier-type '(or (and (not (array fixnum)) (not (array t)) vector) (vector t)))
            (specifier-type '(and (not (array fixnum)) vector))))
   (assert (eq (specifier-type '(or (and simple-array (not (array t)) (not vector)) (simple-array t)))
-              (specifier-type '(or (and simple-array (not vector)) (simple-array t))))))
+              (specifier-type '(or (and simple-array (not vector)) (simple-array t)))))
+  (assert (eq (specifier-type '(or (and vector (not (array t))) (simple-array * (*))))
+              (specifier-type '(and vector (not (and (array t) (not simple-array)))))))
+  (assert (eq (specifier-type '(or (and (not (array t)) (and vector (not simple-array))) (simple-array * (*))))
+              (specifier-type '(and vector (not (and (array t) (not simple-array)))))))
+  (assert (eq (specifier-type '(or (and (not (array t)) (and vector (not simple-array)))
+                                (and (not (array t)) (simple-array * (*)))))
+              (specifier-type '(and vector (not (array t)))))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Fix miscalculated mmap args for massive dynamic-space-size

[snuglas <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  e95ce44479cb424c5c5ff90ed44033ffc7ceb382 (commit)
      from  695ee9b9c0b0a5680fe5575ce3008ce4aa24d8aa (commit)

- Log -----------------------------------------------------------------
commit e95ce44479cb424c5c5ff90ed44033ffc7ceb382
Author: Douglas Katzman <do...@go...>
Date:   Sat Nov 1 12:02:15 2025 -0400

    Fix miscalculated mmap args for massive dynamic-space-size
    
    With mark-region's 128b card size it is quite possible to need a card table
    of 2 gigacards. This happens with a dynamic-space-size slightly over 128GiB.
    (Exactly 128GiB = 1 gigacard). So this how the crash went: 2 gigacards uses
    a 31-bit mask, which is #x7fffffff and 1+ that looks like the most negative
    32-bit int. This caused 'extra_above' in coreparse_alloc_space to add -huge
    to 'size' which made the call to os_allloc_gc_space receive a bad size
    such as 0xffffffffzzzzzzzz which produces ENOMEM.
    
    I don't know how to write a regression test for a "typical" setup though my
    particular setup allowed a heap size of 130GiB other than for the bad math.
---
 src/runtime/arm64-arch.c  | 2 +-
 src/runtime/coreparse.c   | 2 ++
 src/runtime/linux-mman.c  | 7 +++----
 src/runtime/x86-64-arch.c | 2 +-
 4 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/src/runtime/arm64-arch.c b/src/runtime/arm64-arch.c
index 148c60f4f..2296c2762 100644
--- a/src/runtime/arm64-arch.c
+++ b/src/runtime/arm64-arch.c
@@ -361,7 +361,7 @@ void gcbarrier_patch_code(void* where, int nbits)
 os_vm_address_t coreparse_alloc_space(int space_id, int attr,
                                       os_vm_address_t addr, os_vm_size_t size)
 {
-    __attribute__((unused)) int extra_request = 0;
+    __attribute__((unused)) long extra_request = 0;
 #ifdef LISP_FEATURE_IMMOBILE_SPACE
     if (space_id == IMMOBILE_TEXT_CORE_SPACE_ID) {
         extra_request = ALIEN_LINKAGE_SPACE_SIZE;
diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c
index aff1fd105..e216037e3 100644
--- a/src/runtime/coreparse.c
+++ b/src/runtime/coreparse.c
@@ -1015,6 +1015,8 @@ static bool compute_card_table_size(int saved_card_mask_nbits)
 
     // 2 Gigacards should suffice for now. That would span 2TiB of memory
     // using 1Kb card size, or more if larger card size.
+    // (I think 32 bits could be ok too. The AND instruction uses a 4-byte mask, so
+    // #xffffffff would be 0-extended and not sign-extended to the full register width)
     if (nbits > 31)
         lose("dynamic space too large");
 
diff --git a/src/runtime/linux-mman.c b/src/runtime/linux-mman.c
index a3778ce11..57fc411d9 100644
--- a/src/runtime/linux-mman.c
+++ b/src/runtime/linux-mman.c
@@ -72,8 +72,7 @@ __attribute__((unused)) static void* try_find_hole(os_vm_size_t len)
 }
 
 os_vm_address_t
-os_alloc_gc_space(int __attribute__((unused)) space_id,
-                  int attributes, os_vm_address_t addr, os_vm_size_t len)
+os_alloc_gc_space(int space_id, int attributes, os_vm_address_t addr, os_vm_size_t len)
 {
     int protection = attributes & IS_GUARD_PAGE ? OS_VM_PROT_NONE : OS_VM_PROT_ALL;
     attributes &= ~IS_GUARD_PAGE;
@@ -94,8 +93,8 @@ os_alloc_gc_space(int __attribute__((unused)) space_id,
 
     if (actual == MAP_FAILED) {
         if (errno == ENOMEM)
-            fprintf(stderr, "os_alloc_gc_space(%d,%p,%zu) failed with ENOMEM\n",
-                    attributes, addr, len);
+            fprintf(stderr, "os_alloc_gc_space(%d,%d,%p,%zu) failed with ENOMEM\n",
+                    space_id, attributes, addr, len);
         else
             perror("mmap");
         dumpmaps();
diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c
index 127b05ec5..2001604c9 100644
--- a/src/runtime/x86-64-arch.c
+++ b/src/runtime/x86-64-arch.c
@@ -853,7 +853,7 @@ os_vm_address_t coreparse_alloc_space(int space_id, int attr,
 {
     if (size == 0) return addr;
 
-    int extra_below = 0, extra_above = 0;
+    long extra_below = 0, extra_above = 0;
     extern int lisp_code_in_elf();
 
 #ifdef LISP_FEATURE_IMMOBILE_SPACE

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Omit some do-nothing string-to-c-string calls

[snuglas <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  695ee9b9c0b0a5680fe5575ce3008ce4aa24d8aa (commit)
      from  39c030446cd9a462481bfc7eac29b386baf2644b (commit)

- Log -----------------------------------------------------------------
commit 695ee9b9c0b0a5680fe5575ce3008ce4aa24d8aa
Author: Douglas Katzman <do...@go...>
Date:   Sat Nov 1 11:34:19 2025 -0400

    Omit some do-nothing string-to-c-string calls
    
    The runtime does not cons a fresh simple-base-string when passing one to
    a C function declared to receive UTF8-STRING, however the compiler didn't
    realize that this situation does not need a runtime conversion.
    No regression test exercised a declared C argument type of UTF8-STRING
    (as defined in target-c-call) so this adds one.
---
 src/compiler/aliencomp.lisp | 24 ++++++++++++++++++++++++
 tests/alien.impure.lisp     | 15 +++++++++++++++
 2 files changed, 39 insertions(+)

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 285dbb806..664c7fa7c 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -776,3 +776,27 @@
     (if (eq format :default)
         `(sb-alien::default-c-string-external-format)
         `',format)))
+;;; This transform which recognizes :UTF8 as an easy case if the argument is simple-base-string
+;;; does not have to additionally recognize :ASCII, which is done elsewhere - either deport-alloc-gen
+;;; or deport-alloc (I'm not sure which). An ETYPECASE is inserted over the possible choices of
+;;; Lisp arg type, one of which is SIMPLE-BASE-STRING, which undergoes no conversion
+;;; (assisted by SB-ALIEN::C-STRING-NEEDS-CONVERSION-P given :ASCII as the format).
+;;; However I noticed a premature optimization which either accidentally or intentionally
+;;; fails on non-simple strings. Consider the function F:
+;;; (defun f (s)
+;;;   (alien-funcall (extern-alien "getenv"
+;;;                   (function system-area-pointer (c-string :external-format :ascii)))
+;;;                  (the string s)))
+;;; * (f (make-array 4 :element-type 'base-char :displaced-to (coerce "HOME" 'simple-base-string)))
+;;; which gets:
+;;;    debugger invoked on a CASE-FAILURE @1201809010 in thread
+;;;    #<THREAD tid=663886 "main thread" RUNNING {1201758003}>:
+;;;      "HOME" fell through ETYPECASE expression.
+;;;      Wanted one of (NULL (ALIEN (* CHAR)) SIMPLE-BASE-STRING SIMPLE-STRING).
+;;;
+;;; That seems slightly amiss, but I am unwilling to deoptimize the above example by adding
+;;; more branching to the call-out, given absence of any complaints about it in forever.
+#+sb-unicode
+(deftransform sb-alien::string-to-c-string ((string type)
+                                            (simple-base-string (constant-arg (eql :utf8))))
+  'string)
diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index e06f392d3..6eafd2a28 100644
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -16,6 +16,7 @@
 ;;;; more information.
 
 (cl:in-package :cl-user)
+(load "compiler-test-util.lisp")
 
 ;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN)
 ;;; was messed up so badly that trying to execute expressions like
@@ -586,6 +587,20 @@
       (multiple-value-bind (i j k) (funcall fun (addr a) (addr a) nil)
         (assert (= i j k 1))))))
 
+;;; Permanent fnames are omitted from the list of referenced Lisp linkage table
+;;; indices in the code header. Prevent that behavior.
+(sb-int:encapsulate 'sb-int:permanent-fname-p 'test-shim #'sb-int:constantly-nil)
+(with-test (:name :string-passing-no-conversion :skipped-on (:not :sb-unicode))
+  (flet ((has-call (arg-type)
+           (let ((f (compile nil`(lambda (s)
+                                   (with-alien ((getenv (function unsigned utf8-string) :extern))
+                                     (alien-funcall getenv (the ,arg-type s)))))))
+             (find 'sb-alien::string-to-c-string (ctu:find-named-callees f)))))
+    ;; Positive assertion that passing STRING may (in theory) do a conversion
+    (assert (has-call 'string))
+    ;; Negative assertion that passing SIMPLE-BASE-STRING will never do a conversion
+    (assert (not (has-call 'simple-base-string)))))
+
 (cl:in-package "SB-KERNEL")
 (test-util:with-test (:name :hash-consing)
   (assert (eq (parse-alien-type '(integer 9) nil)

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Derive the type of (make-array (list unknown constant) ...)

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  39c030446cd9a462481bfc7eac29b386baf2644b (commit)
      from  2dee7acc1f2e4b291764fb4d99a369ee142c3b17 (commit)

- Log -----------------------------------------------------------------
commit 39c030446cd9a462481bfc7eac29b386baf2644b
Author: Vasily Postnicov <sha...@gm...>
Date:   Sat Nov 1 09:44:48 2025 +0300

    Derive the type of (make-array (list unknown constant) ...)
---
 src/compiler/array-tran.lisp | 15 ++++++++++-----
 tests/array.pure.lisp        |  2 +-
 tests/compiler.pure.lisp     | 13 +++++--------
 3 files changed, 16 insertions(+), 14 deletions(-)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index c0793ca6d..fdac6fba7 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -1005,12 +1005,17 @@
               (loop for d in dims for i from 0
                     collect (list (make-symbol (format nil "D~D" i))
                                   `(the index ,d)))))
-           (dims (if axis-bindings (mapcar #'car axis-bindings) dims))
+           (dim-vars (if axis-bindings (mapcar #'car axis-bindings) dims))
            (size (make-symbol "SIZE"))
            (type (list (cond ((eq et unsupplied) t)
                              (et-constp (constant-form-value et env))
                              (t '*))
-                       (if dims-constp dims (length dims))))
+                       (mapcar
+                        (lambda (dim)
+                          (if (constantp dim env)
+                              (constant-form-value dim env)
+                              '*))
+                        dims)))
            (type (if adjustable
                      `(and (array ,@type) (not simple-array))
                      `(simple-array ,@type)))
@@ -1021,9 +1026,9 @@
                     sb-vm:complex-array-widetag
                     sb-vm:simple-array-widetag)
                ,@(sb-vm::make-array-header-inits
-                  `(make-array ,size ,@keys) size dims)))))
-      `(let* (,@axis-bindings ,@et-binding (,size (the index (* ,@dims))))
-         ,(cond ((or (not contents) (and dims-constp (equal dims data-dims)))
+                  `(make-array ,size ,@keys) size dim-vars)))))
+      `(let* (,@axis-bindings ,@et-binding (,size (the index (* ,@dim-vars))))
+         ,(cond ((or (not contents) (and dims-constp (equal dim-vars data-dims)))
                  ;; If no :initial-contents, or definitely correct shape,
                  ;; then just call the constructor.
                  alloc-form)
diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 3150a25d1..60b3d9ad0 100644
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -408,7 +408,7 @@
              (ecase inline
                (inline
                 (assert failure-p)
-                (assert (= 1 (length warnings))))
+                (assert (= 2 (length warnings))))
                (notinline
                 (assert failure-p)
                 (assert (= 1 (length warnings)))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f7e1ac544..6bccb69f3 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3244,7 +3244,10 @@
      ;; union types
      (let ((s (the (simple-string 10) (eval "0123456789"))))
        (array-in-bounds-p s 9))
-     t)
+     t
+     (let ((a (make-array (list (random 20) 1))))
+       (array-in-bounds-p a 5 2))
+     nil)
     (must-not-optimize
      ;; don't trust non-simple array length in safety=1
      (let ((a (the (array * (10 20)) (make-array '(10 20) :adjustable t))))
@@ -3267,13 +3270,7 @@
        (array-in-bounds-p a (get-universal-time) 1))
      ;; unknown lower bound
      (let ((a (make-array '(5 30))))
-       (array-in-bounds-p a 0 (- (get-universal-time))))
-     ;; in theory we should be able to optimize
-     ;; the following but the current implementation
-     ;; doesn't cut it because the array type's
-     ;; dimensions get reported as (* *).
-     (let ((a (make-array (list (random 20) 1))))
-       (array-in-bounds-p a 5 2)))))
+       (array-in-bounds-p a 0 (- (get-universal-time)))))))
 
 ;;; optimizing (EXPT -1 INTEGER)
 (with-test (:name (expt -1 integer))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Preserve lvar types when doing unconvert-tail-calls.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  2dee7acc1f2e4b291764fb4d99a369ee142c3b17 (commit)
      from  8343fd0935d37eba79f2afacb737429f7a1e41a9 (commit)

- Log -----------------------------------------------------------------
commit 2dee7acc1f2e4b291764fb4d99a369ee142c3b17
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 23:04:11 2025 +0300

    Preserve lvar types when doing unconvert-tail-calls.
    
    Fixes lp#2129649
---
 src/compiler/locall.lisp | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index ca861920b..e5f78bb90 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -1183,7 +1183,8 @@
 ;;; the RETURN-RESULT, because the return might have been deleted (if
 ;;; all calls were TR.)
 (defun unconvert-tail-calls (fun call next-block)
-  (let (maybe-terminate)
+  (let (maybe-terminate
+        used-lvar)
     (do-sset-elements (called (lambda-calls-or-closes fun))
       (when (lambda-p called)
         (dolist (ref (leaf-refs called))
@@ -1210,7 +1211,7 @@
                        ;; derive different results from different
                        ;; calls.)
                        (push this-call maybe-terminate)
-                       (add-lvar-use this-call lvar))))
+                       (add-lvar-use this-call (setf used-lvar lvar)))))
                 (deleted)
                 ;; The called function might be an assignment in the
                 ;; case where we are currently converting that function.
@@ -1218,6 +1219,9 @@
                 ;; function.
                 (assignment
                  (aver (eq called fun)))))))))
+    (when used-lvar
+      (setf (lvar-%derived-type used-lvar) nil)
+      (assert-lvar-type used-lvar (node-derived-type call) **zero-typecheck-policy**))
     maybe-terminate))
 
 ;;; Deal with returning from a LET or assignment that we are

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Better array-type union for intersections with negations.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  8343fd0935d37eba79f2afacb737429f7a1e41a9 (commit)
      from  1aad474567b0fdafda4f56c30e31a9ae30fad499 (commit)

- Log -----------------------------------------------------------------
commit 8343fd0935d37eba79f2afacb737429f7a1e41a9
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 19:20:12 2025 +0300

    Better array-type union for intersections with negations.
    
    Fixes lp#2130441
---
 src/code/type.lisp   | 65 ++++++++++++++++++++++++++++++++++------------------
 tests/type.pure.lisp |  4 +++-
 2 files changed, 46 insertions(+), 23 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index a59726314..e37d32651 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3652,28 +3652,49 @@ expansion happened."
                                                :element-type *wild-type*)
                             type1))))))
     (intersection-type
-     ;; This is the same as in the intersection-simple-union2-type-method,
-     ;; but it doesn't stop if type-union produces a new union type:
-     ;; (or (and vector (not (simple-array t))) simple-vector)
-     ;; => vector
-     (let (unions
-           non-compound)
-       (do ((t1s (intersection-type-types type1) (cdr t1s)))
-           ((null t1s))
-         (let ((union (or (type-union2 type2 (car t1s))
-                          (return-from array-complex-union2-type-method))))
-           (if (typep union '(or compound-type negation-type))
-               (push union unions)
-               (setf non-compound (if non-compound
-                                      (type-intersection non-compound union)
-                                      union)))))
-       (when non-compound
-         (loop for (union . more) on unions
-               do (setf non-compound (type-intersection non-compound union))
-               if (and more
-                       (typep non-compound '(or compound-type negation-type)))
-               return nil
-               finally (return non-compound)))))))
+     (cond (;; (or (and simple-array (not (array t)) (not vector)) (simple-array t))
+            ;; => (or (and simple-array (not vector)) (simple-array t))
+            (and (neq (array-type-complexp type2) :maybe)
+                 (let (not-type
+                       supertype)
+                   (loop for type in (intersection-type-types type1)
+                         if (negation-type-p type)
+                         do (when (csubtypep (negation-type-type type)
+                                             (change-array-type-complexp type2 :maybe))
+                              (setf not-type type))
+                         else if (and
+                                  (array-type-p type)
+                                  (eq (array-type-complexp type)
+                                      (array-type-complexp type2))
+                                  (csubtypep type2 type))
+                         do (setf supertype t))
+                   (when (and not-type supertype)
+                     (type-union (%type-intersection (remove not-type
+                                                             (intersection-type-types type1)))
+                                 type2)))))
+           (t
+            ;; This is the same as in the intersection-simple-union2-type-method,
+            ;; but it doesn't stop if type-union produces a new union type:
+            ;; (or (and vector (not (simple-array t))) simple-vector)
+            ;; => vector
+            (let (unions
+                  non-compound)
+              (do ((t1s (intersection-type-types type1) (cdr t1s)))
+                  ((null t1s))
+                (let ((union (or (type-union2 type2 (car t1s))
+                                 (return-from array-complex-union2-type-method))))
+                  (if (typep union '(or compound-type negation-type))
+                      (push union unions)
+                      (setf non-compound (if non-compound
+                                             (type-intersection non-compound union)
+                                             union)))))
+              (when non-compound
+                (loop for (union . more) on unions
+                      do (setf non-compound (type-intersection non-compound union))
+                      if (and more
+                              (typep non-compound '(or compound-type negation-type)))
+                      return nil
+                      finally (return non-compound)))))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 0f2abe699..ff7b7ebd3 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1109,7 +1109,9 @@
            (specifier-type '(or (not vector) (array bit)))))
   (assert (eq
            (specifier-type '(or (and (not (array fixnum)) (not (array t)) vector) (vector t)))
-           (specifier-type '(and (not (array fixnum)) vector)))))
+           (specifier-type '(and (not (array fixnum)) vector))))
+  (assert (eq (specifier-type '(or (and simple-array (not (array t)) (not vector)) (simple-array t)))
+              (specifier-type '(or (and simple-array (not vector)) (simple-array t))))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Prevent infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  1aad474567b0fdafda4f56c30e31a9ae30fad499 (commit)
      from  79ef6ad65f133bda53c61a629d59e5b11304120a (commit)

- Log -----------------------------------------------------------------
commit 1aad474567b0fdafda4f56c30e31a9ae30fad499
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 18:55:31 2025 +0300

    Prevent infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
---
 src/code/type.lisp | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index a0504e3c3..a59726314 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3661,15 +3661,18 @@ expansion happened."
        (do ((t1s (intersection-type-types type1) (cdr t1s)))
            ((null t1s))
          (let ((union (or (type-union2 type2 (car t1s))
-                          (return-from ARRAY-COMPLEX-UNION2-TYPE-METHOD))))
+                          (return-from array-complex-union2-type-method))))
            (if (typep union '(or compound-type negation-type))
                (push union unions)
                (setf non-compound (if non-compound
                                       (type-intersection non-compound union)
                                       union)))))
        (when non-compound
-         (loop for union in unions
+         (loop for (union . more) on unions
                do (setf non-compound (type-intersection non-compound union))
+               if (and more
+                       (typep non-compound '(or compound-type negation-type)))
+               return nil
                finally (return non-compound)))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Ignore ordering in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  79ef6ad65f133bda53c61a629d59e5b11304120a (commit)
      from  d042ffddeccce0230de0bb6c4cc4bbe2d119f453 (commit)

- Log -----------------------------------------------------------------
commit 79ef6ad65f133bda53c61a629d59e5b11304120a
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 15:44:39 2025 +0300

    Ignore ordering in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
    
    Fixes lp#2130424
---
 src/code/type.lisp   | 27 +++++++++++++++------------
 tests/type.pure.lisp |  5 ++++-
 2 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index ba277029c..a0504e3c3 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3656,18 +3656,21 @@ expansion happened."
      ;; but it doesn't stop if type-union produces a new union type:
      ;; (or (and vector (not (simple-array t))) simple-vector)
      ;; => vector
-     (let ((accumulator *universal-type*))
-       (do ((t2s (intersection-type-types type1) (cdr t2s)))
-           ((null t2s) accumulator)
-         (let ((union (type-union2 type2 (car t2s))))
-           (when (or (not union)
-                     (and (or (compound-type-p union)
-                              (negation-type-p union))
-                          (or (compound-type-p accumulator)
-                              (negation-type-p accumulator))))
-             (return nil))
-           (setf accumulator
-                 (type-intersection accumulator union))))))))
+     (let (unions
+           non-compound)
+       (do ((t1s (intersection-type-types type1) (cdr t1s)))
+           ((null t1s))
+         (let ((union (or (type-union2 type2 (car t1s))
+                          (return-from ARRAY-COMPLEX-UNION2-TYPE-METHOD))))
+           (if (typep union '(or compound-type negation-type))
+               (push union unions)
+               (setf non-compound (if non-compound
+                                      (type-intersection non-compound union)
+                                      union)))))
+       (when non-compound
+         (loop for union in unions
+               do (setf non-compound (type-intersection non-compound union))
+               finally (return non-compound)))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 9c6af7e02..0f2abe699 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1106,7 +1106,10 @@
            (specifier-type 'vector)))
   (assert (eq
            (specifier-type '(or (not vector) bit-vector))
-           (specifier-type '(or (not vector) (array bit))))))
+           (specifier-type '(or (not vector) (array bit)))))
+  (assert (eq
+           (specifier-type '(or (and (not (array fixnum)) (not (array t)) vector) (vector t)))
+           (specifier-type '(and (not (array fixnum)) vector)))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  d042ffddeccce0230de0bb6c4cc4bbe2d119f453 (commit)
      from  4cf1ac31714c4310c69e124e7273c80118044312 (commit)

- Log -----------------------------------------------------------------
commit d042ffddeccce0230de0bb6c4cc4bbe2d119f453
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 02:16:44 2025 +0300

    Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
    
    Fixes lp#2130389
---
 src/code/type.lisp | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index b8b2a46bc..ba277029c 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3661,7 +3661,8 @@ expansion happened."
            ((null t2s) accumulator)
          (let ((union (type-union2 type2 (car t2s))))
            (when (or (not union)
-                     (and (union-type-p union)
+                     (and (or (compound-type-p union)
+                              (negation-type-p union))
                           (or (compound-type-p accumulator)
                               (negation-type-p accumulator))))
              (return nil))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  4cf1ac31714c4310c69e124e7273c80118044312 (commit)
      from  078026b19f84187e988c2585caf9e67dc469cf8f (commit)

- Log -----------------------------------------------------------------
commit 4cf1ac31714c4310c69e124e7273c80118044312
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 01:31:57 2025 +0300

    Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
    
    Fixes lp#2130387
---
 src/code/type.lisp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index d90833396..b8b2a46bc 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3662,7 +3662,7 @@ expansion happened."
          (let ((union (type-union2 type2 (car t2s))))
            (when (or (not union)
                      (and (union-type-p union)
-                          (or (intersection-type-p accumulator)
+                          (or (compound-type-p accumulator)
                               (negation-type-p accumulator))))
              (return nil))
            (setf accumulator

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  078026b19f84187e988c2585caf9e67dc469cf8f (commit)
      from  e37f5a77cb343a411e5f12afd167f45d438c656a (commit)

- Log -----------------------------------------------------------------
commit 078026b19f84187e988c2585caf9e67dc469cf8f
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Oct 31 00:47:53 2025 +0300

    Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
    
    Fixes lp#2130377
---
 src/code/type.lisp | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 248799557..d90833396 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3663,8 +3663,7 @@ expansion happened."
            (when (or (not union)
                      (and (union-type-p union)
                           (or (intersection-type-p accumulator)
-                              (and (negation-type-p accumulator)
-                                   (intersection-type-p (negation-type-type accumulator))))))
+                              (negation-type-p accumulator))))
              (return nil))
            (setf accumulator
                  (type-intersection accumulator union))))))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Institute a depth cutoff for source paths

[crhodes <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  e37f5a77cb343a411e5f12afd167f45d438c656a (commit)
      from  747a7d7acdeee7af812ff90b16a7c4ac381b5bdc (commit)

- Log -----------------------------------------------------------------
commit e37f5a77cb343a411e5f12afd167f45d438c656a
Author: Christophe Rhodes <cs...@ca...>
Date:   Thu Oct 30 21:12:00 2025 +0000

    Institute a depth cutoff for source paths
    
    Somewhat arbitrarily choose 100, since that is where the existing test
    for lp#654289 puts the dividing line between "small" and "big".  What
    this means in practice is that code nested more than 100-levels deep
    from the toplevel will not have accurate source path information
    associated with it.
    
    Make FORM-NUMBER-TRANSLATIONS and SUB-FIND-SOURCE-PATHS consistent in
    how they register (or, rather, do not register) instances of code
    while traversing the current form that are EQL to forms that have
    already been seen.  This allows a consistency test on code with a
    quoted constant as from the lp#654289 bug report.  Also re-enable the
    compiler scaling test, since we have carefully chosen the cutoff to
    make it passable.  (It's still probably a bad idea to put a literal
    1000-level tree in your source code.)
---
 src/code/debug-int.lisp                    | 10 ++++++----
 src/compiler/ir1tran.lisp                  | 15 ++++++++++-----
 tests/compiler.pure.lisp                   |  2 +-
 tests/form-number-translations.impure.lisp |  9 ++++++++-
 4 files changed, 25 insertions(+), 11 deletions(-)

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 4c23b509c..4dd0ebb10 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -3128,11 +3128,13 @@ register."
 (defun form-number-translations (form tlf-number)
   (let ((seen nil)
         (translations (make-array 12 :fill-pointer 0 :adjustable t)))
-    (labels ((translate1 (form path)
+    (labels ((translate1 (form path depth)
                (unless (member form seen)
                  (push form seen)
                  (vector-push-extend (cons (fill-pointer translations) path)
                                      translations)
+                 (unless (< depth 100) ; ARB but has to be the same as in SUB-FIND-SOURCE-PATHS
+                   (return-from translate1))
                  (let ((pos 0)
                        (subform form)
                        (trail form))
@@ -3145,9 +3147,9 @@ register."
                                      ((atom subform) (return)))
                                    (let ((fm (car subform)))
                                      (cond
-                                       ((consp fm) (translate1 fm (cons pos path)))
+                                       ((consp fm) (translate1 fm (cons pos path) (1+ depth)))
                                        ((comma-p fm)
-                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path)))))
+                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path) (1+ depth)))))
                                    (setq subform (cdr subform)
                                          pos (1+ pos))
                                    (when (eq subform trail) (return)))))
@@ -3155,7 +3157,7 @@ register."
                        (frob)
                        (frob)
                        (setq trail (cdr trail))))))))
-      (translate1 form (list tlf-number)))
+      (translate1 form (list tlf-number) 0))
     (coerce translations 'simple-vector)))
 
 ;;; FORM is a top level form, and path is a source-path into it. This
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 6d83e0fe7..7b8f92f11 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -552,11 +552,14 @@
 (defun find-source-paths (form tlf-num)
   (declare (type index tlf-num))
   (let ((*current-form-number* 0))
-    (sub-find-source-paths form (list tlf-num)))
+    (sub-find-source-paths form (list tlf-num) 0))
   (values))
-(defun sub-find-source-paths (form path)
+(defun sub-find-source-paths (form path depth)
   (unless (get-source-path form)
     (note-source-path form path)
+    (unless (< depth 100) ; ARB, see lp#654289
+      #+sb-xc-host (bug "Unexpected depth of code")
+      #-sb-xc-host (return-from sub-find-source-paths))
     (let ((pos 0)
           (subform form)
           (trail form))
@@ -572,12 +575,14 @@
                         (cond
                           ((consp fm)
                            (incf *current-form-number*)
-                           (sub-find-source-paths fm (cons pos path)))
+                           (sub-find-source-paths fm (cons pos path) (1+ depth)))
                           ;; (a b ,c d) -> (a b (comma c) d)
                           ((comma-p fm)
                            (incf *current-form-number*)
-                           (sub-find-source-paths (list 'comma (comma-expr fm)) (cons pos path)))
-                          ((not (zerop pos)) (note-source-path subform pos path))))
+                           (sub-find-source-paths (list 'comma (comma-expr fm)) (cons pos path) (1+ depth)))
+                          ((not (zerop pos))
+                           (unless (get-source-path subform)
+                             (note-source-path subform pos path)))))
                       (setq subform (cdr subform)
                             pos (1+ pos))
                       (when (eq subform trail) (return)))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 2eddb04d8..f7e1ac544 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3739,7 +3739,7 @@
          (load-time-value (the (values fixnum) 42)))
     (() 42)))
 
-(with-test (:name (compile :bug-654289) :fails-on :sbcl)
+(with-test (:name (compile :bug-654289))
   ;; Test that compile-times don't explode when quoted constants
   ;; get big.
   (labels ((time-n (n)
diff --git a/tests/form-number-translations.impure.lisp b/tests/form-number-translations.impure.lisp
index ea4f847d4..750af4114 100644
--- a/tests/form-number-translations.impure.lisp
+++ b/tests/form-number-translations.impure.lisp
@@ -22,7 +22,7 @@
 (defun source-paths (form)
   (let ((sb-c::*source-paths* (make-hash-table :test 'eq))
         (sb-c::*current-form-number* 0))
-    (sb-c::sub-find-source-paths form (list 0))
+    (sb-c::sub-find-source-paths form (list 0) 0)
     (let (result)
       (sb-int:dohash ((k v) sb-c::*source-paths* :result result)
         (declare (ignore k))
@@ -91,3 +91,10 @@
                                      expr))))
                          `(unless ,expr
                             (%failed-aver ',(replace-symbols expr)))))))
+
+(with-test (:name (:static :deep-tree :check-consistency))
+  (labels ((make-tree (n acc)
+             (cond ((zerop n) acc)
+                   (t (make-tree (1- n) (cons acc acc))))))
+    (check-consistency (eval `'(defmacro deep-tree (n)
+                                 (nthcdr n ',(make-tree 200 nil)))))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Change the incrementing of form number in SUB-FIND-SOURCE-PATHS

[crhodes <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  747a7d7acdeee7af812ff90b16a7c4ac381b5bdc (commit)
      from  c61d1c591217659d1ce2edad475bf0c460975f4e (commit)

- Log -----------------------------------------------------------------
commit 747a7d7acdeee7af812ff90b16a7c4ac381b5bdc
Author: Christophe Rhodes <cs...@ca...>
Date:   Tue Oct 21 11:10:34 2025 +0100

    Change the incrementing of form number in SUB-FIND-SOURCE-PATHS
    
    Increment only on recursion, so that the final form number is
    consistent with SB-DI::FORM-NUMBER-TRANSLATIONS.  This allows a
    stronger consistency check.
---
 src/compiler/ir1tran.lisp                  |  3 ++-
 tests/form-number-translations.impure.lisp | 27 +++++++++++++++++----------
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 476042770..6d83e0fe7 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -557,7 +557,6 @@
 (defun sub-find-source-paths (form path)
   (unless (get-source-path form)
     (note-source-path form path)
-    (incf *current-form-number*)
     (let ((pos 0)
           (subform form)
           (trail form))
@@ -572,9 +571,11 @@
                       (let ((fm (car subform)))
                         (cond
                           ((consp fm)
+                           (incf *current-form-number*)
                            (sub-find-source-paths fm (cons pos path)))
                           ;; (a b ,c d) -> (a b (comma c) d)
                           ((comma-p fm)
+                           (incf *current-form-number*)
                            (sub-find-source-paths (list 'comma (comma-expr fm)) (cons pos path)))
                           ((not (zerop pos)) (note-source-path subform pos path))))
                       (setq subform (cdr subform)
diff --git a/tests/form-number-translations.impure.lisp b/tests/form-number-translations.impure.lisp
index 67e6564ed..ea4f847d4 100644
--- a/tests/form-number-translations.impure.lisp
+++ b/tests/form-number-translations.impure.lisp
@@ -28,15 +28,8 @@
         (declare (ignore k))
         (push (cdr v) result)))))
 
-;;; It's not actually clear to me what the coupling /should/ be.  The
-;;; source paths contain extra entries compared with the form number
-;;; translations, but somewhat bizarrely those extra entries are
-;;; associated with a form number that is one above what I would
-;;; expect (that is, they seem logically attached to the "next"
-;;; depth-first number rather than the "current" one).  What does seem
-;;; to be necessary is that all entries in TRANSLATIONS should have a
-;;; corresponding entry in SOURCE-PATHS.
-
+;;; All entries in TRANSLATIONS should have a corresponding entry in
+;;; SOURCE-PATHS.
 (defun find-unfound-translations (translations source-paths)
   (let ((unfound-translations nil))
     (sb-int:dovector (tr translations)
@@ -44,10 +37,24 @@
         (push tr unfound-translations)))
     unfound-translations))
 
+;;; The shortest source-paths for each form number should identify a
+;;; translated form.
+(defun find-untranslated-paths (translations source-paths)
+  (let ((untranslated-paths nil))
+    (let ((copy (copy-list source-paths)))
+      (setf copy (sort copy #'> :key #'length))
+      (setf copy (stable-sort copy #'< :key #'car))
+      (setf copy (remove-duplicates copy :key #'car))
+      (dolist (path copy untranslated-paths)
+        (unless (find path translations :test #'equal)
+          (push path untranslated-paths))))))
+
 (defun check-consistency (form)
   (let ((translations (translations form))
         (source-paths (source-paths form)))
-    (assert (null (find-unfound-translations translations source-paths)))))
+    (assert (null (find-unfound-translations translations source-paths)))
+    (assert (= (length translations) (1+ (reduce #'max source-paths :key #'car))))
+    (assert (null (find-untranslated-paths translations source-paths)))))
 
 (with-test (:name (:static macrolet :check-consistency))
   (check-consistency '(macrolet ((def (x y) `(defun ,x (1+ ,y)))) (def ffloor) (def fceiling))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Don't special-case QUOTE in source path finding

[crhodes <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  c61d1c591217659d1ce2edad475bf0c460975f4e (commit)
      from  9270c144c68932985b850aeae18283aadc17c445 (commit)

- Log -----------------------------------------------------------------
commit c61d1c591217659d1ce2edad475bf0c460975f4e
Author: Christophe Rhodes <cs...@ca...>
Date:   Tue Oct 21 11:00:51 2025 +0100

    Don't special-case QUOTE in source path finding
    
    There is some danger that removing this will cause slowdowns in
    compiling code with large list/tree literal constants -- see lp#654289
    for one example of this.  It's probably the case that embedding large
    list/tree literal constants is A Bad Idea for other reasons -- for
    many of the same reasons as with structured objects in DEFCONSTANT, so
    we should probably enhance the source tracking for forms involving
    quotes inside backquotes rather than speed of compiling code with
    somewhat dubious list constants.
---
 contrib/sb-cover/file-info-tests.lisp      | 31 ++++++++++++++++++++++++++++++
 contrib/sb-cover/test-data-quote.lisp      |  4 ++++
 src/code/debug-int.lisp                    |  7 +------
 src/compiler/ir1tran.lisp                  |  5 -----
 tests/compiler.pure.lisp                   |  2 +-
 tests/form-number-translations.impure.lisp | 16 +++++++++++++++
 6 files changed, 53 insertions(+), 12 deletions(-)

diff --git a/contrib/sb-cover/file-info-tests.lisp b/contrib/sb-cover/file-info-tests.lisp
index 7eb6fa9bf..394c7458f 100644
--- a/contrib/sb-cover/file-info-tests.lisp
+++ b/contrib/sb-cover/file-info-tests.lisp
@@ -117,3 +117,34 @@
                   0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
                   ;;    ` ( 0   1   , ( 1 +   x )   3   .   , ( i f   ( e v e n p   x )   ( l i s t   4 )   ( l i s t   5 ) ) ) )
                   0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 5 5 5 5 5 5 5 5 5 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
+
+(sb-cover:clear-coverage)
+(compile-load "test-data-quote")
+(assert (equalp (get-states "test-data-quote")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   q u o t e - c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 1   ' , ( i f   (  e  v  e  n  p     x  )    ( 1 +   x )   ( +   x   2 ) )   , ( +   x   3 ) ) )
+                  0 1 1 2 2 2 2 2 2 2 2 2 2 10 10 10 10 10 10 10 10 10 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1)))
+
+(quote-comma 0)
+(assert (equalp (get-states "test-data-quote")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   q u o t e - c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 1   ' , ( i f   ( e v e n p   x )   ( 1 +   x )   ( +   x   2 ) )   , ( +   x   3 ) ) )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 9 9 9 9 9 9 9 9 9 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1)))
+
+(quote-comma 1)
+(assert (equalp (get-states "test-data-quote")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   q u o t e - c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 1   ' , ( i f   ( e v e n p   x )   ( 1 +   x )   ( +   x   2 ) )   , ( +   x   3 ) ) )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 5 5 5 5 5 5 5 5 5 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
diff --git a/contrib/sb-cover/test-data-quote.lisp b/contrib/sb-cover/test-data-quote.lisp
new file mode 100644
index 000000000..c5c5c0785
--- /dev/null
+++ b/contrib/sb-cover/test-data-quote.lisp
@@ -0,0 +1,4 @@
+(in-package sb-cover-test)
+
+(defun quote-comma (x)
+  `(1 ',(if (evenp x) (1+ x) (+ x 2)) ,(+ x 3)))
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 72a84c8c2..4c23b509c 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -3147,12 +3147,7 @@ register."
                                      (cond
                                        ((consp fm) (translate1 fm (cons pos path)))
                                        ((comma-p fm)
-                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path)))
-                                       ;; Don't look into quoted
-                                       ;; constants, but see also the
-                                       ;; comment in
-                                       ;; SB-C::SUB-FIND-SOURCE-PATH
-                                       ((eq 'quote fm) (return))))
+                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path)))))
                                    (setq subform (cdr subform)
                                          pos (1+ pos))
                                    (when (eq subform trail) (return)))))
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 941d9cda6..476042770 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -576,11 +576,6 @@
                           ;; (a b ,c d) -> (a b (comma c) d)
                           ((comma-p fm)
                            (sub-find-source-paths (list 'comma (comma-expr fm)) (cons pos path)))
-                          ;; KLUDGE: this assumes all uses of the
-                          ;; QUOTE symbol are actual quotations, which
-                          ;; is not true in general [consider e.g.
-                          ;; (let ((quote (setq x 1))) ...)].
-                          ((eq 'quote fm) (return))
                           ((not (zerop pos)) (note-source-path subform pos path))))
                       (setq subform (cdr subform)
                             pos (1+ pos))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f7e1ac544..2eddb04d8 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3739,7 +3739,7 @@
          (load-time-value (the (values fixnum) 42)))
     (() 42)))
 
-(with-test (:name (compile :bug-654289))
+(with-test (:name (compile :bug-654289) :fails-on :sbcl)
   ;; Test that compile-times don't explode when quoted constants
   ;; get big.
   (labels ((time-n (n)
diff --git a/tests/form-number-translations.impure.lisp b/tests/form-number-translations.impure.lisp
index da0a136a8..67e6564ed 100644
--- a/tests/form-number-translations.impure.lisp
+++ b/tests/form-number-translations.impure.lisp
@@ -68,3 +68,19 @@
                                         (,name (gensym ,(symbol-name name))))
                                     `(let ((,,name ,,exp-temp))
                                        ,,(frob (rest specs) body))))))))))
+
+(with-test (:name (:static :aver :check-consistency))
+  (check-consistency '(defmacro aver (expr)
+                       ;; Don't hold on to symbols, helping shake-packages.
+                       (labels ((replace-symbols (expr)
+                                  (typecase expr
+                                    (null expr)
+                                    (symbol
+                                     (symbol-name expr))
+                                    (cons
+                                     (cons (replace-symbols (car expr))
+                                           (replace-symbols (cdr expr))))
+                                    (t
+                                     expr))))
+                         `(unless ,expr
+                            (%failed-aver ',(replace-symbols expr)))))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Rewrite source-path generation for commas

[crhodes <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  9270c144c68932985b850aeae18283aadc17c445 (commit)
      from  4d929b9352a4bdbb9323cbb10b66f527e1eb9254 (commit)

- Log -----------------------------------------------------------------
commit 9270c144c68932985b850aeae18283aadc17c445
Author: Christophe Rhodes <cs...@ca...>
Date:   Mon Oct 20 20:16:03 2025 +0100

    Rewrite source-path generation for commas
    
    When generating source-paths, treat a comma struct as representing a
    list (comma <expr>), handling the cases when the comma is the bare
    CDR or recursion down the CAR of a list.  Adapt getting the original
    source for a source path to handle this convention, and
    form-number-translations likewise.
    
    This allows sb-cover to define custom comma and backq reader macros
    which actually generate this list structure, making the simple
    list-walking to find character positions there correct.  (It also
    allows a minor modification to SLIME along the same lines to restore
    buffer annotations at the right place in backquoted forms.)
    
    Include tests of SB-COVER on backquoted / unquoted forms, and an
    "incompatible change" note in NEWS.
---
 NEWS                                       |  8 +++++
 contrib/sb-cover/cover.lisp                | 20 +++++++++++++
 contrib/sb-cover/file-info-tests.lisp      | 31 ++++++++++++++++++++
 contrib/sb-cover/test-data-comma.lisp      |  4 +++
 src/code/debug-int.lisp                    | 33 ++++++++++++---------
 src/compiler/ir1report.lisp                | 37 ++++++++++++++---------
 src/compiler/ir1tran.lisp                  | 47 +++++++++++++-----------------
 tests/error-source-path.impure.lisp        | 24 +++++++--------
 tests/form-number-translations.impure.lisp | 17 +++++++++++
 9 files changed, 154 insertions(+), 67 deletions(-)

diff --git a/NEWS b/NEWS
index 0ac21366c..2b50fb64f 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,13 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
+changes relative to sbcl-2.5.10:
+  * incompatible change: the compiler's internal representation of "source
+    paths" for unquoted forms within backquotes has changed.  Other developer
+    tools using this representation, including callers of some exported
+    SB-INTROSPECT functions, will misreport the location of signalled
+    conditions and/or definitions in top-level forms including backquotes and
+    commas.
+
 changes in sbcl-2.5.10 relative to sbcl-2.5.9:
   * platform support:
     ** handling of "./" and "../" in pathname functions on Windows is improved.
diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index 52ab819b2..d0c7b899c 100644
--- a/contrib/sb-cover/cover.lisp
+++ b/contrib/sb-cover/cover.lisp
@@ -668,12 +668,32 @@ The source locations are stored in SOURCE-MAP."
           (when fn
             (set-macro-character char (make-source-recorder fn source-map)
                                  term tab)))))
+    (set-macro-character #\` (make-source-recorder #'read-backq source-map))
+    (set-macro-character #\, (make-source-recorder #'read-comma source-map))
     (set-macro-character #\(
                          (make-source-recorder
                           (make-recording-read-list source-map)
                           source-map))
     tab))
 
+(defvar *backquote-level* 0)
+(defun read-backq (stream ignore)
+  (declare (ignore ignore))
+  (let ((*backquote-level* (1+ *backquote-level*)))
+    (list 'backquote (read stream t nil t))))
+(defun read-comma (stream ignore)
+  (declare (ignore ignore))
+  (unless (> *backquote-level* 0)
+    (when *read-suppress*
+      (return-from read-comma nil))
+    (error "comma found not within a corresponding backquote"))
+  (let ((flag-char (read-char stream)))
+    (case flag-char
+      ((#\. #\@))
+      (t (unread-char flag-char stream)))
+    (let ((*backquote-level* (1- *backquote-level*)))
+      (list 'comma (read stream t nil t)))))
+
 ;;; Ripped from SB-IMPL, since location recording on a cons-cell level
 ;;; can't be done just by simple read-table tricks.
 (defun make-recording-read-list (source-map)
diff --git a/contrib/sb-cover/file-info-tests.lisp b/contrib/sb-cover/file-info-tests.lisp
index bcf6cd0fa..7eb6fa9bf 100644
--- a/contrib/sb-cover/file-info-tests.lisp
+++ b/contrib/sb-cover/file-info-tests.lisp
@@ -86,3 +86,34 @@
                   0 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15
                   ;;      (  1  +     x  )  )
                   0 15 15 15 15 15 15 15 15 15)))
+
+(sb-cover:clear-coverage)
+(compile-load "test-data-comma")
+(assert (equalp (get-states "test-data-comma")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 0   1   , ( 1 +   x )   3   .   , ( i f   (  e  v  e  n  p     x  )    ( l i s t   4 )   ( l i s t   5 ) ) ) )
+                  0 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 10 10 10 10 10 10 10 10 10 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1)))
+
+(comma 1)
+(assert (equalp (get-states "test-data-comma")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 0   1   , ( 1 +   x )   3   .   , ( i f   ( e v e n p   x )   ( l i s t   4 )   ( l i s t   5 ) ) ) )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 6 6 6 6 6 6 6 6 6 1 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1)))
+
+(comma 2)
+(assert (equalp (get-states "test-data-comma")
+                ;;( i n - p a c k a g e   s b - c o v e r - t e s t )
+                #(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  0
+                  ;;( d e f u n   c o m m a   ( x )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+                  ;;    ` ( 0   1   , ( 1 +   x )   3   .   , ( i f   ( e v e n p   x )   ( l i s t   4 )   ( l i s t   5 ) ) ) )
+                  0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 5 5 5 5 5 5 5 5 5 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
diff --git a/contrib/sb-cover/test-data-comma.lisp b/contrib/sb-cover/test-data-comma.lisp
new file mode 100644
index 000000000..734b95539
--- /dev/null
+++ b/contrib/sb-cover/test-data-comma.lisp
@@ -0,0 +1,4 @@
+(in-package sb-cover-test)
+
+(defun comma (x)
+  `(0 1 ,(1+ x) 3 . ,(if (evenp x) (list 4) (list 5))))
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 8fe536cf4..72a84c8c2 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -3118,7 +3118,7 @@ register."
 
 ;;; This returns a table mapping form numbers to source-paths. A
 ;;; source-path indicates a descent into the TOPLEVEL-FORM form,
-;;; going directly to the subform corressponding to the form number.
+;;; going directly to the subform corresponding to the form number.
 ;;;
 ;;; The vector elements are in the same format as the compiler's
 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
@@ -3138,19 +3138,24 @@ register."
                        (trail form))
                    (declare (fixnum pos))
                    (macrolet ((frob ()
-                                '(progn
-                                  (when (atom subform) (return))
-                                  (let ((fm (car subform)))
-                                    (when (comma-p fm)
-                                      (setf fm (comma-expr fm)))
-                                    (cond ((consp fm)
-                                           (translate1 fm (cons pos path)))
-                                          ((eq 'quote fm)
-                                           ;; Don't look into quoted constants.
-                                           (return)))
-                                    (incf pos))
-                                  (setq subform (cdr subform))
-                                  (when (eq subform trail) (return)))))
+                                `(progn
+                                   (cond
+                                     ((comma-p subform)
+                                      (setq subform (list 'comma (comma-expr subform))))
+                                     ((atom subform) (return)))
+                                   (let ((fm (car subform)))
+                                     (cond
+                                       ((consp fm) (translate1 fm (cons pos path)))
+                                       ((comma-p fm)
+                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path)))
+                                       ;; Don't look into quoted
+                                       ;; constants, but see also the
+                                       ;; comment in
+                                       ;; SB-C::SUB-FIND-SOURCE-PATH
+                                       ((eq 'quote fm) (return))))
+                                   (setq subform (cdr subform)
+                                         pos (1+ pos))
+                                   (when (eq subform trail) (return)))))
                      (loop
                        (frob)
                        (frob)
diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 85d7fa753..76a0e6036 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -206,21 +206,30 @@
       (let ((form root)
             (current (rest rpath)))
         (loop
-         (when (comma-p form)
-           (setf form (comma-expr form)))
-         (when (atom form)
+         (loop
+          (unless (comma-p form)
             (return))
-          (let ((head (first form)))
-            (when (symbolp head)
-              (let ((name (symbol-name head)))
-                (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
-                  (context (source-form-context form))))))
-          (when (null current) (return))
-         (let ((cons (nthcdr (pop current) form)))
-           (setq form (if (comma-p cons)
-                          (comma-expr cons)
-                          (car cons)))))
-
+            ;; (... ,<expr> ...) -> (... (unquote <expr>) ...)
+          (aver (= (pop current) 1))
+          (setq form (comma-expr form)))
+         (when (atom form)
+           (return))
+         (let ((head (first form)))
+           (when (symbolp head)
+             (let ((name (symbol-name head)))
+               (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+                 (context (source-form-context form))))))
+         (when (null current)
+           (return))
+         (let ((count (pop current))
+               (next form))
+           (dotimes (i count)
+             (cond
+               ((comma-p next)
+                ;; (... . ,<expr>) -> (... . (unquote <expr>)) -> (... unquote <expr>)
+                (setq next (list (comma-expr next))))
+               (t (setq next (cdr next)))))
+           (setq form (car next))))
         (cond ((context)
                (values form (context)))
               ((and path root)
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 2caa9be33..941d9cda6 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -564,34 +564,29 @@
       (declare (fixnum pos))
       (macrolet ((frob ()
                    `(progn
-                      (let ((fm (cond ((comma-p subform)
-                                       (comma-expr subform))
-                                      ((atom subform)
-                                       (return))
-                                      (t
-                                       (car subform)))))
-                        (when (comma-p fm)
-                          (setf fm (comma-expr fm)))
-                        (cond ((consp fm)
-                               ;; If it's a cons, recurse.
-                               (sub-find-source-paths fm (cons pos path)))
-                              ((eq 'quote fm)
-                               ;; Don't look into quoted constants.
-                               ;; KLUDGE: this can't actually know about constants.
-                               ;; e.g. (let ((quote (error "foo")))) or
-                               ;; (list quote (error "foo")) are not
-                               ;; constants and yet are ignored.
-                               (return))
-                              ((not (zerop pos))
-                               ;; Otherwise store the containing form. It's not
-                               ;; perfect, but better than nothing.
-                               (note-source-path subform pos path)))
-                        (incf pos))
-                      (when (comma-p subform)
-                        (return))
-                      (setq subform (cdr subform))
+                      (cond
+                        ;; (a b . ,c) -> (a b comma c)
+                        ((comma-p subform)
+                         (setq subform (list 'comma (comma-expr subform))))
+                        ((atom subform) (return)))
+                      (let ((fm (car subform)))
+                        (cond
+                          ((consp fm)
+                           (sub-find-source-paths fm (cons pos path)))
+                          ;; (a b ,c d) -> (a b (comma c) d)
+                          ((comma-p fm)
+                           (sub-find-source-paths (list 'comma (comma-expr fm)) (cons pos path)))
+                          ;; KLUDGE: this assumes all uses of the
+                          ;; QUOTE symbol are actual quotations, which
+                          ;; is not true in general [consider e.g.
+                          ;; (let ((quote (setq x 1))) ...)].
+                          ((eq 'quote fm) (return))
+                          ((not (zerop pos)) (note-source-path subform pos path))))
+                      (setq subform (cdr subform)
+                            pos (1+ pos))
                       (when (eq subform trail) (return)))))
         (loop
+         ;; circularity detection by hare and tortoise
          (frob)
          (frob)
          (setq trail (cdr trail)))))))
diff --git a/tests/error-source-path.impure.lisp b/tests/error-source-path.impure.lisp
index ab412bf1b..f51cacbbc 100644
--- a/tests/error-source-path.impure.lisp
+++ b/tests/error-source-path.impure.lisp
@@ -339,27 +339,25 @@
            x)))
    (2 2)))
 
-(with-test (:name :dotted-comma-source-paths)
-  (assert-condition-source-paths
-   (lambda ()
-     `(progn
-        . ,(progn
-             (progn (setq x 1)))))
-   (1 1 1 1 2)))
-
 (with-test (:name (:backquote-comma-error :lp1361502))
   (assert-condition-source-paths
    (lambda () `(1 2 3 4 ,(progn (/ 1 0))))
-   (1 4 1 2)))
+   (1 1 4 1 2)))
 
-(with-test (:name :double-comma-source-paths)
+(with-test (:name :dotted-comma-source-paths)
+  (assert-condition-source-paths
+   (lambda ()
+     `(progn . ,(progn (progn (setq x 1)))))
+   (1 1 2 1 2)))
+
+(with-test (:name :dotted-double-comma-source-paths)
   (assert-condition-source-paths
    (lambda ()
      ``(progn . ,,(progn (progn (setq x 1)))))
-   (1 1 1 1 1 2)))
+   (1 1 1 2 1 1 2)))
 
-(with-test (:name :triple-comma-source-paths)
+(with-test (:name :dotted-triple-comma-source-paths)
   (assert-condition-source-paths
    (lambda ()
      ```(progn . ,,,(progn (progn (setq x 1)))))
-   (2)))
+   (1 1 1 1 2 1 1 1 2)))
diff --git a/tests/form-number-translations.impure.lisp b/tests/form-number-translations.impure.lisp
index f093b39ff..da0a136a8 100644
--- a/tests/form-number-translations.impure.lisp
+++ b/tests/form-number-translations.impure.lisp
@@ -51,3 +51,20 @@
 
 (with-test (:name (:static macrolet :check-consistency))
   (check-consistency '(macrolet ((def (x y) `(defun ,x (1+ ,y)))) (def ffloor) (def fceiling))))
+
+(with-test (:name (:static :once-only :check-consistency))
+  (check-consistency '(defmacro once-only (specs &body body)
+                       (named-let frob ((specs specs)
+                                        (body body))
+                         (if (null specs)
+                             `(progn ,@body)
+                             (let ((spec (first specs)))
+                               ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+                               (unless (proper-list-of-length-p spec 2)
+                                 (error "malformed ONCE-ONLY binding spec: ~S" spec))
+                               (let* ((name (first spec))
+                                      (exp-temp (gensym "ONCE-ONLY")))
+                                 `(let ((,exp-temp ,(second spec))
+                                        (,name (gensym ,(symbol-name name))))
+                                    `(let ((,,name ,,exp-temp))
+                                       ,,(frob (rest specs) body))))))))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Better array-type union canonicalization around dimensions.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  4d929b9352a4bdbb9323cbb10b66f527e1eb9254 (commit)
      from  6b81ee47cce1d9f999c611550a951c4115dc4b2f (commit)

- Log -----------------------------------------------------------------
commit 4d929b9352a4bdbb9323cbb10b66f527e1eb9254
Author: Stas Boukarev <sta...@gm...>
Date:   Thu Oct 30 23:23:18 2025 +0300

    Better array-type union canonicalization around dimensions.
    
    Fixes lp#2130374
---
 src/code/type.lisp   | 15 +++++++++++----
 tests/type.pure.lisp |  5 ++++-
 2 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 89b1cb94f..248799557 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -2504,8 +2504,11 @@ expansion happened."
                    :specialized-element-type (array-type-specialized-element-type type)))
 
 (defun change-array-type (type &key (complexp :inherit)
-                                    element-type)
-  (make-array-type (array-type-dimensions type)
+                                    element-type
+                                    (dimensions :inherit))
+  (make-array-type (if (eq dimensions :inherit)
+                       (array-type-dimensions type)
+                       dimensions)
                    :complexp (if (eq complexp :inherit)
                                  (array-type-complexp type)
                                  complexp)
@@ -3627,14 +3630,18 @@ expansion happened."
                ;; => (or vector (not (array t)))
                ((and
                  (not (and (eq (array-type-complexp not-type1) :maybe)
-                           (eq (array-type-specialized-element-type not-type1) *wild-type*)))
+                           (eq (array-type-specialized-element-type not-type1) *wild-type*)
+                           (eq (array-type-dimensions not-type1) '*)))
                  (csubtypep type2 not-type1))
                 (type-union (change-array-type type2
                                                :complexp (if (eq (array-type-complexp not-type1) :maybe)
                                                              :inherit
                                                              :maybe)
                                                :element-type (unless (eq (array-type-specialized-element-type not-type1) *wild-type*)
-                                                               *wild-type*))
+                                                               *wild-type*)
+                                               :dimensions (if (eq (array-type-dimensions not-type1) '*)
+                                                               :inherit
+                                                               '*))
                             type1))
                ;; (or (vector t) (not (simple-array t)))
                ;; (or vector (not (simple-array t)))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index ec47da821..9c6af7e02 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1103,7 +1103,10 @@
            (specifier-type '(or (vector t) (not simple-array)))))
   (assert (eq
            (specifier-type '(or (and vector (not (simple-array t))) simple-vector))
-           (specifier-type 'vector))))
+           (specifier-type 'vector)))
+  (assert (eq
+           (specifier-type '(or (not vector) bit-vector))
+           (specifier-type '(or (not vector) (array bit))))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  6b81ee47cce1d9f999c611550a951c4115dc4b2f (commit)
      from  b1a36a7eee60f0cac90cb99b337bc9ca1f3523f5 (commit)

- Log -----------------------------------------------------------------
commit 6b81ee47cce1d9f999c611550a951c4115dc4b2f
Author: Stas Boukarev <sta...@gm...>
Date:   Thu Oct 30 22:46:18 2025 +0300

    Stop infinite recursion in ARRAY-COMPLEX-UNION2-TYPE-METHOD.
    
    Fixes lp#2130367
---
 src/code/type.lisp | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index cf736a770..89b1cb94f 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3653,7 +3653,11 @@ expansion happened."
        (do ((t2s (intersection-type-types type1) (cdr t2s)))
            ((null t2s) accumulator)
          (let ((union (type-union2 type2 (car t2s))))
-           (unless union
+           (when (or (not union)
+                     (and (union-type-p union)
+                          (or (intersection-type-p accumulator)
+                              (and (negation-type-p accumulator)
+                                   (intersection-type-p (negation-type-type accumulator))))))
              (return nil))
            (setf accumulator
                  (type-intersection accumulator union))))))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Better (union array-type array-type-intersection) canonicalization.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  b1a36a7eee60f0cac90cb99b337bc9ca1f3523f5 (commit)
      from  0f6ccdc8b9a002d4a83febf3170cba19f8163338 (commit)

- Log -----------------------------------------------------------------
commit b1a36a7eee60f0cac90cb99b337bc9ca1f3523f5
Author: Stas Boukarev <sta...@gm...>
Date:   Thu Oct 30 19:08:00 2025 +0300

    Better (union array-type array-type-intersection) canonicalization.
    
    Fixes lp#2130262
---
 src/code/type.lisp   | 114 +++++++++++++++++++++++++++++----------------------
 tests/type.pure.lisp |   5 ++-
 2 files changed, 68 insertions(+), 51 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 0425e9372..cf736a770 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -3593,56 +3593,70 @@ expansion happened."
    :call-other-method))
 
 (define-type-method (array :complex-union2) (type1 type2)
-  (when (negation-type-p type1)
-    (let ((not-type1 (negation-type-type type1)))
-      (when (array-type-p not-type1)
-        (cond ((and
-                (not (array-type-complexp type2))
-                (eq (array-type-complexp not-type1) :maybe)
-                (csubtypep not-type1 (change-array-type-complexp type2 :maybe)))
-               ;; (or (not base-string) simple-base-string)
-               ;; => (not (and base-string (not simple-array)))
-               (make-negation-type
-                (change-array-type-complexp not-type1 t)))
-              ((and (eq (array-type-complexp not-type1) :maybe)
-                    (eq (array-type-complexp type2) t)
-                    (neq (array-type-specialized-element-type not-type1) *wild-type*)
-                    (equal (array-type-dimensions not-type1)
-                           (array-type-dimensions type2))
-                    (csubtypep type2 not-type1))
-               ;; (or (not (array t)) (and (array t) (not simple-array)))
-               ;; => (not (simple-array t))
-               (make-negation-type
-                (change-array-type-complexp type2 nil)))
-              ((and (eq (array-type-complexp not-type1) :maybe)
-                    (eq (array-type-complexp type2) t)
-                    (csubtypep not-type1
-                               (change-array-type-complexp type2 :maybe)))
-               ;; (or (not (vector * 10)) (and vector (not simple-array)))
-               ;; => (not (simple-array * (10)))
-               (make-negation-type
-                (change-array-type-complexp not-type1 nil)))
-              ;; (or (vector t) (not (array t)))
-              ;; => (or vector (not (array t)))
-              ((and
-                (not (and (eq (array-type-complexp not-type1) :maybe)
-                          (eq (array-type-specialized-element-type not-type1) *wild-type*)))
-                (csubtypep type2 not-type1))
-               (type-union (change-array-type type2
-                                              :complexp (if (eq (array-type-complexp not-type1) :maybe)
-                                                            :inherit
-                                                            :maybe)
-                                              :element-type (unless (eq (array-type-specialized-element-type not-type1) *wild-type*)
-                                                              *wild-type*))
-                           type1))
-              ;; (or (vector t) (not (simple-array t)))
-              ;; (or vector (not (simple-array t)))
-              ((and (neq (array-type-specialized-element-type not-type1) *wild-type*)
-                    (csubtypep type2
-                               (change-array-type-complexp not-type1 :maybe)))
-               (type-union (change-array-type type2
-                                              :element-type *wild-type*)
-                           type1)))))))
+  (typecase type1
+    (negation-type
+     (let ((not-type1 (negation-type-type type1)))
+       (when (array-type-p not-type1)
+         (cond ((and
+                 (not (array-type-complexp type2))
+                 (eq (array-type-complexp not-type1) :maybe)
+                 (csubtypep not-type1 (change-array-type-complexp type2 :maybe)))
+                ;; (or (not base-string) simple-base-string)
+                ;; => (not (and base-string (not simple-array)))
+                (make-negation-type
+                 (change-array-type-complexp not-type1 t)))
+               ((and (eq (array-type-complexp not-type1) :maybe)
+                     (eq (array-type-complexp type2) t)
+                     (neq (array-type-specialized-element-type not-type1) *wild-type*)
+                     (equal (array-type-dimensions not-type1)
+                            (array-type-dimensions type2))
+                     (csubtypep type2 not-type1))
+                ;; (or (not (array t)) (and (array t) (not simple-array)))
+                ;; => (not (simple-array t))
+                (make-negation-type
+                 (change-array-type-complexp type2 nil)))
+               ((and (eq (array-type-complexp not-type1) :maybe)
+                     (eq (array-type-complexp type2) t)
+                     (csubtypep not-type1
+                                (change-array-type-complexp type2 :maybe)))
+                ;; (or (not (vector * 10)) (and vector (not simple-array)))
+                ;; => (not (simple-array * (10)))
+                (make-negation-type
+                 (change-array-type-complexp not-type1 nil)))
+               ;; (or (vector t) (not (array t)))
+               ;; => (or vector (not (array t)))
+               ((and
+                 (not (and (eq (array-type-complexp not-type1) :maybe)
+                           (eq (array-type-specialized-element-type not-type1) *wild-type*)))
+                 (csubtypep type2 not-type1))
+                (type-union (change-array-type type2
+                                               :complexp (if (eq (array-type-complexp not-type1) :maybe)
+                                                             :inherit
+                                                             :maybe)
+                                               :element-type (unless (eq (array-type-specialized-element-type not-type1) *wild-type*)
+                                                               *wild-type*))
+                            type1))
+               ;; (or (vector t) (not (simple-array t)))
+               ;; (or vector (not (simple-array t)))
+               ((and (neq (array-type-specialized-element-type not-type1) *wild-type*)
+                     (csubtypep type2
+                                (change-array-type-complexp not-type1 :maybe)))
+                (type-union (change-array-type type2
+                                               :element-type *wild-type*)
+                            type1))))))
+    (intersection-type
+     ;; This is the same as in the intersection-simple-union2-type-method,
+     ;; but it doesn't stop if type-union produces a new union type:
+     ;; (or (and vector (not (simple-array t))) simple-vector)
+     ;; => vector
+     (let ((accumulator *universal-type*))
+       (do ((t2s (intersection-type-types type1) (cdr t2s)))
+           ((null t2s) accumulator)
+         (let ((union (type-union2 type2 (car t2s))))
+           (unless union
+             (return nil))
+           (setf accumulator
+                 (type-intersection accumulator union))))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 7a61d937a..ec47da821 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1100,7 +1100,10 @@
            (specifier-type '(or (simple-array * (*)) (not (array t))))))
   (assert (eq
            (specifier-type '(or simple-vector (not simple-array)))
-           (specifier-type '(or (vector t) (not simple-array))))))
+           (specifier-type '(or (vector t) (not simple-array)))))
+  (assert (eq
+           (specifier-type '(or (and vector (not (simple-array t))) simple-vector))
+           (specifier-type 'vector))))
 
 (with-test (:name :intersection-not-numeric)
   (assert (eql

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Better (union array-type (not array-type)) canonicalization.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  0f6ccdc8b9a002d4a83febf3170cba19f8163338 (commit)
      from  1dae803e4cb46dc7d19420b57b081c5ab12c958c (commit)

- Log -----------------------------------------------------------------
commit 0f6ccdc8b9a002d4a83febf3170cba19f8163338
Author: Stas Boukarev <sta...@gm...>
Date:   Thu Oct 30 17:43:22 2025 +0300

    Better (union array-type (not array-type)) canonicalization.
---
 src/code/type.lisp   | 34 +++++++++++++++++++++++++++++++++-
 tests/type.pure.lisp | 17 +++++++++++++++++
 2 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 9eaf362ee..0425e9372 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -2503,6 +2503,17 @@ expansion happened."
                    :element-type (array-type-element-type type)
                    :specialized-element-type (array-type-specialized-element-type type)))
 
+(defun change-array-type (type &key (complexp :inherit)
+                                    element-type)
+  (make-array-type (array-type-dimensions type)
+                   :complexp (if (eq complexp :inherit)
+                                 (array-type-complexp type)
+                                 complexp)
+                   :element-type (or element-type
+                                     (array-type-element-type type))
+                   :specialized-element-type (or element-type
+                                                 (array-type-specialized-element-type type))))
+
 (define-type-method (negation :simple-intersection2) (type1 type2)
   (let ((not1 (negation-type-type type1))
         (not2 (negation-type-type type2)))
@@ -3610,7 +3621,28 @@ expansion happened."
                ;; (or (not (vector * 10)) (and vector (not simple-array)))
                ;; => (not (simple-array * (10)))
                (make-negation-type
-                (change-array-type-complexp not-type1 nil))))))))
+                (change-array-type-complexp not-type1 nil)))
+              ;; (or (vector t) (not (array t)))
+              ;; => (or vector (not (array t)))
+              ((and
+                (not (and (eq (array-type-complexp not-type1) :maybe)
+                          (eq (array-type-specialized-element-type not-type1) *wild-type*)))
+                (csubtypep type2 not-type1))
+               (type-union (change-array-type type2
+                                              :complexp (if (eq (array-type-complexp not-type1) :maybe)
+                                                            :inherit
+                                                            :maybe)
+                                              :element-type (unless (eq (array-type-specialized-element-type not-type1) *wild-type*)
+                                                              *wild-type*))
+                           type1))
+              ;; (or (vector t) (not (simple-array t)))
+              ;; (or vector (not (simple-array t)))
+              ((and (neq (array-type-specialized-element-type not-type1) *wild-type*)
+                    (csubtypep type2
+                               (change-array-type-complexp not-type1 :maybe)))
+               (type-union (change-array-type type2
+                                              :element-type *wild-type*)
+                           type1)))))))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index f577fa21e..7a61d937a 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -1085,6 +1085,23 @@
                (specifier-type '(array t))))
   (assert (sb-kernel:intersection-type-p (specifier-type '(and (vector unknown) bit-vector)))))
 
+(with-test (:name :array-canonical-union)
+  (assert (eq
+           (specifier-type '(or simple-vector (not (simple-array t))))
+           (specifier-type '(or vector (not (simple-array t))))))
+  (assert (eq
+           (specifier-type '(or (vector t) (not (simple-array t))))
+           (specifier-type '(or vector (not (simple-array t))))))
+  (assert (eq
+           (specifier-type '(or (vector t) (not (array t))))
+           (specifier-type '(or vector (not (array t))))))
+  (assert (eq
+           (specifier-type '(or simple-vector (not (array t))))
+           (specifier-type '(or (simple-array * (*)) (not (array t))))))
+  (assert (eq
+           (specifier-type '(or simple-vector (not simple-array)))
+           (specifier-type '(or (vector t) (not simple-array))))))
+
 (with-test (:name :intersection-not-numeric)
   (assert (eql
            (specifier-type '(and (not (eql 1)) (not (eql 0))))

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Strengthen SB-COVER tests of states

[crhodes <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  1dae803e4cb46dc7d19420b57b081c5ab12c958c (commit)
      from  520be177b5de667a5da80af95f5c509167c0141b (commit)

- Log -----------------------------------------------------------------
commit 1dae803e4cb46dc7d19420b57b081c5ab12c958c
Author: Christophe Rhodes <cs...@ca...>
Date:   Thu Oct 30 11:40:46 2025 +0000

    Strengthen SB-COVER tests of states
    
    We should not signal warnings when reading or finding source positions
    for our own test files.
---
 tests/sb-cover.impure.lisp | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/tests/sb-cover.impure.lisp b/tests/sb-cover.impure.lisp
index fbc8fe98d..ae05d51ee 100644
--- a/tests/sb-cover.impure.lisp
+++ b/tests/sb-cover.impure.lisp
@@ -31,8 +31,12 @@
     (warning ())))
 
 (defun sb-cover-test:get-states (x)
-  (sb-cover::refresh-coverage-info)
-  (nth-value 1 (sb-cover::compute-file-info (namestring (sb-cover-test:source-pathname x)) :default)))
+  (handler-case
+      (progn
+        (sb-cover::refresh-coverage-info)
+        (nth-value 1 (sb-cover::compute-file-info (namestring (sb-cover-test:source-pathname x)) :default)))
+    (warning (condition)
+      (error "Unexpected warning: ~A" condition))))
 
 (with-test (:name :sb-cover)
   (test-util:with-test-directory (sb-cover-test:*output-directory*)

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


hooks/post-receive
-- 
SBCL

[Sbcl-commits] master: Fold foldable-read-only with multiple references.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  520be177b5de667a5da80af95f5c509167c0141b (commit)
      from  4e153c434a5c8af639898591cc715352bdfa8d56 (commit)

- Log -----------------------------------------------------------------
commit 520be177b5de667a5da80af95f5c509167c0141b
Author: Stas Boukarev <sta...@gm...>
Date:   Wed Oct 29 17:00:49 2025 +0300

    Fold foldable-read-only with multiple references.
---
 src/compiler/ir1opt.lisp   | 24 ++++++++++++++++--------
 src/compiler/ir1util.lisp  |  8 ++++++--
 tests/compiler-2.pure.lisp |  8 ++++++++
 3 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 71b00a3f8..5b17f9d4f 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1876,14 +1876,22 @@
            (args (basic-combination-args combination)))
       (cond ((not (or (ir1-attributep attr foldable)
                       (and (ir1-attributep attr foldable-read-only)
-                           (let ((dest (node-dest combination)))
-                             (and (combination-p dest)
-                                  (eq (combination-kind dest) :known)
-                                  (let* ((info (combination-fun-info dest))
-                                         (read-only (fun-info-read-only-args info)))
-                                    (when read-only
-                                      (logbitp (position (node-lvar combination) (combination-args dest))
-                                               read-only))))))))
+                           ;; (car (list 1)) => (car '(1))
+                           (block nil
+                             (map-refs
+                              (lambda (dest lvar)
+                                (unless (and (combination-p dest)
+                                             (eq (combination-kind dest) :known)
+                                             (let* ((info (combination-fun-info dest))
+                                                    (read-only (fun-info-read-only-args info)))
+                                               (when read-only
+                                                 (logbitp (position lvar (combination-args dest))
+                                                          read-only))))
+                                  (return)))
+                              (node-lvar combination)
+                              :leaf-set (lambda () (return))
+                              :cast t)
+                             t))))
              nil)
             ((ir1-attributep attr call)
              (map-combination-args-and-types
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index dbe3c4688..4c9a37787 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -3281,9 +3281,10 @@ is :ANY, the function name is not checked."
                   when (eq v lambda-var)
                   do (funcall function combination arg))))))))
 
-(declaim (ftype (sfunction (function t &key (:leaf-set t) (:multiple-uses t)) null) map-refs))
+(declaim (ftype (sfunction (function t &key (:leaf-set t) (:multiple-uses t) (:cast t)) null) map-refs))
 (defun map-refs (function leaf/lvar &key leaf-set
-                                         multiple-uses)
+                                         multiple-uses
+                                         cast)
   (declare (dynamic-extent function leaf-set multiple-uses))
   (let ((seen-calls))
     (labels ((recur (leaf/lvar)
@@ -3299,6 +3300,9 @@ is :ANY, the function name is not checked."
                     (cond ((and multiple-uses
                                 (consp (lvar-uses leaf/lvar)))
                            (funcall multiple-uses))
+                          ((and cast
+                                (cast-p dest))
+                           (recur (node-lvar dest)))
                           ((and (combination-p dest)
                                 (eq (combination-kind dest) :local))
                            (let ((lambda (combination-lambda dest)))
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 0b41c3f07..bbbff2cf4 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -4927,3 +4927,11 @@
    (lambda (r)
      (apply #'make-array 1 :element-type t r))
    (vector t)))
+
+(with-test (:name :foldable-read-only)
+  (assert-type
+   (lambda ()
+     (let ((l (list 1)))
+       (values (car l)
+               (car l))))
+   (values (eql 1) (eql 1) &optional)))

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


hooks/post-receive
-- 
SBCL