1 | ;;; Code coverage reporting facility, based on the SBCL's |
---|
2 | ;;; sb-cover written by Juho Snellman, and placed under public domain. |
---|
3 | ;;; Port to ccl by gz@clozure.com |
---|
4 | |
---|
5 | (in-package :ccl) |
---|
6 | |
---|
7 | (export '(*compile-code-coverage* |
---|
8 | report-coverage |
---|
9 | reset-coverage |
---|
10 | clear-coverage |
---|
11 | save-coverage-in-file |
---|
12 | restore-coverage-from-file)) |
---|
13 | |
---|
14 | (defconstant $not-executed-style 2) |
---|
15 | (defconstant $totally-covered-style 5) |
---|
16 | (defconstant $partially-covered-style 6) |
---|
17 | |
---|
18 | (defparameter *file-coverage* ()) |
---|
19 | (defparameter *coverage-subnotes* (make-hash-table :test #'eq)) |
---|
20 | (defparameter *emitted-code-notes* (make-hash-table :test #'eq)) |
---|
21 | (defparameter *entry-code-notes* (make-hash-table :test #'eq)) |
---|
22 | |
---|
23 | |
---|
24 | (defun file-coverage-file (entry) |
---|
25 | (car entry)) |
---|
26 | |
---|
27 | (defun file-coverage-functions (entry) |
---|
28 | (cadr entry)) |
---|
29 | |
---|
30 | (defun file-coverage-toplevel-functions (entry) |
---|
31 | (cddr entry)) |
---|
32 | |
---|
33 | (defun coverage-subnotes (note) |
---|
34 | (gethash note *coverage-subnotes*)) |
---|
35 | |
---|
36 | (defun emitted-code-note-p (note) |
---|
37 | (gethash note *emitted-code-notes*)) |
---|
38 | |
---|
39 | (defun entry-code-note-p (note) |
---|
40 | (gethash note *entry-code-notes*)) |
---|
41 | |
---|
42 | (defmacro lfunloop (for var in function &body loop-body) |
---|
43 | (assert (and (memq for '(for as)) (eq in 'in))) |
---|
44 | (let ((fn (gensym)) |
---|
45 | (lfv (gensym)) |
---|
46 | (i (gensym))) |
---|
47 | `(loop with ,fn = ,function |
---|
48 | with ,lfv = (function-to-function-vector ,fn) |
---|
49 | for ,i from #+ppc-target 0 #+x86-target (%function-code-words fn) below (uvsize ,lfv) |
---|
50 | as ,var = (uvref ,lfv ,i) |
---|
51 | ,@loop-body))) |
---|
52 | |
---|
53 | |
---|
54 | (defun map-function-coverage (lfun fn &optional refs) |
---|
55 | (let ((refs (cons lfun refs))) |
---|
56 | (lfunloop for imm in lfun |
---|
57 | when (code-note-p imm) |
---|
58 | do (funcall fn imm) |
---|
59 | when (and (functionp imm) |
---|
60 | (not (memq imm refs))) |
---|
61 | do (map-function-coverage imm fn refs)))) |
---|
62 | |
---|
63 | (defun get-function-coverage (fn refs) |
---|
64 | (let ((entry (function-entry-code-note fn)) |
---|
65 | (refs (cons fn refs))) |
---|
66 | (declare (dynamic-extent refs)) |
---|
67 | (when entry |
---|
68 | ;; This can occur legitimately when the same source is used multiple times, |
---|
69 | ;; as when 'body' contains local fn defs in something like: |
---|
70 | ;; (defmacro define-twice (defn) (defun fn-1 ,@defn) (defun fn-2 ,@defn)) |
---|
71 | #+never-mind |
---|
72 | (when (and (gethash entry *entry-code-notes*) |
---|
73 | (neq fn (gethash entry *entry-code-notes*))) |
---|
74 | (cerror "ignore" "Note ~s is entry note for both ~s and ~s" |
---|
75 | entry fn (gethash entry *entry-code-notes*))) |
---|
76 | (setf (gethash entry *entry-code-notes*) fn)) |
---|
77 | (nconc |
---|
78 | (and entry (list fn)) |
---|
79 | (lfunloop for imm in fn |
---|
80 | when (code-note-p imm) |
---|
81 | do (let ((parent (code-note-parent-note imm))) |
---|
82 | (setf (gethash imm *emitted-code-notes*) t) |
---|
83 | (when parent |
---|
84 | (if (consp parent) |
---|
85 | (loop for p in parent |
---|
86 | do (pushnew imm (gethash p *coverage-subnotes*))) |
---|
87 | (pushnew imm (gethash parent *coverage-subnotes*))))) |
---|
88 | when (and (functionp imm) |
---|
89 | (not (memq imm refs))) |
---|
90 | nconc (get-function-coverage imm refs))))) |
---|
91 | |
---|
92 | |
---|
93 | (defun get-coverage () |
---|
94 | (setq *file-coverage* nil) |
---|
95 | (clrhash *coverage-subnotes*) |
---|
96 | (clrhash *emitted-code-notes*) |
---|
97 | (clrhash *entry-code-notes*) |
---|
98 | (loop for data in *code-covered-functions* |
---|
99 | when (consp data) |
---|
100 | do (destructuring-bind (file . toplevel-functions) data |
---|
101 | (push (list* file |
---|
102 | ;; Duplicates are possible if you have multiple instances of |
---|
103 | ;; (load-time-value (foo)) where (foo) returns an lfun. |
---|
104 | ;; CL-PPCRE does that. |
---|
105 | (delete-duplicates |
---|
106 | (loop for fn across toplevel-functions |
---|
107 | nconc (get-function-coverage fn nil))) |
---|
108 | toplevel-functions) |
---|
109 | *file-coverage*)))) |
---|
110 | |
---|
111 | (defun show-notes (note) |
---|
112 | (when (functionp note) |
---|
113 | (setq note (function-entry-code-note note))) |
---|
114 | (labels ((show (note indent label) |
---|
115 | (dotimes (i indent) (write-char #\space)) |
---|
116 | (format t "~a ~a" label note) |
---|
117 | (unless (emitted-code-note-p note) |
---|
118 | (format t " [Not Emitted]")) |
---|
119 | (when (entry-code-note-p note) |
---|
120 | (format t " (Entry to ~s)" (entry-code-note-p note))) |
---|
121 | (format t "~%") |
---|
122 | (when (code-note-p note) |
---|
123 | (loop with subindent = (+ indent 3) |
---|
124 | for sub in (coverage-subnotes note) as i upfrom 1 |
---|
125 | do (show sub subindent (format nil "~a~d." label i)))))) |
---|
126 | (show note 0 ""))) |
---|
127 | |
---|
128 | (defun covered-functions-for-file (path) |
---|
129 | (let* ((true-path (probe-file path)) |
---|
130 | (data (find-if #'(lambda (data) |
---|
131 | (or (equalp (car data) path) |
---|
132 | (and true-path (equalp (probe-file (car data)) true-path)))) |
---|
133 | *code-covered-functions*))) |
---|
134 | (cdr data))) |
---|
135 | |
---|
136 | (defun clear-coverage () |
---|
137 | "Clear all files from the coverage database. The files will be re-entered |
---|
138 | into the database when the FASL files (produced by compiling with |
---|
139 | CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the |
---|
140 | image." |
---|
141 | (setq *code-covered-functions* nil)) |
---|
142 | |
---|
143 | (defun reset-coverage () |
---|
144 | "Reset all coverage data back to the `Not executed` state." |
---|
145 | (flet ((reset (note) (setf (code-note-code-coverage note) nil))) |
---|
146 | (loop for data in *code-covered-functions* |
---|
147 | do (typecase data |
---|
148 | (cons ;; (source-file . functions) |
---|
149 | (loop for fn across (cdr data) |
---|
150 | do (map-function-coverage fn #'reset))) |
---|
151 | (function (map-function-coverage data #'reset)))))) |
---|
152 | |
---|
153 | (defun save-function-coverage (fn &optional (refs ())) |
---|
154 | (push fn refs) |
---|
155 | (cons (let ((name (function-name fn))) |
---|
156 | (and (symbolp name) |
---|
157 | (symbol-package name) |
---|
158 | name)) |
---|
159 | (lfunloop for imm in fn |
---|
160 | when (code-note-p imm) |
---|
161 | collect (code-note-code-coverage imm) |
---|
162 | when (and (functionp imm) (not (memq imm refs))) |
---|
163 | collect (save-function-coverage imm refs)))) |
---|
164 | |
---|
165 | |
---|
166 | |
---|
167 | (defun save-coverage () |
---|
168 | "Returns an opaque representation of the current code coverage state. |
---|
169 | The only operation that may be done on the state is passing it to |
---|
170 | RESTORE-COVERAGE. The representation is guaranteed to be readably printable. |
---|
171 | A representation that has been printed and read back will work identically |
---|
172 | in RESTORE-COVERAGE." |
---|
173 | (loop for data in *code-covered-functions* |
---|
174 | when (consp data) |
---|
175 | collect (cons (car data) |
---|
176 | (map 'vector #'save-function-coverage (cdr data))))) |
---|
177 | |
---|
178 | (defun restore-coverage (coverage-state) |
---|
179 | "Restore the code coverage data back to an earlier state produced by |
---|
180 | SAVE-COVERAGE." |
---|
181 | (loop for (saved-file . saved-fns) in coverage-state |
---|
182 | as fns = (covered-functions-for-file saved-file) |
---|
183 | do (flet ((mismatched (why &rest args) |
---|
184 | (error "Mismatched coverage data for ~s, ~?" saved-file why args))) |
---|
185 | (cond ((null fns) |
---|
186 | (warn "Couldn't restore saved coverage for ~s, no matching file present" |
---|
187 | saved-file)) |
---|
188 | ((not (eql (length fns) (length saved-fns))) |
---|
189 | (mismatched "was ~s functions, now ~s" (length saved-fns) (length fns))) |
---|
190 | (t |
---|
191 | (loop for fn across fns |
---|
192 | for saved-data across saved-fns |
---|
193 | do (labels |
---|
194 | ((rec (fn saved-data refs) |
---|
195 | (push fn refs) |
---|
196 | (let* ((name (car saved-data)) |
---|
197 | (saved-imms (cdr saved-data))) |
---|
198 | (unless (equalp name |
---|
199 | (let ((name (function-name fn))) |
---|
200 | (and (symbolp name) name))) |
---|
201 | (mismatched "had ~s now have ~s" name (function-name fn))) |
---|
202 | (lfunloop for imm in fn |
---|
203 | when (code-note-p imm) |
---|
204 | do (if (or (null saved-imms) (consp (car saved-imms))) |
---|
205 | (mismatched "in ~s" name) |
---|
206 | (setf (code-note-code-coverage imm) (pop saved-imms))) |
---|
207 | when (and (functionp imm) |
---|
208 | (not (memq imm refs))) |
---|
209 | do (if (or (null saved-imms) (atom (car saved-imms))) |
---|
210 | (mismatched "in ~s" name) |
---|
211 | (rec imm (pop saved-imms) refs)))))) |
---|
212 | (rec fn saved-data nil)))))))) |
---|
213 | |
---|
214 | (defun save-coverage-in-file (pathname) |
---|
215 | "Call SAVE-COVERAGE and write the results of that operation into the |
---|
216 | file designated by PATHNAME." |
---|
217 | (with-open-file (stream pathname |
---|
218 | :direction :output |
---|
219 | :if-exists :supersede |
---|
220 | :if-does-not-exist :create) |
---|
221 | (with-standard-io-syntax |
---|
222 | (let ((*package* *ccl-package*)) |
---|
223 | (write (save-coverage) :stream stream))) |
---|
224 | (values))) |
---|
225 | |
---|
226 | (defun restore-coverage-from-file (pathname) |
---|
227 | "READ the contents of the file designated by PATHNAME and pass the |
---|
228 | result to RESTORE-COVERAGE." |
---|
229 | (with-open-file (stream pathname :direction :input) |
---|
230 | (with-standard-io-syntax |
---|
231 | (let ((*package* *ccl-package*)) |
---|
232 | (restore-coverage (read stream)))) |
---|
233 | (values))) |
---|
234 | |
---|
235 | (defun common-coverage-directory () |
---|
236 | (let* ((host :unknown) |
---|
237 | (rev-dir ())) |
---|
238 | (loop for data in *code-covered-functions* |
---|
239 | when (consp data) |
---|
240 | do (let ((file (probe-file (car data)))) |
---|
241 | (when file |
---|
242 | (cond ((eq host :unknown) |
---|
243 | (setq host (pathname-host file) |
---|
244 | rev-dir (reverse (pathname-directory file)))) |
---|
245 | ((not (equalp host (pathname-host file))) |
---|
246 | (return-from common-coverage-directory nil)) |
---|
247 | (t |
---|
248 | (let* ((path (pathname-directory file)) |
---|
249 | (dir-len (length rev-dir)) |
---|
250 | (len (length path))) |
---|
251 | (if (< len dir-len) |
---|
252 | (setq rev-dir (nthcdr (- dir-len len) rev-dir)) |
---|
253 | (setq path (subseq path 0 dir-len))) |
---|
254 | (loop for pp on (reverse path) until (equalp pp rev-dir) |
---|
255 | do (pop rev-dir)))))))) |
---|
256 | (unless (eq host :unknown) |
---|
257 | (make-pathname :host host :directory (reverse rev-dir))))) |
---|
258 | |
---|
259 | |
---|
260 | (defun report-coverage (output-file &key (external-format :default) (statistics t)) |
---|
261 | "Print a code coverage report of all instrumented files into DIRECTORY. |
---|
262 | If DIRECTORY does not exist, it will be created. The main report will be |
---|
263 | printed to the file cover-index.html. The external format of the source |
---|
264 | files can be specified with the EXTERNAL-FORMAT parameter. |
---|
265 | If :STATISTICS is non-nil, a CSV file is generated with a table. If |
---|
266 | :STATISTICS is a filename, that file is used, else 'statistics.csv' is |
---|
267 | written to the output directory. |
---|
268 | " |
---|
269 | (let* ((paths) |
---|
270 | (directory (make-pathname :name nil :type nil :defaults output-file)) |
---|
271 | (coverage-dir (common-coverage-directory)) |
---|
272 | (*file-coverage* nil) |
---|
273 | (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) |
---|
274 | (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) |
---|
275 | (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) |
---|
276 | (get-coverage) |
---|
277 | (ensure-directories-exist directory) |
---|
278 | (loop for coverage in *file-coverage* |
---|
279 | as file = (or (probe-file (file-coverage-file coverage)) |
---|
280 | (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage)) |
---|
281 | nil)) |
---|
282 | do (when file |
---|
283 | (let* ((src-name (enough-namestring file coverage-dir)) |
---|
284 | (html-name (substitute #\_ #\: (substitute #\_ #\. (substitute #\_ #\/ src-name))))) |
---|
285 | (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory) |
---|
286 | :direction :output |
---|
287 | :if-exists :supersede |
---|
288 | :if-does-not-exist :create) |
---|
289 | (report-file-coverage coverage stream external-format)) |
---|
290 | (push (list* src-name html-name coverage) paths)))) |
---|
291 | (setq paths (sort paths #'string< :key #'car)) |
---|
292 | (when (null paths) |
---|
293 | (error "No code coverage data available")) |
---|
294 | (let* ((index-file (merge-pathnames output-file "index.html")) |
---|
295 | (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) |
---|
296 | (pathnamep statistics)) |
---|
297 | (merge-pathnames statistics "statistics.csv") |
---|
298 | "statistics.csv") |
---|
299 | output-file)))) |
---|
300 | (with-open-file (html-stream index-file |
---|
301 | :direction :output |
---|
302 | :if-exists :supersede |
---|
303 | :if-does-not-exist :create) |
---|
304 | (if stats-file |
---|
305 | (with-open-file (stats-stream stats-file |
---|
306 | :direction :output |
---|
307 | :if-exists :supersede |
---|
308 | :if-does-not-exist :create) |
---|
309 | (report-coverage-to-streams paths html-stream stats-stream)) |
---|
310 | (report-coverage-to-streams paths html-stream nil))) |
---|
311 | (values index-file stats-file)))) |
---|
312 | |
---|
313 | (defun report-coverage-to-streams (paths html-stream stats-stream) |
---|
314 | (write-coverage-styles html-stream) |
---|
315 | (unless paths |
---|
316 | (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?") |
---|
317 | (format html-stream "<h3>No code coverage data found.</h3>~%") |
---|
318 | (when stats-stream (format stats-stream "No code coverage data found.~%")) |
---|
319 | (return-from report-coverage-to-streams)) |
---|
320 | (format html-stream "<table class='summary'>") |
---|
321 | (coverage-stats-head html-stream stats-stream) |
---|
322 | (loop for prev = nil then src-name |
---|
323 | for (src-name report-name . coverage) in paths |
---|
324 | for even = nil then (not even) |
---|
325 | do (when (or (null prev) |
---|
326 | (not (equal (pathname-directory (pathname src-name)) |
---|
327 | (pathname-directory (pathname prev))))) |
---|
328 | (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name)))) |
---|
329 | (format html-stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%" dir) |
---|
330 | (when stats-stream (format stats-stream "~a~%" dir)))) |
---|
331 | do (coverage-stats-data html-stream stats-stream coverage even report-name src-name)) |
---|
332 | (format html-stream "</table>")) |
---|
333 | |
---|
334 | (defun precompute-note-coverage (note &optional refs) |
---|
335 | (when note |
---|
336 | (let ((subnotes (coverage-subnotes note)) |
---|
337 | (refs (cons note refs))) |
---|
338 | (declare (dynamic-extent refs)) |
---|
339 | (loop for sub in subnotes |
---|
340 | when (member sub refs) |
---|
341 | do (break "Circularity!!") |
---|
342 | unless (member sub refs) |
---|
343 | do (precompute-note-coverage sub refs)) |
---|
344 | (when (and (or (not (emitted-code-note-p note)) |
---|
345 | (code-note-code-coverage note)) |
---|
346 | (loop for sub in subnotes |
---|
347 | always (or (eq 'full (code-note-code-coverage sub)) |
---|
348 | (entry-code-note-p sub)))) |
---|
349 | (setf (code-note-code-coverage note) 'full))))) |
---|
350 | |
---|
351 | |
---|
352 | (defun fill-with-text-style (coverage location-note styles) |
---|
353 | (let ((style (case coverage |
---|
354 | ((full) $totally-covered-style) |
---|
355 | ((nil) $not-executed-style) |
---|
356 | (t $partially-covered-style)))) |
---|
357 | (fill styles style |
---|
358 | :start (source-note-start-pos location-note) |
---|
359 | :end (source-note-end-pos location-note)))) |
---|
360 | |
---|
361 | (defun update-text-styles (note styles) |
---|
362 | (when (source-note-p note) |
---|
363 | (fill-with-text-style (code-note-code-coverage note) note styles)) |
---|
364 | (unless (and (emitted-code-note-p note) |
---|
365 | (memq (code-note-code-coverage note) '(nil full)) |
---|
366 | ;; If not a source note, descend in case have some subnotes |
---|
367 | ;; that can be shown |
---|
368 | (source-note-p note)) |
---|
369 | (loop for sub in (coverage-subnotes note) |
---|
370 | unless (entry-code-note-p sub) |
---|
371 | do (update-text-styles sub styles)))) |
---|
372 | |
---|
373 | (defun colorize-source-note (note styles) |
---|
374 | ;; Change coverage flag to 'full if all subforms are covered. |
---|
375 | (precompute-note-coverage note) |
---|
376 | ;; Now actually change text styles, from outside in. |
---|
377 | ;; But first, a special kludge: |
---|
378 | ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " |
---|
379 | ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner |
---|
380 | ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that |
---|
381 | ;; expanded into the above, there isn't a clear way to show the distinction between |
---|
382 | ;; just referencing the inner fn and executing it. In practice, the colorization |
---|
383 | ;; based on the inner function is more interesting -- consider for example DEFUN, |
---|
384 | ;; nobody cares if the defun form itself got executed. |
---|
385 | ;; So when showing the colorization of an inner function, we usurp the whole nearest source |
---|
386 | ;; form, provided it can be done unambiguously. |
---|
387 | (loop for n = note then parent until (source-note-p n) |
---|
388 | as parent = (code-note-parent-note n) |
---|
389 | do (unless (and parent |
---|
390 | (labels ((no-other-entry-subnotes (n refs) |
---|
391 | (let ((subs (coverage-subnotes n)) |
---|
392 | (refs (cons n refs))) |
---|
393 | (declare (dynamic-extent refs)) |
---|
394 | (loop for sub in subs |
---|
395 | always (or (memq sub refs) |
---|
396 | (eq sub note) |
---|
397 | (and (not (entry-code-note-p sub)) |
---|
398 | (no-other-entry-subnotes sub refs))))))) |
---|
399 | (no-other-entry-subnotes parent ()))) |
---|
400 | (return nil)) |
---|
401 | finally (fill-with-text-style (code-note-code-coverage note) n styles)) |
---|
402 | (update-text-styles note styles)) |
---|
403 | |
---|
404 | (defun function-source-form-note (fn) |
---|
405 | (loop for n = (function-entry-code-note fn) then (code-note-parent-note n) |
---|
406 | do (when (null n) (return nil)) |
---|
407 | do (when (source-note-p n) |
---|
408 | (loop for s = (code-note-source n) while (source-note-p s) |
---|
409 | do (setq n s)) |
---|
410 | (return n)))) |
---|
411 | |
---|
412 | |
---|
413 | (defun colorize-function (fn styles &optional refs) |
---|
414 | (let* ((note (function-entry-code-note fn)) |
---|
415 | (source (function-source-form-note fn)) |
---|
416 | (refs (cons fn refs))) |
---|
417 | (declare (dynamic-extent refs)) |
---|
418 | ;; Colorize the body of the function |
---|
419 | (when note |
---|
420 | (colorize-source-note note styles)) |
---|
421 | ;; And now any subfunction references |
---|
422 | (lfunloop for imm in fn |
---|
423 | when (and (functionp imm) |
---|
424 | (not (memq imm refs)) |
---|
425 | ;; Make sure this fn is in the source we're currently looking at. |
---|
426 | ;; It might not be, if it is referenced via (load-time-value (foo)) |
---|
427 | ;; where (foo) returns an lfun from some different source entirely. |
---|
428 | ;; CL-PPCRE does that. |
---|
429 | (or (null source) |
---|
430 | (eq source (function-source-form-note imm)) |
---|
431 | #+debug (progn |
---|
432 | (warn "Ignoring ref to ~s from ~s" imm fn) |
---|
433 | nil))) |
---|
434 | do (colorize-function imm styles refs)))) |
---|
435 | |
---|
436 | (defun report-file-coverage (coverage html-stream external-format) |
---|
437 | "Print a code coverage report of FILE into the stream HTML-STREAM." |
---|
438 | (format html-stream "<html><head>") |
---|
439 | (write-coverage-styles html-stream) |
---|
440 | (format html-stream "</head><body>") |
---|
441 | (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format) |
---|
442 | (let ((string (make-string (file-length s)))) |
---|
443 | (read-sequence string s) |
---|
444 | string))) |
---|
445 | (styles (make-array (length source) |
---|
446 | :initial-element 0 |
---|
447 | :element-type '(unsigned-byte 2)))) |
---|
448 | (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) |
---|
449 | (print-coverage-report html-stream coverage styles source) |
---|
450 | (format html-stream "</body></html>"))) |
---|
451 | |
---|
452 | (defun print-coverage-report (html-stream coverage styles source) |
---|
453 | (let ((*print-case* :downcase)) |
---|
454 | (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" (file-coverage-file coverage)) |
---|
455 | |
---|
456 | (format html-stream "<table class='summary'>") |
---|
457 | (coverage-stats-head html-stream nil) |
---|
458 | (coverage-stats-data html-stream nil coverage) |
---|
459 | (format html-stream "</table>") |
---|
460 | |
---|
461 | (format html-stream "<div class='key'><b>Key</b><br />~%") |
---|
462 | (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) |
---|
463 | (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) |
---|
464 | (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style) |
---|
465 | (format html-stream "<p></p><div><code>~%") |
---|
466 | |
---|
467 | (flet ((line (line) |
---|
468 | (unless (eql line 0) |
---|
469 | (format html-stream "</span>")) |
---|
470 | (incf line) |
---|
471 | (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code> " line) |
---|
472 | line)) |
---|
473 | (loop with line = (line 0) with col = 0 |
---|
474 | for last-style = nil then style |
---|
475 | for char across source |
---|
476 | for style across styles |
---|
477 | do (unless (eq style last-style) |
---|
478 | (when last-style |
---|
479 | (format html-stream "</span>")) |
---|
480 | (format html-stream "<span class='state-~a'>" style)) |
---|
481 | do (case char |
---|
482 | ((#\Newline) |
---|
483 | (setq style nil) |
---|
484 | (setq col 0) |
---|
485 | (setq line (line line))) |
---|
486 | ((#\Space) |
---|
487 | (incf col) |
---|
488 | (write-string " " html-stream)) |
---|
489 | ((#\Tab) |
---|
490 | (dotimes (i (- 8 (mod col 8))) |
---|
491 | (incf col) |
---|
492 | (write-string " " html-stream))) |
---|
493 | (t |
---|
494 | (incf col) |
---|
495 | (if (alphanumericp char) |
---|
496 | (write-char char html-stream) |
---|
497 | (format html-stream "&#~D;" (char-code char)))))) |
---|
498 | (format html-stream "</code></div>")))) |
---|
499 | |
---|
500 | |
---|
501 | (defun coverage-stats-head (html-stream stats-stream) |
---|
502 | (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>") |
---|
503 | (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>" |
---|
504 | '("Source file" |
---|
505 | "Total" "Covered" "% covered" |
---|
506 | "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")) |
---|
507 | (when stats-stream |
---|
508 | (format stats-stream "~{~a~^,~}" |
---|
509 | '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered" |
---|
510 | "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" |
---|
511 | "Functions Partly Covered" "% Functions Partly Covered" |
---|
512 | "Functions Not Entered" "% Functions Not Entered")))) |
---|
513 | |
---|
514 | (defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name) |
---|
515 | (format html-stream "<tr class='~:[odd~;even~]'>" evenp) |
---|
516 | (if report-name |
---|
517 | (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name) |
---|
518 | (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage))) |
---|
519 | (when stats-stream |
---|
520 | (format stats-stream "~a," (file-coverage-file coverage))) |
---|
521 | (let ((exp-counts (count-covered-expressions coverage))) |
---|
522 | (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts) |
---|
523 | (when stats-stream |
---|
524 | (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) |
---|
525 | (destructuring-bind (total . counts) (count-covered-functions coverage) |
---|
526 | (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts) |
---|
527 | (when stats-stream |
---|
528 | (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts)))) |
---|
529 | |
---|
530 | (defun count-covered-functions (coverage) |
---|
531 | (let ((fully 0) (partly 0) (never 0) (total 0)) |
---|
532 | (map nil #'(lambda (function) |
---|
533 | (let ((note (function-entry-code-note function))) |
---|
534 | (when (and note |
---|
535 | ;; Ignore toplevel functions created by the compiler. |
---|
536 | (or (source-note-p note) |
---|
537 | (code-note-parent-note note) |
---|
538 | (code-note-source note))) |
---|
539 | (incf total) |
---|
540 | (case (code-note-code-coverage note) |
---|
541 | ((full) (incf fully)) |
---|
542 | ((nil) (incf never)) |
---|
543 | (t (incf partly)))))) |
---|
544 | (file-coverage-functions coverage)) |
---|
545 | (if (> total 0) |
---|
546 | (list total |
---|
547 | fully (* 100.0 (/ fully total)) |
---|
548 | partly (* 100.0 (/ partly total)) |
---|
549 | never (* 100.0 (/ never total))) |
---|
550 | '(0 0 -- 0 -- 0 --)))) |
---|
551 | |
---|
552 | (defun count-covered-expressions (coverage) |
---|
553 | (let ((covered 0) (total 0)) |
---|
554 | (map nil #'(lambda (function) |
---|
555 | (let ((note (function-entry-code-note function))) |
---|
556 | (when (and note |
---|
557 | ;; Ignore toplevel functions created by the compiler. |
---|
558 | (or (source-note-p note) |
---|
559 | (code-note-parent-note note) |
---|
560 | (code-note-source note))) |
---|
561 | (labels ((rec (note) |
---|
562 | (incf total) |
---|
563 | (when (code-note-code-coverage note) |
---|
564 | (incf covered)) |
---|
565 | (loop for sub in (coverage-subnotes note) |
---|
566 | unless (entry-code-note-p sub) do (rec sub)))) |
---|
567 | (rec note))))) |
---|
568 | (file-coverage-functions coverage)) |
---|
569 | (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) |
---|
570 | |
---|
571 | |
---|
572 | (defun write-coverage-styles (html-stream) |
---|
573 | (format html-stream "<style type='text/css'> |
---|
574 | *.state-~a { background-color: #ffaaaa } |
---|
575 | *.state-~a { background-color: #aaffaa } |
---|
576 | *.state-~a { background-color: #44dd44 } |
---|
577 | div.key { margin: 20px; width: 88ex } |
---|
578 | div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px; |
---|
579 | /* border-style: solid none none none; border-width: 1px; |
---|
580 | border-color: #dddddd */ } |
---|
581 | |
---|
582 | *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } |
---|
583 | |
---|
584 | table.summary tr.head-row { background-color: #aaaaff } |
---|
585 | table.summary tr td.text-cell { text-align: left } |
---|
586 | table.summary tr td.main-head { text-align: center } |
---|
587 | table.summary tr td { text-align: right } |
---|
588 | table.summary tr.even { background-color: #eeeeff } |
---|
589 | table.summary tr.subheading { background-color: #aaaaff} |
---|
590 | table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; } |
---|
591 | </style>" |
---|
592 | $not-executed-style |
---|
593 | $partially-covered-style |
---|
594 | $totally-covered-style |
---|
595 | )) |
---|