X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=3748cf8ebf66771e4c0111e2a9a6c8863ab5f170;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=93aeb42ab0f8d4895e8dac57ab8ff3e13c24148c;hpb=ff57884e206ac28660af6af34315bc9b81697f57;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 93aeb42..3748cf8 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -759,15 +759,60 @@
                          (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"))))
+      (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-continuation arg-type)
+(defun map-combination-args-and-types (fun call)
+  (declare (type function fun) (type combination call))
+  (binding* ((type (continuation-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 (continuation-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-continuation-type arg type policy))
+     call))
+  (values))
 
 ;;;; FIXME: Move to some other file.
 (defun check-catch-tag-type (tag)