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

Warn about improper lists created by list*

Browse source
This commit is contained in:
Stas Boukarev 2026-09-09 07:33:31 +03:00
parent d6c5a50395
commit f4a731c355
3 changed files with 36 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
src/compiler/ir1util.lisp
View file

@ -321,6 +321,11 @@
((cast-p dest)
(lvar-dest-var (node-lvar dest)))))))
(defmacro lvar-intersectp (lvar type)
`(types-equal-or-intersect (lvar-type ,lvar) (specifier-type ',type)))
(defmacro lvar-subtypep (lvar type)
`(csubtypep (lvar-type ,lvar) (specifier-type ',type)))
(defun immediately-used-let-dest (node &optional flushable)
(let ((lvar (node-lvar node)))
(when lvar
@ -742,7 +747,7 @@
(declare (ignorable name combination args rotated))
,match-form)))))))
(defvar *combination-match-aliases* (make-hash-table :test #'eq))
(defglobal *combination-match-aliases* (make-hash-table :test #'eq))
(defmacro def-combination-match-alias (name ll &body body)
`(pushnew ',(if (integerp ll)
@ -4512,7 +4517,16 @@ is :ANY, the function name is not checked."
(loop for (call . values) in values
do (let ((*compiler-error-context* call))
(report values)))
t))))))
t)
#-sb-xc-host
(t
(combination-match2 ((lvar-uses lvar) :transform nil)
((list* (:+ args) last)
(unless (lvar-intersectp last list)
(warn 'type-warning
:format-control
"~@<LIST* with the last argument ~s creates an improper list.~@:>"
:format-arguments (list (type-specifier (lvar-type last)))))))))))))
(defun process-lvar-hook-annotation (lvar annotation)
(when (constant-lvar-p lvar)
@ -4753,11 +4767,6 @@ is :ANY, the function name is not checked."
(and (boundp '*component-being-compiled*)
(> (component-phase-counter *component-being-compiled*) 0)))
(defmacro lvar-intersectp (lvar type)
`(types-equal-or-intersect (lvar-type ,lvar) (specifier-type ',type)))
(defmacro lvar-subtypep (lvar type)
`(csubtypep (lvar-type ,lvar) (specifier-type ',type)))
(defun combination-name (combination)
(lvar-fun-name (combination-fun combination) t))

19
tests/bad-code.pure.lisp
View file

@ -1153,8 +1153,27 @@
'(lambda (x)
(make-array (list* -1 x)))
:allow-warnings t)))
(assert (nth-value 2
(checked-compile
'(lambda (x)
(make-array (cons x 1)))
:allow-warnings t)))
(assert (nth-value 2
(checked-compile
'(lambda (x)
(make-array (list 'a x)))
:allow-warnings t))))
(with-test (:name :improper-list*)
(assert (nth-value 2
(checked-compile
'(lambda (x)
(declare (integer x))
(remove 0 (list* 1 x)))
:allow-warnings t)))
(assert (nth-value 2
(checked-compile
'(lambda (x)
(declare (integer x))
(remove 2 (cons x 1)))
:allow-warnings t))))

2
tests/compiler.pure.lisp
View file

@ -4476,7 +4476,7 @@
(lambda () (append nil 10)) (integer 10 10)
(lambda (x) (append x 10)) (or (integer 10 10) cons)
(lambda (x) (append x (cons 1 2))) cons
(lambda (x y) (append x (cons 1 2) y)) cons
(lambda (x y) (append x (list 1 2) y)) cons
(lambda (x y) (nconc x (the list y) x)) t
(lambda (x y) (nconc (the atom x) y)) t
(lambda (x y) (nconc (the (or null (eql 10)) x) y)) t