1 ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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.
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.
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
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)
24 #:use-module (system foreign)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-11))
31 (let ((input (open-input-string snippet)))
32 (set-port-filename! input filename)
33 (read-enable 'positions)
34 (compile (read input))))))
36 (define %test-vm (make-vm))
38 (define test-procedure
45 (with-test-prefix "instrumented/executed-lines"
47 (pass-if "instr = exec"
48 (let ((proc (code "foo.scm" "(lambda (x y) ;; 0
50 (let-values (((data result)
51 (with-code-coverage %test-vm
52 (lambda () (proc 1 2)))))
53 (and (coverage-data? data)
55 (let-values (((instr exec)
56 (instrumented/executed-lines data "foo.scm")))
57 (and (= 2 instr) (= 2 exec)))))))
59 (pass-if "instr >= exec"
60 (let ((proc (code "foo.scm" "(lambda (x y) ;; 0
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))))))))
74 (with-test-prefix "line-execution-counts"
77 (let ((proc (code "bar.scm" "(lambda (x y) ;; 0
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")))
85 (every (lambda (line+count)
86 (let ((line (car line+count))
87 (count (cdr line+count)))
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
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")))
108 (every (lambda (line+count)
109 (let ((line (car line+count))
110 (count (cdr line+count)))
114 ((4 5 6) (= count 77))
121 (let ((proc (code "baz.scm" "(lambda (x y) ;; 0
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")))
132 (every (lambda (line+count)
133 (let ((line (car line+count))
134 (count (cdr line+count)))
136 ((0 1 5) (= count 1))
138 ((4) #t) ;; the start of the `else' branch is
139 ;; attributed to line 4
143 (pass-if "one proc hit, one proc unused"
144 (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0
146 (not (odd? (1- x))))))
147 (odd? (lambda (x) ;; 3
148 (not (even? (1- x)))))) ;; 4
150 (let-values (((data result)
151 (with-code-coverage %test-vm
152 (lambda () (proc 0)))))
153 (let ((counts (line-execution-counts data "baz.scm")))
155 (every (lambda (line+count)
156 (let ((line (car line+count))
157 (count (cdr line+count)))
160 ((2 3 4) (= count 0))
165 (pass-if "case-lambda"
166 (let ((proc (code "cl.scm" "(case-lambda ;; 0
168 ((x y) (+ x y))) ;; 2")))
169 (let-values (((data result)
170 (with-code-coverage %test-vm
172 (+ (proc 1) (proc 2 3))))))
173 (let ((counts (line-execution-counts data "cl.scm")))
175 (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))
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))))))))
189 (with-test-prefix "procedure-execution-count"
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)
198 (= (procedure-execution-count data proc) 2)))))
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
205 (+ (proc 1) (proc 2 3))))))
206 (and (coverage-data? data)
208 (= (procedure-execution-count data proc) 2)))))
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)
217 (not (procedure-execution-count data proc))))))
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)
227 (= (procedure-execution-count data proc) 1)))))
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 (false-if-exception ; can we resolve `scm_call_2'?
234 (pointer->procedure '*
235 (dynamic-func "scm_call_2"
239 (let-values (((data result)
240 (with-code-coverage %test-vm
242 (call (make-pointer (object-address proc))
243 (make-pointer (object-address 1))
244 (make-pointer (object-address 2)))))))
245 (and (coverage-data? data)
246 (= (object-address 3) (pointer-address result))
247 (= (procedure-execution-count data proc) 1)))
248 (throw 'unresolved))))
250 (pass-if "called from eval"
251 (let-values (((data result)
252 (with-code-coverage %test-vm
254 (eval '(test-procedure 123) (current-module))))))
255 (and (coverage-data? data)
256 (= (test-procedure 123) result)
257 (= (procedure-execution-count data test-procedure) 1)))))
260 (with-test-prefix "instrumented-source-files"
262 (pass-if "source files are listed as expected"
263 (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
264 (let-values (((data result)
265 (with-code-coverage %test-vm
266 (lambda () (proc 1 2)))))
268 (let ((files (map basename (instrumented-source-files data))))
269 (and (member "boot-9.scm" files)
270 (member "chbouib.scm" files)
271 (not (member "foo.scm" files))))))))