0.8.3.39:

[sbcl.git] / src / compiler / ctype.lisp

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 3edc03b..3748cf8 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -265,7 +265,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
@@ -418,7 +418,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))
@@ -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-note
-                              :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)))))))
+\f
+;;; 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))
 \f
 ;;;; FIXME: Move to some other file.
 (defun check-catch-tag-type (tag)