mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 09:20:23 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'type-check-init-forms' into 'develop'

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

See merge request embeddable-common-lisp/ecl!316
This commit is contained in:
Daniel Kochmański 2024-01-26 08:14:20 +00:00
commit e851458058
3 changed files with 87 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
View file

@ -269,7 +269,9 @@
;; no initform
;; ECL_NIL has been set in keyvars if keyword parameter is not supplied.
(setf (second KEYVARS[i]) i)
(bind KEYVARS[i] var))
(bind KEYVARS[i] var)
(when (car type-check)
(c2expr* (car type-check))))
(t
;; with initform
(setf (second KEYVARS[i]) (+ nkey i))
@ -281,8 +283,8 @@
(let ((*opened-c-braces* (1+ *opened-c-braces*)))
(setf (second KEYVARS[i]) i)
(bind KEYVARS[i] var)
(if (car type-check)
(c2expr* (car type-check))))
(when (car type-check)
(c2expr* (car type-check))))
(wt-nl "}")))
(when flag
(setf (second KEYVARS[i]) (+ nkey i))

65
src/cmp/cmptype.lsp
View file

@ -56,37 +56,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)))