~ chicken-core (chicken-5) c369ad4f5e28aa92bbfb2995f91a9e33bc56360c
commit c369ad4f5e28aa92bbfb2995f91a9e33bc56360c
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Jul 13 22:27:20 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 13 22:27:20 2016 +0200
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 2bb671ce..de54596c 100644
--- a/NEWS
+++ b/NEWS
@@ -58,6 +58,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 4a50b445..f29f4d08 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -912,11 +912,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 92f77558..dadf2c6c 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)))))))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index e685ac11..e21eb969 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -147,51 +147,51 @@ Warning: at toplevel:
(scrutiny-tests.scm:208) in procedure call to `f', expected argument #1 of type `list' but was given an argument of type `(pair fixnum fixnum)'
Warning: in toplevel procedure `vector-ref-warn1':
- (scrutiny-tests.scm:219) in procedure call to `"vector-ref"', index -1 out of range for vector of length 3
+ (scrutiny-tests.scm:214) in procedure call to `"vector-ref"', index -1 out of range for vector of length 3
Warning: in toplevel procedure `vector-ref-warn2':
- (scrutiny-tests.scm:221) in procedure call to `"vector-ref"', index 3 out of range for vector of length 3
+ (scrutiny-tests.scm:216) in procedure call to `"vector-ref"', index 3 out of range for vector of length 3
Warning: in toplevel procedure `vector-ref-warn3':
- (scrutiny-tests.scm:223) in procedure call to `"vector-ref"', index 4 out of range for vector of length 3
+ (scrutiny-tests.scm:217) in procedure call to `"vector-ref"', index 4 out of range for vector of length 3
Warning: in toplevel procedure `vector-ref-standard-warn1':
- (scrutiny-tests.scm:231) in procedure call to `vector-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:220) in procedure call to `vector-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
Warning: in toplevel procedure `vector-set!-warn1':
- (scrutiny-tests.scm:234) in procedure call to `"vector-set!"', index -1 out of range for vector of length 3
+ (scrutiny-tests.scm:221) in procedure call to `"vector-set!"', index -1 out of range for vector of length 3
Warning: in toplevel procedure `vector-set!-warn2':
- (scrutiny-tests.scm:236) in procedure call to `"vector-set!"', index 3 out of range for vector of length 3
+ (scrutiny-tests.scm:222) in procedure call to `"vector-set!"', index 3 out of range for vector of length 3
Warning: in toplevel procedure `vector-set!-warn3':
- (scrutiny-tests.scm:238) in procedure call to `"vector-set!"', index 4 out of range for vector of length 3
+ (scrutiny-tests.scm:223) in procedure call to `"vector-set!"', index 4 out of range for vector of length 3
Warning: in toplevel procedure `vector-set!-standard-warn1':
- (scrutiny-tests.scm:246) in procedure call to `vector-set!', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:226) in procedure call to `vector-set!', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
Warning: in toplevel procedure `list-ref-warn1':
- (scrutiny-tests.scm:249) in procedure call to `"list-ref"', index -1 out of range for list of type (list symbol symbol symbol)
+ (scrutiny-tests.scm:232) in procedure call to `"list-ref"', index -1 out of range for list of type (list symbol symbol symbol)
Warning: in toplevel procedure `list-ref-warn2':
- (scrutiny-tests.scm:251) in procedure call to `"list-ref"', index -1 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
+ (scrutiny-tests.scm:234) in procedure call to `"list-ref"', index -1 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
Warning: in toplevel procedure `list-ref-warn3':
- (scrutiny-tests.scm:253) in procedure call to `"list-ref"', index 3 out of range for list of type (list symbol symbol symbol)
+ (scrutiny-tests.scm:236) in procedure call to `"list-ref"', index 3 out of range for list of type (list symbol symbol symbol)
Warning: in toplevel procedure `list-ref-warn4':
- (scrutiny-tests.scm:255) in procedure call to `"list-ref"', index 3 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
+ (scrutiny-tests.scm:238) in procedure call to `"list-ref"', index 3 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
Warning: in toplevel procedure `list-ref-warn5':
- (scrutiny-tests.scm:257) in procedure call to `"list-ref"', index 4 out of range for list of type (list symbol symbol symbol)
+ (scrutiny-tests.scm:240) in procedure call to `"list-ref"', index 4 out of range for list of type (list symbol symbol symbol)
Warning: in toplevel procedure `list-ref-warn6':
- (scrutiny-tests.scm:259) in procedure call to `"list-ref"', index 4 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
+ (scrutiny-tests.scm:242) in procedure call to `"list-ref"', index 4 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
Warning: in toplevel procedure `list-ref-standard-warn1':
- (scrutiny-tests.scm:271) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:254) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
Warning: in toplevel procedure `list-ref-standard-warn2':
- (scrutiny-tests.scm:273) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:256) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
Warning: redefinition of standard binding: car
Trap