~ chicken-core (chicken-5) afcab700abd7ecb1b9e35ed84ffe733b527e02df
commit afcab700abd7ecb1b9e35ed84ffe733b527e02df
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jul 24 15:37:11 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Jul 25 09:31:04 2016 +1200
Do not warn for out of range indices into possibly smashed list types
When a list is smashed, usually ends up as (or pair null). If then we
cons something onto it, it's seen as a list of length 1 or possibly 2.
We should *not* give a warning on (list-ref 3 that-list), because it may
originally have been a list of a greater length. We don't know that, so
we should avoid warning for anything that's not absolutely sure to be a
proper list.
Luckily, if it's typed as a proper list, that's presumably safe. That's
because a list with smashed components should end in just "pair", due to
possible mutation by set-cdr!, which means its type is not that of a
proper list.
We still always warn when list-ref takes a negative index, because
that's never ever valid, regardless of the argument list type.
We still always preserve types when using list-ref, even on a list with
smashed components, as long as the list is known to contain the index.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index de54596c..d4eb49dc 100644
--- a/NEWS
+++ b/NEWS
@@ -57,7 +57,7 @@
- define-constant now correctly keeps symbol values quoted.
- 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.
+ for vectors and proper 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).
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9eb00529..b143b0cf 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2232,6 +2232,7 @@
;; Split a list or pair type form at index i, calling k with the two
;; sections of the type or returning #f if it doesn't match that far.
+ ;; Note that "list-of" is handled by "forall" entries in types.db
(define (split-list-type l i k)
(cond ((not (pair? l))
(and (fx= i 0) (eq? l 'null) (k l l)))
@@ -2252,6 +2253,13 @@
(else #f))))
(else #f)))
+ ;; canonicalize-list-type will have taken care of converting (pair
+ ;; (pair ...)) to (list ...) or (list-of ...) for proper lists.
+ (define (proper-list-type-length t)
+ (cond ((eq? t 'null) 0)
+ ((and (pair? t) (eq? (car t) 'list)) (length (cdr t)))
+ (else #f)))
+
(define (list+index-call-result-type-special-case k)
(lambda (node args loc rtypes)
(or (and-let* ((subs (node-subexpressions node))
@@ -2261,17 +2269,27 @@
((eq? 'quote (node-class index)))
(val (first (node-parameters index)))
((fixnum? val))) ; Standard type warning otherwise
- (or (and (>= val 0) (split-list-type arg1 val k))
- (begin
- (report
- loc "~ain procedure call to `~a', index ~a out of \
- range for list of type ~a"
- (node-source-prefix node)
- ;; TODO: It might make more sense to use
- ;; "pname" here
- (first (node-parameters (first subs)))
- val arg1)
- #f)))
+ ;; TODO: It might make sense to use "pname" when reporting
+ (cond ((negative? val)
+ ;; Negative indices should always generate a warning
+ (report
+ loc "~ain procedure call to `~a', index ~a is \
+ negative, which is never valid"
+ (node-source-prefix node)
+ (first (node-parameters (first subs))) val)
+ #f)
+ ((split-list-type arg1 val k))
+ ;; Warn only if it's a known proper list. This avoids
+ ;; false warnings due to component smashing.
+ ((proper-list-type-length arg1) =>
+ (lambda (length)
+ (report
+ loc "~ain procedure call to `~a', index ~a out of \
+ range for proper list of length ~a"
+ (node-source-prefix node)
+ (first (node-parameters (first subs))) val length)
+ #f))
+ (else #f)))
rtypes)))
(define-special-case list-ref
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index dadf2c6c..a9f1942c 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -230,27 +230,68 @@
;; otherwise we won't get the warnings for subsequent references.
(let ((l1 (list 'a 'b 'c)))
(define (list-ref-warn1) (list-ref l1 -1)))
+;; This warns regardless of not knowing the length of the list
(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
(define (list-ref-warn2) (list-ref l2 -1)))
+;; Not knowing the length of a "list-of" is not an issue here
+(let ((l3 (the (list-of symbol) '(x y z))))
+ (define (list-ref-warn3) (list-ref l3 -1)))
(let ((l1 (list 'a 'b 'c)))
- (define (list-ref-warn3) (list-ref l1 3)))
-(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
- (define (list-ref-warn4) (list-ref l2 3)))
+ (define (list-ref-warn4) (list-ref l1 3)))
+;; This can't warn: it strictly doesn't know the length of the list.
+;; The eval could return a list of length >= 1!
+#;(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-warn5) (list-ref l2 3)))
(let ((l1 (list 'a 'b 'c)))
(define (list-ref-warn5) (list-ref l1 4)))
-(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+;; Same as above
+#;(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
(define (list-ref-warn6) (list-ref l2 4)))
+;; We add the second check to ensure that we don't give false warnings
+;; for smashed types, because we don't know the original size.
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-nowarn1) (list-ref l1 0))
+ (define (list-ref-nowarn2) (list-ref l1 0)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-nowarn3) (list-ref l2 0))
+ (define (list-ref-nowarn4) (list-ref l2 0)))
(let ((l1 (list 'a 'b 'c)))
- (define (list-ref-nowarn1) (list-ref l1 0)))
+ (define (list-ref-nowarn5) (list-ref l1 2))
+ (define (list-ref-nowarn6) (list-ref l1 2)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-nowarn7) (list-ref l2 2))
+ (define (list-ref-nowarn8) (list-ref l2 2)))
+;; Verify that we don't give bogus warnings, like mentioned above.
(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
- (define (list-ref-nowarn2) (list-ref l2 0)))
+ (define (list-ref-nowarn9) (list-ref l2 5)))
+;; We don't know the length of a "list-of", so we can't warn
+(let ((l3 (the (list-of symbol) '(x y z))))
+ (define (list-ref-nowarn10) (list-ref l3 100)))
+
+;; The second check here should still give a warning, this has
+;; nothing to do with component smashing.
(let ((l1 (list 'a 'b 'c)))
- (define (list-ref-nowarn3) (list-ref l1 2)))
+ (define (list-ref-standard-warn1) (list-ref l1 'bad))
+ (define (list-ref-standard-warn2) (list-ref l1 'bad)))
(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
- (define (list-ref-nowarn4) (list-ref l2 2)))
+ (define (list-ref-standard-warn3) (list-ref l2 'bad))
+ (define (list-ref-standard-warn4) (list-ref l2 'bad)))
+;; Test type preservation of list-ref
(let ((l1 (list 'a 'b 'c)))
- (define (list-ref-standard-warn1) (list-ref l1 'bad)))
+ (define (list-ref-type-warn1) (add1 (list-ref l1 1))))
(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
- (define (list-ref-standard-warn2) (list-ref l2 'bad)))
+ (define (list-ref-type-warn2) (add1 (list-ref l2 1))))
+;; This is handled by the list-ref entry in types.db, *not* the
+;; special-cased code.
+(let ((l3 (the (list-of symbol) '(a b c))))
+ (define (list-ref-type-warn3) (add1 (list-ref l3 1))))
+
+;; Sanity check
+(let ((l1 (list 1 2 3)))
+ (define (list-ref-type-nowarn1) (add1 (list-ref l1 1))))
+(let ((l2 (cons 1 (cons 2 (cons 3 (eval '(list)))))))
+ (define (list-ref-type-nowarn2) (add1 (list-ref l2 1))))
+(let ((l3 (the (list-of fixnum) '(1 2 3))))
+ (define (list-ref-type-nowarn3) (add1 (list-ref l3 1))))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 8446362c..7d02af33 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -171,27 +171,39 @@ Warning: in toplevel procedure `vector-set!-standard-warn1':
(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:232) 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 is negative, which is never valid
Warning: in toplevel procedure `list-ref-warn2':
- (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 *)))
+ (scrutiny-tests.scm:235) in procedure call to `list-ref', index -1 is negative, which is never valid
Warning: in toplevel procedure `list-ref-warn3':
- (scrutiny-tests.scm:236) in procedure call to `list-ref', index 3 out of range for list of type (list symbol symbol symbol)
+ (scrutiny-tests.scm:238) in procedure call to `list-ref', index -1 is negative, which is never valid
Warning: in toplevel procedure `list-ref-warn4':
- (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 *)))
+ (scrutiny-tests.scm:240) in procedure call to `list-ref', index 3 out of range for proper list of length 3
Warning: in toplevel procedure `list-ref-warn5':
- (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:242) in procedure call to `list-ref', index 4 out of range for list of type (pair symbol (pair symbol (pair symbol *)))
+ (scrutiny-tests.scm:246) in procedure call to `list-ref', index 4 out of range for proper list of length 3
Warning: in toplevel procedure `list-ref-standard-warn1':
- (scrutiny-tests.scm:254) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:275) 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:256) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (scrutiny-tests.scm:276) 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-warn3':
+ (scrutiny-tests.scm:278) 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-warn4':
+ (scrutiny-tests.scm:279) 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-type-warn1':
+ (scrutiny-tests.scm:283) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
+
+Warning: in toplevel procedure `list-ref-type-warn2':
+ (scrutiny-tests.scm:285) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
+
+Warning: in toplevel procedure `list-ref-type-warn3':
+ (scrutiny-tests.scm:289) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
Warning: redefinition of standard binding: car
Trap