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

Correctly not check ftypes of unused optionals

Browse source 
Fixes lp#2165974
This commit is contained in:
Stas Boukarev 2026-09-01 16:53:10 +03:00
parent 9685c98e78
commit 303db288a5
2 changed files with 81 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/compiler/locall.lisp
View file

@ -302,7 +302,8 @@
return var)))
(when (and var
(not (lambda-var-refs var))
(eql (lambda-var-type var) *universal-type*))
(eq (leaf-defined-type var) *universal-type*) ;; ftype
(eq (lambda-var-type var) *universal-type*))
(let* ((info (lambda-var-arg-info var))
(kind (arg-info-kind info)))
(or (and (eq kind :optional)

79
tests/compiler-2.pure.lisp
View file

@ -5183,3 +5183,82 @@
(unless (fboundp name)
(push name no-folders)))))))
(assert (not no-folders))))
(declaim (ftype (function (&key (:a float)) t) ftype-test-unused-key)
(ftype (function (t &key (:a float)) t) ftype-test-unused-key2)
(ftype (function (&optional float) t) ftype-test-unused-opt)
(ftype (function (&optional float float) t) ftype-test-unused-opt2)
(ftype (function (t &optional float float) t) ftype-test-unused-opt3))
(defun ftype-test-unused-key (&key a)
(declare (ignore a)))
(defun ftype-test-unused-key2 (x &key a)
(declare (ignore x a)))
(defun ftype-test-unused-opt (&optional a)
(declare (ignore a)))
(defun ftype-test-unused-opt2 (&optional a b)
(declare (ignore a b)))
(defun ftype-test-unused-opt3 (x &optional a b)
(declare (ignore x a b)))
(with-test (:name :ftype-unused-optional)
(checked-compile-and-assert
(:optimize :default)
`(lambda () (ftype-test-unused-opt))
(() nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda () (ftype-test-unused-key))
(() nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda () (ftype-test-unused-opt2))
(() nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt2 a))
((0.0) nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt3 a))
((0.0) nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt3 1 a))
((0.0) nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda () (ftype-test-unused-key2 1))
(() nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-key :a a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-key2 1 :a a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt2 a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt2 a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt2 0.0 a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt3 1 a))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :default)
`(lambda (a) (ftype-test-unused-opt3 1 0.0 a))
((1) (condition 'type-error))))