common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Handle string designators in sequence-result-nth-arg.

Browse source 
NIL also happens to be a sequence, leading to bad results.

Fixes lp#2023118
This commit is contained in:
Stas Boukarev 2023-06-07 11:08:23 +03:00
parent daab4012d8
commit 6f73a5b4cd
3 changed files with 31 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/compiler/fndb.lisp
View file

@ -1311,7 +1311,7 @@
(:start (inhibit-flushing index 0))
(:end (inhibit-flushing sequence-end nil)))
simple-string (flushable)
:derive-type (sequence-result-nth-arg 0 :preserve-dimensions t))
:derive-type (sequence-result-nth-arg 0 :preserve-dimensions t :string-designator t))
(defknown (nstring-upcase nstring-downcase nstring-capitalize)
((modifying string) &key (:start index) (:end sequence-end))

15
src/compiler/knownfun.lisp
View file

@ -334,16 +334,23 @@
;;; N'th argument. If arg is a list, result is a list. If arg is a
;;; vector, result is a vector with the same element type.
(defun sequence-result-nth-arg (n &key preserve-dimensions
preserve-vector-type)
preserve-vector-type
string-designator)
(lambda (call)
(declare (type combination call))
(let ((lvar (nth n (combination-args call))))
(when lvar
(let ((type (lvar-type lvar)))
(cond ((simplify-list-type type
:preserve-dimensions preserve-dimensions))
(cond ((and (not string-designator)
(simplify-list-type type
:preserve-dimensions preserve-dimensions)))
((not (csubtypep type (specifier-type 'vector)))
nil)
(cond ((not string-designator) nil)
((csubtypep type (specifier-type 'character))
(specifier-type `(simple-string 1)))
((and (constant-lvar-p lvar)
(symbolp (lvar-value lvar)))
(ctype-of (symbol-name (lvar-value lvar))))))
(preserve-vector-type
type)
(t

19
tests/string.pure.lisp
View file

@ -355,3 +355,22 @@ claim that any particular result from these edge cases constitutes a bug.
(assert (if (sb-kernel:dynamic-space-obj-p str)
(eq res str)
(not (eq res str))))))
(with-test (:name :string-case-type)
(macrolet
((check (fun expected)
`(assert
(type-specifiers-equal
(second
(third
(sb-kernel:%simple-fun-type
(checked-compile '(lambda (x)
(declare (ignorable x))
,fun)))))
',expected))))
(check (string-upcase nil)
(simple-base-string 3))
(check (string-upcase (the symbol x))
simple-string)
(check (string-upcase (the character x))
(simple-string 1))))