>From 39844c1859d7fc5f22430f5dd136e393701757a3 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sun, 17 Aug 2014 13:10:43 +1200
Subject: [PATCH 3/5] Add scrutiny special cases for split-at, 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.
---
 scrutinizer.scm           |   16 +++++++++++++++-
 tests/typematch-tests.scm |   12 +++++++++++-
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index c756067..6de343f 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2235,7 +2235,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, split-at
 
 (let ()
 
@@ -2285,6 +2287,18 @@
 
   (define-special-case list-tail
     (list+index-call-result-type-special-case
+     (lambda (_ result-type) (list result-type))))
+
+  (define-special-case split-at
+    (list+index-call-result-type-special-case
+     (lambda result-types (list result-types))))
+
+  (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)))))
 
 (define-special-case list
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 85ada83..4051595 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))
-- 
1.7.10.4