From 6a14bc0b4e4d07b41f93193ae0cad1507c62923b Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 1 May 2024 19:45:10 +0300 Subject: [PATCH] Check functional arguments argcounts with multiple uses. Warn in (sort x (or f (lambda (x) (< x 0)))) --- src/code/type.lisp | 1 + src/compiler/callable-args.lisp | 231 ++++++++++++++++++++++------------------ tests/bad-code.pure.lisp | 10 ++ 3 files changed, 137 insertions(+), 105 deletions(-) diff --git a/src/code/type.lisp b/src/code/type.lisp index 146bca14e..2a1b0368b 100644 --- a/src/code/type.lisp +++ b/src/code/type.lisp @@ -471,6 +471,7 @@ (make-fun-type :required (fun-type-required ftype) :optional (fun-type-optional ftype) :keyp (fun-type-keyp ftype) + :rest (fun-type-rest ftype) :keywords (fun-type-keywords ftype) :allowp (fun-type-allowp ftype) :returns rtype diff --git a/src/compiler/callable-args.lisp b/src/compiler/callable-args.lisp index fab674462..e8efa6fc3 100644 --- a/src/compiler/callable-args.lisp +++ b/src/compiler/callable-args.lisp @@ -169,19 +169,15 @@ (when lvar (call lvar annotation))))))))) -(defun lvar-fun-type (lvar &optional defined-here asserted-type) - ;; Handle #'function, 'function and (lambda (x y)) - (let* ((use (principal-lvar-use lvar)) - (lvar-type (lvar-type lvar)) +;; Handle #'function, 'function and (lambda (x y)) +(defun node-fun-type (node &optional defined-here asserted-type) + (let* ((use node) + (lvar-type (single-value-type (node-derived-type use))) (leaf (if (ref-p use) (ref-leaf use) - (return-from lvar-fun-type + (return-from node-fun-type (values lvar-type - (typecase use - (node - (node-source-form use)) - (t - '.anonymous.)))))) + (node-source-form use))))) (asserted t) (defined-type (and (global-var-p leaf) (case (leaf-where-from leaf) @@ -193,7 +189,7 @@ (and (defined-fun-p leaf) (eq (defined-fun-inlinep leaf) 'notinline)) (fun-lexically-notinline-p (leaf-%source-name leaf) - (node-lexenv (lvar-dest lvar)))) + (node-lexenv (lvar-dest (node-lvar node))))) (setf asserted nil) lvar-type) (t @@ -202,7 +198,7 @@ (cond ((or (and (defined-fun-p leaf) (eq (defined-fun-inlinep leaf) 'notinline)) (fun-lexically-notinline-p (leaf-%source-name leaf) - (node-lexenv (lvar-dest lvar)))) + (node-lexenv (lvar-dest (node-lvar node))))) lvar-type) (t (global-ftype (leaf-%source-name leaf))))) @@ -226,8 +222,7 @@ :returns (tail-set-type (lambda-tail-set entry-fun)))) ((and asserted-type - (not (or (constant-lvar-p lvar) - (constant-p leaf)))) + (not (constant-p leaf))) (setf asserted nil) ;; Don't trust FUNCTION type declarations, ;; they perform no runtime assertions. @@ -238,10 +233,8 @@ (fun-name (cond ((or (fun-type-p lvar-type) (functional-p leaf) (global-var-p leaf)) - (cond ((or (constant-lvar-p lvar) - ;; A constant may fail some checks in constant-lvar-p - (constant-p leaf)) - (let ((value (lvar-value lvar))) + (cond ((constant-p leaf) + (let ((value (constant-value leaf))) (etypecase value #-sb-xc-host (function @@ -253,15 +246,15 @@ (leaf-debug-name (lambda-entry-fun leaf))) (t (leaf-debug-name leaf)))) - ((constant-lvar-p lvar) - (lvar-value lvar)) + ((constant-p leaf) + (constant-value leaf)) (t - (return-from lvar-fun-type lvar-type)))) + (return-from node-fun-type lvar-type)))) (type (cond ((fun-type-p lvar-type) lvar-type) ((symbolp fun-name) (if (or (fun-lexically-notinline-p fun-name - (node-lexenv (lvar-dest lvar))) + (node-lexenv (node-dest node))) (and (or asserted-type defined-here) (neq (info :function :where-from fun-name) :declared))) @@ -276,6 +269,26 @@ lvar-type)))) (values type fun-name leaf asserted))) +(defun lvar-fun-type (lvar &optional defined-here asserted-type) + (let* ((use (principal-lvar-use lvar)) + (lvar-type (lvar-type lvar))) + (if (ref-p use) + (multiple-value-bind (type fun-name leaf asserted) (node-fun-type use defined-here asserted-type) + (let ((int (if (fun-type-p lvar-type) + ;; save the cast type + (type-intersection type lvar-type) + type))) + (values (if (neq int *empty-type*) + int + lvar-type) + fun-name leaf asserted))) + (values lvar-type + (typecase use + (node + (node-source-form use)) + (t + '.anonymous.)))))) + (defun callable-argument-lossage-kind (fun-name leaf soft hard) (if (or (not leaf) (and (not (memq (leaf-where-from leaf) '(:defined-here :declared-verify))) @@ -436,7 +449,7 @@ (defun report-arg-count-mismatch (fun caller type arg-count condition-type - &optional lossage-fun) + &optional lossage-fun name) (flet ((lose (format-control &rest format-args) (if lossage-fun (apply lossage-fun format-control format-args) @@ -444,7 +457,8 @@ :format-arguments format-args)) t) (callee () - (nth-value 1 (lvar-fun-type fun))) + (or name + (nth-value 1 (lvar-fun-type fun)))) (caller () (or caller (loop for annotation in (lvar-annotations fun) @@ -497,87 +511,94 @@ ;;; This can provide better errors and better handle OR types than a ;;; simple type intersection. (defun check-function-designator-lvar (lvar annotation) - (multiple-value-bind (type name leaf) (lvar-fun-type lvar) - (cond - ((and name - (valid-function-name-p name) - (memq (info :function :kind name) '(:macro :special-form))) - (compiler-warn "~(~a~) ~s where a function is expected" - (info :function :kind name) name)) - ((fun-type-p type) - ;; If the destination is a combination-fun that means the function - ;; is called here and not passed somewhere else, there's no longer a - ;; need to check the function type, the arguments to the call will - ;; do the same job. - (unless (let* ((dest (lvar-dest lvar))) - (and (basic-combination-p dest) - (eq (basic-combination-fun dest) lvar))) - (multiple-value-bind (args results) - (function-designator-lvar-types annotation) - (let* ((condition (callable-argument-lossage-kind name - leaf - 'simple-style-warning - 'simple-warning)) - (type-condition (case condition - (simple-style-warning - 'type-style-warning) - (t - 'type-warning))) - (caller (lvar-function-designator-annotation-caller annotation)) - (arg-count (length args))) - (or (report-arg-count-mismatch lvar caller - type - arg-count - condition) - (let ((param-types (fun-type-n-arg-types arg-count type))) - (unless (and (eq caller 'reduce) - (eql arg-count 2)) - (disable-arg-count-checking leaf type arg-count)) - (block nil - ;; Need to check each OR seperately, a UNION could - ;; intersect with the function parameters - (labels ((hide-ors (current-or or-part) - (loop for spec in args - collect (cond ((eq spec current-or) - or-part) - ((typep spec '(cons (eql or))) - (sb-kernel::%type-union (cdr spec))) - (t - spec)))) - (check (arg param &optional - current-spec) - (when (eq (type-intersection param arg) *empty-type*) - (warn type-condition - :format-control - "The function ~S is called by ~S with ~S but it accepts ~S." - :format-arguments - (list - name - caller - (mapcar #'type-specifier (hide-ors current-spec arg)) - (mapcar #'type-specifier param-types))) - (return t)))) - (loop for arg-type in args - for param-type in param-types - if (typep arg-type '(cons (eql or))) - do (loop for type in (cdr arg-type) - do (check type param-type arg-type)) - else do (check arg-type param-type))))) - (let ((returns (single-value-type (fun-type-returns type)))) - (when (and (neq returns *wild-type*) - (neq returns *empty-type*) - (neq results *wild-type*) - (eq (type-intersection returns results) *empty-type*)) - (warn type-condition - :format-control - "The function ~S called by ~S returns ~S but ~S is expected" - :format-arguments - (list - name - caller - (type-specifier returns) - (type-specifier results))))))))) - t)))) + (map-all-uses + (lambda (node) + (multiple-value-bind (type name leaf) (node-fun-type node) + (cond + ((and name + (valid-function-name-p name) + (memq (info :function :kind name) '(:macro :special-form))) + (compiler-warn "~(~a~) ~s where a function is expected" + (info :function :kind name) name)) + ((fun-type-p type) + ;; If the destination is a combination-fun that means the function + ;; is called here and not passed somewhere else, there's no longer a + ;; need to check the function type, the arguments to the call will + ;; do the same job. + (unless (let* ((dest (lvar-dest lvar))) + (and (basic-combination-p dest) + (eq (basic-combination-fun dest) lvar))) + (multiple-value-bind (args results) + (function-designator-lvar-types annotation) + (let* ((condition (if (consp (lvar-uses lvar)) + 'simple-style-warning + (callable-argument-lossage-kind name + leaf + 'simple-style-warning + 'simple-warning))) + (type-condition (case condition + (simple-style-warning + 'type-style-warning) + (t + 'type-warning))) + (caller (lvar-function-designator-annotation-caller annotation)) + (arg-count (length args))) + (or (report-arg-count-mismatch lvar caller + type + arg-count + condition + nil + name) + (let ((param-types (fun-type-n-arg-types arg-count type))) + (unless (and (eq caller 'reduce) + (eql arg-count 2)) + (disable-arg-count-checking leaf type arg-count)) + (block nil + ;; Need to check each OR seperately, a UNION could + ;; intersect with the function parameters + (labels ((hide-ors (current-or or-part) + (loop for spec in args + collect (cond ((eq spec current-or) + or-part) + ((typep spec '(cons (eql or))) + (sb-kernel::%type-union (cdr spec))) + (t + spec)))) + (check (arg param &optional + current-spec) + (when (eq (type-intersection param arg) *empty-type*) + (warn type-condition + :format-control + "The function ~S is called by ~S with ~S but it accepts ~S." + :format-arguments + (list + name + caller + (mapcar #'type-specifier (hide-ors current-spec arg)) + (mapcar #'type-specifier param-types))) + (return t)))) + (loop for arg-type in args + for param-type in param-types + if (typep arg-type '(cons (eql or))) + do (loop for type in (cdr arg-type) + do (check type param-type arg-type)) + else do (check arg-type param-type))))) + (let ((returns (single-value-type (fun-type-returns type)))) + (when (and (neq returns *wild-type*) + (neq returns *empty-type*) + (neq results *wild-type*) + (eq (type-intersection returns results) *empty-type*)) + (warn type-condition + :format-control + "The function ~S called by ~S returns ~S but ~S is expected" + :format-arguments + (list + name + caller + (type-specifier returns) + (type-specifier results))))))))))))) + lvar) + t) (defun check-function-lvar (lvar annotation) (let ((atype (lvar-function-annotation-type annotation))) diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp index 5fa3c5651..46cf63144 100644 --- a/tests/bad-code.pure.lisp +++ b/tests/bad-code.pure.lisp @@ -786,3 +786,13 @@ `(lambda () (format t "~r" t)) :allow-warnings t)))) + +(with-test (:name :multiple-uses-funargs) + (assert (nth-value 3 + (checked-compile + `(lambda (x f) + (sort x + (or f + (lambda (x) + (< x 0))))) + :allow-style-warnings t)))) -- 2.11.4.GIT