source: branches/qres/ccl/library/cover.lisp @ 14058

Last change on this file since 14058 was 14058, checked in by gz, 10 years ago

support for code coverage of acode (r13891, r13929, r13942, r13964, r13965, r13966, r14044)

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