~ chicken-core (chicken-5) 9413c4bf1b4b0c95e60ba12e082f4e03b4c0f8ef

commit 9413c4bf1b4b0c95e60ba12e082f4e03b4c0f8ef
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jun 25 22:51:20 2019 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 29 14:11:35 2019 +0200

    Fix lfa2 type analysis for conditionals.
    
    Merge the types of the branches of conditional nodes when computing the result type.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/lfa2.scm b/lfa2.scm
index 3226b2e6..f7516658 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -258,6 +258,15 @@
 	     `(struct ,(##sys#slot lit 0)))
 	    ((char? lit) 'char)
 	    (else '*)))
+    
+    (define (merge t1 t2)
+      (cond ((eq? t1 t2) t1)
+            ((and (pair? t1) (pair? t2)
+                  (eq? (car t1) 'struct)
+                  (eq? (car t2) 'struct)
+                  (eq? (cadr t1) (cadr t2)))
+             t1)
+            (else '*)))
 
     (define (report elim)
       (cond ((assoc elim stats) =>
@@ -348,16 +357,15 @@
 	   (vartype (first params) te ae))
 	  ((if ##core#cond) 
 	   (let ((tr (walk (first subs) te ae)))
-	     (cond ((and (pair? tr) (eq? 'boolean (car tr)))
-		    (walk (second subs)
-			  (append (second tr) te)
-			  ae)
-		    (walk (third subs)
-			  (append (third tr) te)
-			  ae))
-		   (else
-		    (walk (second subs) te ae)
-		    (walk (third subs) te ae)))))
+	     (if (and (pair? tr) (eq? 'boolean (car tr)))
+                 (merge (walk (second subs)
+                              (append (second tr) te)
+                              ae)
+                        (walk (third subs)
+                              (append (third tr) te)
+                              ae)))
+                 (merge (walk (second subs) te ae)
+                        (walk (third subs) te ae))))
 	  ((quote) (constant-result (first params)))
 	  ((let)
 	   (let* ((val (first subs))