source: trunk/source/library/cover.lisp @ 14798

Last change on this file since 14798 was 14798, checked in by gz, 8 years ago

Initial support for incremental code coverage info.

File size: 53.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2008-2009 Clozure Associates
4;;;   This file is part of Clozure CL.
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; Code coverage reporting facility, originally inspired by SBCL's sb-cover API.
18
19(in-package :ccl)
20
21(eval-when (eval load compile)
22  (export '(*compile-code-coverage*
23            report-coverage
24            reset-coverage
25            clear-coverage
26            save-coverage-in-file
27            restore-coverage-from-file
28           
29            save-coverage  ;; stupid name, here for backward compatibility
30            get-coverage
31            restore-coverage
32            combine-coverage
33            read-coverage-from-file
34            write-coverage-to-file
35           
36            reset-incremental-coverage
37            get-incremental-coverage
38            incremental-coverage-source-matches
39            incremental-coverage-svn-matches
40           
41            coverage-statistics
42            coverage-source-file
43            coverage-expressions-total
44            coverage-expressions-entered
45            coverage-expressions-covered
46            coverage-unreached-branches
47            coverage-code-forms-total
48            coverage-code-forms-covered
49            coverage-functions-total
50            coverage-functions-fully-covered
51            coverage-functions-partly-covered
52            coverage-functions-not-entered
53           
54            without-compiling-code-coverage)))
55
56(defconstant $no-style 0)
57(defconstant $not-executed-style 1)
58(defconstant $totally-covered-style 2)
59(defconstant $partially-covered-style 3)
60
61(defparameter *file-coverage* ())
62(defparameter *coverage-subnotes* (make-hash-table :test #'eq))
63(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
64(defparameter *entry-code-notes* (make-hash-table :test #'eq))
65(defparameter *source-coverage* (make-hash-table :test #'eq))
66
67(defmacro with-decoded-coverage ((&key (cover '*code-covered-functions*) (precompute t)) &body body)
68  `(let* ((*file-coverage* nil)
69          (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
70          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
71          (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
72          (*source-coverage* ,(and precompute `(make-hash-table :test #'eq :shared nil))))
73     (decode-coverage :cover ,cover :precompute ,precompute)
74     ,@body))
75
76
77(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
78  alist)
79
80(defstruct incremental-coverage
81  list)
82
83;; Wrapper in case we ever want to do dwim on raw alists
84(defun coverage-state-alist (coverage)
85  (etypecase coverage
86    (coverage-state (%coverage-state-alist coverage))))
87
88
89(defstruct (ccl:coverage-statistics (:conc-name "COVERAGE-"))
90  source-file
91  expressions-total
92  expressions-entered
93  expressions-covered
94  unreached-branches
95  code-forms-total
96  code-forms-covered
97  functions-total
98  functions-fully-covered
99  functions-partly-covered
100  functions-not-entered)
101
102
103(defun file-coverage-file (entry)
104  (car entry))
105
106(defun file-coverage-functions (entry)
107  (cadr entry))
108
109(defun file-coverage-toplevel-functions (entry)
110  (caddr entry))
111
112(defun file-coverage-statistics (entry)
113  (cdddr entry))
114
115(defun coverage-subnotes (note) ;; reversed parent chain
116  (gethash note *coverage-subnotes*))
117
118(defun emitted-code-note-p (note)
119  (gethash note *emitted-code-notes*))
120
121(defun entry-code-note-p (note)
122  (gethash note *entry-code-notes*))
123
124(defun source-coverage (source-note)
125  (gethash source-note *source-coverage*))
126
127(defun map-function-coverage (lfun fn &optional refs)
128  (let ((refs (cons lfun refs))
129        (source (function-outermost-entry-source lfun)))
130    (declare (dynamic-extent refs))
131    (lfunloop for imm in lfun
132              when (code-note-p imm)
133              do (funcall fn imm)
134              when (and (functionp imm)
135                        (not (memq imm refs))
136                        ;; Make sure this fn is in the source we're currently looking at.
137                        ;; It might not be, if it is referenced via (load-time-value (foo))
138                        ;; where (foo) returns an lfun from some different source entirely.
139                        ;; CL-PPCRE does that.
140                        (or (null source) (eq source (function-outermost-entry-source imm))))
141              do (map-function-coverage imm fn refs))))
142
143(defun decode-coverage-subfunctions (lfun refs)
144  (let ((refs (cons lfun refs))
145        (source (function-outermost-entry-source lfun)))
146    (declare (dynamic-extent refs))
147    (nconc
148     (and (function-entry-code-note lfun) (list lfun))
149     (lfunloop for imm in lfun
150               when (and (functionp imm)
151                         (not (memq imm refs))
152                         (or (null source)
153                             (eq source (function-outermost-entry-source imm))))
154               nconc (decode-coverage-subfunctions imm refs)))))
155
156(defun decode-function-coverage (fn)
157  (let ((all (decode-coverage-subfunctions fn nil)))
158    (loop for fn in all as entry = (function-entry-code-note fn)
159      do (assert (eq fn (gethash entry *entry-code-notes* fn)))
160      do (setf (gethash entry *entry-code-notes*) fn)
161      do (lfunloop for imm in fn
162                   when (code-note-p imm) do (setf (gethash imm *emitted-code-notes*) t)))
163    all))
164
165(defun code-covered-info.file (data) (and (consp data) (car data)))
166(defun code-covered-info.fns (data) (and (consp data) (if (consp (cdr data)) (cadr data) (cdr data))))
167(defun code-covered-info.ef (data) (and (consp data) (consp (cdr data)) (caddr data)))
168(defun code-covered-info.id (data) (and (consp data) (consp (cdr data)) (cadddr data)))
169
170(defun code-covered-info-with-fns (data new-fns)
171  (assert (consp data))
172  (if (consp (cdr data))
173    (let ((new (copy-list data)))
174      (setf (cadr new) new-fns)
175      new)
176    (cons (car data) new-fns)))
177
178(defun decode-coverage (&key (cover *code-covered-functions*) (precompute t))
179  (setq *file-coverage* nil)
180  (clrhash *coverage-subnotes*)
181  (clrhash *emitted-code-notes*)
182  (clrhash *entry-code-notes*)
183  (when precompute (clrhash *source-coverage*))
184  (loop for data in cover
185    do (let* ((file (code-covered-info.file data))
186              (toplevel-functions (code-covered-info.fns data)))
187         (when file
188           (let* ((all-functions (delete-duplicates
189                                  ;; Duplicates are possible if you have multiple instances of
190                                  ;; (load-time-value (foo)) where (foo) returns an lfun.
191                                  ;; CL-PPCRE does that.
192                                  (loop for fn across toplevel-functions
193                                    nconc (decode-coverage-subfunctions fn nil))))
194                  (coverage (list* file
195                                   all-functions
196                                   toplevel-functions
197                                   (make-coverage-statistics :source-file file))))
198             (push coverage *file-coverage*)
199             ;; record emitted notes
200             (loop for fn in all-functions as entry = (function-entry-code-note fn)
201               do (assert (eq fn (gethash entry *entry-code-notes* fn)))
202               do (setf (gethash entry *entry-code-notes*) fn)
203               do (lfunloop for imm in fn
204                            when (code-note-p imm)
205                            do (setf (gethash imm *emitted-code-notes*) t)))))))
206  ;; Now get subnotes, including un-emitted ones.
207  (loop for note being the hash-key of *emitted-code-notes*
208    do (loop for n = note then parent as parent = (code-note-parent-note n)
209         while parent
210         do (pushnew n (gethash parent *coverage-subnotes*))
211         until (emitted-code-note-p parent)))
212  ;; Now get source mapping
213  (when precompute
214    (loop for coverage in *file-coverage*
215      do (precompute-source-coverage coverage)
216      ;; bit of overkill, but we end up always wanting them.
217      do (compute-file-coverage-statistics coverage))))
218
219(defun file-coverage-acode-queue (coverage)
220  (loop with hash = (make-hash-table :test #'eq :shared nil)
221        for fn in (file-coverage-functions coverage)
222        as acode = (%function-acode-string fn)
223        as entry = (function-entry-code-note fn)
224        as sn = (entry-note-unambiguous-source entry)
225        as toplevel-sn = (function-outermost-entry-source fn)
226        do (when sn
227             (assert toplevel-sn)
228             (let* ((pos (source-note-end-pos sn))
229                    (cell (assq acode (gethash toplevel-sn hash))))
230               (if cell
231                 (setf (cdr cell) (max (cdr cell) pos))
232                 (push (cons acode pos) (gethash toplevel-sn hash)))))
233        finally (return (sort (loop for sn being the hash-key of hash using (hash-value alist)
234                                    collect (cons (source-note-end-pos sn)
235                                                  (mapcar #'car (sort alist #'< :key #'cdr))))
236                              #'< :key #'car))))
237
238#+debug
239(defun show-notes (note)
240  (when (functionp note)
241    (setq note (function-entry-code-note note)))
242  (labels ((show (note indent label)
243             (dotimes (i indent) (write-char #\space))
244             (format t "~a ~a" label note)
245             (unless (emitted-code-note-p note)
246               (format t " [Not Emitted]"))
247             (when (entry-code-note-p note)
248               (format t " (Entry to ~s)" (entry-code-note-p note)))
249             (when (code-note-acode-range note)
250               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
251                 (format t " [acode ~a:~a]" s e)))
252             (format t "~%")
253             (when (code-note-p note)
254               (loop with subindent = (+ indent 3)
255                     for sub in (coverage-subnotes note) as i upfrom 1
256                     do (show sub subindent (format nil "~a~d." label i))))))
257    (show note 0 "")))
258
259(defun assoc-by-filename (path alist)
260  (let* ((true-path (probe-file path)))
261    (find-if #'(lambda (data)
262                 (or (equalp (car data) path)
263                     (and true-path (equalp (probe-file (car data)) true-path))))
264             alist)))
265
266(defun ccl:clear-coverage ()
267  "Clear all files from the coverage database. The files will be re-entered
268into the database when the FASL files (produced by compiling with
269CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
270image."
271  (setq *code-covered-functions* nil))
272
273(defun reset-function-coverage (lfun)
274  (map-function-coverage lfun #'(lambda (note)
275                                  (setf (code-note-code-coverage note) nil))))
276
277(defun reset-function-incremental-coverage (lfun)
278  (map-function-coverage lfun #'(lambda (note)
279                                  (when (code-note-code-coverage note)
280                                    (setf (code-note-code-coverage note) :prior)))))
281
282(defun ccl:reset-coverage ()
283  "Reset all coverage data back to the `Not executed` state."
284  (loop for data in *code-covered-functions*
285        do (typecase data
286             (cons
287                (loop for fn across (code-covered-info.fns data)
288                      do (reset-function-coverage fn)))
289             (function (reset-function-coverage data)))))
290
291
292(defun ccl:reset-incremental-coverage ()
293  "Mark a starting point for recording incremental coverage.
294   Has no effect on regular coverage recording."
295  (loop for data in *code-covered-functions*
296    do (typecase data
297         (cons
298          (loop for fn across (code-covered-info.fns data)
299            do (reset-function-incremental-coverage fn)))
300         (function (reset-function-incremental-coverage data)))))
301
302
303;; Name used for consistency checking across file save/restore
304(defun function-covered-name (fn)
305  (let ((name (function-name fn)))
306    (and (symbolp name)
307         (symbol-package name)
308         name)))
309 
310
311(defun coverage-mismatch (why &rest args)
312  ;; Throw to somebody who knows what file we're working on.
313  (throw 'coverage-mismatch (cons why args)))
314
315(defmacro with-coverage-mismatch-catch ((saved-file) &body body)
316  `(let ((file ,saved-file))
317     (with-simple-restart (ignore-file "Ignore ~s and continue" file)
318       (let ((err (catch 'coverage-mismatch 
319                    ,@body
320                    nil)))
321         (when err
322           (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))))
323
324
325;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage).
326(defun save-function-coverage (fn &optional (refs ()))
327  (let ((refs (cons fn refs))
328        (source (function-outermost-entry-source fn)))
329    (declare (dynamic-extent refs))
330    (cons (function-covered-name fn)
331          ;; See comments in map-function-coverage
332          (lfunloop for imm in fn as i upfrom 0
333                    when (and (code-note-p imm)
334                              (code-note-code-coverage imm))
335                    collect i into list
336                    when (and (functionp imm)
337                              (not (memq imm refs))
338                              (or (null source) (eq source (function-outermost-entry-source imm))))
339                    collect (cons i (save-function-coverage imm refs)) into list
340                    finally (return (and list (coerce list 'vector)))))))
341
342(defun copy-function-coverage (fn-data)
343  (cons (car fn-data)
344        (and (cdr fn-data)
345             (map 'vector #'(lambda (imm-data)
346                              (if (consp imm-data)
347                                (cons (car imm-data)
348                                      (copy-function-coverage (cdr imm-data)))
349                                imm-data))
350                  (cdr fn-data)))))
351
352(defun restore-function-coverage (fn saved-fn-data &optional (refs ()))
353  (let* ((refs (cons fn refs))
354         (source (function-outermost-entry-source fn))
355         (saved-name (car saved-fn-data))
356         (saved-imms (cdr saved-fn-data))
357         (nimms (length saved-imms))
358         (n 0))
359    (declare (dynamic-extent refs))
360    (unless (equalp saved-name (function-covered-name fn))
361      (coverage-mismatch "had function ~s now have ~s" saved-name fn))
362    ;; See comments in map-function-coverage
363    (lfunloop for imm in fn as i upfrom 0
364              when (code-note-p imm)
365              do (let* ((next (and (< n nimms) (aref saved-imms n))))
366                   (when (if (consp next) (<= (car next) i) (and next (< next i)))
367                     (coverage-mismatch "in ~s" fn))
368                   (when (setf (code-note-code-coverage imm)
369                               (and (eql next i) 'restored))
370                     (incf n)))
371              when (and (functionp imm)
372                        (not (memq imm refs))
373                        (or (null source) (eq source (function-outermost-entry-source imm))))
374              do (let* ((next (and (< n nimms) (aref saved-imms n))))
375                   (unless (and (consp next) (eql (car next) i))
376                     (coverage-mismatch "in ~s" fn))
377                   (restore-function-coverage imm (cdr next) refs)
378                   (incf n)))))
379
380
381(defun add-function-coverage (fn-data new-fn-data)
382  (let* ((fn-name (car fn-data))
383         (imms (cdr fn-data))
384         (new-fn-name (car new-fn-data))
385         (new-imms (cdr new-fn-data)))
386    (flet ((kar (x) (if (consp x) (%car x) x)))
387      (declare (inline kar))
388      (unless (equalp fn-name new-fn-name)
389        (coverage-mismatch "function ~s vs. ~s" fn-name new-fn-name))
390      (when new-imms
391        (loop for new across new-imms
392              as old = (find (kar new) imms :key #'kar)
393              if (and (null old) (fixnump new))
394                collect new into extras
395              else do (unless (eql old new)
396                        (if (and (consp new) (consp old))
397                          (add-function-coverage (cdr old) (cdr new))
398                          (coverage-mismatch "in function ~s" fn-name)))
399              finally (when extras
400                        (setf (cdr fn-data)
401                              (sort (concatenate 'vector imms extras) #'< :key #'kar))))))
402    fn-data))
403
404
405(defun ccl:get-coverage ()
406  "Returns a snapshot of the current coverage state"
407  (make-coverage-state
408   :alist (loop for data in *code-covered-functions*
409                when (consp data)
410                  collect (code-covered-info-with-fns
411                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
412
413;; Backward compatibility with sbcl name.
414(setf (symbol-function 'ccl:save-coverage) #'ccl:get-coverage)
415
416(defun ccl:combine-coverage (coverage-states)
417  (let ((result nil))
418    (map nil
419         (lambda (coverage-state)
420           (loop for saved-data in (coverage-state-alist coverage-state)
421                 as saved-file = (code-covered-info.file saved-data)
422                 as saved-fns = (code-covered-info.fns saved-data)
423                 as result-data = (assoc-by-filename saved-file result)
424                 as result-fns = (code-covered-info.fns result-data)
425                 do (with-coverage-mismatch-catch (saved-file)
426                      (cond ((null result-fns)
427                             (push (code-covered-info-with-fns
428                                    saved-data (map 'vector #'copy-function-coverage saved-fns))
429                                   result))
430                            ((not (eql (length result-fns) (length saved-fns)))
431                             (coverage-mismatch "different function counts"))
432                            (t
433                             (unless (equal (code-covered-info.id saved-data)
434                                            (code-covered-info.id result-data))
435                               (cerror "Ignore the mismatch"
436                                       "Combining different versions of file ~s (checksum mismatch)"
437                                       saved-file))
438                             (loop for result-fn across result-fns
439                                   for saved-fn across saved-fns
440                                   do (add-function-coverage result-fn saved-fn)))))))
441         coverage-states)
442    (make-coverage-state :alist (nreverse result))))
443
444
445(defun ccl:restore-coverage (coverage-state)
446  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
447  (loop for saved-data in (coverage-state-alist coverage-state)
448        for saved-file = (code-covered-info.file saved-data)
449        as saved-fns = (code-covered-info.fns saved-data)
450        for current-data = (assoc-by-filename saved-file *code-covered-functions*)
451        as fns = (and current-data (code-covered-info.fns current-data))
452        do (with-coverage-mismatch-catch (saved-file)
453             (cond ((null fns)
454                    (warn "Couldn't restore saved coverage for ~s, no matching file present"
455                          saved-file))
456                   ((not (eql (length fns) (length saved-fns)))
457                    (coverage-mismatch "had ~s functions, now have ~s"
458                                       (length saved-fns) (length fns)))
459                   (t 
460                    (unless (equal (code-covered-info.id saved-data)
461                                   (code-covered-info.id current-data))
462                      (cerror "Ignore the mismatch"
463                              "Restoring different version of file ~s (checksum mismatch)"
464                              saved-file))
465                    (map nil #'restore-function-coverage fns saved-fns))))))
466
467(defun ccl:get-incremental-coverage (&key (reset t))
468  "Return the delta coverage since the last reset of incremental coverage.
469  If RESET is true (the default), it also resets incremental coverage now."
470  ;; An incremental coverage snapshot is just a list of covered (i.e. entered) code notes.
471  ;; It is not savable in a file.
472  (let ((covered nil))
473    (flet ((get-fn (note)
474             (let ((coverage (code-note-code-coverage note)))
475               (when (and coverage (not (eq coverage :prior)))
476                 (when reset (setf (code-note-code-coverage note) :prior))
477                 (push note covered)))))
478      (loop for data in *code-covered-functions*
479        when (consp data)
480        do (loop for fn across (code-covered-info.fns data)
481             do (map-function-coverage fn #'get-fn)))
482      (make-incremental-coverage :list covered))))
483
484(defun ccl:incremental-coverage-svn-matches (collection &key (directory (current-directory)) (revision :base))
485  "Given a hash table COLLECTION whose values are incremental coverage deltas, return a list
486  of all keys corresponding to those deltas that intersect any region in a file in DIRECTORY that
487  has changed since revision REVISION in subversion."
488  (incremental-coverage-source-matches collection (get-svn-changes :directory directory
489                                                                   :revision revision
490                                                                   :reverse t)))
491
492(defun ccl:incremental-coverage-source-matches (collection sources)
493  "Given a hash table COLLECTION whose values are incremental coverage delta, return a list
494  of all keys corresponding to deltas that intersect any region in SOURCES.  SOURCES
495  should be a list of source notes and/or pathnames"
496  (let ((coverages (remove-duplicates
497                    (mapcar (lambda (file)
498                              (or (assoc-by-filename file *code-covered-functions*)
499                                  (error "There is no coverage info for ~s" file)))
500                            ;; remove dups for efficiency, since assoc-by-filename can be expensive,
501                            ;; and the filenames will typically be EQ since all created at once.
502                            ;; But don't bother with EQUAL testing, since assoc-by-filename will do that.
503                            ;; Note - source-note-filename accepts pathnames and just returns them.
504                            (remove-duplicates (mapcar #'source-note-filename sources))))))
505    (with-decoded-coverage (:cover coverages :precompute nil)
506      (loop for sn in sources
507        do (let* ((coverage (assoc-by-filename (source-note-filename sn) coverages))
508                  (matches (code-notes-for-region coverage
509                                                  (source-note-start-pos sn)
510                                                  (source-note-end-pos sn))))
511             (flet ((matches (delta)
512                      (loop for note in (incremental-coverage-list delta) thereis (memq note matches))))
513               (typecase collection
514                 (hash-table (loop for key being the hash-key of collection using (hash-value delta)
515                               when (matches delta) collect key))
516                 (sequence (remove-if-not #'matches collection)))))))))
517
518
519
520
521(defun nearest-source-note (note)
522  (loop for n = note then (code-note-parent-note n)
523        thereis (and n (code-note-source-note n))))
524
525;; Given a region of a file, find a set of code notes that completely covers it, i.e.
526;; a set such that if none of the code notes in the set have been executed, then it's guaranteed
527;; that modifying the region is not going to affect execution.  Try to make that set as small
528;; as possible.
529(defun code-notes-for-region (coverage start-pos end-pos)
530  (let* ((notes (loop for fn across (file-coverage-toplevel-functions coverage)
531                  as note = (function-entry-code-note fn) as source = (nearest-source-note note)
532                  when (and source
533                            (or (null end-pos) (< (source-note-start-pos source) end-pos))
534                            (or (null start-pos) (< start-pos (source-note-end-pos source))))
535                  ;; This function intersects the region.  Find the smallest subnote that contains all
536                  ;; of this function's part of the region.
537                  collect (let ((start (max start-pos (source-note-start-pos source)))
538                                (end (min end-pos (source-note-end-pos source))))
539                            (iterate tighten ((note note))
540                              (loop for subnote in (coverage-subnotes note)
541                                as subsource = (nearest-source-note subnote)
542                                do (when (and (<= (source-note-start-pos subsource) start)
543                                              (<= end (source-note-end-pos subsource)))
544                                     (return (tighten subnote)))
545                                finally (return note))))))
546         (emitted-notes (iterate splat ((notes notes))
547                          (loop for note in notes
548                            nconc (if (emitted-code-note-p note)
549                                    (list note)
550                                    (splat (coverage-subnotes note)))))))
551    emitted-notes))
552
553
554;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
555
556(defvar *loading-coverage*)
557
558(defun ccl:write-coverage-to-file (coverage pathname)
559  "Write the coverage state COVERAGE in the file designated by PATHNAME"
560  (with-open-file (stream pathname
561                          :direction :output
562                          :if-exists :supersede
563                          :if-does-not-exist :create)
564    (with-standard-io-syntax
565      (let ((*package* (pkg-arg "CCL")))
566        (format stream "(in-package :ccl)~%~s~%"
567                `(setq *loading-coverage* ',(coverage-state-alist coverage)))))
568    (values)))
569 
570(defun ccl:read-coverage-from-file (pathname)
571  " Return the coverage state saved in the file.  Doesn't affect the current coverage state."
572  (let ((*package* (pkg-arg "CCL"))
573        (*loading-coverage* :none))
574    (load pathname)
575    (when (eq *loading-coverage* :none)
576      (error "~s doesn't seem to be a saved coverage file" pathname))
577    (make-coverage-state :alist *loading-coverage*)))
578
579(defun ccl:save-coverage-in-file (pathname)
580  "Save the current coverage state in the file designed by PATHNAME"
581  (write-coverage-to-file (save-coverage) pathname))
582
583(defun ccl:restore-coverage-from-file (pathname)
584  "Set the current coverage state from the file designed by PATHNAME"
585  (restore-coverage (read-coverage-from-file pathname)))
586
587(defun common-coverage-directory ()
588  (let* ((host :unknown)
589         (rev-dir ()))
590    (loop for data in *code-covered-functions*
591       when (consp data)
592       do (let ((file (probe-file (code-covered-info.file data))))
593            (when file
594              (cond ((eq host :unknown)
595                     (setq host (pathname-host file)
596                           rev-dir (reverse (pathname-directory file))))
597                    ((not (equalp host (pathname-host file)))
598                     (return-from common-coverage-directory nil))
599                    (t
600                     (let* ((path (pathname-directory file))
601                            (dir-len (length rev-dir))
602                            (len (length path)))
603                       (if (< len dir-len)
604                         (setq rev-dir (nthcdr (- dir-len len) rev-dir))
605                         (setq path (subseq path 0 dir-len)))
606                       (loop for pp on (reverse path) until (equalp pp rev-dir)
607                          do (pop rev-dir))))))))
608    (unless (eq host :unknown)
609      (make-pathname :host host :directory (reverse rev-dir)))))
610
611
612(defun ccl:coverage-statistics ()
613  (with-decoded-coverage ()
614    (mapcar #'file-coverage-statistics *file-coverage*)))
615
616(defun compute-file-coverage-statistics (coverage)
617  (count-covered-sexps coverage)
618  (count-unreached-branches coverage)
619  (count-covered-aexps coverage)
620  (count-covered-entry-notes coverage))
621
622
623(defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t))
624  "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE
625and, in the same directory, one html file for each instrumented source file that has been
626loaded in the current session.
627The external format of the source files can be specified with the EXTERNAL-FORMAT parameter.
628If :STATISTICS is non-nil, a CSV file is generated with a table.  If
629:STATISTICS is a filename, that file is used, else 'statistics.csv' is
630written to the output directory.
631"
632  (let* ((paths)
633         (directory (make-pathname :name nil :type nil :defaults output-file))
634         (coverage-dir (common-coverage-directory))
635         (index-file (and html (merge-pathnames output-file "index.html")))
636         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
637                                                              (pathnamep statistics))
638                                                        (merge-pathnames statistics "statistics.csv")
639                                                        "statistics.csv")
640                                                      output-file))))
641    (ensure-directories-exist directory)
642    (with-decoded-coverage ()
643      (loop for coverage in *file-coverage*
644        as truename = (or (probe-file (file-coverage-file coverage))
645                          (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
646                            nil))
647        do (when truename
648             (let* ((src-name (enough-namestring truename coverage-dir))
649                    (html-name (substitute
650                                #\_ #\: (substitute
651                                         #\_ #\. (substitute
652                                                  #\_ #\/ (namestring-unquote src-name)))))
653                    (file (file-coverage-file coverage)))
654               (when html
655                 (with-coverage-mismatch-catch (file)
656                   (let* ((data (assoc-by-filename file *code-covered-functions*))
657                          (checksum (fcomp-file-checksum (code-covered-info.file data)
658                                                         :external-format (code-covered-info.ef data))))
659                     (unless (eql checksum (code-covered-info.id data))
660                       (cerror "Try coloring anyway"
661                               "File ~s has changed since coverage source location info was recorded."
662                               (code-covered-info.file data))))
663                   (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
664                                           :direction :output
665                                           :if-exists :supersede
666                                           :if-does-not-exist :create)
667                     (report-file-coverage index-file coverage stream external-format))))
668               (push (list* src-name html-name coverage) paths))))
669      (when (null paths)
670        (error "No code coverage data available"))
671      (setq paths (sort paths #'(lambda (path1 path2)
672                                  (let* ((f1 (car path1))
673                                         (f2 (car path2)))
674                                    (or (string< (directory-namestring f1)
675                                                 (directory-namestring f2))
676                                        (and (equal (pathname-directory f1)
677                                                    (pathname-directory f2))
678                                             (string< (file-namestring f1)
679                                                      (file-namestring f2))))))))
680      (if html
681        (with-open-file (html-stream index-file
682                                     :direction :output
683                                     :if-exists :supersede
684                                     :if-does-not-exist :create)
685          (if stats-file
686            (with-open-file (stats-stream stats-file
687                                          :direction :output
688                                          :if-exists :supersede
689                                          :if-does-not-exist :create)
690              (report-coverage-to-streams paths html-stream stats-stream))
691            (report-coverage-to-streams paths html-stream nil)))
692        (if stats-file
693          (with-open-file (stats-stream stats-file
694                                        :direction :output
695                                        :if-exists :supersede
696                                        :if-does-not-exist :create)
697            (report-coverage-to-streams paths nil stats-stream))
698          (error "One of :HTML or :STATISTICS must be non-nil")))
699      (values index-file stats-file))))
700
701(defun report-coverage-to-streams (paths html-stream stats-stream)
702  (when html-stream (write-coverage-styles html-stream))
703  (unless paths
704    (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
705    (when html-stream (format html-stream "<h3>No code coverage data found.</h3>~%"))
706    (when stats-stream (format stats-stream "No code coverage data found.~%"))
707    (return-from report-coverage-to-streams))
708  (when html-stream (format html-stream "<table class='summary'>"))
709  (coverage-stats-head html-stream stats-stream)
710  (loop for prev = nil then src-name
711        for (src-name report-name . coverage) in paths
712        for even = nil then (not even)
713        do (when (or (null prev)
714                     (not (equal (pathname-directory (pathname src-name))
715                                 (pathname-directory (pathname prev)))))
716             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
717               (when html-stream (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir))
718               (when stats-stream (format stats-stream "~a~%" dir))))
719        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
720  (when html-stream (format html-stream "</table>")))
721
722(defun style-for-coverage (coverage)
723  (case coverage
724    ((full) $totally-covered-style)
725    ((nil) $not-executed-style)
726    (t $partially-covered-style)))
727 
728(defun fill-with-text-style (source-note styles)
729  (fill styles (style-for-coverage (source-coverage source-note))
730        :start (source-note-start-pos source-note)
731        :end (source-note-end-pos source-note)))
732
733(defun update-text-styles (note styles)
734  (let ((source (code-note-source-note note)))
735    (when source
736      (fill-with-text-style source styles))
737    (unless (and (emitted-code-note-p note)
738                 (memq (code-note-code-coverage note) '(nil full))
739                 ;; If not a source note, descend in case have some subnotes
740                 ;; that can be shown
741                 source)
742      (loop for sub in (coverage-subnotes note)
743            unless (entry-code-note-p sub)
744            do (update-text-styles sub styles)))))
745
746(defun entry-note-unambiguous-source (entry-note)
747  ;; Return the nearest containing source note provided it can be done unambiguously.
748  (loop for n = entry-note then parent until (code-note-source-note n)
749        as parent = (code-note-parent-note n)
750        do (unless (and parent
751                        (labels ((no-other-entry-subnotes (n refs)
752                                   (let ((subs (coverage-subnotes n))
753                                         (refs (cons n refs)))
754                                     (declare (dynamic-extent refs))
755                                     (loop for sub in subs
756                                           always (or (memq sub refs)
757                                                      (eq sub entry-note)
758                                                      (and (not (entry-code-note-p sub))
759                                                           (no-other-entry-subnotes sub refs)))))))
760                          (no-other-entry-subnotes parent ())))
761             (return nil))
762        finally (return (code-note-source-note n))))
763
764;; In some cases, a single source form may be claimed by multiple code notes.  Precompute
765;; per-source coverage info so coloring can reflect aggregated info for all coverage points.
766;; This also changes coverage flag to 'full if all subforms are called.
767(defun precompute-source-coverage (coverage)
768  (labels
769      ((record-1 (source note)
770         (when source
771           (let ((old (gethash source *source-coverage* :default))
772                 (new (code-note-code-coverage note)))
773             (unless (eq old new)
774               (setf (gethash source *source-coverage*) (if (eq old :default) new t))))))
775       (record* (note)
776         (loop with full = (or (code-note-code-coverage note)
777                               (not (emitted-code-note-p note)))
778               for sub in (coverage-subnotes note)
779               unless (entry-code-note-p sub)
780                 do (progn
781                      (record* sub)
782                      (unless (eq (code-note-code-coverage sub) 'full)
783                        (setq full nil)))
784               finally (when full
785                         (setf (code-note-code-coverage note) 'full)))
786         (record-1 (code-note-source-note note) note))
787       (record-entry (note)
788         (record* note)
789         ;; A special kludge for entry notes:
790         ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
791         ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
792         ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
793         ;; expanded into the above, there isn't a clear way to show the distinction between
794         ;; just referencing the inner fn and executing it.  In practice, the colorization
795         ;; based on the inner function is more interesting -- consider for example DEFUN,
796         ;; nobody cares whether the defun form itself got executed.
797         ;; So when showing the colorization of an inner function, we usurp the whole nearest source
798         ;; form, provided it can be done unambiguously.
799         (record-1 (entry-note-unambiguous-source note) note)))
800    (map-coverage-entry-notes coverage #'record-entry)))
801
802(defun colorize-source-note (note styles)
803  ;; See comment in precompute-source-coverage
804  (let ((source (entry-note-unambiguous-source note)))
805    (when source
806      (fill-with-text-style source styles)))
807  (update-text-styles note styles))
808
809(defun function-outermost-entry-source (fn)
810  ;; Find the outermost source form containing the fn.
811  (loop with sn = nil
812        for n = (function-entry-code-note fn) then (code-note-parent-note n)
813        do (when (null n) (return nil))
814        do (when (setq sn (code-note-source-note n))
815             (loop for s = (source-note-source sn) while (source-note-p s)
816                   do (setq sn s))
817             (return sn))))
818
819(defun colorize-acode (fn acode-styles)
820  (let* ((acode (%function-acode-string fn))
821         (note (function-entry-code-note fn))
822         (range (and note (code-note-acode-range note))))
823    (when (and acode range)
824      (let* ((cell (or (gethash acode acode-styles)
825                       (setf (gethash acode acode-styles)
826                             (let ((string (decode-string-from-octets acode :external-format :utf-8)))
827                               (cons string
828                                     (make-array (length string)
829                                                 :initial-element $no-style
830                                                 :element-type '(unsigned-byte 2)))))))
831             (styles (cdr cell)))
832        (iterate update ((note note))
833          (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
834            (when (and start
835                       (setq start (position-if-not #'whitespacep acode :start start :end end :key #'code-char)))
836              (fill styles (style-for-coverage (code-note-code-coverage note))
837                    :start start
838                    :end end)))
839          (loop for sub in (coverage-subnotes note)
840            unless (entry-code-note-p sub)
841            do (update sub)))))))
842
843(defun colorize-function (fn styles acode-styles &optional refs)
844  (let* ((note (function-entry-code-note fn))
845         (source (function-outermost-entry-source fn))
846         (refs (cons fn refs)))
847    (declare (dynamic-extent refs))
848    ;; Colorize the body of the function
849    (when note
850      (colorize-source-note note styles)
851      (colorize-acode fn acode-styles))
852    ;; And now any subfunction references
853    (lfunloop for imm in fn
854              when (and (functionp imm)
855                        (not (memq imm refs))
856                        ;; See note in decode-function-coverage
857                        (or (null source)
858                            (eq source (function-outermost-entry-source imm))
859                            #+debug (progn
860                                      (warn "Ignoring ref to ~s from ~s" imm fn)
861                                      nil)))
862              do (colorize-function imm styles acode-styles refs))))
863
864(defun report-file-coverage (index-file coverage html-stream external-format)
865  "Print a code coverage report of FILE into the stream HTML-STREAM."
866  (format html-stream "<html><head>")
867  (write-coverage-styles html-stream)
868  (format html-stream "</head><body>")
869  (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format)
870                   (let ((string (make-string (file-length s))))
871                     (read-sequence string s)
872                     string)))
873         (styles (make-array (length source)
874                             :initial-element $no-style
875                             :element-type '(unsigned-byte 2)))
876         (acode-styles (make-hash-table :test #'eq)))
877    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles))
878         (file-coverage-toplevel-functions coverage))
879    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
880    (format html-stream "</body></html>")))
881
882(defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
883  (let ((*print-case* :downcase))
884    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
885            (native-translated-namestring (make-pathname :name (pathname-name index-file)
886                                                         :type (pathname-type index-file)))
887            (file-coverage-file coverage))
888    (format html-stream "<table class='summary'>")
889    (coverage-stats-head html-stream nil)
890    (coverage-stats-data html-stream nil coverage)
891    (format html-stream "</table>")
892
893    (format html-stream "<div class='key'><b>Key</b><br />~%")
894    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
895    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
896    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
897    (format html-stream "<div class='stsource'>Uninstrumented - a form whose coverage was not measured</div>")
898    (format html-stream "</div><p></p>~%")
899
900    ;; Output source intertwined with acode
901    (iterate output ((start 0) (line 0) (queue (file-coverage-acode-queue coverage)))
902      (format html-stream "<div class='source'><code>")
903      (let ((next (car queue)))
904        (multiple-value-bind (end last-line)
905            (output-styled html-stream source styles
906                           :start start
907                           :line line
908                           :limit (car next))
909          (format html-stream "</code></div>~%")
910          (when (and next end (<= (car next) end))
911            (destructuring-bind (pos . strings) next
912              (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
913                                   <div class='acode' id='a~:*~d'><code>" pos)
914              (loop for acode in strings as (string . styles) = (gethash acode acode-styles)
915                    do (output-styled html-stream string styles)
916                    do (fresh-line html-stream))
917              (format html-stream "</code></div><hr/>~%")
918              (output (1+ end) last-line (cdr queue)))))))))
919
920(defun output-styled (html-stream source styles &key (start 0) line limit)
921  (let ((last-style $no-style)
922        (col 0)
923        (line line))
924    (labels ((outch (char)
925               (if (eql char #\Tab)
926                 (dotimes (i (- 8 (mod col 8)))
927                   (incf col)
928                   (write-string " " html-stream))
929                 (progn
930                   (incf col)
931                   (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
932                     (write-char char html-stream)
933                     (format html-stream "&#~D;" (char-code char))))))
934             (start-line ()
935               (when line
936                 (incf line)
937                 (format html-stream "<span class='line'>~A</span>" line))
938               (write-char #\space html-stream)
939               (setq col 0))
940             (set-style (new)
941               (unless (eq last-style new)
942                 (unless (eq last-style $no-style) (format html-stream "</span>"))
943                 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
944                 (setq last-style new)))
945             (end-line ()
946               (set-style $no-style)
947               (format html-stream "~%")))
948      (declare (inline outch start-line end-line))
949      (unless limit (setq limit (length source)))
950      (start-line)
951      (loop
952        for pos from start below (length source)
953        as char = (aref source pos) as style = (aref styles pos)
954        do (set-style style)
955        do (case char
956             ((#\Newline)
957              (end-line)
958              (when (<= limit pos)
959                (return (values pos line)))
960              (start-line))
961             (t
962              (outch char)))
963        finally (end-line)))))
964
965
966(defun coverage-stats-head (html-stream stats-stream)
967  (when html-stream
968    (format html-stream "<tr class='head-row'><td></td>")
969    (format html-stream "<td class='main-head' colspan='5'>Expressions</td>")
970    (format html-stream "<td class='main-head' colspan='1'>Branches</td>")
971    (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>")
972    (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>")
973    (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
974            '("Source file"
975              ;; Expressions
976              "Total" "Entered" "% entered" "Fully covered" "% fully covered"
977              ;; Branches
978              "total unreached"
979              ;; Code forms
980              "Total" "Covered" "% covered"
981              ;; Functions
982              "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
983  (when stats-stream
984    (format stats-stream "~{~a~^,~}"
985            `("Source file"
986              "Expressions Total" "Expressions Entered" "% Expressions Entered"
987              "Unreached Branches"
988              "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
989              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
990              "Functions Partly Covered" "% Functions Partly Covered"
991              "Functions Not Entered" "% Functions Not Entered"))))
992
993(defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name)
994  (when html-stream
995    (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
996    (if report-name
997      (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name)
998      (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage))))
999  (when stats-stream
1000    (format stats-stream "~a," (file-coverage-file coverage)))
1001
1002  (let* ((stats (file-coverage-statistics coverage))
1003         (total (coverage-expressions-total stats))
1004         (entered (coverage-expressions-entered stats))
1005         (covered (coverage-expressions-covered stats))
1006         (exp-counts (list total
1007                           entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
1008                           covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
1009    (when html-stream
1010      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
1011    (when stats-stream
1012      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
1013
1014  (let ((count (coverage-unreached-branches (file-coverage-statistics coverage))))
1015    (when html-stream
1016      (format html-stream "<td>~:[-~;~:*~a~]</td>" count))
1017    (when stats-stream
1018      (format stats-stream "~:[~;~:*~a~]," count)))
1019
1020  (let* ((stats (file-coverage-statistics coverage))
1021         (total (coverage-code-forms-total stats))
1022         (covered (coverage-code-forms-covered stats))
1023         (exp-counts (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
1024    (when html-stream
1025      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
1026    (when stats-stream
1027      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
1028
1029  (let* ((stats (file-coverage-statistics coverage))
1030         (total (coverage-functions-total stats))
1031         (fully (coverage-functions-fully-covered stats))
1032         (partly (coverage-functions-partly-covered stats))
1033         (never (coverage-functions-not-entered stats))
1034         (counts (list fully
1035                       (if (> total 0) (* 100.0 (/ fully total)) '--)
1036                       partly
1037                       (if (> total 0) (* 100.0 (/ partly total)) '--)
1038                       never
1039                       (if (> total 0) (* 100.0 (/ never total)) '--))))
1040    (when html-stream
1041      (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts))
1042    (when stats-stream
1043      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
1044
1045(defun map-coverage-entry-notes (coverage fn)
1046  (map nil #'(lambda (function)
1047                 (let ((note (function-entry-code-note function)))
1048                   (when (and note
1049                              ;; Ignore toplevel functions created by the compiler.
1050                              (or (code-note-source-note note)
1051                                  (code-note-parent-note note)))
1052                     (funcall fn note))))
1053       (file-coverage-functions coverage)))
1054
1055
1056(defun count-covered-entry-notes (coverage)
1057  (let ((fully 0) (partly 0) (never 0) (total 0))
1058    (map-coverage-entry-notes
1059     coverage
1060     #'(lambda (note)
1061         (incf total)
1062         (case (code-note-code-coverage note)
1063           ((full) (incf fully))
1064           ((nil) (incf never))
1065           (t (incf partly)))))
1066    (let ((stats (file-coverage-statistics coverage)))
1067      (setf (coverage-functions-total stats) total)
1068      (setf (coverage-functions-fully-covered stats) fully)
1069      (setf (coverage-functions-partly-covered stats) partly)
1070      (setf (coverage-functions-not-entered stats) never))))
1071
1072(defun count-covered-aexps (coverage)
1073  (let ((covered 0) (total 0))
1074    (map-coverage-entry-notes
1075     coverage
1076     (lambda (note)
1077       (labels ((rec (note)
1078                  (when (emitted-code-note-p note)
1079                    (incf total)
1080                    (when (code-note-code-coverage note)
1081                      (incf covered)))
1082                  (loop for sub in (coverage-subnotes note)
1083                        unless (entry-code-note-p sub) do (rec sub))))
1084         (rec note))))
1085    (let ((stats (file-coverage-statistics coverage)))
1086      (setf (coverage-code-forms-total stats) total)
1087      (setf (coverage-code-forms-covered stats) covered))))
1088
1089(defun count-covered-sexps (coverage)
1090  ;; Count the number of source expressions that have been entered (regardless
1091  ;; of whether or not they are completely covered).
1092  (let ((entered 0) (covered 0) (total 0)
1093        (done (make-hash-table :test #'eq :shared nil)))
1094    (map-coverage-entry-notes
1095     coverage
1096     (lambda (note)
1097       (labels ((rec (note)
1098                  (let ((source-note (code-note-source-note note)))
1099                    (when (and source-note (not (gethash source-note done)))
1100                      (setf (gethash source-note done) t)
1101                      (incf total)
1102                      (let ((data (source-coverage source-note)))
1103                        (when data
1104                          (incf entered)
1105                          (when (eq data 'full)
1106                            (incf covered)))))
1107                    (loop for sub in (coverage-subnotes note)
1108                          unless (entry-code-note-p sub) do (rec sub)))))
1109         (rec note))))
1110    (let ((stats (file-coverage-statistics coverage)))
1111      (setf (coverage-expressions-total stats) total)
1112      (setf (coverage-expressions-entered stats) entered)
1113      (setf (coverage-expressions-covered stats) covered))))
1114
1115(defun count-unreached-branches (coverage)
1116  ;; Count the number of maximal unentered forms
1117  (let ((count 0))
1118    (map-coverage-entry-notes
1119     coverage
1120     (lambda (note)
1121       (labels ((rec (note parent)
1122                  (case (code-note-code-coverage note)
1123                    ((full) nil)
1124                    ((nil) (when parent (incf count)))
1125                    (t (loop for sub in (coverage-subnotes note)
1126                             unless (entry-code-note-p sub) do (rec sub note))))))
1127         (rec note nil))))
1128    (let ((stats (file-coverage-statistics coverage)))
1129      (setf (coverage-unreached-branches stats) count))))
1130
1131(defun write-coverage-styles (html-stream)
1132  (format html-stream "<style type='text/css'>
1133*.st~a { background-color: #ffaaaa }
1134*.st~a { background-color: #aaffaa }
1135*.st~a { background-color: #44dd44 }
1136*.stsource { background-color: #eeeeee; }
1137*.key { margin: 20px; width: 88ex }
1138*.source { width: 120ex; background-color: #eeeeee; padding-left: 5px;
1139             /* border-style: solid none none none; border-width: 1px;
1140             border-color: #dddddd */
1141             white-space: pre; }
1142
1143*.acode { border-left: 1px dashed #c0c0c0;
1144         margin-top: 1ex;
1145         margin-left: 6ex;
1146         margin-bottom: 2ex;
1147         white-space: pre;
1148         display: none; }
1149
1150*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
1151
1152*.toggle { font-size: small; }
1153
1154table.summary tr.head-row { background-color: #aaaaff }
1155table.summary tr td.text-cell { text-align: left }
1156table.summary tr td.main-head { text-align: center }
1157table.summary tr td { text-align: right }
1158table.summary tr.even { background-color: #eeeeff }
1159table.summary tr.subheading { background-color: #aaaaff}
1160table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
1161
1162</style>
1163
1164<script type='text/javascript'>
1165function swap (id) {
1166  var acode = document.getElementById('a' + id);
1167  var prompt = document.getElementById('p' + id);
1168  if (acode.style.display == 'block') {
1169      acode.style.display = 'none';
1170      prompt.innerHTML = 'Show expansion';
1171  } else {
1172    acode.style.display = 'block';
1173    prompt.innerHTML = 'Hide expansion';
1174  }
1175}
1176</script>
1177"
1178          $not-executed-style
1179          $partially-covered-style
1180          $totally-covered-style
1181          ))
1182
Note: See TracBrowser for help on using the repository browser.