~ chicken-core (chicken-5) 9bb90f7761760efa69bd78c391b9e35bbc5320c9

commit 9bb90f7761760efa69bd78c391b9e35bbc5320c9
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Oct 12 19:07:20 2012 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Fri Oct 12 20:47:52 2012 +0200

    Reduce typeset in alternative conditional branch with predicate.
    
    During flow-analysis, when a predicate is applied to a variable, the
    variable is assumed to have the corresponding type in the consequent
    branch of a conditional that depends on this predicate call. This
    patch adds a small enhancement that, in case the variable type is
    known to be a typeset (an "(or ...)" type), reduces the typeset by
    removing those types that match the predicate-type:
    
    (let ((a ...))  ; say "a" is of type "(or string number)"
      (if (number? a)
          ...           ; "a" is known to be of type "number"
          ...))         ; "a" is now known to be of type "string"  <- new
    
    Here "number" matches the predicate type of "number?" ("number"),
    is removed from the "(or string number)" type, and results in
    type "string" for "a" in the second "if" branch.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3ed4753d..b4f4b3dd 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -447,6 +447,19 @@
 		(make-list argc '*)))
 	  (make-list argc '*)))
 
+    (define (reduce-typeset t pt typeenv)
+      (and-let* ((tnew
+		  (let rec ((t t))
+		    (and (pair? t)
+			 (case (car t)
+			   ((forall) 
+			    (and-let* ((t2 (rec (third t))))
+			      `(forall ,(second t) ,t2)))
+			   ((or) 
+			    `(or ,@(remove (cut match-types <> pt typeenv) (cdr t))))
+			   (else #f))))))
+	(simplify-type tnew)))
+
     (define (walk n e loc dest tail flow ctags) ; returns result specifier
       (let ((subs (node-subexpressions n))
 	    (params (node-parameters n)) 
@@ -717,12 +730,25 @@
 						    (not (get db var 'assigned)) 
 						    (not oparg?))))
 				    (cond (pred
+					   ;;XXX is this needed? "typeenv" is the te of "args",
+					   ;;    not of "pt":
 					   (let ((pt (resolve pt typeenv)))
 					     (d "  predicate `~a' indicates `~a' is ~a in flow ~a"
 						pn var pt (car ctags))
 					     (add-to-blist 
 					      var (car ctags)
-					      (if (and a (type<=? (cdr a) pt)) (cdr a) pt))))
+					      (if (and a (type<=? (cdr a) pt)) (cdr a) pt))
+					     ;; if the variable type is an "or"-type, we can
+					     ;; can remove all elements that match the predicate
+					     ;; type
+					     (when a
+					       ;;XXX hack, again:
+					       (let* ((tenv2 (type-typeenv `(or ,(cdr a) ,pt)))
+						      (at (reduce-typeset (cdr a) pt tenv2)))
+						 (when at
+						   (d "  predicate `~a' indicates `~a' is ~a in flow ~a"
+						      pn var at (cdr ctags))
+						   (add-to-blist var (cdr ctags) at))))))
 					  (a
 					   (when enforces
 					     (let ((ar (cond ((blist-type var flow) =>
diff --git a/tests/scrutiny-tests-3.scm b/tests/scrutiny-tests-3.scm
index 41b46fb7..243a069a 100644
--- a/tests/scrutiny-tests-3.scm
+++ b/tests/scrutiny-tests-3.scm
@@ -10,3 +10,22 @@
  (compiler-typecase vec
    ((vector-of boolean) #f)
    (vector #t)))
+
+
+;;; reduce OR-types in alternative branch of conditional with predicate
+
+(define something)
+
+(let ((x (the (or string number) something)))
+  (if (number? x)
+      (compiler-typecase x
+	(number 1))
+      (compiler-typecase x
+	(string 2))))
+
+(let ((x (the (forall ((a string) (b number)) (or a b)) something)))
+  (if (number? x)
+      (compiler-typecase x
+	(number 3))
+      (compiler-typecase x
+	(string 4))))