This patch addresses the problem reported by Sven Hartrumpf
(#1624).
felix
From 41bf17c22a5b68e537d041b11b15f42d4b53dd88 Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
