Menu
▾
▴
Re: [Sbcl-devel] [Sbcl-commits] master: Restore non-simple strings of length 1 as character designators
|
From: Stas B. <sta...@gm...> - 2026-05-02 22:14:29
|
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 <sbc...@li...> wrote: > > The branch "master" has been updated in SBCL: > via 39a97c73287f1f55dae37dc2e351badb5da2536f (commit) > from 072061b567e9bd3d6c2d4b42972d5baeba070172 (commit) > > - Log ----------------------------------------------------------------- > commit 39a97c73287f1f55dae37dc2e351badb5da2536f > Author: Christophe Rhodes <cs...@ca...> > 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 > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-commits |
