~ chicken-core (chicken-5) b7e293696efe4f1bfdfdcd8239c0b76de0dd615f

commit b7e293696efe4f1bfdfdcd8239c0b76de0dd615f
Author:     megane <meganeka@gmail.com>
AuthorDate: Tue Sep 18 12:42:44 2018 +0300
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Oct 2 12:21:17 2018 +0200

    * 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 <peter@more-magic.net>
    Signed-off-by: felix <felix@call-with-current-continuation.org>

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)