From 7db38d54717be5dd65ecc177cf71d0c21fbaef54 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 13 Jul 2016 21:34:41 +0200 Subject: [PATCH 3/4] 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. --- NEWS | 3 ++ scrutinizer.scm | 110 ++++++++++++++++++++++++++++++----------------- tests/scrutiny-tests.scm | 64 +++++++++++++++++++++++++++ tests/scrutiny.expected | 48 +++++++++++++++++++++ 4 files changed, 185 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 2a2268c..223b491 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 ee54e52..6031195 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 fddeac4..fbd82d2 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 6811bee..2dcf723 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 -- 2.1.4