mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 07:12:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: check that the type of init-forms for optional and keyword arguments matches their proclaimed types

Browse source 
For now, we only check constant init forms where we can do the check
at compile time.
This commit is contained in:
Marius Gerbershagen 2023-12-30 18:33:16 +01:00
parent db4e3a0013
commit 561b09a8ce
2 changed files with 82 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

65
src/cmp/cmptype.lsp
View file

@ -61,37 +61,70 @@
;; TYPE CHECKING
;;
(defun lambda-type-check-init-forms (optionals keywords opt-types key-types)
(flet ((maybe-fix-type (var init type type-iterator)
(multiple-value-bind (constantp value)
(c1form-constant-p init)
(when (and constantp (not (typep value type)))
(cmpwarn-style "The init-form of the argument ~A of ~:[an anonymous function~;the function ~:*~A~] is not of the declared type ~A."
(var-name var)
(fun-name *current-function*)
type)
;; As a matter of policy, we allow init-forms whose
;; type does not match the proclaimed type of the
;; corresponding argument. In that case, we extend the
;; type to also allow the initial value to be passed as
;; an argument to the function.
(setf (first type-iterator) (type-or type `(eql ,value))
(var-type var) (type-or (var-type var) `(eql ,value)))))))
(loop for var in optionals by #'cdddr
for init in (rest optionals) by #'cdddr
for type-iterator on (rest opt-types) by #'cdddr
for type = (first type-iterator)
do (maybe-fix-type var init type type-iterator))
(loop for key-list on keywords by #'cddddr
for keyword = (first key-list)
for var = (second key-list)
for init = (third key-list)
for type-iterator = (loop for key-list on (rest key-types) by #'cddr
when (eq keyword (first key-list))
return (rest key-list)
finally (return '(t)))
for type = (first type-iterator)
do (maybe-fix-type var init type type-iterator))))
(defun lambda-type-check-associate (fname requireds optionals keywords global-fun-p)
(multiple-value-bind (arg-types found)
(and global-fun-p (get-arg-types fname *cmp-env* global-fun-p))
(if found
(multiple-value-bind (req-types opt-types rest-flag key-flag
key-types allow-other-keys)
key-types allow-other-keys)
(si:process-lambda-list arg-types 'ftype)
(declare (ignore rest-flag key-flag allow-other-keys))
(lambda-type-check-init-forms optionals keywords opt-types key-types)
(list
(loop for var in requireds
for type in (rest req-types)
collect (cons var type))
for type in (rest req-types)
collect (cons var type))
(loop for optional in optionals by #'cdddr
for type in (rest opt-types) by #'cdddr
collect (cons optional type))
for type in (rest opt-types) by #'cdddr
collect (cons optional type))
(loop for key-list on keywords by #'cddddr
for keyword = (first key-list)
for key-var = (second key-list)
for type = (loop for key-list on (rest key-types) by #'cddr
when (eq keyword (first key-list))
return (second key-list)
finally (return t))
collect (cons key-var type))))
for keyword = (first key-list)
for key-var = (second key-list)
for type = (loop for key-list on (rest key-types) by #'cddr
when (eq keyword (first key-list))
return (second key-list)
finally (return t))
collect (cons key-var type))))
(list
(loop for var in requireds
collect (cons var t))
collect (cons var t))
(loop for optional in optionals by #'cdddr
collect (cons optional t))
collect (cons optional t))
(loop for key-list on keywords by #'cddddr
for key-var = (second key-list)
collect (cons key-var t))))))
for key-var = (second key-list)
collect (cons key-var t))))))
(defun lambda-type-check-precise (assoc-list ts)
(loop for record in assoc-list

33
src/tests/normal-tests/compiler.lsp
View file

@ -2361,3 +2361,36 @@
0))))
(let ((res (FUNCALL fun)))
(is (= 1 res) "Res is ~s, should be 1." res))))
;;; Date 2023-12-23
;;; Description
;;;
;;; The compiler trusted proclaimed types for optional or keyword
;;; arguments even if their init-forms did not match the
;;; proclaimed types, leading to unsafe code even in safe mode.
;;; While technically incorrect, init-forms not matching the
;;; proclaimed type of the corresponding argument is common enough
;;; that we allow it, only signaling a style-warning.
;;;
(test cmp.0098.init-forms-type-check
(proclaim '(ftype (function (&optional number) t) foo.0098a))
(defun foo.0098a (&optional x) (if x (list x) :good))
(is (nth-value 1 (compile 'foo.0098a))) ; check that we get a style-warning
(is (eql (funcall 'foo.0098a) :good))
(is (eql (funcall 'foo.0098a nil) :good)) ; the type of x is (or number null)
(is (equal (funcall 'foo.0098a 0) (list 0)))
(signals type-error (funcall 'foo.0098a :bad-arg))
(proclaim '(ftype (function (&key (:x string) (:y integer)) t) foo.0098b))
(defun foo.0098b (&key x (y 1.0)) (if x (1+ y) :good))
(is (nth-value 1 (compile 'foo.0098b))) ; check that we get a style-warning
(is (eql (funcall 'foo.0098b) :good))
(is (eql (funcall 'foo.0098b :x nil) :good))
(is (eql (funcall 'foo.0098b :x "") 2.0))
(is (eql (funcall 'foo.0098b :y 0) :good))
(is (eql (funcall 'foo.0098b :y 1.0) :good))
(is (eql (funcall 'foo.0098b :x "" :y 0) 1))
(signals type-error (funcall 'foo.0098b :x :bad-arg))
(signals type-error (funcall 'foo.0098b :y :bad-arg))
(signals type-error (funcall 'foo.0098b :x nil :y :bad-arg))
(signals type-error (funcall 'foo.0098b :x "" :y :bad-arg)))