From 561b09a8cedfbe040d4259df8aca1f0f59ae273d Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 30 Dec 2023 18:33:16 +0100 Subject: [PATCH] cmp: check that the type of init-forms for optional and keyword arguments matches their proclaimed types For now, we only check constant init forms where we can do the check at compile time. --- src/cmp/cmptype.lsp | 65 ++++++++++++++++++++++------- src/tests/normal-tests/compiler.lsp | 33 +++++++++++++++ 2 files changed, 82 insertions(+), 16 deletions(-) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 68c52b196..5bda60b9e 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -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 diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 6a7300952..0ee963a99 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -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)))