From: Alexey Dejneka <adejneka@comail.ru>
Date: Mon, 7 Jul 2003 16:35:48 +0000 (+0000)
Subject: 0.8.1.27:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=11745f006f4eb17fdc6189475f22a79f52bbde6c;p=sbcl.git

0.8.1.27:
        * Derive types of variables, bound with MV-BIND, even if we
          don't know the number of values, returned by the argument.
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 114def3..2c8b88f 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1294,12 +1294,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
              "VALUES-TYPE"
              "VALUES-TYPE-ERROR"
+             "VALUES-TYPE-IN"
              "VALUES-TYPE-INTERSECTION"
              "VALUES-TYPE-OPTIONAL"
+             "VALUES-TYPE-OUT"
              "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
              "VALUES-TYPE-REST" "VALUES-TYPE-UNION"
              "VALUES-TYPE-TYPES" "VALUES-TYPES"
-             "VALUES-TYPE-START"
              "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
              "VECTOR-TO-VECTOR*"
              "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 861ff45..d0a2938 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -470,8 +470,8 @@
               (cond ((args-type-rest type))
                     (t default-type)))))
 
-;;; If COUNT values are supplied, which types should they have?
-(defun values-type-start (type count)
+;;; types of values in (the <type> (values o_1 ... o_n))
+(defun values-type-out (type count)
   (declare (type ctype type) (type unsigned-byte count))
   (if (eq type *wild-type*)
       (make-list count :initial-element *universal-type*)
@@ -489,6 +489,29 @@
                   do (res rest))))
         (res))))
 
+;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
+(defun values-type-in (type count)
+  (declare (type ctype type) (type unsigned-byte count))
+  (if (eq type *wild-type*)
+      (make-list count :initial-element *universal-type*)
+      (collect ((res))
+        (let ((null-type (specifier-type 'null)))
+          (loop for type in (values-type-required type)
+             while (plusp count)
+             do (decf count)
+             do (res type))
+          (loop for type in (values-type-optional type)
+             while (plusp count)
+             do (decf count)
+             do (res (type-union type null-type)))
+          (when (plusp count)
+            (loop with rest = (acond ((values-type-rest type)
+                                      (type-union it null-type))
+                                     (t null-type))
+               repeat count
+               do (res rest))))
+        (res))))
+
 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
 ;;; than TYPES2. The second value is T if OPERATION always returned a
diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 9d13c97..4958c90 100644
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -269,8 +269,8 @@
                                        force-hairy)))
                 ((not (eq vcount :unknown))
                  (maybe-negate-check value
-                                     (values-type-start ctype vcount)
-                                     (values-type-start atype vcount)
+                                     (values-type-out ctype vcount)
+                                     (values-type-out atype vcount)
                                      t))
                 (t
                  (values :too-hairy nil))))))))
@@ -389,11 +389,11 @@
 			((= length 1)
                          (single-value-type atype))
                         (t
-			 (make-values-type :required 
-			                   (values-type-start atype length)))))
+			 (make-values-type
+                          :required (values-type-out atype length)))))
            (dtype (node-derived-type cast))
-           (dtype (make-values-type :required 
-	                            (values-type-start dtype length))))
+           (dtype (make-values-type
+                   :required (values-type-out dtype length))))
       (setf (cast-asserted-type cast) atype)
       (setf (node-derived-type cast) dtype)))
 
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 0cac21d..f527b05 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1527,19 +1527,16 @@
 ;;; vars.
 (defun ir1-optimize-mv-bind (node)
   (declare (type mv-combination node))
-  (let ((arg (first (basic-combination-args node)))
-	(vars (lambda-vars (combination-lambda node))))
-    (multiple-value-bind (types nvals)
-	(values-types (continuation-derived-type arg))
-      (unless (eq nvals :unknown)
-	(mapc (lambda (var type)
-		(if (basic-var-sets var)
-		    (propagate-from-sets var type)
-		    (propagate-to-refs var type)))
-	      vars
-              (adjust-list types
-                           (length vars)
-                           (specifier-type 'null)))))
+  (let* ((arg (first (basic-combination-args node)))
+         (vars (lambda-vars (combination-lambda node)))
+         (n-vars (length vars))
+         (types (values-type-in (continuation-derived-type arg)
+                                n-vars)))
+    (loop for var in vars
+          and type in types
+          do (if (basic-var-sets var)
+                 (propagate-from-sets var type)
+                 (propagate-to-refs var type)))
     (setf (continuation-reoptimize arg) nil))
   (values))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 695a9d7..55a1b79 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.26"
+"0.8.1.27"