~ chicken-core (chicken-5) dc55c85015b0fa961537a6aa8c21bad7b09e4167

commit dc55c85015b0fa961537a6aa8c21bad7b09e4167
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Wed Jul 13 22:27:20 2016 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 24 11:50:39 2016 +1200

    Keep vector length when smashing component types.
    
    We just convert the slot types to '*, so we still know the length of the
    vector.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 223b4917..f22ca62a 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 79241c44..0451af8c 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 fbd82d2c..70582119 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)))))))