~ chicken-core (chicken-5) 62d7991d41418cb29809e3e235fe5b50619f8225

commit 62d7991d41418cb29809e3e235fe5b50619f8225
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Nov 27 17:15:19 2017 +1300
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Dec 2 16:36:17 2017 +0100

    Generalise result type when scrutiniser merges differently-valued procedures
    
    When merging procedures with different result counts, we have to fall
    back to an "any" result since there's currently no way to express that a
    procedure may have, for example, zero or one results.
    
    We also generalise union types that include a "noreturn" result to the
    "any" type, since we can't (currently) do anything useful with
    procedures that are potentially-but-not-certainly noreturn.
    
    Fixes #1399.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 074681f1..84e96b29 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1246,13 +1246,12 @@
 			       constraints))
 		     (simplify (third t))))
 		  ((or)
- 		   (let* ((ts (map simplify (cdr t)))
- 			  (tslen (length ts)))
- 		     (cond ((= 1 tslen) (car ts))
-			   ((null? ts) '*)
- 			   ((> tslen +maximal-union-type-length+)
- 			    (d "union-type cutoff! (~a): ~s" tslen ts)
- 			    '*)
+		   (let ((ts (delete-duplicates (map simplify (cdr t)) eq?)))
+		     (cond ((null? ts) '*)
+			   ((null? (cdr ts)) (car ts))
+			   ((> (length ts) +maximal-union-type-length+)
+			    (d "union-type cutoff! (~a): ~s" (length ts) ts)
+			    '*)
 			   ((every procedure-type? ts)
 			    (if (any (cut eq? 'procedure <>) ts)
 				'procedure
@@ -1281,7 +1280,7 @@
 					    (cond ((and (pair? t) (eq? 'or (car t)))
 						   (cdr t))
 						  ((eq? t 'undefined) (return 'undefined))
-						  ((eq? t 'noreturn) '())
+						  ((eq? t 'noreturn) (return '*))
 						  (else (list t)))))
 					ts))
 				   (ts2 (let loop ((ts ts) (done '()))
@@ -1402,11 +1401,8 @@
   (call/cc
    (lambda (return)
      (let loop ((ts1 ts11) (ts2 ts21))
-       (cond ((null? ts1) '())
-	     ((null? ts2) '())
+       (cond ((and (null? ts1) (null? ts2)) '())
 	     ((or (atom? ts1) (atom? ts2)) (return '*))
-	     ((eq? 'noreturn (car ts1)) (loop (cdr ts1) ts2))
-	     ((eq? 'noreturn (car ts2)) (loop ts1 (cdr ts2)))
 	     (else (cons (simplify-type `(or ,(car ts1) ,(car ts2)))
 			 (loop (cdr ts1) (cdr ts2)))))))))
 
diff --git a/tests/scrutiny-tests-3.scm b/tests/scrutiny-tests-3.scm
index 75c88f88..a8bb7db5 100644
--- a/tests/scrutiny-tests-3.scm
+++ b/tests/scrutiny-tests-3.scm
@@ -36,3 +36,12 @@
 	(number 3))
       (compiler-typecase x
 	(string 4))))
+
+
+;;; #1399 incorrect return type after merge with noreturn procedure
+
+(let ((x (the (->) something))
+      (y (the (-> noreturn) something)))
+  (compiler-typecase (if something x y)
+    ((->) (error "#1399 regression test failure"))
+    (else 'ok)))