X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=a67b43ff7c1894d146c91e35a166ace43ce6c941;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=35538cac6ad1571b7364dc78cd2a98a233b0eb80;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 35538ca..a67b43f 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -93,99 +93,103 @@
 ;;; matches the specified result.
 ;;;
 ;;; Unlike the argument test, the result test may be called on values
-;;; or function types. If STRICT-RESULT is true and SAFETY is
-;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
-;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
-;;; intersected with the CONT's ASSERTED-TYPE.
+;;; or function types. NODE-DERIVED-TYPE is intersected with the
+;;; trusted asserted type.
 ;;;
 ;;; The error and warning functions are functions that are called to
 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
 ;;; combination node so that COMPILER-WARNING and related functions
 ;;; will do the right thing if they are supplied.
-(defun valid-function-use (call type &key
-				((:argument-test *ctype-test-fun*) #'csubtypep)
-				(result-test #'values-subtypep)
-				(strict-result nil)
-				((:lossage-fun *lossage-fun*))
-				((:unwinnage-fun *unwinnage-fun*)))
-  (declare (type function result-test) (type combination call)
-	   (type fun-type type))
+(defun valid-fun-use (call type &key
+                      ((:argument-test *ctype-test-fun*) #'csubtypep)
+                      (result-test #'values-subtypep)
+                      ((:lossage-fun *lossage-fun*))
+                      ((:unwinnage-fun *unwinnage-fun*)))
+  (declare (type (or function null) result-test) (type combination call)
+	   ;; FIXME: Could TYPE here actually be something like
+	   ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))?  How
+	   ;; horrible...  -- CSR, 2003-05-03
+	   (type ctype type))
   (let* ((*lossage-detected* nil)
 	 (*unwinnage-detected* nil)
 	 (*compiler-error-context* call)
-	 (args (combination-args call))
-	 (nargs (length args))
-	 (required (fun-type-required type))
-	 (min-args (length required))
-	 (optional (fun-type-optional type))
-	 (max-args (+ min-args (length optional)))
-	 (rest (fun-type-rest type))
-	 (keyp (fun-type-keyp type)))
-
-    (cond
-     ((fun-type-wild-args type)
-      (do ((i 1 (1+ i))
-	   (arg args (cdr arg)))
-	  ((null arg))
-	(check-arg-type (car arg) *wild-type* i)))
-     ((not (or optional keyp rest))
-      (if (/= nargs min-args)
-	  (note-lossage
-	   "The function was called with ~R argument~:P, but wants exactly ~R."
-	   nargs min-args)
-	  (check-fixed-and-rest args required nil)))
-     ((< nargs min-args)
-      (note-lossage
-       "The function was called with ~R argument~:P, but wants at least ~R."
-       nargs min-args))
-     ((<= nargs max-args)
-      (check-fixed-and-rest args (append required optional) rest))
-     ((not (or keyp rest))
-      (note-lossage
-       "The function was called with ~R argument~:P, but wants at most ~R."
-       nargs max-args))
-     ((and keyp (oddp (- nargs max-args)))
-      (note-lossage
-       "The function has an odd number of arguments in the keyword portion."))
-     (t
-      (check-fixed-and-rest args (append required optional) rest)
-      (when keyp
-	(check-key-args args max-args type))))
-
-    (let* ((dtype (node-derived-type call))
-	   (return-type (fun-type-returns type))
-	   (cont (node-cont call))
-	   (out-type
-	    (if (or (not (continuation-type-check cont))
-		    (and strict-result (policy call (/= safety 0))))
-		dtype
-		(values-type-intersection (continuation-asserted-type cont)
-					  dtype))))
-      (multiple-value-bind (int win) (funcall result-test out-type return-type)
-	(cond ((not win)
-	       (note-unwinnage "can't tell whether the result is a ~S"
-			       (type-specifier return-type)))
-	      ((not int)
-	       (note-lossage "The result is a ~S, not a ~S."
-			     (type-specifier out-type)
-			     (type-specifier return-type))))))
-
+         (args (combination-args call)))
+    (if (fun-type-p type)
+        (let* ((nargs (length args))
+               (required (fun-type-required type))
+               (min-args (length required))
+               (optional (fun-type-optional type))
+               (max-args (+ min-args (length optional)))
+               (rest (fun-type-rest type))
+               (keyp (fun-type-keyp type)))
+          (cond
+            ((fun-type-wild-args type)
+             (loop for arg in args
+                   and i from 1
+                   do (check-arg-type arg *universal-type* i)))
+            ((not (or optional keyp rest))
+             (if (/= nargs min-args)
+                 (note-lossage
+                  "The function was called with ~R argument~:P, but wants exactly ~R."
+                  nargs min-args)
+                 (check-fixed-and-rest args required nil)))
+            ((< nargs min-args)
+             (note-lossage
+              "The function was called with ~R argument~:P, but wants at least ~R."
+              nargs min-args))
+            ((<= nargs max-args)
+             (check-fixed-and-rest args (append required optional) rest))
+            ((not (or keyp rest))
+             (note-lossage
+              "The function was called with ~R argument~:P, but wants at most ~R."
+              nargs max-args))
+            ((and keyp (oddp (- nargs max-args)))
+             (note-lossage
+              "The function has an odd number of arguments in the keyword portion."))
+            (t
+             (check-fixed-and-rest args (append required optional) rest)
+             (when keyp
+               (check-key-args args max-args type))))
+
+          (when result-test
+            (let* ((dtype (node-derived-type call))
+                   (out-type (or
+                              (binding* ((lvar (node-lvar call) :exit-if-null)
+                                         (dest (lvar-dest lvar)))
+                                (when (and (cast-p dest)
+                                           (eq (cast-type-to-check dest) *wild-type*)
+                                           (immediately-used-p lvar call))
+                                  (values-type-intersection
+                                   dtype (cast-asserted-type dest))))
+                              dtype))
+                   (return-type (fun-type-returns type)))
+              (multiple-value-bind (int win) (funcall result-test out-type return-type)
+                (cond ((not win)
+                       (note-unwinnage "can't tell whether the result is a ~S"
+                                       (type-specifier return-type)))
+                      ((not int)
+                       (note-lossage "The result is a ~S, not a ~S."
+                                     (type-specifier out-type)
+                                     (type-specifier return-type))))))))
+        (loop for arg in args
+              and i from 1
+              do (check-arg-type arg *wild-type* i)))
     (cond (*lossage-detected* (values nil t))
-	  (*unwinnage-detected* (values nil nil))
-	  (t (values t t)))))
-
-;;; Check that the derived type of the continuation CONT is compatible
-;;; with TYPE. N is the arg number, for error message purposes. We
-;;; return true if arg is definitely o.k. If the type is a magic
-;;; CONSTANT-TYPE, then we check for the argument being a constant
-;;; value of the specified type. If there is a manifest type error
-;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even
-;;; when our type is satisfied under the test.
-(defun check-arg-type (cont type n)
-  (declare (type continuation cont) (type ctype type) (type index n))
+          (*unwinnage-detected* (values nil nil))
+          (t (values t t)))))
+
+;;; Check that the derived type of the LVAR is compatible with TYPE. N
+;;; is the arg number, for error message purposes. We return true if
+;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
+;;; we check for the argument being a constant value of the specified
+;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
+;;; we flame about the asserted type even when our type is satisfied
+;;; under the test.
+(defun check-arg-type (lvar type n)
+  (declare (type lvar lvar) (type ctype type) (type index n))
   (cond
    ((not (constant-type-p type))
-    (let ((ctype (continuation-type cont)))
+    (let ((ctype (lvar-type lvar)))
       (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
 	(cond ((not win)
 	       (note-unwinnage "can't tell whether the ~:R argument is a ~S"
@@ -199,16 +203,16 @@
 	       (note-unwinnage "The ~:R argument never returns a value." n)
 	       nil)
 	      (t t)))))
-    ((not (constant-continuation-p cont))
+    ((not (constant-lvar-p lvar))
      (note-unwinnage "The ~:R argument is not a constant." n)
      nil)
     (t
-     (let ((val (continuation-value cont))
+     (let ((val (lvar-value lvar))
 	   (type (constant-type-type type)))
        (multiple-value-bind (res win) (ctypep val type)
 	 (cond ((not win)
 		(note-unwinnage "can't tell whether the ~:R argument is a ~
-			        constant ~S:~%  ~S"
+                                 constant ~S:~%  ~S"
 				n (type-specifier type) val)
 		nil)
 	       ((not res)
@@ -247,12 +251,12 @@
     (let ((k (car key)))
       (cond
        ((not (check-arg-type k (specifier-type 'symbol) n)))
-       ((not (constant-continuation-p k))
+       ((not (constant-lvar-p k))
 	(note-unwinnage "The ~:R argument (in keyword position) is not a ~
-                        constant."
+                         constant."
 			n))
        (t
-	(let* ((name (continuation-value k))
+	(let* ((name (lvar-value k))
 	       (info (find name (fun-type-keywords type)
 			   :key #'key-info-name)))
 	  (cond ((not info)
@@ -268,7 +272,7 @@
 ;;;
 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
 ;;; the &REST type.
-(declaim (ftype (function (functional) fun-type) definition-type))
+(declaim (ftype (sfunction (functional) fun-type) definition-type))
 (defun definition-type (functional)
   (if (lambda-p functional)
       (make-fun-type
@@ -357,8 +361,8 @@
 	 (args (combination-args call))
 	 (nargs (length args))
 	 (allowp (some (lambda (x)
-			 (and (constant-continuation-p x)
-			      (eq (continuation-value x) :allow-other-keys)))
+			 (and (constant-lvar-p x)
+			      (eq (lvar-value x) :allow-other-keys)))
 		       args)))
 
     (setf (approximate-fun-type-min-args type)
@@ -372,10 +376,10 @@
 	 (setf (approximate-fun-type-types type)
 	       (nconc types
 		      (mapcar (lambda (x)
-				(list (continuation-type x)))
+				(list (lvar-type x)))
 			      arg))))
       (when (null arg) (return))
-      (pushnew (continuation-type (car arg))
+      (pushnew (lvar-type (car arg))
 	       (car old)
 	       :test #'type=))
 
@@ -386,8 +390,8 @@
 	   (setf (approximate-fun-type-keys type) (keys)))
 	(let ((key (first arg))
 	      (val (second arg)))
-	  (when (constant-continuation-p key)
-	    (let ((name (continuation-value key)))
+	  (when (constant-lvar-p key)
+	    (let ((name (lvar-value key)))
 	      (when (keywordp name)
 		(let ((old (find-if
 			    (lambda (x)
@@ -395,7 +399,7 @@
 				   (= (approximate-key-info-position x)
 				      pos)))
 			    (keys)))
-		      (val-type (continuation-type val)))
+		      (val-type (lvar-type val)))
 		  (cond (old
 			 (pushnew val-type
 				  (approximate-key-info-types old)
@@ -410,7 +414,7 @@
 				:types (list val-type))))))))))))
     type))
 
-;;; This is similar to VALID-FUNCTION-USE, but checks an
+;;; This is similar to VALID-FUN-USE, but checks an
 ;;; APPROXIMATE-FUN-TYPE against a real function type.
 (declaim (ftype (function (approximate-fun-type fun-type
 			   &optional function function function)
@@ -421,7 +425,7 @@
 					  #'types-equal-or-intersect)
 					 (*lossage-fun*
 					  #'compiler-style-warn)
-					 (*unwinnage-fun* #'compiler-note))
+					 (*unwinnage-fun* #'compiler-notify))
   (let* ((*lossage-detected* nil)
 	 (*unwinnage-detected* nil)
 	 (required (fun-type-required type))
@@ -550,7 +554,7 @@
 	       ((eq int *empty-type*)
 		(note-lossage
 		 "Definition's declared type for variable ~A:~%  ~S~@
-		  conflicts with this type from ~A:~%  ~S"
+                  conflicts with this type from ~A:~%  ~S"
 		 (leaf-debug-name var) (type-specifier vtype)
 		 where (type-specifier type))
 		(return-from try-type-intersections (values nil nil)))
@@ -559,7 +563,7 @@
 	  vars types)
     (values vars (res))))
 
-;;; Check that the optional-dispatch OD conforms to Type. We return
+;;; Check that the optional-dispatch OD conforms to TYPE. We return
 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
 ;;; problems, otherwise NIL, NIL.
 ;;;
@@ -602,7 +606,7 @@
 	     (unless (eq x y)
 	       (note-lossage
 		"The definition ~:[doesn't have~;has~] ~A, but ~
-		~A ~:[doesn't~;does~]."
+                 ~A ~:[doesn't~;does~]."
 		x what where y))))
       (frob (optional-dispatch-keyp od) (fun-type-keyp type)
 	    "&KEY arguments")
@@ -672,7 +676,7 @@
 
       (try-type-intersections (vars) (res) where))))
 
-;;; Check that Type doesn't specify any funny args, and do the
+;;; Check that TYPE doesn't specify any funny args, and do the
 ;;; intersection.
 (defun find-lambda-types (lambda type where)
   (declare (type clambda lambda) (type fun-type type) (string where))
@@ -707,11 +711,11 @@
 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
 ;;; false). If there was a problem, we return NIL.
 (defun assert-definition-type
-       (functional type &key (really-assert t)
-		   ((:lossage-fun *lossage-fun*)
-		    #'compiler-style-warn)
-		   unwinnage-fun
-		   (where "previous declaration"))
+    (functional type &key (really-assert t)
+     ((:lossage-fun *lossage-fun*)
+      #'compiler-style-warn)
+     unwinnage-fun
+     (where "previous declaration"))
   (declare (type functional functional)
 	   (type function *lossage-fun*)
 	   (string where))
@@ -728,34 +732,126 @@
 	       (find-lambda-types functional type where))))
       (let* ((type-returns (fun-type-returns type))
 	     (return (lambda-return (main-entry functional)))
-	     (atype (when return
-		      (continuation-asserted-type (return-result return)))))
+	     (dtype (when return
+                      (lvar-derived-type (return-result return)))))
 	(cond
-	 ((and atype (not (values-types-equal-or-intersect atype
-							   type-returns)))
-	  (note-lossage
-	   "The result type from ~A:~%  ~S~@
-	   conflicts with the definition's result type assertion:~%  ~S"
-	   where (type-specifier type-returns) (type-specifier atype))
-	  nil)
-	 (*lossage-detected* nil)
-	 ((not really-assert) t)
-	 (t
-	  (when atype
-	    (assert-continuation-type (return-result return) atype))
-	  (loop for var in vars and type in types do
-	    (cond ((basic-var-sets var)
-		   (when (and unwinnage-fun
-			      (not (csubtypep (leaf-type var) type)))
-		     (funcall unwinnage-fun
-			      "Assignment to argument: ~S~%  ~
-			       prevents use of assertion from function ~
-			       type ~A:~%  ~S~%"
-			      (leaf-debug-name var)
-			      where
-			      (type-specifier type))))
-		  (t
-		   (setf (leaf-type var) type)
-		   (dolist (ref (leaf-refs var))
-		     (derive-node-type ref type)))))
-	  t))))))
+          ((and dtype (not (values-types-equal-or-intersect dtype
+                                                            type-returns)))
+           (note-lossage
+            "The result type from ~A:~%  ~S~@
+             conflicts with the definition's result type:~%  ~S"
+            where (type-specifier type-returns) (type-specifier dtype))
+           nil)
+          (*lossage-detected* nil)
+          ((not really-assert) t)
+          (t
+           (let ((policy (lexenv-policy (functional-lexenv functional))))
+             (when (policy policy (> type-check 0))
+               (assert-lvar-type (return-result return) type-returns
+                                 policy)))
+           (loop for var in vars and type in types do
+                 (cond ((basic-var-sets var)
+                        (when (and unwinnage-fun
+                                   (not (csubtypep (leaf-type var) type)))
+                          (funcall unwinnage-fun
+                                   "Assignment to argument: ~S~%  ~
+                                    prevents use of assertion from function ~
+                                    type ~A:~%  ~S~%"
+                                   (leaf-debug-name var)
+                                   where
+                                   (type-specifier type))))
+                       (t
+                        (setf (leaf-type var) type)
+                        (dolist (ref (leaf-refs var))
+                          (derive-node-type ref (make-single-value-type type))))))
+           t))))))
+
+;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
+(defun assert-global-function-definition-type (name fun)
+  (declare (type functional fun))
+  (let ((type (info :function :type name))
+        (where (info :function :where-from name)))
+    (when (eq where :declared)
+      (setf (leaf-type fun) type)
+      (assert-definition-type
+       fun type
+       :unwinnage-fun #'compiler-notify
+       :where "proclamation"
+       :really-assert (not (awhen (info :function :info name)
+                             (ir1-attributep (fun-info-attributes it)
+                                             explicit-check)))))))
+
+;;; Call FUN with (arg-lvar arg-type)
+(defun map-combination-args-and-types (fun call)
+  (declare (type function fun) (type combination call))
+  (binding* ((type (lvar-type (combination-fun call)))
+             (nil (fun-type-p type) :exit-if-null)
+             (args (combination-args call)))
+    (dolist (req (fun-type-required type))
+      (when (null args) (return-from map-combination-args-and-types))
+      (let ((arg (pop args)))
+        (funcall fun arg req)))
+    (dolist (opt (fun-type-optional type))
+      (when (null args) (return-from map-combination-args-and-types))
+      (let ((arg (pop args)))
+        (funcall fun arg opt)))
+
+    (let ((rest (fun-type-rest type)))
+      (when rest
+        (dolist (arg args)
+          (funcall fun arg rest))))
+
+    (dolist (key (fun-type-keywords type))
+      (let ((name (key-info-name key)))
+        (do ((arg args (cddr arg)))
+            ((null arg))
+          (when (eq (lvar-value (first arg)) name)
+            (funcall fun (second arg) (key-info-type key))))))))
+
+;;; Assert that CALL is to a function of the specified TYPE. It is
+;;; assumed that the call is legal and has only constants in the
+;;; keyword positions.
+(defun assert-call-type (call type)
+  (declare (type combination call) (type fun-type type))
+  (derive-node-type call (fun-type-returns type))
+  (let ((policy (lexenv-policy (node-lexenv call))))
+    (map-combination-args-and-types
+     (lambda (arg type)
+       (assert-lvar-type arg type policy))
+     call))
+  (values))
+
+;;;; FIXME: Move to some other file.
+(defun check-catch-tag-type (tag)
+  (declare (type lvar tag))
+  (let ((ctype (lvar-type tag)))
+    (when (csubtypep ctype (specifier-type '(or number character)))
+      (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
+                            tends to be unportable because THROW and CATCH ~
+                            use EQ comparison)~@:>"
+			   (lvar-source tag)
+			   (type-specifier (lvar-type tag))))))
+
+(defun %compile-time-type-error (values atype dtype)
+  (declare (ignore dtype))
+  (if (and (consp atype)
+           (eq (car atype) 'values))
+      (error 'values-type-error :datum values :expected-type atype)
+      (error 'type-error :datum (car values) :expected-type atype)))
+
+(defoptimizer (%compile-time-type-error ir2-convert)
+    ((objects atype dtype) node block)
+  (let ((*compiler-error-context* node))
+    (setf (node-source-path node)
+          (cdr (node-source-path node)))
+    (destructuring-bind (values atype dtype)
+        (basic-combination-args node)
+      (declare (ignore values))
+      (let ((atype (lvar-value atype))
+            (dtype (lvar-value dtype)))
+      (unless (eq atype nil)
+        (warn 'type-warning
+	      :format-control 
+	      "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+	      :format-arguments (list atype dtype)))))
+    (ir2-convert-full-call node block)))