From 41bf17c22a5b68e537d041b11b15f42d4b53dd88 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 25 Jun 2019 22:51:20 +0200
Subject: [PATCH] Fix lfa2 type analysis for conditionals.

Merge the types of the branches of conditional nodes when computing the result type.
---
 lfa2.scm | 28 ++++++++++++++++++----------
 1 file changed, 18 insertions(+), 10 deletions(-)

diff --git a/lfa2.scm b/lfa2.scm
index 5d739d9a..7473cdd1 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))
-- 
2.19.1