From 2be5885a19e5bc390a87087bb93f853732165c3b Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Tue, 18 Sep 2018 12:42:44 +0300
Subject: [PATCH 2/2] * scrutinizer.scm (refine-types): Add special case for
 (or pair null) and list-of

Fixes #1533
* tests/scrutinizer-tests.scm: New test. Note list is an alias for (list-of *)
* tests/typematch-tests.scm: Add test + fix 'infer' macro

Signed-off-by: Peter Bex <address@hidden>
---
 scrutinizer.scm             |  5 +++++
 tests/scrutinizer-tests.scm |  1 +
 tests/typematch-tests.scm   | 16 +++++++++++-----
 3 files changed, 17 insertions(+), 5 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index e30d81be..8209ae38 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1442,6 +1442,11 @@
 	((and (pair? t2) (memq (car t2) '(forall refine)))
 	 (let ((t2* (loop t1 (third t2))))
 	   (and t2* (list (car t2) (second t2) t2*))))
+	;; (or pair null) ~> (list-of a) -> (list-of a)
+	((and (pair? t1) (eq? (car t1) 'or)
+	      (lset=/eq? '(null pair) (cdr t1))
+	      (and (pair? t2) (eq? 'list-of (car t2))))
+	 t2)
 	((and (pair? t1) (eq? (car t1) 'or))
 	 (let ((ts (filter-map (lambda (t) (loop t t2)) (cdr t1))))
 	   (and (pair? ts) (cons 'or ts))))
diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
index 94ce66bd..939351ac 100644
--- a/tests/scrutinizer-tests.scm
+++ b/tests/scrutinizer-tests.scm
@@ -304,6 +304,7 @@
 (test (~> (list (refine (a) x))
           (refine (a) (list (refine (b) y)))
           (refine (a) (list (refine (b) y)))))
+(test (~> (or pair null) list list))
 
 (begin-for-syntax
   (when (not success) (exit 1)))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index e4123cd8..4d8f40cd 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -66,11 +66,12 @@
    (lambda (e _i _c)
      (apply
       (lambda (t x)
-	`(test-equal ',(strip-syntax e)
-	   (compiler-typecase ,x
-	     (,t #t)
-	     (else #f))
-	   #t))
+	;; TODO: test-equal smashes types: change rest of the macros
+	;; to handle this
+	`(let ((res (compiler-typecase ,x
+		      (,t #t)
+		      (else #f))))
+	   (test-equal ',(strip-syntax e) res #t)))
       (cdr e)))))
 
 (define-syntax infer-not
@@ -392,4 +393,9 @@
 ;; Always a bignum
 (infer-last (fixnum bignum) #x7fffffffffffffff)
 
+;; Issue #1533
+(let ((a (the (or pair null) (cons 1 '()))))
+  (length a) ; refine (or pair null) with list (= (list-of *))
+  (infer list a))
+
 (test-exit)
-- 
2.11.0