Commit | Line | Data |
---|---|---|
36b5e394 LC |
1 | ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
1a6ff60d | 3 | ;;;; Copyright (C) 2010, 2011, 2012 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 | ||
36 | (define %test-vm (make-vm)) | |
37 | ||
7c42e426 LC |
38 | (define test-procedure |
39 | (compile '(lambda (x) | |
40 | (if (> x 2) | |
41 | (- x 2) | |
42 | (+ x 2))))) | |
43 | ||
36b5e394 LC |
44 | \f |
45 | (with-test-prefix "instrumented/executed-lines" | |
46 | ||
47 | (pass-if "instr = exec" | |
48 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
49 | (+ x y)) ;; 1"))) | |
50 | (let-values (((data result) | |
51 | (with-code-coverage %test-vm | |
52 | (lambda () (proc 1 2))))) | |
53 | (and (coverage-data? data) | |
54 | (= 3 result) | |
55 | (let-values (((instr exec) | |
56 | (instrumented/executed-lines data "foo.scm"))) | |
57 | (and (= 2 instr) (= 2 exec))))))) | |
58 | ||
59 | (pass-if "instr >= exec" | |
60 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
61 | (if (> x y) ;; 1 | |
62 | (begin ;; 2 | |
63 | (display x) ;; 3 | |
64 | (+ x y)))) ;; 4"))) | |
65 | (let-values (((data result) | |
66 | (with-code-coverage %test-vm | |
67 | (lambda () (proc 1 2))))) | |
68 | (and (coverage-data? data) | |
69 | (let-values (((instr exec) | |
70 | (instrumented/executed-lines data "foo.scm"))) | |
71 | (and (> instr 0) (>= instr exec)))))))) | |
72 | ||
73 | \f | |
74 | (with-test-prefix "line-execution-counts" | |
75 | ||
76 | (pass-if "once" | |
77 | (let ((proc (code "bar.scm" "(lambda (x y) ;; 0 | |
78 | (+ (/ x y) ;; 1 | |
79 | (* x y))) ;; 2"))) | |
80 | (let-values (((data result) | |
81 | (with-code-coverage %test-vm | |
82 | (lambda () (proc 1 2))))) | |
83 | (let ((counts (line-execution-counts data "bar.scm"))) | |
84 | (and (pair? counts) | |
85 | (every (lambda (line+count) | |
86 | (let ((line (car line+count)) | |
87 | (count (cdr line+count))) | |
88 | (and (>= line 0) | |
89 | (<= line 2) | |
90 | (= count 1)))) | |
91 | counts)))))) | |
92 | ||
93 | (pass-if "several times" | |
94 | (let ((proc (code "fooz.scm" "(lambda (x) ;; 0 | |
95 | (format #f \"hello\") ;; 1 | |
96 | (let loop ((x x)) ;; 2 | |
97 | (cond ((> x 0) ;; 3 | |
98 | (begin ;; 4 | |
99 | (format #f \"~a\" x) | |
100 | (loop (1- x)))) ;; 6 | |
101 | ((= x 0) #t) ;; 7 | |
102 | ((< x 0) 'never))))"))) | |
103 | (let-values (((data result) | |
104 | (with-code-coverage %test-vm | |
105 | (lambda () (proc 77))))) | |
106 | (let ((counts (line-execution-counts data "fooz.scm"))) | |
107 | (and (pair? counts) | |
108 | (every (lambda (line+count) | |
109 | (let ((line (car line+count)) | |
110 | (count (cdr line+count))) | |
111 | (case line | |
112 | ((0 1) (= count 1)) | |
113 | ((2 3) (= count 78)) | |
114 | ((4 5 6) (= count 77)) | |
115 | ((7) (= count 1)) | |
e7bee747 LC |
116 | ((8) (= count 0)) |
117 | (else #f)))) | |
36b5e394 LC |
118 | counts)))))) |
119 | ||
120 | (pass-if "some" | |
121 | (let ((proc (code "baz.scm" "(lambda (x y) ;; 0 | |
122 | (if (> x y) ;; 1 | |
123 | (begin ;; 2 | |
124 | (display x) ;; 3 | |
125 | (+ x y)) ;; 4 | |
126 | (+ x y))) ;; 5"))) | |
127 | (let-values (((data result) | |
128 | (with-code-coverage %test-vm | |
129 | (lambda () (proc 1 2))))) | |
130 | (let ((counts (line-execution-counts data "baz.scm"))) | |
131 | (and (pair? counts) | |
132 | (every (lambda (line+count) | |
133 | (let ((line (car line+count)) | |
134 | (count (cdr line+count))) | |
135 | (case line | |
136 | ((0 1 5) (= count 1)) | |
137 | ((2 3) (= count 0)) | |
138 | ((4) #t) ;; the start of the `else' branch is | |
139 | ;; attributed to line 4 | |
140 | (else #f)))) | |
141 | counts)))))) | |
142 | ||
143 | (pass-if "one proc hit, one proc unused" | |
144 | (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0 | |
145 | (or (= x 0) ;; 1 | |
146 | (not (odd? (1- x)))))) | |
147 | (odd? (lambda (x) ;; 3 | |
148 | (not (even? (1- x)))))) ;; 4 | |
149 | even?)"))) | |
150 | (let-values (((data result) | |
151 | (with-code-coverage %test-vm | |
152 | (lambda () (proc 0))))) | |
153 | (let ((counts (line-execution-counts data "baz.scm"))) | |
154 | (and (pair? counts) | |
155 | (every (lambda (line+count) | |
156 | (let ((line (car line+count)) | |
157 | (count (cdr line+count))) | |
158 | (case line | |
159 | ((0 1) (= count 1)) | |
160 | ((2 3 4) (= count 0)) | |
161 | ((5) (= count 1)) | |
162 | (else #f)))) | |
163 | counts)))))) | |
164 | ||
01291304 LC |
165 | (pass-if "case-lambda" |
166 | (let ((proc (code "cl.scm" "(case-lambda ;; 0 | |
167 | ((x) (+ x 3)) ;; 1 | |
168 | ((x y) (+ x y))) ;; 2"))) | |
169 | (let-values (((data result) | |
170 | (with-code-coverage %test-vm | |
171 | (lambda () | |
172 | (+ (proc 1) (proc 2 3)))))) | |
173 | (let ((counts (line-execution-counts data "cl.scm"))) | |
174 | (and (pair? counts) | |
175 | (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts)))))) | |
176 | ||
36b5e394 LC |
177 | (pass-if "all code on one line" |
178 | ;; There are several proc/IP pairs pointing to this source line, yet the hit | |
179 | ;; count for the line should be 1. | |
180 | (let ((proc (code "one-liner.scm" | |
181 | "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))"))) | |
182 | (let-values (((data result) | |
183 | (with-code-coverage %test-vm | |
184 | (lambda () (proc 451 1884))))) | |
185 | (let ((counts (line-execution-counts data "one-liner.scm"))) | |
186 | (equal? counts '((0 . 1)))))))) | |
187 | ||
188 | \f | |
189 | (with-test-prefix "procedure-execution-count" | |
190 | ||
191 | (pass-if "several times" | |
192 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
193 | (let-values (((data result) | |
194 | (with-code-coverage %test-vm | |
195 | (lambda () (+ (proc 1 2) (proc 2 3)))))) | |
196 | (and (coverage-data? data) | |
197 | (= 3 result) | |
198 | (= (procedure-execution-count data proc) 2))))) | |
199 | ||
01291304 LC |
200 | (pass-if "case-lambda" |
201 | (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))"))) | |
202 | (let-values (((data result) | |
203 | (with-code-coverage %test-vm | |
204 | (lambda () | |
205 | (+ (proc 1) (proc 2 3)))))) | |
206 | (and (coverage-data? data) | |
207 | (= 6 result) | |
208 | (= (procedure-execution-count data proc) 2))))) | |
209 | ||
36b5e394 LC |
210 | (pass-if "never" |
211 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
212 | (let-values (((data result) | |
213 | (with-code-coverage %test-vm | |
214 | (lambda () (+ 1 2))))) | |
215 | (and (coverage-data? data) | |
216 | (= 3 result) | |
639b2eb7 LC |
217 | (not (procedure-execution-count data proc)))))) |
218 | ||
1a6ff60d LC |
219 | (pass-if "applicable struct" |
220 | (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw)) | |
221 | (proc (lambda args (length args))) | |
222 | (b (make-struct <box> 0 proc))) | |
223 | (let-values (((data result) | |
224 | (with-code-coverage %test-vm b))) | |
225 | (and (coverage-data? data) | |
226 | (= 0 result) | |
227 | (= (procedure-execution-count data proc) 1))))) | |
228 | ||
639b2eb7 LC |
229 | (pass-if "called from C" |
230 | ;; The `scm_call_N' functions use the VM returned by `the-vm'. This | |
231 | ;; test makes sure that they get to use %TEST-VM. | |
232 | (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))")) | |
233 | (call (pointer->procedure '* | |
234 | (dynamic-func "scm_call_2" | |
235 | (dynamic-link)) | |
236 | '(* * *)))) | |
237 | (let-values (((data result) | |
238 | (with-code-coverage %test-vm | |
239 | (lambda () | |
240 | (call (make-pointer (object-address proc)) | |
241 | (make-pointer (object-address 1)) | |
242 | (make-pointer (object-address 2))))))) | |
243 | (and (coverage-data? data) | |
244 | (= (object-address 3) (pointer-address result)) | |
7c42e426 LC |
245 | (= (procedure-execution-count data proc) 1))))) |
246 | ||
247 | (pass-if "called from eval" | |
248 | (let-values (((data result) | |
249 | (with-code-coverage %test-vm | |
250 | (lambda () | |
251 | (eval '(test-procedure 123) (current-module)))))) | |
252 | (and (coverage-data? data) | |
253 | (= (test-procedure 123) result) | |
254 | (= (procedure-execution-count data test-procedure) 1))))) | |
36b5e394 LC |
255 | |
256 | \f | |
257 | (with-test-prefix "instrumented-source-files" | |
258 | ||
259 | (pass-if "source files are listed as expected" | |
260 | (let ((proc (code "chbouib.scm" "(lambda (x y) x)"))) | |
261 | (let-values (((data result) | |
262 | (with-code-coverage %test-vm | |
263 | (lambda () (proc 1 2))))) | |
264 | ||
265 | (let ((files (map basename (instrumented-source-files data)))) | |
266 | (and (member "boot-9.scm" files) | |
267 | (member "chbouib.scm" files) | |
268 | (not (member "foo.scm" files)))))))) |