>From bb36d4d74508c13af6b2f48523bb6f7289532dbc Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sun, 29 Dec 2013 14:47:32 +1300
Subject: [PATCH 3/3] Improve scrutiny for pair types

This avoids lossy canonicalization of pair types in the scrutinizer, and
makes type matching slightly more accurate when matching (pair ...)
forms against list/list-of types. This allows type variables in pairs to
be unified from the type environment during pair <-> list-of
comparisons. Fixes #1039.
---
 scrutinizer.scm           |   30 +++++++++---------------
 tests/typematch-tests.scm |   56 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 67 insertions(+), 19 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index d7b7dfa..9fe3bf8 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1147,14 +1147,13 @@
 		   (every match1 (cdr t1) (cdr t2))))
 	     (else #f) ) )
 	  ((and (pair? t1) (eq? 'pair (car t1)))
-	   (and (not exact) (not all)
-		(pair? t2)
+	   (and (pair? t2)
 		(case (car t2)
 		  ((list-of)
-		   (let ((ct1 (canonicalize-list-type t1)))
-		     (if ct1
-			 (match1 ct1 t2)
-			 #t)))		; inexact match
+		   (and (not exact)
+			(not all)
+			(match1 (second t1) (second t2))
+			(match1 (third t1) t2)))
 		  ((list)
 		   (and (pair? (cdr t2))
 			(match1 (second t1) (second t2))
@@ -1167,10 +1166,9 @@
 	   (and (pair? t1)
 		(case (car t1)
 		  ((list-of)
-		   (let ((ct2 (canonicalize-list-type t2)))
-		     (if ct2
-			 (match1 t1 ct2)
-			 (and (not exact) (not all)))))	; inexact mode: ok
+		   (and (not exact)
+			(match1 (second t1) (second t2))
+			(match1 t1 (third t2))))
 		  ((list)
 		   (and (pair? (cdr t1))
 			(match1 (second t1) (second t2))
@@ -1348,9 +1346,8 @@
 			 (tcdr (simplify (third t))))
 		     (if (and (eq? '* tcar) (eq? '* tcdr))
 			 'pair
-			 (let ((t `(pair ,tcar ,tcdr)))
-			   (or (canonicalize-list-type t)
-			       t)))))
+			 (canonicalize-list-type
+			  `(pair ,tcar ,tcdr)))))
 		  ((vector-of)
 		   (let ((t2 (simplify (second t))))
 		     (if (eq? t2 '*)
@@ -2172,16 +2169,11 @@
 	   (let rec ((tr tcdr) (ts (list tcar)))
 	     (cond ((eq? 'null tr)
 		    `(list ,@(reverse ts)))
-		   ((eq? 'list tr) tr)
 		   ((and (pair? tr) (eq? 'pair (first tr)))
 		    (rec (third tr) (cons (second tr) ts)))
 		   ((and (pair? tr) (eq? 'list (first tr)))
 		    `(list ,@(reverse ts) ,@(cdr tr)))
-		   ((and (pair? tr) (eq? 'list-of (first tr)))
-		    `(list-of
-		      ,(simplify-type
-			`(or ,@(reverse ts) ,@(cdr tr)))))
-		   (else #f)))))
+		   (else t)))))
 	(else t)))
 
 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6ea5b49..b5d9d94 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -170,6 +170,10 @@
 (checkp pointer-vector? (make-pointer-vector 1) pointer-vector)
 (checkp pointer? (address->pointer 1) pointer)
 
+(mn list null)
+(mn pair null)
+(mn pair list)
+
 (mn (procedure (*) *) (procedure () *))
 (m (procedure (#!rest) . *) (procedure (*) . *))
 (mn (procedure () *) (procedure () * *))
@@ -177,6 +181,58 @@
 (mx (forall (a) (procedure (#!rest a) a)) +)
 (mx (list fixnum) '(1))
 
+;;; pairs
+
+(: car-alike  (forall (a) ((pair a *) -> a)))
+(: cadr-alike (forall (a) ((pair * (pair a *)) -> a)))
+(: cddr-alike (forall (a) ((pair * (pair * a)) -> a)))
+
+(define car-alike car)
+(define cadr-alike cadr)
+(define cddr-alike cddr)
+
+(: l (list-of fixnum))
+(: p (pair fixnum (pair fixnum fixnum)))
+
+(define l '(1 2 3))
+(define p '(1 2 . 3))
+
+(mx fixnum (car-alike l))
+(mx fixnum (car-alike p))
+(mx fixnum (cadr-alike l))
+(mx fixnum (cadr-alike p))
+(mx list   (cddr-alike l))
+(mx fixnum (cddr-alike p))
+
+(ms '(1 2) '() pair)
+(ms '() '(1 2) (not pair))
+(ms '() '(1 . 2) (not pair))
+(ms '(1 2) '(1 . 2) (pair * pair))
+(ms '(1 2) '(1 . 2) (pair * list))
+(ms '(1 2) '(1 2 3) (pair * (pair * null)))
+(ms '(1 2) '(1 2 3) (pair * (pair * (not pair))))
+(ms '(1 2 3) '(1 2) (pair * (pair * (not null))))
+(ms '(1 2 . 3) '(1 2 3) (pair * (pair * fixnum)))
+
+(m (pair * null) (list *))
+(m (pair * (list *)) (list * *))
+(m (pair * (list fixnum)) (list * fixnum))
+(m (pair fixnum (list *)) (list fixnum *))
+(m (pair fixnum (pair * null)) (list fixnum *))
+(m (pair fixnum (pair fixnum null)) (list fixnum fixnum))
+(m (pair char (list fixnum)) (list char fixnum))
+(m (pair fixnum (list char)) (list fixnum char))
+(m (pair fixnum (list fixnum)) (list fixnum fixnum))
+
+(mn (pair * *) list)
+(mn (pair * list) list)
+(mn (pair fixnum *) (list-of *))
+(mn (pair fixnum *) (list-of fixnum))
+(mn (pair fixnum (list-of *)) (list-of fixnum))
+(mn (pair fixnum (list-of fixnum)) (list-of fixnum))
+(mn (pair char (list-of fixnum)) (list-of fixnum))
+(mn (pair fixnum (list-of char)) (list-of fixnum))
+(mn (pair fixnum (list-of fixnum)) (list-of fixnum))
 
 ;;; special cases
 
-- 
1.7.10.4