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

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 35538ca..97923ac 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -102,12 +102,12 @@
 ;;; 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*)))
+(defun valid-fun-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))
   (let* ((*lossage-detected* nil)
@@ -672,7 +672,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))
@@ -742,7 +742,8 @@
 	 ((not really-assert) t)
 	 (t
 	  (when atype
-	    (assert-continuation-type (return-result return) atype))
+	    (assert-continuation-type (return-result return) atype
+                                      (lexenv-policy (functional-lexenv functional))))
 	  (loop for var in vars and type in types do
 	    (cond ((basic-var-sets var)
 		   (when (and unwinnage-fun
@@ -759,3 +760,24 @@
 		   (dolist (ref (leaf-refs var))
 		     (derive-node-type ref type)))))
 	  t))))))
+
+(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-note
+                              :where "proclamation"))))
+
+;;;; FIXME: Move to some other file.
+(defun check-catch-tag-type (tag)
+  (declare (type continuation tag))
+  (let ((ctype (continuation-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)~@:>"
+			   (continuation-source tag)
+			   (type-specifier (continuation-type tag))))))