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

Last change on this file since 14493 was 14493, checked in by gz, 9 years ago

Merge code coverage fixes (r14476, r14477) into 1.6

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