>From 2f96ca6af2cfdb29b10dd00f656fa2a2f22f0e37 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sat, 16 Aug 2014 16:42:07 +1200
Subject: [PATCH 2/5] Walk nested pair types in special-cased scrutiny for
 list-ref/list-tail

Also, remove the unused ##sys#list-ref alias and its special case.

Fixes #759.
---
 library.scm               |    1 -
 scrutinizer.scm           |   86 +++++++++++++++++++++++++++------------------
 tests/typematch-tests.scm |   16 +++++++--
 3 files changed, 65 insertions(+), 38 deletions(-)

diff --git a/library.scm b/library.scm
index 74980fb..fb85c86 100644
--- a/library.scm
+++ b/library.scm
@@ -4763,7 +4763,6 @@ EOF
 (define ##sys#list? list?)
 (define ##sys#null? null?)
 (define ##sys#map-n map)
-(define ##sys#list-ref list-ref)
 
 
 ;;; Promises:
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c437933..c756067 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2232,42 +2232,60 @@
   (define-special-case vector-ref vector-ref-result-type)
   (define-special-case ##sys#vector-ref vector-ref-result-type))
 
+
+;;; List-related special cases
+;
+; Preserve known element types for list-ref, list-tail.
+
 (let ()
-  (define (list-ref-result-type node args rtypes)
-    (or (and-let* ((subs (node-subexpressions node))
-                   ((= (length subs) 3))
-                   (arg1 (walked-result (second args)))
-                   ((pair? arg1))
-                   ((eq? 'list (car arg1)))
-                   (index (third subs))
-                   ((eq? 'quote (node-class index)))
-                   (val (first (node-parameters index)))
-                   ((fixnum? val))
-                   ((>= val 0))  ;XXX could warn on failure (but needs location)
-                   ((< val (length (cdr arg1)))))
-          (list (list-ref (cdr arg1) val)))
-	rtypes))
-  (define-special-case list-ref list-ref-result-type)
-  (define-special-case ##sys#list-ref list-ref-result-type))
 
-(define-special-case list-tail
-  (lambda (node args rtypes)
-    (or (and-let* ((subs (node-subexpressions node))
-                   ((= (length subs) 3))
-                   (arg1 (walked-result (second args)))
-                   ((pair? arg1))
-                   ((eq? 'list (car arg1)))
-                   (index (third subs))
-                   ((eq? 'quote (node-class index)))
-                   (val (first (node-parameters index)))
-                   ((fixnum? val))
-                   ((>= val 0))
-                   ((<= val (length (cdr arg1)))))   ;XXX could warn on failure (but needs location)
-          (let ((rest (list-tail (cdr arg1) val)))
-            (list (if (null? rest)
-                      'null
-                      `(list ,@rest)))))
-	rtypes)))
+  (define (list-or-null a)
+    (if (null? a) 'null `(list ,@a)))
+
+  ;; Split a list or pair type form at index i, calling k with the two
+  ;; sections of the type or returning #f if it doesn't match that far.
+  (define (split-list-type l i k)
+    (cond ((not (pair? l))
+	   (and (fx= i 0) (eq? l 'null) (k l l)))
+	  ((eq? (first l) 'list)
+	   (and (fx< i (length l))
+		(receive (left right) (split-at (cdr l) i)
+		  (k (list-or-null left)
+		     (list-or-null right)))))
+	  ((eq? (first l) 'pair)
+	   (let lp ((a '()) (l l) (i i))
+	     (cond ((fx= i 0)
+		    (k (list-or-null (reverse a)) l))
+		   ((and (pair? l)
+			 (eq? (first l) 'pair))
+		    (lp (cons (second l) a)
+                        (third l)
+                        (sub1 i)))
+		   (else #f))))
+	  (else #f)))
+
+  (define (list+index-call-result-type-special-case k)
+    (lambda (node args rtypes)
+      (or (and-let* ((subs (node-subexpressions node))
+		     ((= (length subs) 3))
+		     (arg1 (walked-result (second args)))
+		     (index (third subs))
+		     ((eq? 'quote (node-class index)))
+		     (val (first (node-parameters index)))
+		     ((fixnum? val))
+		     ((>= val 0)))
+	    (split-list-type arg1 val k))
+	  rtypes)))
+
+  (define-special-case list-ref
+    (list+index-call-result-type-special-case
+     (lambda (_ result-type)
+       (and (pair? result-type)
+	    (list (cadr result-type))))))
+
+  (define-special-case list-tail
+    (list+index-call-result-type-special-case
+     (lambda (_ result-type) (list result-type)))))
 
 (define-special-case list
   (lambda (node args rtypes)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6cbcc9a..85ada83 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -49,9 +49,11 @@
 (define-syntax mx
   (syntax-rules ()
     ((_ t x) 
-     (compiler-typecase 
-      x
-      (t 'ok)))))
+     (begin
+       (print 'x " = " 't)
+       (compiler-typecase
+	x
+	(t 'ok))))))
 
 (define-syntax mn
   (er-macro-transformer
@@ -266,6 +268,14 @@
 (mx (list fixnum float) (list-copy (list 1 2.3)))
 (mx (pair fixnum float) (list-copy (cons 1 2.3)))
 (mx fixnum (list-copy 1))
+(mx fixnum (list-ref (list 1 2.3) 0))
+(mx fixnum (list-ref (cons 1 2.3) 0))
+(mx float (list-ref (list 1 2.3) 1))
+(mx (list fixnum float) (list-tail (list 1 2.3) 0))
+(mx (pair fixnum float) (list-tail (cons 1 2.3) 0))
+(mx (list float) (list-tail (list 1 2.3) 1))
+(mx float (list-tail (cons 1 2.3) 1))
+(mx null  (list-tail (list 1 2.3) 2))
 
 (: f1 (forall (a) ((list-of a) -> a)))
 (define (f1 x) (car x))
-- 
1.7.10.4