~ chicken-core (chicken-5) 3ec1969166532c7e61b55332122cbdc5847b44c3
commit 3ec1969166532c7e61b55332122cbdc5847b44c3
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Jul 13 21:34:41 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 24 11:50:39 2016 +1200
Add scrutiny warning for bad indexing into vectors and lists.
If vector-ref, vector-set!, list-ref, list-tail, drop or take are used
with an index that's known to be out of bounds for the vector or
list/pair sequence (of known length), give a warning.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 2a2268ca..223b4917 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,9 @@
- Compiler:
- 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.
- 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 22ea79b4..79241c44 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -133,6 +133,23 @@
((memq t '(eof null fixnum char boolean undefined)) #t)
(else #f)))
+(define (node-source-prefix n)
+ (let ((line (node-line-number n)))
+ (if (not line) "" (sprintf "(~a) " line))))
+
+(define (location-name loc)
+ (define (lname loc1)
+ (if loc1
+ (sprintf "procedure `~a'" (real-name loc1))
+ "unknown procedure"))
+ (cond ((null? loc) "at toplevel:\n ")
+ ((null? (cdr loc))
+ (sprintf "in toplevel ~a:\n " (lname (car loc))))
+ (else
+ (let rec ((loc loc))
+ (if (null? (cdr loc))
+ (location-name loc)
+ (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr loc))))))))
(define (scrutinize node db complain specialize)
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
@@ -274,24 +291,6 @@
(set! errors #t)
(apply report loc msg args))
- (define (node-source-prefix n)
- (let ((line (node-line-number n)))
- (if (not line) "" (sprintf "(~a) " line))))
-
- (define (location-name loc)
- (define (lname loc1)
- (if loc1
- (sprintf "procedure `~a'" (real-name loc1))
- "unknown procedure"))
- (cond ((null? loc) "at toplevel:\n ")
- ((null? (cdr loc))
- (sprintf "in toplevel ~a:\n " (lname (car loc))))
- (else
- (let rec ((loc loc))
- (if (null? (cdr loc))
- (location-name loc)
- (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr loc))))))))
-
(define add-loc cons)
(define (fragment x)
@@ -805,7 +804,7 @@
'##compiler#special-result-type))
=> (lambda (srt)
(dd " hardcoded special result-type: ~a" var)
- (set! r (srt n args r))))))))
+ (set! r (srt n args loc r))))))))
subs
(cons
fn
@@ -2181,7 +2180,7 @@
(##sys#put! 'name '##compiler#special-result-type handler))))
(define-special-case ##sys#make-structure
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(or (and-let* ((subs (node-subexpressions node))
((>= (length subs) 2))
(arg1 (second subs))
@@ -2196,7 +2195,17 @@
rtypes)))
(let ()
- (define (known-length-vector-index node args expected-argcount)
+ ;; TODO: Complain argument not available here, so we can't use the
+ ;; standard "report" defined above. However, ##sys#enable-warnings
+ ;; and "complain" (do-scrutinize) are always true together, except
+ ;; that "complain" will be false while ##sys#enable-warnings is true
+ ;; on "no-usual-integrations", so perhaps get rid of "complain"?
+ (define (report loc msg . args)
+ (warning
+ (conc (location-name loc)
+ (sprintf "~?" msg (map unrename-type args)))))
+
+ (define (known-length-vector-index node args loc expected-argcount)
(and-let* ((subs (node-subexpressions node))
((= (length subs) (add1 expected-argcount)))
(arg1 (walked-result (second args)))
@@ -2205,16 +2214,23 @@
(index (third subs))
((eq? 'quote (node-class index)))
(val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0))
- ;; XXX could warn on failure (but needs location)
- ((< val (length (cdr arg1)))))
- val))
+ ((fixnum? val)) ; Standard type warning otherwise
+ (vector-length (length (cdr arg1))))
+ (if (and (>= val 0) (< val vector-length))
+ val
+ (begin
+ (report
+ loc "~ain procedure call to `~s', index ~a out of range \
+ for vector of length ~a"
+ (node-source-prefix node)
+ ;; TODO: It might make more sense to use "pname" here
+ (first (node-parameters (first subs))) val vector-length)
+ #f))))
;; These are a bit hacky, since they mutate the node. These special
;; cases are really only intended for determining result types...
- (define (vector-ref-result-type node args rtypes)
- (or (and-let* ((index (known-length-vector-index node args 2))
+ (define (vector-ref-result-type node args loc rtypes)
+ (or (and-let* ((index (known-length-vector-index node args loc 2))
(arg1 (walked-result (second args)))
(vector (second (node-subexpressions node))))
(mutate-node! node `(##sys#slot ,vector ',index))
@@ -2225,8 +2241,8 @@
(define-special-case ##sys#vector-ref vector-ref-result-type)
(define-special-case vector-set!
- (lambda (node args rtypes)
- (or (and-let* ((index (known-length-vector-index node args 3))
+ (lambda (node args loc rtypes)
+ (or (and-let* ((index (known-length-vector-index node args loc 3))
(subs (node-subexpressions node))
(vector (second subs))
(new-value (fourth subs))
@@ -2248,6 +2264,11 @@
; list-ref, list-tail, drop, take
(let ()
+ ;; See comment in vector (let) just above this
+ (define (report loc msg . args)
+ (warning
+ (conc (location-name loc)
+ (sprintf "~?" msg (map unrename-type args)))))
(define (list-or-null a)
(if (null? a) 'null `(list ,@a)))
@@ -2275,16 +2296,25 @@
(else #f)))
(define (list+index-call-result-type-special-case k)
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(or (and-let* ((subs (node-subexpressions node))
((= (length subs) 3))
(arg1 (walked-result (second args)))
(index (third subs))
((eq? 'quote (node-class index)))
(val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0)))
- (split-list-type arg1 val k))
+ ((fixnum? val))) ; Standard type warning otherwise
+ (or (and (>= val 0) (split-list-type arg1 val k))
+ (begin
+ (report
+ loc "~ain procedure call to `~s', 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)))
rtypes)))
(define-special-case list-ref
@@ -2306,27 +2336,27 @@
(lambda (_ result-type) (list result-type)))))
(define-special-case list
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(if (null? (cdr args))
'(null)
`((list ,@(map walked-result (cdr args)))))))
(define-special-case ##sys#list
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(if (null? (cdr args))
'(null)
`((list ,@(map walked-result (cdr args)))))))
(define-special-case vector
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
`((vector ,@(map walked-result (cdr args))))))
(define-special-case ##sys#vector
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
`((vector ,@(map walked-result (cdr args))))))
(define-special-case reverse
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(or (and-let* ((subs (node-subexpressions node))
((= (length subs) 2))
(arg1 (walked-result (second args)))
@@ -2342,7 +2372,7 @@
(let ()
(define (complex-object-constructor-result-type-special-case type)
- (lambda (node args rtypes)
+ (lambda (node args loc rtypes)
(or (and-let* ((subs (node-subexpressions node))
(fill (case (length subs)
((2) '*)
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index fddeac4b..fbd82d2c 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -207,3 +207,67 @@
(let ((f (the (null -> *) _))) (f (make-list x))) ; no warning
(let ((f (the (list -> *) _))) (f (cons 1 2))) ; warning
(let ((f (the (list -> *) _))) (f (cons 1 x))) ; no warning
+
+
+;; 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-set!-standard-warn1) (vector-set! v1 'bad 'whatever)))
+
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-warn1) (list-ref l1 -1)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-warn2) (list-ref l2 -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)))
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-warn5) (list-ref l1 4)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-warn6) (list-ref l2 4)))
+
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-nowarn1) (list-ref l1 0)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-nowarn2) (list-ref l2 0)))
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-nowarn3) (list-ref l1 2)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-nowarn4) (list-ref l2 2)))
+
+(let ((l1 (list 'a 'b 'c)))
+ (define (list-ref-standard-warn1) (list-ref l1 'bad)))
+(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
+ (define (list-ref-standard-warn2) (list-ref l2 'bad)))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 6811bee3..2dcf723f 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -141,4 +141,52 @@ Warning: at toplevel:
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
+
+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
+
+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
+
+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'
+
+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
+
+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
+
+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
+
+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'
+
+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)
+
+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 *)))
+
+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)
+
+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 *)))
+
+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)
+
+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 *)))
+
+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'
+
+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'
+
Warning: redefinition of standard binding: car
Trap