Commit | Line | Data |
---|---|---|
36b5e394 LC |
1 | ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
3 | ;;;; Copyright (C) 2010 Free Software Foundation, Inc. | |
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) | |
24 | #:use-module (srfi srfi-1) | |
25 | #:use-module (srfi srfi-11)) | |
26 | ||
27 | (define-syntax code | |
28 | (syntax-rules () | |
29 | ((_ filename snippet) | |
30 | (let ((input (open-input-string snippet))) | |
31 | (set-port-filename! input filename) | |
32 | (read-enable 'positions) | |
33 | (compile (read input)))))) | |
34 | ||
35 | (define %test-vm (make-vm)) | |
36 | ||
37 | \f | |
38 | (with-test-prefix "instrumented/executed-lines" | |
39 | ||
40 | (pass-if "instr = exec" | |
41 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
42 | (+ x y)) ;; 1"))) | |
43 | (let-values (((data result) | |
44 | (with-code-coverage %test-vm | |
45 | (lambda () (proc 1 2))))) | |
46 | (and (coverage-data? data) | |
47 | (= 3 result) | |
48 | (let-values (((instr exec) | |
49 | (instrumented/executed-lines data "foo.scm"))) | |
50 | (and (= 2 instr) (= 2 exec))))))) | |
51 | ||
52 | (pass-if "instr >= exec" | |
53 | (let ((proc (code "foo.scm" "(lambda (x y) ;; 0 | |
54 | (if (> x y) ;; 1 | |
55 | (begin ;; 2 | |
56 | (display x) ;; 3 | |
57 | (+ x y)))) ;; 4"))) | |
58 | (let-values (((data result) | |
59 | (with-code-coverage %test-vm | |
60 | (lambda () (proc 1 2))))) | |
61 | (and (coverage-data? data) | |
62 | (let-values (((instr exec) | |
63 | (instrumented/executed-lines data "foo.scm"))) | |
64 | (and (> instr 0) (>= instr exec)))))))) | |
65 | ||
66 | \f | |
67 | (with-test-prefix "line-execution-counts" | |
68 | ||
69 | (pass-if "once" | |
70 | (let ((proc (code "bar.scm" "(lambda (x y) ;; 0 | |
71 | (+ (/ x y) ;; 1 | |
72 | (* x y))) ;; 2"))) | |
73 | (let-values (((data result) | |
74 | (with-code-coverage %test-vm | |
75 | (lambda () (proc 1 2))))) | |
76 | (let ((counts (line-execution-counts data "bar.scm"))) | |
77 | (and (pair? counts) | |
78 | (every (lambda (line+count) | |
79 | (let ((line (car line+count)) | |
80 | (count (cdr line+count))) | |
81 | (and (>= line 0) | |
82 | (<= line 2) | |
83 | (= count 1)))) | |
84 | counts)))))) | |
85 | ||
86 | (pass-if "several times" | |
87 | (let ((proc (code "fooz.scm" "(lambda (x) ;; 0 | |
88 | (format #f \"hello\") ;; 1 | |
89 | (let loop ((x x)) ;; 2 | |
90 | (cond ((> x 0) ;; 3 | |
91 | (begin ;; 4 | |
92 | (format #f \"~a\" x) | |
93 | (loop (1- x)))) ;; 6 | |
94 | ((= x 0) #t) ;; 7 | |
95 | ((< x 0) 'never))))"))) | |
96 | (let-values (((data result) | |
97 | (with-code-coverage %test-vm | |
98 | (lambda () (proc 77))))) | |
99 | (let ((counts (line-execution-counts data "fooz.scm"))) | |
100 | (and (pair? counts) | |
101 | (every (lambda (line+count) | |
102 | (let ((line (car line+count)) | |
103 | (count (cdr line+count))) | |
104 | (case line | |
105 | ((0 1) (= count 1)) | |
106 | ((2 3) (= count 78)) | |
107 | ((4 5 6) (= count 77)) | |
108 | ((7) (= count 1)) | |
109 | ((8) (= count 0))))) | |
110 | counts)))))) | |
111 | ||
112 | (pass-if "some" | |
113 | (let ((proc (code "baz.scm" "(lambda (x y) ;; 0 | |
114 | (if (> x y) ;; 1 | |
115 | (begin ;; 2 | |
116 | (display x) ;; 3 | |
117 | (+ x y)) ;; 4 | |
118 | (+ x y))) ;; 5"))) | |
119 | (let-values (((data result) | |
120 | (with-code-coverage %test-vm | |
121 | (lambda () (proc 1 2))))) | |
122 | (let ((counts (line-execution-counts data "baz.scm"))) | |
123 | (and (pair? counts) | |
124 | (every (lambda (line+count) | |
125 | (let ((line (car line+count)) | |
126 | (count (cdr line+count))) | |
127 | (case line | |
128 | ((0 1 5) (= count 1)) | |
129 | ((2 3) (= count 0)) | |
130 | ((4) #t) ;; the start of the `else' branch is | |
131 | ;; attributed to line 4 | |
132 | (else #f)))) | |
133 | counts)))))) | |
134 | ||
135 | (pass-if "one proc hit, one proc unused" | |
136 | (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0 | |
137 | (or (= x 0) ;; 1 | |
138 | (not (odd? (1- x)))))) | |
139 | (odd? (lambda (x) ;; 3 | |
140 | (not (even? (1- x)))))) ;; 4 | |
141 | even?)"))) | |
142 | (let-values (((data result) | |
143 | (with-code-coverage %test-vm | |
144 | (lambda () (proc 0))))) | |
145 | (let ((counts (line-execution-counts data "baz.scm"))) | |
146 | (and (pair? counts) | |
147 | (every (lambda (line+count) | |
148 | (let ((line (car line+count)) | |
149 | (count (cdr line+count))) | |
150 | (case line | |
151 | ((0 1) (= count 1)) | |
152 | ((2 3 4) (= count 0)) | |
153 | ((5) (= count 1)) | |
154 | (else #f)))) | |
155 | counts)))))) | |
156 | ||
157 | (pass-if "all code on one line" | |
158 | ;; There are several proc/IP pairs pointing to this source line, yet the hit | |
159 | ;; count for the line should be 1. | |
160 | (let ((proc (code "one-liner.scm" | |
161 | "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))"))) | |
162 | (let-values (((data result) | |
163 | (with-code-coverage %test-vm | |
164 | (lambda () (proc 451 1884))))) | |
165 | (let ((counts (line-execution-counts data "one-liner.scm"))) | |
166 | (equal? counts '((0 . 1)))))))) | |
167 | ||
168 | \f | |
169 | (with-test-prefix "procedure-execution-count" | |
170 | ||
171 | (pass-if "several times" | |
172 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
173 | (let-values (((data result) | |
174 | (with-code-coverage %test-vm | |
175 | (lambda () (+ (proc 1 2) (proc 2 3)))))) | |
176 | (and (coverage-data? data) | |
177 | (= 3 result) | |
178 | (= (procedure-execution-count data proc) 2))))) | |
179 | ||
180 | (pass-if "never" | |
181 | (let ((proc (code "foo.scm" "(lambda (x y) x)"))) | |
182 | (let-values (((data result) | |
183 | (with-code-coverage %test-vm | |
184 | (lambda () (+ 1 2))))) | |
185 | (and (coverage-data? data) | |
186 | (= 3 result) | |
187 | (not (procedure-execution-count data proc))))))) | |
188 | ||
189 | \f | |
190 | (with-test-prefix "instrumented-source-files" | |
191 | ||
192 | (pass-if "source files are listed as expected" | |
193 | (let ((proc (code "chbouib.scm" "(lambda (x y) x)"))) | |
194 | (let-values (((data result) | |
195 | (with-code-coverage %test-vm | |
196 | (lambda () (proc 1 2))))) | |
197 | ||
198 | (let ((files (map basename (instrumented-source-files data)))) | |
199 | (and (member "boot-9.scm" files) | |
200 | (member "chbouib.scm" files) | |
201 | (not (member "foo.scm" files)))))))) |