Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv8960/src/compiler
Modified Files:
ir1opt.lisp ir1tran.lisp node.lisp
Log Message:
1.0.18.21: More STYLE-WARNINGs
* STYLE-WARN for argument list mismatches for all already-defined
functions.
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.130
retrieving revision 1.131
diff -u -d -r1.130 -r1.131
--- ir1opt.lisp 18 Feb 2008 19:25:23 -0000 1.130
+++ ir1opt.lisp 16 Jul 2008 20:51:14 -0000 1.131
@@ -892,12 +892,22 @@
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type ir1-converting-not-optimizing-p)
+(defun validate-call-type (call type defined-type ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
(cond ((not (fun-type-p type))
(aver (multiple-value-bind (val win)
(csubtypep type (specifier-type 'function))
(or val (not win))))
+ ;; In the commonish case where the function has been defined
+ ;; in another file, we only get FUNCTION for the type; but we
+ ;; can check whether the current call is valid for the
+ ;; existing definition, even if only to STYLE-WARN about it.
+ (when defined-type
+ (valid-fun-use call defined-type
+ :argument-test #'always-subtypep
+ :result-test nil
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun #'compiler-notify))
(recognize-known-call call ir1-converting-not-optimizing-p))
((valid-fun-use call type
:argument-test #'always-subtypep
@@ -947,7 +957,7 @@
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (lvar-type fun-lvar) nil)
+ (validate-call-type call (lvar-type fun-lvar) nil nil)
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.163
retrieving revision 1.164
diff -u -d -r1.163 -r1.164
--- ir1tran.lisp 15 Jun 2008 11:13:42 -0000 1.163
+++ ir1tran.lisp 16 Jul 2008 20:51:15 -0000 1.164
@@ -118,6 +118,9 @@
(not (fun-lexically-notinline-p name)))))
(info :function :type name)
(specifier-type 'function))
+ :defined-type (if (eq where :defined)
+ (info :function :type name)
+ *universal-type*)
:where-from where)))
;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
@@ -1042,8 +1045,9 @@
(type leaf var))
(let* ((node (ir1-convert-combination start next result form var))
(fun-lvar (basic-combination-fun node))
- (type (leaf-type var)))
- (when (validate-call-type node type t)
+ (type (leaf-type var))
+ (defined-type (leaf-defined-type var)))
+ (when (validate-call-type node type defined-type t)
(setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
(setf (lvar-reoptimize fun-lvar) nil)))
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -d -r1.76 -r1.77
--- node.lisp 3 Jul 2008 19:24:50 -0000 1.76
+++ node.lisp 16 Jul 2008 20:51:15 -0000 1.77
@@ -617,6 +617,9 @@
:read-only t)
;; the type which values of this leaf must have
(type *universal-type* :type ctype)
+ ;; the type which values of this leaf have last been defined to have
+ ;; (but maybe won't have in future, in case of redefinition)
+ (defined-type *universal-type* :type ctype)
;; where the TYPE information came from:
;; :DECLARED, from a declaration.
;; :ASSUMED, from uses of the object.
|