~ chicken-core (chicken-5) b946076726a7800301dbf1deac0463829e2498db

commit b946076726a7800301dbf1deac0463829e2498db
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Aug 17 13:10:43 2014 +1200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 19 14:22:16 2014 +0200

    Add scrutiny special cases for drop & take
    
    This preserves the element types of pair and list arguments in the
    result types for these procedures where possible, similarly to the
    preexisting special cases for list-ref and list-tail.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index fd783b95..c5cd8c4c 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2186,7 +2186,9 @@
 
 ;;; List-related special cases
 ;
-; Preserve known element types for list-ref, list-tail.
+; Preserve known element types for:
+;
+;   list-ref, list-tail, drop, take
 
 (let ()
 
@@ -2235,6 +2237,14 @@
 	    (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 take
+    (list+index-call-result-type-special-case
+     (lambda (result-type _) (list result-type))))
+
+  (define-special-case drop
     (list+index-call-result-type-special-case
      (lambda (_ result-type) (list result-type)))))
 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 85ada83f..40515957 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,7 @@
 ;;;; typematch-tests.scm
 
 
-(use lolevel data-structures)
+(use srfi-1 lolevel data-structures)
 
 
 (define-syntax check
@@ -276,6 +276,16 @@
 (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))
+(mx (list fixnum float) (drop (list 1 2.3) 0))
+(mx (pair fixnum float) (drop (cons 1 2.3) 0))
+(mx (list float) (drop (list 1 2.3) 1))
+(mx float (drop (cons 1 2.3) 1))
+(mx null (drop (list 1 2.3) 2))
+(mx null (take (list 1 2.3) 0))
+(mx null (take (cons 1 2.3) 0))
+(mx (list fixnum) (take (list 1 2.3) 1))
+(mx (list fixnum) (take (cons 1 2.3) 1))
+(mx (list fixnum float) (take (list 1 2.3) 2))
 
 (: f1 (forall (a) ((list-of a) -> a)))
 (define (f1 x) (car x))