>From 02585429c61ae021e6724d7bae9268ecc77eb8e8 Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Mon, 27 Nov 2017 17:15:19 +1300 Subject: [PATCH] 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. --- scrutinizer.scm | 20 ++++++++------------ tests/scrutiny-tests-3.scm | 9 +++++++++ 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/scrutinizer.scm b/scrutinizer.scm index 9720ea0d..6ecf7ba1 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -1220,13 +1220,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 @@ -1254,7 +1253,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 '())) @@ -1356,11 +1355,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))) -- 2.11.0