source: release/1.6/source/library/cover.lisp @ 14753

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

Merge another code coverage fix (r14572)

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