From 2a48a4f6026a61345f9bb01aca53bd6ee2af53d7 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 13 Jul 2016 22:27:20 +0200
Subject: [PATCH 4/4] Keep vector length when smashing component types.

We just convert the slot types to '*, so we still know the length of the
vector.
---
 NEWS                     |  2 ++
 scrutinizer.scm          |  7 ++++++-
 tests/scrutiny-tests.scm | 47 +++++++++++++++--------------------------------
 3 files changed, 23 insertions(+), 33 deletions(-)

diff --git a/NEWS b/NEWS
index 223b491..f22ca62 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,8 @@
   - Warnings are now emitted when using vector-{ref,set!} or one
     of take, drop, list-ref or list-tail with an out of range index
     for vectors and lists of a definitely known length.
+  - The scrutinizer will no longer drop knowledge of the length of a
+    vector.  It still drops types of its contents (which may be mutated).
 
 - Runtime system:
   - C_locative_ref has been deprecated in favor of C_a_i_locative_ref,
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6031195..f534f8c 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -907,11 +907,16 @@
 	   (dd "  smashing `~s' in ~a" (caar lst) where)
 	   (change! 'vector)
 	   (car t))
+	  ((vector)
+	   (dd "  smashing `~s' in ~a" (caar lst) where)
+	   ;; (vector x y z) => (vector * * *)
+	   (change! (cons 'vector (map (constantly '*) (cdr t))))
+	   (car t))
 	  ((list-of list)
 	   (dd "  smashing `~s' in ~a" (caar lst) where)
 	   (change! '(or pair null))
 	   (car t))
-	  ((pair vector)
+	  ((pair)
 	   (dd "  smashing `~s' in ~a" (caar lst) where)
 	   (change! (car t))
 	   (car t))
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index fbd82d2..7058211 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -210,41 +210,24 @@
 
 
 ;; Indexing into vectors or lists of known size.
-;;
-;; TODO: The specific vector or list type will be smashed to just
-;; "vector" or "(or pair null)" after the first operation.  This is
-;; why the let is repeated; otherwise we won't get the warnings for
-;; subsequent references.  For vectors this is overly pessimistic.
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-warn1) (vector-ref v1 -1)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-warn2) (vector-ref v1 3)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-warn3) (vector-ref v1 4)))
-
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-nowarn1) (vector-ref v1 0)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-nowarn2) (vector-ref v1 2)))
-
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-ref-standard-warn1) (vector-ref v1 'bad)))
-
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-set!-warn1) (vector-set! v1 -1 'whatever)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-set!-warn2) (vector-set! v1 3 'whatever)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-set!-warn3) (vector-set! v1 4 'whatever)))
-
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-set!-nowarn1) (vector-set! v1 0 'whatever)))
-(let ((v1 (vector 'a 'b 'c)))
-  (define (vector-set!-nowarn2) (vector-set! v1 2 'whatever)))
-
 (let ((v1 (vector 'a 'b 'c)))
+  (define (vector-ref-warn1) (vector-ref v1 -1))
+  ;; After the first expression, v1's type is smashed to (vector * * *)!
+  (define (vector-ref-warn2) (vector-ref v1 3))
+  (define (vector-ref-warn3) (vector-ref v1 4))
+  (define (vector-ref-nowarn1) (vector-ref v1 0))
+  (define (vector-ref-nowarn2) (vector-ref v1 2))
+  (define (vector-ref-standard-warn1) (vector-ref v1 'bad))
+  (define (vector-set!-warn1) (vector-set! v1 -1 'whatever))
+  (define (vector-set!-warn2) (vector-set! v1 3 'whatever))
+  (define (vector-set!-warn3) (vector-set! v1 4 'whatever))
+  (define (vector-set!-nowarn1) (vector-set! v1 0 'whatever))
+  (define (vector-set!-nowarn2) (vector-set! v1 2 'whatever))
   (define (vector-set!-standard-warn1) (vector-set! v1 'bad 'whatever)))
 
+;; The specific list type will be smashed to just "(or pair null)"
+;; after the first operation.  This is why the let is repeated;
+;; otherwise we won't get the warnings for subsequent references.
 (let ((l1 (list 'a 'b 'c)))
   (define (list-ref-warn1) (list-ref l1 -1)))
 (let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
-- 
2.1.4