master: check-concatenate: consider each constant value

The branch "master" has been updated in SBCL:
       via  5881276137ac2b800ac25cbfa9eaecbcddd05a09 (commit)
      from  91b8b81d14e0b722eee160765e151fae84c0637b (commit)

- Log -----------------------------------------------------------------
commit 5881276137ac2b800ac25cbfa9eaecbcddd05a09
Author: Stas Boukarev <[email protected]>
Date:   Wed Jun 3 04:16:23 2026 +0300

    check-concatenate: consider each constant value
---
 src/compiler/seqtran.lisp | 47 +++++++++++++++++++++++++++++++++--------------
 tests/bad-code.pure.lisp  |  7 +++++++
 2 files changed, 40 insertions(+), 14 deletions(-)

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index db4f7bfc9..858a7b6da 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1842,19 +1842,38 @@
                 (eq result-element-type *universal-type*))
       (loop for i from 0
             for sequence in sequences
-            for element-type = (sequence-elements-type sequence)
-            do (when (and element-type
-                          (not (eq element-type *wild-type*))
-                          (not (types-equal-or-intersect element-type result-element-type)))
-                 (let ((*compiler-error-context* node))
-                   (compiler-warn "Can't ~a elements of type ~s into ~s"
-                                  description
-                                  (type-specifier element-type)
-                                  (if (ctype-p type)
-                                      (type-specifier (make-array-type '(*)
-                                                                       :specialized-element-type type
-                                                                       :element-type type))
-                                      type))))))))
+            for constant = (and (constant-lvar-p sequence)
+                                (lvar-value sequence))
+            do (if (and constant
+                        (proper-sequence-p constant))
+                   (map nil
+                        (lambda (elt)
+                          (multiple-value-bind (fits really) (ctypep elt result-element-type)
+                            (when (and really (not fits))
+                              (let ((*compiler-error-context* node))
+                                (compiler-warn "Can't ~a ~s, of type ~s, into ~s"
+                                               description
+                                               elt (type-of elt)
+                                               (if (ctype-p type)
+                                                   (type-specifier (make-array-type '(*)
+                                                                                    :specialized-element-type type
+                                                                                    :element-type type))
+                                                   type))
+                                (return)))))
+                        constant)
+                   (let ((element-type (sequence-elements-type sequence)))
+                     (when (and element-type
+                                (not (eq element-type *wild-type*))
+                                (not (types-equal-or-intersect element-type result-element-type)))
+                       (let ((*compiler-error-context* node))
+                         (compiler-warn "Can't ~a elements of type ~s into ~s"
+                                        description
+                                        (type-specifier element-type)
+                                        (if (ctype-p type)
+                                            (type-specifier (make-array-type '(*)
+                                                                             :specialized-element-type type
+                                                                             :element-type type))
+                                            type))))))))))
 
 (defoptimizer (%concatenate-to-string ir2-hook) ((&rest args) node)
   (check-concatenate 'string args node))
@@ -1872,7 +1891,7 @@
 
 (defoptimizer (merge ir2-hook) ((type sequence1 sequence2 predicate &key &allow-other-keys) node)
   (when (constant-lvar-p type)
-   (check-concatenate (lvar-value type) (list sequence1 sequence2) node "merge")))
+    (check-concatenate (lvar-value type) (list sequence1 sequence2) node "merge")))
 
 ;;; Expand simple cases of UB<SIZE>-BASH-COPY inline.  "simple" is
 ;;; defined as those cases where we are doing word-aligned copies from
diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp
index e822da9fa..93b34c766 100644
--- a/tests/bad-code.pure.lisp
+++ b/tests/bad-code.pure.lisp
@@ -1101,3 +1101,10 @@
                                       #'list)
                                   1 #'eq))
                       :allow-style-warnings t))))
+
+(with-test (:name :concatenate-mismatch)
+  (assert (nth-value 2
+                     (checked-compile
+                      `(lambda (m)
+                         (concatenate 'string '(1 #\a) m))
+                      :allow-warnings t))))

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


hooks/post-receive
-- 
SBCL