X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=8e1940b821c74f31cd11f4b886aac3e433c3f276;hb=f741a144c386acdb82cac2e3352abab7cff65f1d;hp=1470a49a30c4afe00366d764a9f4029b3a0b2773;hpb=81153b7c9824ef389928ff6d04fb5acbcffb3867;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 1470a49..8e1940b 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -616,7 +616,7 @@
       (unless (optional-dispatch-keyp od)
         (frob (not (null (optional-dispatch-more-entry od)))
               (not (null (fun-type-rest type)))
-              "&REST arguments"))
+              "&REST argument"))
       (frob (optional-dispatch-allowp od) (fun-type-allowp type)
             "&ALLOW-OTHER-KEYS"))
 
@@ -776,14 +776,36 @@
   (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)))))))
+      (let ((type (massage-global-definition-type type fun)))
+        (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))))))))
+
+;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
+;;; doesn't complain about the type missing &REST -- which is good, because in
+;;; that case &REST is really an implementation detail and not part of the
+;;; interface. However since we set the leaf type missing &REST from there
+;;; would be a bad thing -- to make up a new type if necessary.
+(defun massage-global-definition-type (type fun)
+  (if (and (fun-type-p type)
+           (optional-dispatch-p fun)
+           (optional-dispatch-keyp fun)
+           (optional-dispatch-more-entry fun)
+           (not (or (fun-type-rest type)
+                    (fun-type-wild-args type))))
+      (make-fun-type :required (fun-type-required type)
+                     :optional (fun-type-optional type)
+                     :rest *universal-type*
+                     :keyp (fun-type-keyp type)
+                     :keywords (fun-type-keywords type)
+                     :allowp (fun-type-allowp type)
+                     :returns (fun-type-returns type))
+      type))
 
 ;;; Call FUN with (arg-lvar arg-type)
 (defun map-combination-args-and-types (fun call)
@@ -815,13 +837,27 @@
 ;;; 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)
+(defun assert-call-type (call type &optional (trusted t))
   (declare (type combination call) (type fun-type type))
-  (derive-node-type call (fun-type-returns type))
-  (let ((policy (lexenv-policy (node-lexenv call))))
+  (let ((policy (lexenv-policy (node-lexenv call)))
+        (returns (fun-type-returns type)))
+    (if trusted
+        (derive-node-type call returns)
+        (let ((lvar (node-lvar call)))
+          ;; If the value is used in a non-tail position, and
+          ;; the lvar is a single-use, assert the type. Multiple use
+          ;; sites need to be elided because the assertion has to apply
+          ;; to all uses. Tail positions are elided because the assertion
+          ;; would lose cause us not the be in a tail-position anymore.
+          (when (and lvar
+                     (not (return-p (lvar-dest lvar)))
+                     (lvar-has-single-use-p lvar))
+            (when (assert-lvar-type lvar returns policy)
+              (reoptimize-lvar lvar)))))
     (map-combination-args-and-types
      (lambda (arg type)
-       (assert-lvar-type arg type policy))
+       (when (assert-lvar-type arg type policy)
+         (unless trusted (reoptimize-lvar arg))))
      call))
   (values))