master: Restore non-simple strings of length 1 as character designators

The branch "master" has been updated in SBCL:
       via  39a97c73287f1f55dae37dc2e351badb5da2536f (commit)
      from  072061b567e9bd3d6c2d4b42972d5baeba070172 (commit)

- Log -----------------------------------------------------------------
commit 39a97c73287f1f55dae37dc2e351badb5da2536f
Author: Christophe Rhodes <[email protected]>
Date:   Sat May 2 22:45:58 2026 +0100

    Restore non-simple strings of length 1 as character designators
    
    The 1 in the (STRING 1) type refers to the size of the underlying
    array, not the length of the sequence.
---
 NEWS                       |  4 ++++
 src/code/target-char.lisp  | 10 ++++++++--
 src/compiler/fndb.lisp     |  2 +-
 src/compiler/typetran.lisp |  2 +-
 tests/character.pure.lisp  | 22 +++++++++++++++++++++-
 5 files changed, 35 insertions(+), 5 deletions(-)

diff --git a/NEWS b/NEWS
index 01a71ff57..343133cdf 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
+changes relative to sbcl-2.6.4:
+  * bug fix: strings of arbitrary size with fill-pointer set to 1 are
+    character designators.  (reported by _death)
+
 changes in sbcl-2.6.4 relative to sbcl-2.6.3:
   * minor incompatible change: when DEFSETF is called on a name that was
     previously used as a (presumed) call to a function, it issues a single
diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp
index d3ae2c87c..a6d2ce141 100644
--- a/src/code/target-char.lisp
+++ b/src/code/target-char.lisp
@@ -249,14 +249,20 @@ there are no character bits or fonts.)"
   "Return the character with the code CODE."
   (code-char code))
 
+(defun length-1-string-p (x)
+  (and (typep x 'string) (= (length x) 1)))
+(defun symbol-with-length-1-name-p (x)
+  (and (typep x 'symbol) (length-1-string-p (symbol-name x))))
+(deftype character-designator ()
+  '(or character (satisfies length-1-string-p) (satisfies symbol-with-length-1-name-p)))
+
 (defun character (object)
   "Coerce OBJECT into a CHARACTER if possible. Legal inputs are characters,
 strings and symbols of length 1."
   (flet ((do-error (control args)
            (error 'simple-type-error
                   :datum object
-                  ;;?? how to express "symbol with name of length 1"?
-                  :expected-type '(or character (string 1))
+                  :expected-type 'character-designator
                   :format-control control
                   :format-arguments args)))
     (typecase object
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 4bee1843f..6ed77011c 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -591,7 +591,7 @@
     (character character) boolean
   (movable foldable flushable no-verify-arg-count))
 
-(defknown character ((or character (string 1) symbol))
+(defknown character ((or character (simple-string 1) (and string (not simple-string)) symbol))
     character
     (movable foldable unsafely-flushable))
 (defknown char-code (character) %char-code (movable foldable flushable))
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index e6adc10fc..b198c1f35 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -1846,7 +1846,7 @@
              (fail)))
           ((eql type-specifier 'character)
            (unless (types-equal-or-intersect value-type
-                                             (specifier-type '(or symbol (string 1))))
+                                             (specifier-type '(or symbol (simple-string 1) (and string (not simple-string)))))
              (fail)))
           ((csubtypep to-type (specifier-type 'complex))
            (unless (types-equal-or-intersect value-type
diff --git a/tests/character.pure.lisp b/tests/character.pure.lisp
index cf203c052..722c37e82 100644
--- a/tests/character.pure.lisp
+++ b/tests/character.pure.lisp
@@ -238,4 +238,24 @@
    (lambda (x)
      (character x)
      x)
-   (or (string 1) character symbol)))
+   (or (simple-string 1) (and string (not simple-string)) character symbol)))
+
+(with-test (:name (character :input :fill-pointer))
+  (checked-compile-and-assert
+   ()
+   `(lambda (x) (character x))
+   (((make-array 1 :element-type 'character :fill-pointer 0 :initial-element #\x)) (condition 'type-error))
+   (((make-array 1 :element-type 'character :fill-pointer 1 :initial-element #\x)) #\x)
+   (((make-array 2 :element-type 'character :fill-pointer 0 :initial-element #\x)) (condition 'type-error))
+   (((make-array 2 :element-type 'character :fill-pointer 1 :initial-element #\x)) #\x)
+   (((make-array 2 :element-type 'character :fill-pointer 2 :initial-element #\x)) (condition 'type-error))))
+
+(with-test (:name (coerce character :input :fill-pointer))
+  (checked-compile-and-assert
+   ()
+   `(lambda (x y) (coerce x y))
+   (((make-array 1 :element-type 'character :fill-pointer 0 :initial-element #\x) 'character) (condition 'type-error))
+   (((make-array 1 :element-type 'character :fill-pointer 1 :initial-element #\x) 'character) #\x)
+   (((make-array 2 :element-type 'character :fill-pointer 0 :initial-element #\x) 'character) (condition 'type-error))
+   (((make-array 2 :element-type 'character :fill-pointer 1 :initial-element #\x) 'character) #\x)
+   (((make-array 2 :element-type 'character :fill-pointer 2 :initial-element #\x) 'character) (condition 'type-error))))

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


hooks/post-receive
-- 
SBCL