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

The array type specifiers should finally be extended. To express fp/no
fp, length, like this, displacement, etc. And also allow making the
length variable, i.e. (string (integer 0 5)).

On Sun, May 3, 2026 at 1:08 AM crhodes via Sbcl-commits
<[email protected]> wrote:
>
> 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
>
>
> _______________________________________________
> Sbcl-commits mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits


_______________________________________________
Sbcl-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sbcl-commits