Commit | Line | Data |
---|---|---|
36b5e394 LC |
1 | ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
5e8f5eba | 3 | ;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
36b5e394 LC |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (test-coverage) | |
20 | #:use-module (test-suite lib) | |
21 | #:use-module (system vm coverage) | |
22 | #:use-module (system vm vm) | |
23 | #:use-module (system base compile) | |
639b2eb7 | 24 | #:use-module (system foreign) |
36b5e394 LC |
25 | #:use-module (srfi srfi-1) |
26 | #:use-module (srfi srfi-11)) | |
27 | ||
28 | (define-syntax code | |
29 | (syntax-rules () | |
30 | ((_ filename snippet) | |
31 | (let ((input (open-input-string snippet))) | |
32 | (set-port-filename! input filename) | |
33 | (read-enable 'positions) | |
34 | (compile (read input)))))) | |
35 | ||
7c42e426 LC |
36 | (define test-procedure |
37 | (compile '(lambda (x) | |
38 | (if (> x 2) | |
39 | (- x 2) | |
40 | (+ x 2))))) | |
41 | ||
36b5e394 LC |
42 | \f |
43 | (with-test-prefix "instrumented/executed-lines" | |
44 | ||
45 | (pass-if "instr = exec" | |
46 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
47 | (+ x y)) ;; 1"))) | |
48 | (let-values (((data result) | |
a222cbc9 | 49 | (with-code-coverage |
36b5e394 LC |
50 | (lambda () (proc 1 2))))) |
51 | (and (coverage-data? data) | |
52 | (= 3 result) | |
53 | (let-values (((instr exec) | |
54 | (instrumented/executed-lines data "foo.scm"))) | |
55 | (and (= 2 instr) (= 2 exec))))))) | |
56 | ||
57 | (pass-if "instr >= exec" | |
58 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
59 | (if (> x y) ;; 1 | |
60 | (begin ;; 2 | |
61 | (display x) ;; 3 | |
62 | (+ x y)))) ;; 4"))) | |
63 | (let-values (((data result) | |
a222cbc9 | 64 | (with-code-coverage |
36b5e394 LC |
65 | (lambda () (proc 1 2))))) |
66 | (and (coverage-data? data) | |
67 | (let-values (((instr exec) | |
68 | (instrumented/executed-lines data "foo.scm"))) | |
69 | (and (> instr 0) (>= instr exec)))))))) | |
70 | ||
71 | \f | |
72 | (with-test-prefix "line-execution-counts" | |
73 | ||
74 | (pass-if "once" | |
75 | (let ((proc (code "bar.scm" "(lambda (x y) ;; 0 | |
76 | (+ (/ x y) ;; 1 | |
77 | (* x y))) ;; 2"))) | |
78 | (let-values (((data result) | |
a222cbc9 | 79 | (with-code-coverage |
36b5e394 LC |
80 | (lambda () (proc 1 2))))) |
81 | (let ((counts (line-execution-counts data "bar.scm"))) | |
82 | (and (pair? counts) | |
83 | (every (lambda (line+count) | |
84 | (let ((line (car line+count)) | |
85 | (count (cdr line+count))) | |
86 | (and (>= line 0) | |
87 | (<= line 2) | |
88 | (= count 1)))) | |
89 | counts)))))) | |
90 | ||
91 | (pass-if "several times" | |
92 | (let ((proc (code "fooz.scm" "(lambda (x) ;; 0 | |
93 | (format #f \"hello\") ;; 1 | |
94 | (let loop ((x x)) ;; 2 | |
95 | (cond ((> x 0) ;; 3 | |
96 | (begin ;; 4 | |
97 | (format #f \"~a\" x) | |
98 | (loop (1- x)))) ;; 6 | |
99 | ((= x 0) #t) ;; 7 | |
100 | ((< x 0) 'never))))"))) | |
101 | (let-values (((data result) | |
a222cbc9 | 102 | (with-code-coverage |
36b5e394 LC |
103 | (lambda () (proc 77))))) |
104 | (let ((counts (line-execution-counts data "fooz.scm"))) | |
105 | (and (pair? counts) | |
106 | (every (lambda (line+count) | |
107 | (let ((line (car line+count)) | |
108 | (count (cdr line+count))) | |
a285f38f AW |
109 | ;; The actual line counts for aliasing |
110 | ;; operations, like the loop header that | |
111 | ;; initializes "x" to "x", are sensitive to | |
112 | ;; whether there is an associated "mov" | |
113 | ;; instruction, or whether the value is left | |
114 | ;; in place. Currently there are no | |
115 | ;; instructions for line 2, but we allow 1 as | |
116 | ;; well. | |
36b5e394 | 117 | (case line |
a285f38f AW |
118 | ((0 1) (= count 1)) |
119 | ((2) (<= 0 count 1)) | |
5e8f5eba | 120 | ((3) (= count 78)) |
36b5e394 LC |
121 | ((4 5 6) (= count 77)) |
122 | ((7) (= count 1)) | |
e7bee747 LC |
123 | ((8) (= count 0)) |
124 | (else #f)))) | |
36b5e394 LC |
125 | counts)))))) |
126 | ||
127 | (pass-if "some" | |
128 | (let ((proc (code "baz.scm" "(lambda (x y) ;; 0 | |
129 | (if (> x y) ;; 1 | |
130 | (begin ;; 2 | |
131 | (display x) ;; 3 | |
132 | (+ x y)) ;; 4 | |
133 | (+ x y))) ;; 5"))) | |
134 | (let-values (((data result) | |
a222cbc9 | 135 | (with-code-coverage |
36b5e394 LC |
136 | (lambda () (proc 1 2))))) |
137 | (let ((counts (line-execution-counts data "baz.scm"))) | |
138 | (and (pair? counts) | |
139 | (every (lambda (line+count) | |
140 | (let ((line (car line+count)) | |
141 | (count (cdr line+count))) | |
142 | (case line | |
143 | ((0 1 5) (= count 1)) | |
144 | ((2 3) (= count 0)) | |
145 | ((4) #t) ;; the start of the `else' branch is | |
146 | ;; attributed to line 4 | |
147 | (else #f)))) | |
148 | counts)))))) | |
149 | ||
150 | (pass-if "one proc hit, one proc unused" | |
151 | (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0 | |
152 | (or (= x 0) ;; 1 | |
153 | (not (odd? (1- x)))))) | |
154 | (odd? (lambda (x) ;; 3 | |
155 | (not (even? (1- x)))))) ;; 4 | |
156 | even?)"))) | |
157 | (let-values (((data result) | |
a222cbc9 | 158 | (with-code-coverage |
36b5e394 LC |
159 | (lambda () (proc 0))))) |
160 | (let ((counts (line-execution-counts data "baz.scm"))) | |
161 | (and (pair? counts) | |
162 | (every (lambda (line+count) | |
163 | (let ((line (car line+count)) | |
164 | (count (cdr line+count))) | |
165 | (case line | |
7a5a5335 AW |
166 | ((0 1) (= count 1)) |
167 | ((2 3 4 5) (= count 0)) | |
168 | (else #f)))) | |
36b5e394 LC |
169 | counts)))))) |
170 | ||
01291304 LC |
171 | (pass-if "case-lambda" |
172 | (let ((proc (code "cl.scm" "(case-lambda ;; 0 | |
173 | ((x) (+ x 3)) ;; 1 | |
174 | ((x y) (+ x y))) ;; 2"))) | |
175 | (let-values (((data result) | |
a222cbc9 | 176 | (with-code-coverage |
01291304 LC |
177 | (lambda () |
178 | (+ (proc 1) (proc 2 3)))))) | |
179 | (let ((counts (line-execution-counts data "cl.scm"))) | |
180 | (and (pair? counts) | |
181 | (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts)))))) | |
182 | ||
36b5e394 LC |
183 | (pass-if "all code on one line" |
184 | ;; There are several proc/IP pairs pointing to this source line, yet the hit | |
185 | ;; count for the line should be 1. | |
186 | (let ((proc (code "one-liner.scm" | |
187 | "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))"))) | |
188 | (let-values (((data result) | |
a222cbc9 | 189 | (with-code-coverage |
36b5e394 LC |
190 | (lambda () (proc 451 1884))))) |
191 | (let ((counts (line-execution-counts data "one-liner.scm"))) | |
192 | (equal? counts '((0 . 1)))))))) | |
193 | ||
194 | \f | |
195 | (with-test-prefix "procedure-execution-count" | |
196 | ||
197 | (pass-if "several times" | |
198 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
199 | (let-values (((data result) | |
a222cbc9 | 200 | (with-code-coverage |
36b5e394 LC |
201 | (lambda () (+ (proc 1 2) (proc 2 3)))))) |
202 | (and (coverage-data? data) | |
203 | (= 3 result) | |
204 | (= (procedure-execution-count data proc) 2))))) | |
205 | ||
01291304 LC |
206 | (pass-if "case-lambda" |
207 | (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))"))) | |
208 | (let-values (((data result) | |
a222cbc9 | 209 | (with-code-coverage |
01291304 LC |
210 | (lambda () |
211 | (+ (proc 1) (proc 2 3)))))) | |
212 | (and (coverage-data? data) | |
213 | (= 6 result) | |
214 | (= (procedure-execution-count data proc) 2))))) | |
215 | ||
36b5e394 LC |
216 | (pass-if "never" |
217 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
218 | (let-values (((data result) | |
a222cbc9 | 219 | (with-code-coverage |
36b5e394 LC |
220 | (lambda () (+ 1 2))))) |
221 | (and (coverage-data? data) | |
222 | (= 3 result) | |
697c4f29 | 223 | (zero? (procedure-execution-count data proc)))))) |
639b2eb7 | 224 | |
1a6ff60d LC |
225 | (pass-if "applicable struct" |
226 | (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw)) | |
227 | (proc (lambda args (length args))) | |
228 | (b (make-struct <box> 0 proc))) | |
229 | (let-values (((data result) | |
a222cbc9 | 230 | (with-code-coverage b))) |
1a6ff60d LC |
231 | (and (coverage-data? data) |
232 | (= 0 result) | |
233 | (= (procedure-execution-count data proc) 1))))) | |
234 | ||
639b2eb7 LC |
235 | (pass-if "called from C" |
236 | ;; The `scm_call_N' functions use the VM returned by `the-vm'. This | |
a222cbc9 | 237 | ;; test makes sure that their calls are traced. |
639b2eb7 | 238 | (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))")) |
41f2f14b LC |
239 | (call (false-if-exception ; can we resolve `scm_call_2'? |
240 | (pointer->procedure '* | |
241 | (dynamic-func "scm_call_2" | |
242 | (dynamic-link)) | |
243 | '(* * *))))) | |
244 | (if call | |
245 | (let-values (((data result) | |
a222cbc9 | 246 | (with-code-coverage |
41f2f14b LC |
247 | (lambda () |
248 | (call (make-pointer (object-address proc)) | |
249 | (make-pointer (object-address 1)) | |
250 | (make-pointer (object-address 2))))))) | |
251 | (and (coverage-data? data) | |
252 | (= (object-address 3) (pointer-address result)) | |
253 | (= (procedure-execution-count data proc) 1))) | |
254 | (throw 'unresolved)))) | |
7c42e426 LC |
255 | |
256 | (pass-if "called from eval" | |
257 | (let-values (((data result) | |
a222cbc9 | 258 | (with-code-coverage |
7c42e426 LC |
259 | (lambda () |
260 | (eval '(test-procedure 123) (current-module)))))) | |
261 | (and (coverage-data? data) | |
262 | (= (test-procedure 123) result) | |
263 | (= (procedure-execution-count data test-procedure) 1))))) | |
36b5e394 LC |
264 | |
265 | \f | |
266 | (with-test-prefix "instrumented-source-files" | |
267 | ||
268 | (pass-if "source files are listed as expected" | |
269 | (let ((proc (code "chbouib.scm" "(lambda (x y) x)"))) | |
270 | (let-values (((data result) | |
a222cbc9 | 271 | (with-code-coverage |
36b5e394 LC |
272 | (lambda () (proc 1 2))))) |
273 | ||
274 | (let ((files (map basename (instrumented-source-files data)))) | |
275 | (and (member "boot-9.scm" files) | |
276 | (member "chbouib.scm" files) | |
3a858c32 | 277 | #t)))))) |