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

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

Code coverage support

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