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

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) ((cast-p dest)
(lvar-dest-var (node-lvar 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) (defun immediately-used-let-dest (node &optional flushable)
(let ((lvar (node-lvar node))) (let ((lvar (node-lvar node)))
(when lvar (when lvar
@ -742,7 +747,7 @@
(declare (ignorable name combination args rotated)) (declare (ignorable name combination args rotated))
,match-form))))))) ,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) (defmacro def-combination-match-alias (name ll &body body)
`(pushnew ',(if (integerp ll) `(pushnew ',(if (integerp ll)
@ -4512,7 +4517,16 @@ is :ANY, the function name is not checked."
(loop for (call . values) in values (loop for (call . values) in values
do (let ((*compiler-error-context* call)) do (let ((*compiler-error-context* call))
(report values))) (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) (defun process-lvar-hook-annotation (lvar annotation)
(when (constant-lvar-p lvar) (when (constant-lvar-p lvar)
@ -4753,11 +4767,6 @@ is :ANY, the function name is not checked."
(and (boundp '*component-being-compiled*) (and (boundp '*component-being-compiled*)
(> (component-phase-counter *component-being-compiled*) 0))) (> (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) (defun combination-name (combination)
(lvar-fun-name (combination-fun combination) t)) (lvar-fun-name (combination-fun combination) t))

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

@ -1153,8 +1153,27 @@
'(lambda (x) '(lambda (x)
(make-array (list* -1 x))) (make-array (list* -1 x)))
:allow-warnings t))) :allow-warnings t)))
(assert (nth-value 2
(checked-compile
'(lambda (x)
(make-array (cons x 1)))
:allow-warnings t)))
(assert (nth-value 2 (assert (nth-value 2
(checked-compile (checked-compile
'(lambda (x) '(lambda (x)
(make-array (list 'a x))) (make-array (list 'a x)))
:allow-warnings t)))) :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 () (append nil 10)) (integer 10 10)
(lambda (x) (append x 10)) (or (integer 10 10) cons) (lambda (x) (append x 10)) (or (integer 10 10) cons)
(lambda (x) (append x (cons 1 2))) 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 x (the list y) x)) t
(lambda (x y) (nconc (the atom x) y)) t (lambda (x y) (nconc (the atom x) y)) t
(lambda (x y) (nconc (the (or null (eql 10)) x) y)) t (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t