~ chicken-core (chicken-5) f335156a069b4be8c3ec90c1c3f5bddb076f2759

commit f335156a069b4be8c3ec90c1c3f5bddb076f2759
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 15 08:19:38 2011 +0100
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Dec 18 16:10:32 2011 +0100

    scrutiny: add special cases for result types of list-ref/list-tail
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 2f8ed8f0..a3e2ad4e 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2147,6 +2147,42 @@
   (define-special-case vector-ref vector-ref-result-type)
   (define-special-case ##sys#vector-ref vector-ref-result-type))
 
+(let ()
+  (define (list-ref-result-type node args rtypes)
+    (or (let ((subs (node-subexpressions node))
+	      (arg1 (second args)))
+	  (and (pair? arg1)
+	       (eq? 'list (car arg1))
+	       (= (length subs) 3)
+	       (let ((index (third subs)))
+		 (and (eq? 'quote (node-class index))
+		      (let ((val (first (node-parameters index))))
+			(and (fixnum? val)
+			     (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure (but needs location)
+			     (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 (let ((subs (node-subexpressions node))
+	      (arg1 (second args)))
+	  (and (pair? arg1)
+	       (eq? 'list (car arg1))
+	       (= (length subs) 3)
+	       (let ((index (third subs)))
+		 (and (eq? 'quote (node-class index))
+		      (let ((val (first (node-parameters index))))
+			(and (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-special-case list
   (lambda (node args rtypes)
     (if (null? (cdr args))
diff --git a/types.db b/types.db
index 5d8c746f..9f97c469 100644
--- a/types.db
+++ b/types.db
@@ -163,6 +163,7 @@
 	      ((null) '0)
 	      ((list) (##core#inline "C_u_i_length" #(1))))
 
+;; these are special cased (see scrutinizer.scm)
 (list-tail (forall (a) (#(procedure #:clean #:enforce) list-tail ((list-of a) fixnum) (list-of a))))
 (list-ref (forall (a) (#(procedure #:clean #:enforce) list-ref ((list-of a) fixnum) a)))