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

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

acode coverage reporting: remember to init *code-note-acode-strings*. Be more conscientious about ignoring embedded functions from other files. Finally, acode-queue needs to be per file, duh.

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