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

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

Reorganize coverage reporting to do structured output, identifying all source and code forms, and output almost-raw coverage data separately. Have javascript compute and set the coloring of the forms on the fly.

File size: 67.1 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(eval-when (eval load compile)
22  (export '(*compile-code-coverage*
23            report-coverage
24            reset-coverage
25            clear-coverage
26            save-coverage-in-file
27            restore-coverage-from-file
28           
29            save-coverage  ;; stupid name, here for backward compatibility
30            get-coverage
31            restore-coverage
32            combine-coverage
33            read-coverage-from-file
34            write-coverage-to-file
35           
36            reset-incremental-coverage
37            get-incremental-coverage
38            incremental-coverage-source-matches
39            incremental-coverage-svn-matches
40           
41            coverage-statistics
42            coverage-source-file
43            coverage-expressions-total
44            coverage-expressions-entered
45            coverage-expressions-covered
46            coverage-unreached-branches
47            coverage-code-forms-total
48            coverage-code-forms-covered
49            coverage-functions-total
50            coverage-functions-fully-covered
51            coverage-functions-partly-covered
52            coverage-functions-not-entered
53           
54            without-compiling-code-coverage)))
55
56(defconstant $no-style 0)
57(defconstant $not-executed-style 1)
58(defconstant $totally-covered-style 2)
59(defconstant $partially-covered-style 3)
60
61;; These global values are for use in debugging only.  Exported functions always shadow these with thread-local tables.
62(defparameter *file-coverage* ())
63(defparameter *coverage-tags* nil)
64(defparameter *code-note-tags* nil)
65
66(defparameter *code-note-subnotes* (make-hash-table :test #'eq))
67(defparameter *code-note-function* (make-hash-table :test #'eq))
68(defparameter *entry-note-function* (make-hash-table :test #'eq))
69(defparameter *code-note-index* (make-hash-table :test #'eq))
70(defparameter *emitted-code-notes* (make-array 10 :adjustable t :fill-pointer 0))
71
72(defparameter *source-note-index* (make-hash-table :test #'eq))
73(defparameter *source-code-notes* (make-hash-table :test #'eq))
74(defparameter *covered-source-notes* (make-array 10 :adjustable t :fill-pointer 0))
75
76
77(defmacro with-coverage-decoding ((&key tags (precompute t)) &body body)
78  ;; Set up thread-local environment, and decode tags, since those aren't file-specific
79  `(let* ((*coverage-tags* nil)
80          (*code-note-tags* nil)
81          (*file-coverage* nil)
82          (*code-note-subnotes* (make-hash-table :test #'eq :shared nil))
83          (*code-note-function* (make-hash-table :test #'eq :shared nil))
84          (*entry-note-function* (make-hash-table :test #'eq :shared nil))
85          (*code-note-index* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
86          (*emitted-code-notes* ,(when precompute `(make-array 100 :adjustable t :fill-pointer 0)))
87          (*source-note-index* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
88          (*source-code-notes* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
89          (*covered-source-notes* ,(when precompute `(make-array 100 :adjustable t :fill-pointer 0))))
90     ,@(when tags `((decode-coverage-tags ,tags)))
91     ,@body))
92
93
94(defmacro with-decoded-file-coverage ((coveragevar data &key) &body body)
95  `(progn
96     ;; Wonder if it'd be faster to make new tables instead of clrhash...
97     (clrhash *code-note-subnotes*)
98     (clrhash *code-note-function*)
99     (clrhash *entry-note-function*)
100     (when *code-note-index* (clrhash *code-note-index*))
101     (when *emitted-code-notes* (setf (fill-pointer *emitted-code-notes*) 0))
102     (when *source-note-index* (clrhash *source-note-index*))
103     (when *covered-source-notes* (setf (fill-pointer *covered-source-notes*) 0))
104     (when *source-code-notes* (clrhash *source-code-notes*))
105     (let ((,coveragevar (decode-file-coverage ,data)))
106       (push ,coveragevar *file-coverage*)
107       ,@body)))
108
109
110(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
111  alist)
112
113(defstruct incremental-coverage
114  list)
115
116;; Wrapper in case we ever want to do dwim on raw alists
117(defun coverage-state-alist (coverage)
118  (etypecase coverage
119    (coverage-state (%coverage-state-alist coverage))))
120
121
122(defstruct (ccl:coverage-statistics (:conc-name "COVERAGE-"))
123  source-file
124  expressions-total
125  expressions-entered
126  expressions-covered
127  unreached-branches
128  code-forms-total
129  code-forms-covered
130  functions-total
131  functions-fully-covered
132  functions-partly-covered
133  functions-not-entered)
134
135
136(defun file-coverage-file (entry)
137  (car entry))
138
139(defun file-coverage-functions (entry)
140  (cadr entry))
141
142(defun file-coverage-toplevel-functions (entry)
143  (caddr entry))
144
145(defun file-coverage-statistics (entry)
146  (cdddr entry))
147
148(defun file-coverage-index (entry)
149  (position entry *file-coverage*))
150
151(defun code-note-subnotes (note) ;; reversed parent chain
152  (gethash note *code-note-subnotes*))
153
154(defun emitted-code-note-p (note)
155  (gethash note *code-note-function*))
156
157(defun code-note-function (note)
158  (gethash note *code-note-function*))
159
160(defun entry-code-note-p (note)
161  (gethash note *entry-note-function*))
162
163(defun code-note-index (code-note)
164  (gethash code-note *code-note-index*))
165
166(defun code-note-tags (code-note)
167  (gethash code-note *code-note-tags*))
168
169(defun source-code-notes (source-note)
170  (gethash source-note *source-code-notes*))
171
172(defun source-note-index (source-note)
173  (gethash source-note *source-note-index*))
174
175(defun source-coverage (source)
176  (loop with entered = nil and covered = t
177        for note in  (source-code-notes source)
178        do (case (code-note-code-coverage note)
179             ((nil) (setq covered nil))
180             ((full) (setq entered t))
181             (t (setq entered t covered nil)))
182        finally (return (and entered (if covered 'full t)))))
183
184(defun map-function-coverage (lfun fn &optional refs)
185  (let ((refs (cons lfun refs))
186        (source (function-outermost-entry-source lfun)))
187    (declare (dynamic-extent refs))
188    (lfunloop for imm in lfun
189              when (code-note-p imm)
190              do (funcall fn imm)
191              when (and (functionp imm)
192                        (not (memq imm refs))
193                        ;; Make sure this fn is in the source we're currently looking at.
194                        ;; It might not be, if it is referenced via (load-time-value (foo))
195                        ;; where (foo) returns an lfun from some different source entirely.
196                        ;; CL-PPCRE does that.
197                        (or (null source) (eq source (function-outermost-entry-source imm))))
198              do (map-function-coverage imm fn refs))))
199
200(defun collect-coverage-subfunctions (lfun refs)
201  (let ((refs (cons lfun refs))
202        (source (function-outermost-entry-source lfun)))
203    (declare (dynamic-extent refs))
204    (assert source) ;; all source-less functions have been eliminated.
205    (nconc
206     (and (function-entry-code-note lfun) (list lfun))
207     (lfunloop for imm in lfun
208               when (and (functionp imm)
209                         (not (memq imm refs))
210                         (eq source (function-outermost-entry-source imm)))
211               nconc (collect-coverage-subfunctions imm refs)))))
212
213(defun code-covered-info.file (data) (and (consp data) (car data)))
214(defun code-covered-info.fns (data) (and (consp data) (if (consp (cdr data)) (cadr data) (cdr data))))
215(defun code-covered-info.ef (data) (and (consp data) (consp (cdr data)) (caddr data)))
216(defun code-covered-info.id (data) (and (consp data) (consp (cdr data)) (cadddr data)))
217
218(defun code-covered-info-with-fns (data new-fns)
219  (assert (consp data))
220  (if (consp (cdr data))
221    (let ((new (copy-list data)))
222      (setf (cadr new) new-fns)
223      new)
224    (cons (car data) new-fns)))
225
226
227(defun decode-file-coverage (data &key (precompute t))
228  (let ((file (code-covered-info.file data)))
229    (when file
230      (let* ((file-name (pathname-name file))
231             (file-type (pathname-type file))
232             (toplevel-functions (loop for fn across (code-covered-info.fns data)
233                                       nconc (iterate flatten ((fn fn))
234                                               (let* ((entry (function-entry-code-note fn))
235                                                      (source (and entry (nearest-source-note entry))))
236                                                 (if source
237                                                   (let ((source-file (source-note-filename source)))
238                                                     ;; ignore fns from other files, as could happen through '#.(fun).
239                                                     ;; Unfortunately, can't do this reliably since source-note-filename can involve
240                                                     ;; a logical host not defined in this image, use a heuristic.
241                                                     (when (and (equalp (pathname-name source-file) file-name)
242                                                                (equalp (pathname-type source-file) file-type))
243                                                       (list fn)))
244                                                   ;; A top level function without source must be a compiler-generated toplevel
245                                                   ;; form, ignore it and treat its subfunctions as top level.
246                                                   (lfunloop for imm in fn
247                                                     when (functionp imm) nconc (flatten imm)))))))
248             (all-functions (delete-duplicates
249                             ;; Duplicates are possible if you have multiple instances of
250                             ;; (load-time-value (foo)) where (foo) returns an lfun.
251                             ;; CL-PPCRE does that.
252                             (loop for fn in toplevel-functions
253                                   nconc (collect-coverage-subfunctions fn nil))))
254             (coverage (list* file
255                              all-functions
256                              toplevel-functions
257                              (make-coverage-statistics :source-file file))))
258        ;; record emitted notes
259        (loop for fn in all-functions as entry = (function-entry-code-note fn)
260              do (assert (eq fn (gethash entry *entry-note-function* fn)))
261              do (setf (gethash entry *entry-note-function*) fn)
262              do (lfunloop for imm in fn
263                   when (code-note-p imm)
264                   do (setf (gethash imm *code-note-function*) fn)))
265        ;; Now get the emitted subnotes of any note (including emitted subnotes of unemitted notes)
266        (loop for note being the hash-key of *code-note-function*
267              do (loop for n = note then parent as parent = (code-note-parent-note n)
268                       do (push note (gethash parent *code-note-subnotes*));; parent = nil collects toplevel notes
269                       while (and parent (not (gethash parent *code-note-function*)))))
270        ;; Now get source mapping
271        (when precompute
272          (precompute-source-coverage coverage)
273          ;; bit of overkill, but we end up always wanting them.
274          (compute-file-coverage-statistics coverage))
275        coverage))))
276
277#+debug
278(defun show-notes (note)
279  (when (functionp note)
280    (setq note (function-entry-code-note note)))
281  (labels ((show (note indent label)
282             (dotimes (i indent) (write-char #\space))
283             (format t "~a ~a" label note)
284             (unless (emitted-code-note-p note)
285               (format t " [Not Emitted]"))
286             (when (entry-code-note-p note)
287               (format t " (Entry to ~s)" (entry-code-note-p note)))
288             (when (code-note-acode-range note)
289               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
290                 (format t " [acode ~a:~a]" s e)))
291             (format t "~%")
292             (when (code-note-p note)
293               (loop with subindent = (+ indent 3)
294                     for sub in (code-note-subnotes note) as i upfrom 1
295                     do (show sub subindent (format nil "~a~d." label i))))))
296    (show note 0 "")))
297
298(defun assoc-by-filename (path alist)
299  (let* ((true-path (probe-file path)))
300    (find-if #'(lambda (data)
301                 (or (equalp (car data) path)
302                     (and true-path (equalp (probe-file (car data)) true-path))))
303             alist)))
304
305(defun ccl:clear-coverage ()
306  "Clear all files from the coverage database. The files will be re-entered
307into the database when the FASL files (produced by compiling with
308CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
309image."
310  (setq *code-covered-functions* nil))
311
312(defun reset-function-coverage (lfun)
313  (map-function-coverage lfun #'(lambda (note)
314                                  (setf (code-note-code-coverage note) nil))))
315
316(defun reset-function-incremental-coverage (lfun)
317  (map-function-coverage lfun #'(lambda (note)
318                                  (when (code-note-code-coverage note)
319                                    (setf (code-note-code-coverage note) :prior)))))
320
321(defun ccl:reset-coverage ()
322  "Reset all coverage data back to the `Not executed` state."
323  (loop for data in *code-covered-functions*
324        do (typecase data
325             (cons
326                (loop for fn across (code-covered-info.fns data)
327                      do (reset-function-coverage fn)))
328             (function (reset-function-coverage data)))))
329
330
331(defun ccl:reset-incremental-coverage ()
332  "Mark a starting point for recording incremental coverage.
333   Has no effect on regular coverage recording."
334  (loop for data in *code-covered-functions*
335        do (typecase data
336             (cons
337                (loop for fn across (code-covered-info.fns data)
338                      do (reset-function-incremental-coverage fn)))
339             (function (reset-function-incremental-coverage data)))))
340
341
342;; Name used for consistency checking across file save/restore
343(defun function-covered-name (fn)
344  (let ((name (function-name fn)))
345    (and (symbolp name)
346         (symbol-package name)
347         name)))
348 
349
350(defun coverage-mismatch (why &rest args)
351  ;; Throw to somebody who knows what file we're working on.
352  (throw 'coverage-mismatch (cons why args)))
353
354(defmacro with-coverage-mismatch-catch ((saved-file) &body body)
355  `(let ((file ,saved-file))
356     (with-simple-restart (ignore-file "Ignore ~s and continue" file)
357       (let ((err (catch 'coverage-mismatch 
358                    ,@body
359                    nil)))
360         (when err
361           (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))))
362
363
364;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage).
365(defun save-function-coverage (fn &optional (refs ()))
366  (let ((refs (cons fn refs))
367        (source (function-outermost-entry-source fn)))
368    (declare (dynamic-extent refs))
369    (cons (function-covered-name fn)
370          ;; See comments in map-function-coverage
371          (lfunloop for imm in fn as i upfrom 0
372                    when (and (code-note-p imm)
373                              (code-note-code-coverage imm))
374                    collect i into list
375                    when (and (functionp imm)
376                              (not (memq imm refs))
377                              (or (null source) (eq source (function-outermost-entry-source imm))))
378                    collect (cons i (save-function-coverage imm refs)) into list
379                    finally (return (and list (coerce list 'vector)))))))
380
381(defun copy-function-coverage (fn-data)
382  (cons (car fn-data)
383        (and (cdr fn-data)
384             (map 'vector #'(lambda (imm-data)
385                              (if (consp imm-data)
386                                (cons (car imm-data)
387                                      (copy-function-coverage (cdr imm-data)))
388                                imm-data))
389                  (cdr fn-data)))))
390
391(defun restore-function-coverage (fn saved-fn-data &optional (refs ()))
392  (let* ((refs (cons fn refs))
393         (source (function-outermost-entry-source fn))
394         (saved-name (car saved-fn-data))
395         (saved-imms (cdr saved-fn-data))
396         (nimms (length saved-imms))
397         (n 0))
398    (declare (dynamic-extent refs))
399    (unless (equalp saved-name (function-covered-name fn))
400      (coverage-mismatch "had function ~s now have ~s" saved-name fn))
401    ;; See comments in map-function-coverage
402    (lfunloop for imm in fn as i upfrom 0
403              when (code-note-p imm)
404              do (let* ((next (and (< n nimms) (aref saved-imms n))))
405                   (when (if (consp next) (<= (car next) i) (and next (< next i)))
406                     (coverage-mismatch "in ~s" fn))
407                   (when (setf (code-note-code-coverage imm)
408                               (and (eql next i) 'restored))
409                     (incf n)))
410              when (and (functionp imm)
411                        (not (memq imm refs))
412                        (or (null source) (eq source (function-outermost-entry-source imm))))
413              do (let* ((next (and (< n nimms) (aref saved-imms n))))
414                   (unless (and (consp next) (eql (car next) i))
415                     (coverage-mismatch "in ~s" fn))
416                   (restore-function-coverage imm (cdr next) refs)
417                   (incf n)))))
418
419
420(defun add-function-coverage (fn-data new-fn-data)
421  (let* ((fn-name (car fn-data))
422         (imms (cdr fn-data))
423         (new-fn-name (car new-fn-data))
424         (new-imms (cdr new-fn-data)))
425    (flet ((kar (x) (if (consp x) (%car x) x)))
426      (declare (inline kar))
427      (unless (equalp fn-name new-fn-name)
428        (coverage-mismatch "function ~s vs. ~s" fn-name new-fn-name))
429      (when new-imms
430        (loop for new across new-imms
431              as old = (find (kar new) imms :key #'kar)
432              if (and (null old) (fixnump new))
433                collect new into extras
434              else do (unless (eql old new)
435                        (if (and (consp new) (consp old))
436                          (add-function-coverage (cdr old) (cdr new))
437                          (coverage-mismatch "in function ~s" fn-name)))
438              finally (when extras
439                        (setf (cdr fn-data)
440                              (sort (concatenate 'vector imms extras) #'< :key #'kar))))))
441    fn-data))
442
443
444(defun ccl:get-coverage ()
445  "Returns a snapshot of the current coverage state"
446  (make-coverage-state
447   :alist (loop for data in *code-covered-functions*
448                when (consp data)
449                  collect (code-covered-info-with-fns
450                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
451
452;; Backward compatibility with sbcl name.
453(setf (symbol-function 'ccl:save-coverage) #'ccl:get-coverage)
454
455(defun ccl:combine-coverage (coverage-states)
456  (let ((result nil))
457    (map nil
458         (lambda (coverage-state)
459           (loop for saved-data in (coverage-state-alist coverage-state)
460                 as saved-file = (code-covered-info.file saved-data)
461                 as saved-fns = (code-covered-info.fns saved-data)
462                 as result-data = (assoc-by-filename saved-file result)
463                 as result-fns = (code-covered-info.fns result-data)
464                 do (with-coverage-mismatch-catch (saved-file)
465                      (cond ((null result-fns)
466                             (push (code-covered-info-with-fns
467                                    saved-data (map 'vector #'copy-function-coverage saved-fns))
468                                   result))
469                            ((not (eql (length result-fns) (length saved-fns)))
470                             (coverage-mismatch "different function counts"))
471                            (t
472                             (unless (equal (code-covered-info.id saved-data)
473                                            (code-covered-info.id result-data))
474                               (cerror "Ignore the mismatch"
475                                       "Combining different versions of file ~s (checksum mismatch)"
476                                       saved-file))
477                             (loop for result-fn across result-fns
478                                   for saved-fn across saved-fns
479                                   do (add-function-coverage result-fn saved-fn)))))))
480         coverage-states)
481    (make-coverage-state :alist (nreverse result))))
482
483
484(defun ccl:restore-coverage (coverage-state)
485  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
486  (loop for saved-data in (coverage-state-alist coverage-state)
487        for saved-file = (code-covered-info.file saved-data)
488        as saved-fns = (code-covered-info.fns saved-data)
489        for current-data = (assoc-by-filename saved-file *code-covered-functions*)
490        as fns = (and current-data (code-covered-info.fns current-data))
491        do (with-coverage-mismatch-catch (saved-file)
492             (cond ((null fns)
493                    (warn "Couldn't restore saved coverage for ~s, no matching file present"
494                          saved-file))
495                   ((not (eql (length fns) (length saved-fns)))
496                    (coverage-mismatch "had ~s functions, now have ~s"
497                                       (length saved-fns) (length fns)))
498                   (t 
499                    (unless (equal (code-covered-info.id saved-data)
500                                   (code-covered-info.id current-data))
501                      (cerror "Ignore the mismatch"
502                              "Restoring different version of file ~s (checksum mismatch)"
503                              saved-file))
504                    (map nil #'restore-function-coverage fns saved-fns))))))
505
506(defun ccl:get-incremental-coverage (&key (reset t))
507  "Return the delta coverage since the last reset of incremental coverage.
508  If RESET is true (the default), it also resets incremental coverage now."
509  ;; An incremental coverage snapshot is just a list of covered (i.e. entered) code notes.
510  ;; It is not savable in a file.
511  (let ((covered nil))
512    (flet ((get-fn (note)
513             (let ((coverage (code-note-code-coverage note)))
514               (when (and coverage (not (eq coverage :prior)))
515                 (when reset (setf (code-note-code-coverage note) :prior))
516                 (push note covered)))))
517      (loop for data in *code-covered-functions*
518            when (consp data)
519              do (loop for fn across (code-covered-info.fns data)
520                       do (map-function-coverage fn #'get-fn)))
521      (make-incremental-coverage :list covered))))
522
523(defun decode-coverage-tags (tags)
524  (when tags
525    (let ((note->tags (make-hash-table :test #'eq :shared nil)))
526      (flet ((register (i delta)
527               (loop for note in (incremental-coverage-list delta) do (push i (gethash note note->tags)))))
528        (etypecase tags
529          (hash-table
530           (let* ((count (hash-table-count tags))
531                  (tags-vector (make-array count)))
532             (enumerate-hash-keys-and-values tags tags-vector nil)
533             (loop for i from 0 below count
534                   do (register i (gethash (aref tags-vector i) tags)))
535             (setq *coverage-tags* tags-vector)))
536        (list
537         (loop for i upfrom 0 as delta in tags do (register i delta)
538               finally (setq *coverage-tags* i)))
539        (vector
540         (loop for i from 0 below (length tags) do (register i (aref tags i))
541               finally (setq *coverage-tags* i)))))
542      (setq *code-note-tags* note->tags))))
543
544
545(defun ccl:incremental-coverage-svn-matches (collection &key (directory (current-directory)) (revision :base))
546  "Given a hash table COLLECTION whose values are incremental coverage deltas, return a list
547  of all keys corresponding to those deltas that intersect any region in a file in DIRECTORY that
548  has changed since revision REVISION in subversion."
549  (incremental-coverage-source-matches collection (get-svn-changes :directory directory
550                                                                   :revision revision
551                                                                   :reverse t)))
552
553(defun ccl:incremental-coverage-source-matches (collection sources)
554  "Given a hash table COLLECTION whose values are incremental coverage delta, return a list
555  of all keys corresponding to deltas that intersect any region in SOURCES.  SOURCES
556  should be a list of source notes and/or pathnames"
557  (let ((alist ()))
558    (loop for source in sources
559          as file = (source-note-filename source)
560          ;; Typically source notes will have eq filenames since created all at once, so the
561          ;; assq will find it after the first time.
562          as cell = (or (assq file alist)
563                        (assoc-by-filename file alist)
564                        (let* ((data (or (assoc-by-filename file *code-covered-functions*)
565                                         (error "There is no coverage info for ~s" file)))
566                               (cell (list* file data nil)))
567                          (push cell alist)
568                          cell))
569          do (push source (cddr cell)))
570    (with-coverage-decoding (:precompute nil)
571      (loop for (nil data . sources) in alist
572            do (with-decoded-file-coverage (coverage data)
573                 (loop for sn in sources
574                       as matches = (code-notes-for-region coverage (source-note-start-pos sn) (source-note-end-pos sn))
575                       nconc (flet ((matches (delta)
576                                      (loop for note in (incremental-coverage-list delta) thereis (memq note matches))))
577                               (typecase collection
578                                 (hash-table (loop for key being the hash-key of collection using (hash-value delta)
579                                                   when (matches delta) collect key))
580                                 (sequence (coerce (remove-if-not #'matches collection) 'list))))))))))
581
582
583
584
585(defun nearest-source-note (note)
586  (loop for n = note then (code-note-parent-note n)
587        thereis (and n (code-note-source-note n))))
588
589(defun code-note-emitted-parent (note)
590  (loop while (setq note (code-note-parent-note note))
591        when (emitted-code-note-p note) return note))
592
593;; Given a region of a file, find a set of code notes that completely covers it, i.e.
594;; a set such that if none of the code notes in the set have been executed, then it's guaranteed
595;; that modifying the region is not going to affect execution.  Try to make that set as small
596;; as possible.
597(defun code-notes-for-region (coverage start-pos end-pos)
598  (let* ((notes (loop for fn in (file-coverage-toplevel-functions coverage)
599                      as note = (function-entry-code-note fn) as source = (nearest-source-note note)
600                      when (and (or (null end-pos) (< (source-note-start-pos source) end-pos))
601                                (or (null start-pos) (< start-pos (source-note-end-pos source))))
602                        ;; This function intersects the region.  Find the smallest subnote that contains all
603                        ;; of this function's part of the region.
604                        collect (let ((start (max start-pos (source-note-start-pos source)))
605                                      (end (min end-pos (source-note-end-pos source))))
606                                  (iterate tighten ((note note))
607                                    (loop for subnote in (code-note-subnotes note)
608                                          as subsource = (nearest-source-note subnote)
609                                          do (when (and (<= (source-note-start-pos subsource) start)
610                                                        (<= end (source-note-end-pos subsource)))
611                                               (return (tighten subnote)))
612                                          finally (return note))))))
613         (emitted-notes (iterate splat ((notes notes))
614                          (loop for note in notes
615                                nconc (if (emitted-code-note-p note)
616                                        (list note)
617                                        (splat (code-note-subnotes note)))))))
618    emitted-notes))
619
620
621;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
622
623(defvar *loading-coverage*)
624
625(defun ccl:write-coverage-to-file (coverage pathname)
626  "Write the coverage state COVERAGE in the file designated by PATHNAME"
627  (with-open-file (stream pathname
628                          :direction :output
629                          :if-exists :supersede
630                          :if-does-not-exist :create)
631    (with-standard-io-syntax
632      (let ((*package* (pkg-arg "CCL")))
633        (format stream "(in-package :ccl)~%~s~%"
634                `(setq *loading-coverage* ',(coverage-state-alist coverage)))))
635    (values)))
636 
637(defun ccl:read-coverage-from-file (pathname)
638  " Return the coverage state saved in the file.  Doesn't affect the current coverage state."
639  (let ((*package* (pkg-arg "CCL"))
640        (*loading-coverage* :none))
641    (load pathname)
642    (when (eq *loading-coverage* :none)
643      (error "~s doesn't seem to be a saved coverage file" pathname))
644    (make-coverage-state :alist *loading-coverage*)))
645
646(defun ccl:save-coverage-in-file (pathname)
647  "Save the current coverage state in the file designed by PATHNAME"
648  (write-coverage-to-file (save-coverage) pathname))
649
650(defun ccl:restore-coverage-from-file (pathname)
651  "Set the current coverage state from the file designed by PATHNAME"
652  (restore-coverage (read-coverage-from-file pathname)))
653
654(defun common-coverage-directory ()
655  (let* ((host :unknown)
656         (rev-dir ()))
657    (loop for data in *code-covered-functions*
658          when (consp data)
659            do (let ((file (probe-file (code-covered-info.file data))))
660                 (when file
661                   (cond ((eq host :unknown)
662                          (setq host (pathname-host file)
663                                rev-dir (reverse (pathname-directory file))))
664                         ((not (equalp host (pathname-host file)))
665                          (return-from common-coverage-directory nil))
666                         (t
667                          (let* ((path (pathname-directory file))
668                                 (dir-len (length rev-dir))
669                                 (len (length path)))
670                            (if (< len dir-len)
671                              (setq rev-dir (nthcdr (- dir-len len) rev-dir))
672                              (setq path (subseq path 0 dir-len)))
673                            (loop for pp on (reverse path) until (equalp pp rev-dir)
674                                  do (pop rev-dir))))))))
675    (unless (eq host :unknown)
676      (make-pathname :host host :directory (reverse rev-dir)))))
677
678
679(defun ccl:coverage-statistics ()
680  (with-coverage-decoding ()
681    (loop for data in *code-covered-functions*
682          do (with-decoded-file-coverage (coverage data)
683               (file-coverage-statistics coverage)))))
684
685(defun compute-file-coverage-statistics (coverage)
686  (count-unreached-branches coverage)
687  (count-covered-aexps coverage)
688  (count-covered-sexps coverage))
689
690(defun native-file-namestring (file)
691  (native-translated-namestring (make-pathname :name (pathname-name file)
692                                               :type (pathname-type file))))
693
694
695(defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t) (tags nil))
696  "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE
697and, in the same directory, one html file for each instrumented source file that has been
698loaded in the current session.
699The external format of the source files can be specified with the EXTERNAL-FORMAT parameter.
700If :STATISTICS is non-nil, a CSV file is generated with a table.  If
701:STATISTICS is a filename, that file is used, else 'statistics.csv' is
702written to the output directory.
703If :TAGS is non-nil, it must be a hash table whose values are incremental coverage snapshots. This
704causes the HTML report to include incremental coverage information"
705  ;; TODO: *** How to present incremental coverage info in statistics file?
706  (let* ((paths)
707         (directory (make-pathname :name nil :type nil :defaults output-file))
708         (coverage-dir (common-coverage-directory))
709         (index-file (and html (merge-pathnames output-file "index.html")))
710         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
711                                                              (pathnamep statistics))
712                                                          (merge-pathnames statistics "statistics.csv")
713                                                          "statistics.csv")
714                                                      output-file))))
715    (ensure-directories-exist directory)
716    (with-coverage-decoding (:tags tags)
717      (loop for data in *code-covered-functions* as file = (code-covered-info.file data)
718            as truename =  (and file (or (probe-file file)
719                                         (progn (warn "Cannot find ~s, won't report coverage" file)
720                                                nil)))
721            do (when truename
722                 (let* ((src-name (enough-namestring truename coverage-dir))
723                        (html-name (substitute
724                                    #\_ #\: (substitute
725                                             #\_ #\. (substitute
726                                                      #\_ #\/ (namestring-unquote src-name))))))
727                   (with-decoded-file-coverage (coverage data)
728                     (when html
729                       (let* ((checksum (fcomp-file-checksum file :external-format (code-covered-info.ef data))))
730                         (unless (eql checksum (code-covered-info.id data))
731                           (cerror "Try coloring anyway"
732                                   "File ~s has changed since coverage source location info was recorded."
733                                   file)))
734                       (report-file-coverage index-file coverage directory html-name external-format))
735                     (push (list* src-name html-name coverage) paths)))))
736      (when (null paths)
737        (error "No code coverage data available"))
738      (setq paths (sort paths #'(lambda (path1 path2)
739                                  (let* ((f1 (car path1))
740                                         (f2 (car path2)))
741                                    (or (string< (directory-namestring f1)
742                                                 (directory-namestring f2))
743                                        (and (equal (pathname-directory f1)
744                                                    (pathname-directory f2))
745                                             (string< (file-namestring f1)
746                                                      (file-namestring f2))))))))
747      (if html
748        (with-open-file (html-stream index-file
749                                     :direction :output
750                                     :if-exists :supersede
751                                     :if-does-not-exist :create)
752          (if stats-file
753            (with-open-file (stats-stream stats-file
754                                          :direction :output
755                                          :if-exists :supersede
756                                          :if-does-not-exist :create)
757              (report-coverage-to-streams paths html-stream stats-stream))
758            (report-coverage-to-streams paths html-stream nil)))
759        (if stats-file
760          (with-open-file (stats-stream stats-file
761                                        :direction :output
762                                        :if-exists :supersede
763                                        :if-does-not-exist :create)
764            (report-coverage-to-streams paths nil stats-stream))
765          (error "One of :HTML or :STATISTICS must be non-nil"))))
766    (values index-file stats-file)))
767
768
769(defun report-coverage-to-streams (paths html-stream stats-stream)
770  (when html-stream
771    (format html-stream "<html><head>~%")
772    (write-coverage-styles html-stream)
773    (format html-stream "~%</head>~%<body>"))
774  (unless paths
775    (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
776    (when html-stream (format html-stream "<h3>No code coverage data found.</h3>~%"))
777    (when stats-stream (format stats-stream "No code coverage data found.~%"))
778    (return-from report-coverage-to-streams))
779  (when html-stream (format html-stream "<table class='summary'>"))
780  (coverage-stats-head html-stream stats-stream t)
781  (loop for prev = nil then src-name
782        for (src-name report-name . coverage) in paths
783        for even = nil then (not even)
784        do (when (or (null prev)
785                     (not (equal (pathname-directory (pathname src-name))
786                                 (pathname-directory (pathname prev)))))
787             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
788               (when html-stream (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir))
789               (when stats-stream (format stats-stream "~a~%" dir))))
790        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
791  (when html-stream (format html-stream "</table></body></html>")))
792
793(defun style-for-coverage (coverage)
794  (case coverage
795    ((full) $totally-covered-style)
796    ((nil) $not-executed-style)
797    (t $partially-covered-style)))
798 
799(defun precompute-source-coverage (coverage)
800  ;; linearize emitted notes with children preceding parents, and mark up fully covered ones.
801  ;; This assumes code notes are never individually reset, so once something is fully
802  ;; covered, it stays fully covered, so no need to reinit the setting, just update.
803  (let ((subnotes *code-note-subnotes*)
804        (vector *emitted-code-notes*)
805        (index-hash *code-note-index*))
806    (iterate descend ((note nil))
807      (let ((full-p (and note (code-note-code-coverage note))))
808        (loop for subnote in (gethash note subnotes)
809              do (unless (descend subnote) (setq full-p nil))
810              do (setf (gethash subnote index-hash) (vector-push-extend subnote vector)))
811        (when full-p         ;; return true if full, nil if not.
812          (setf (code-note-code-coverage note) 'full)))))
813  ;; Find all source notes
814  ;; Note that can't compute a source hierarchy because the reader flattens the backpointers
815  ;; so each subnote points directly to the toplevel note.
816  (labels ((subnotep (a b)
817             (or (eq a b) (and a (subnotep (code-note-parent-note a) b))))
818           (register (source emitted-notes)
819             (assert emitted-notes)
820             (let ((prior-notes (gethash source *source-code-notes*)))
821               (if prior-notes
822                 ;; In some cases, a single source form may be claimed by multiple code notes,
823                 (setq emitted-notes
824                       (nconc
825                        (setq emitted-notes
826                              (remove-if (lambda (new)
827                                           (some (lambda (old) (subnotep new old)) prior-notes))
828                                         emitted-notes))
829                        (if emitted-notes
830                          (remove-if (lambda (old)
831                                       (some (lambda (new) (subnotep old new)) emitted-notes))
832                                     prior-notes)
833                          prior-notes)))
834                 ;; Else this is the first time, record it
835                 (vector-push-extend source *covered-source-notes*)))
836             (setf (gethash source *source-code-notes*) emitted-notes)))
837    (loop for note across *emitted-code-notes*
838          as source = (code-note-source-note note)
839          when source do (register source (list note))
840            ;; want to look at all notes, even unemitted, so can get all source forms
841            do (loop while (and (setq note (code-note-parent-note note))
842                                (not (emitted-code-note-p note)))
843                     when (setq source (code-note-source-note note))
844                       do (register source (code-note-subnotes note))))
845    (setf *covered-source-notes*
846          (sort *covered-source-notes* #'< :key #'source-note-start-pos)) ;; this puts parents before children
847    (loop for source across *covered-source-notes* as index upfrom 0
848          do (setf (gethash source *source-note-index*) index)))
849  (assert (eql (length *covered-source-notes*) (hash-table-count *source-code-notes*)))
850  coverage)
851
852(defun file-coverage-html-queue (coverage)
853  (declare (ignore coverage)) ;; turns out everything we need is already in global variables
854  ;; Collect top-level sources.  *covered-source-notes* is sorted by start address.
855  (let ((queue (loop with vector = *covered-source-notes* with len = (length vector)
856                     for start = 0 then end while (< start len)
857                     as sn = (aref vector start)
858                     as end = (loop with limit = (source-note-end-pos sn)
859                                    for i from (1+ start) below len
860                                    until (<= limit (source-note-start-pos (aref vector i)))
861                                    finally (return i))
862                     collect (list* end nil (source-note-end-pos sn)))));; (end-index acodes . end-pos)
863    ;; Find all acode strings, assign them to appropriate toplevel source form, and collect
864    ;; all code notes for each acode.
865    (loop for note across *emitted-code-notes*
866          when (code-note-acode-range note)
867            do (let* ((source (nearest-source-note note))
868                      (pos (source-note-start-pos source))
869                      (cell (loop for cell in queue while (<= (cddr cell) pos) finally (return cell)))
870                      (acode (%function-acode-string (code-note-function note)))
871                      (acell (or (assq acode (cadr cell))
872                                 (car (push (list* acode nil 0) (cadr cell))))));; (acode notes . src-pos)
873                 (assert (and cell acode))
874                 (setf (cddr acell) (min (cddr acell) pos));; earliest known source for this acode
875                 (push note (cadr acell))))
876    ;; Sort acode by source position within source form, sort notes by position within the acode,
877    ;; get rid of the end-pos/src-pos fields since no longer needed.
878    (loop for cell in queue
879          do (setf (cdr cell) (sort (cadr cell) #'< :key #'cddr));; (end-index . acodes)
880          do (loop for acell in (cdr cell)
881                   do (setf (cdr acell) (sort (cadr acell) #'< :key #'code-note-acode-start-pos)))) ; (acode . notes)
882    queue))
883
884
885(defun function-outermost-entry-source (fn)
886  ;; Find the outermost source form containing the fn.
887  (loop with sn = nil
888        for n = (function-entry-code-note fn) then (code-note-parent-note n)
889        do (when (null n) (return nil))
890        do (when (setq sn (code-note-source-note n))
891             (loop for s = (source-note-source sn) while (source-note-p s)
892                   do (setq sn s))
893             (return sn))))
894
895
896(defun report-file-coverage (index-file coverage directory html-name external-format)
897  (with-open-file (js-stream (make-pathname :name html-name :type "js" :defaults directory)
898                             :direction :output
899                             :if-exists :supersede
900                             :if-does-not-exist :create)
901    (write-coverage-js-file js-stream coverage))
902  (with-open-file (html-stream (make-pathname :name html-name :type "html" :defaults directory)
903                               :direction :output
904                               :if-exists :supersede
905                               :if-does-not-exist :create)
906    (write-coverage-html-file index-file html-name html-stream coverage external-format)))
907
908(defun write-coverage-html-file (index-file html-name html-stream coverage source-external-format)
909  (let ((*print-case* :downcase))
910
911    (format html-stream "<html><head>")
912    (write-coverage-styles html-stream)
913    (format html-stream "<script src='~a.js'></script>~%" html-name)
914    (format html-stream "</head><body onload='colorize(true)'>")
915
916    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
917            (native-file-namestring index-file)
918            (file-coverage-file coverage))
919    (format html-stream "<table class='summary'>")
920    (file-coverage-stats-html html-stream)
921    (format html-stream "</table>")
922
923    ;;(format html-stream "~2%<a href='javascript:DEBUG_OUT(CodeParents)'>Doit</a><div id='foo'>Debug output here</div>")
924
925    (format html-stream "<div class='key'><b>Key</b><br />~%")
926    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
927    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
928    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
929    (format html-stream "<div class='stsource'>Uninstrumented - a form whose coverage was not measured</div>")
930    (format html-stream "</div><p></p>~%")
931
932    (output-spanned-html html-stream coverage source-external-format)
933
934    (format html-stream "</body></html>")))
935
936#|
937var COV = ['unknown', 'not', 'all', 'some'];
938function DEBUG_OUT(text) {
939  var msg = document.getElementById('foo');
940  msg.innerHTML = msg.innerHTML + '<br />' + text;
941}
942|#
943
944;; This goes in each file.
945(defparameter $coverage-javascript "
946
947function tags_intersect (tags1, tags2) {   // tags2 = true means all tags.
948  if (tags2 === true)
949    return (tags1.length > 0);
950  for (var i = 0; i < tags1.length; i++) {
951    var tag1 = tags1[i];
952    for (var j = 0; j < tags2.length; j++)
953      if (tag1 == tags2[j]) return true;
954  }
955  return false;
956}
957
958function is_member (elt, vec) {
959  for (var i = 0; i < vec.length; i++) {
960    if (vec[i] == elt) return true;
961  }
962  return false;
963}
964
965function set_stats_with_pct(name, count, total) {
966  var pct;
967
968  if (total > 0) {
969    var pct = (count * 100) / total;
970    pct = pct.toFixed(1) + '&#37;';
971  }
972  else {
973    pct = '--';
974  }
975 
976  document.getElementById(name).innerHTML = count;
977
978  document.getElementById(name + 'Pct').innerHTML =  pct;
979}
980
981function colorize (tags_to_show) {
982  var style;
983
984  // Compute acode coverage and colorize acode
985  var total = (CodeTags ? CodeTags.length : CodeCoverage.length) - 1;
986  var num_entered = 0;
987  var coverage = new Array(total);
988
989  for (var cn = 0; cn < total; cn++) {
990    var covered = (CodeTags ? tags_intersect(CodeTags[cn], tags_to_show) : CodeCoverage[cn]);
991    style = (covered ? ALL_COVERED : NOT_COVERED);
992
993    var sub_style = coverage[cn];
994    if (sub_style && (style != sub_style)) style = PARTLY_COVERED;
995
996    coverage[cn] = style; // save for source coloring use below
997    if (style != NOT_COVERED) num_entered++;
998    var parent = CodeParents[cn];
999    if (parent) {
1000      var sibs_style = coverage[parent];
1001      if (sibs_style != style) coverage[parent] = (!sibs_style ? style : PARTLY_COVERED);
1002    }
1003
1004  var elt = document.getElementById('f~dc' + cn);  // some notes don't have a matched up source.
1005  if (elt) elt.className = 'st' + style;
1006  }
1007
1008
1009  document.getElementById('acodeTotal').innerHTML = total;
1010  set_stats_with_pct('acodeCovered', num_entered, total);
1011
1012  // Count unreached branches (aka maximal unentered forms)
1013  var total = coverage.length;
1014  var num_branches = 0;
1015  var parent;
1016  for (var cn = 0; cn < total; cn++) {
1017    if ((coverage[cn] == NOT_COVERED) && // not covered
1018        (parent = CodeParents[cn]) &&  // has a parent
1019        (coverage[parent] != NOT_COVERED) &&  // that's covered
1020        (!is_member(cn, FunctionNotes))) // and not an entry note
1021      num_branches++;
1022  }
1023
1024  document.getElementById('branchUnreached').innerHTML = num_branches;
1025
1026
1027  // Colorize Source
1028  var total = (SourceCodeNotes ? SourceCodeNotes.length : SourceCoverage.length) - 1;
1029  var num_all = 0, num_partly = 0;
1030
1031  for (var sn = 0; sn < total; sn++) {
1032    if (SourceCodeNotes) {
1033      var notes = SourceCoverage[sn];
1034      for (var i = 0, style = NO_DATA; i < notes.length; i++) {
1035        var note_style = coverage[notes[i]];
1036        if (style != note_style) style = (style == NO_DATA ? note_style : PARTLY_COVERED);
1037      }
1038    }
1039    else {
1040      style = SourceCoverage[sn];
1041    }
1042
1043    switch (style) {
1044      case ALL_COVERED: num_all++; break;
1045      case PARTLY_COVERED: num_partly++; break;
1046    }
1047
1048   document.getElementById('f~:*~ds' + sn).className = 'st' + style;
1049
1050  }
1051  document.getElementById('srcTotal').innerHTML = total;
1052  set_stats_with_pct('srcEntered', num_all + num_partly, total);
1053  set_stats_with_pct('srcCovered', num_all, total);
1054
1055  var total = FunctionNotes.length - 1;
1056  var num_all = 0, num_partly = 0, num_not = 0;
1057
1058  for (var i = 0; i < total; i++) {
1059    var cn = FunctionNotes[i];
1060    switch (coverage[FunctionNotes[i]]) {
1061      case ALL_COVERED: num_all++; break;
1062      case PARTLY_COVERED: num_partly++; break;
1063      case NOT_COVERED: num_not++; break;
1064    }
1065  }
1066
1067  document.getElementById('fnTotal').innerHTML = total;
1068  set_stats_with_pct('fnCovered', num_all, total);
1069  set_stats_with_pct('fnPartly', num_partly, total);
1070  set_stats_with_pct('fnUnentered', num_not, total);
1071
1072
1073}
1074")
1075
1076
1077(defmacro write-js-array (js-stream-expr var-expr data-expr writer)
1078  (let ((js-stream (gensym))
1079        (var (gensym))
1080        (data (gensym)))
1081    `(let ((,js-stream ,js-stream-expr)
1082           (,var ,var-expr)
1083           (,data ,data-expr))
1084       (when ,var (format ,js-stream "~2&var ~a = " ,var))
1085       (format ,js-stream "[")
1086       (loop with len = (and (vectorp ,data) (length ,data))
1087             for index upfrom 0
1088             while (if len (< index len) ,data)
1089             as note = (if len (aref ,data index) (pop ,data))
1090             do (funcall ,writer ,js-stream note)
1091             do (write-string (if (eql 0 (mod index 50)) #.(format nil ",~% ") ", ") ,js-stream))
1092       ;; Add an element at the end because otherwise get the wrong length if last element is empty
1093       (format ,js-stream "'end']")
1094       (when ,var (format ,js-stream ";~%")))))
1095
1096;; output with a line break every 100 entries
1097(defun write-coverage-js-file (js-stream coverage)
1098  (flet ((write-code-parent (js-stream cn)
1099           (let* ((parent (code-note-emitted-parent cn)))
1100             (when parent
1101               (format js-stream "~a" (code-note-index parent)))))
1102         (write-function-note (js-stream fn)
1103           (format js-stream "~a" (code-note-index (function-entry-code-note fn))))
1104         (write-source-coverage (js-stream sn)
1105           (format js-stream "~a" (style-for-coverage (source-coverage sn))))
1106         (write-code-coverage (js-stream cn)
1107           (when (code-note-code-coverage cn) (format js-stream "1")))
1108         (write-source-notes (js-stream sn)
1109           (write-js-array js-stream nil (source-code-notes sn)
1110                           (lambda (js-stream cn) (format js-stream "~a" (code-note-index cn)))))
1111         (write-code-tags (js-stream cn)
1112           (write-js-array js-stream nil (code-note-tags cn)
1113                           (lambda (js-stream tag) (format js-stream "~a" tag)))))
1114
1115    (format js-stream "~&var NO_DATA = ~d, NOT_COVERED = ~d, ALL_COVERED = ~d, PARTLY_COVERED = ~d;~2%"
1116            $not-executed-style $not-executed-style $totally-covered-style $partially-covered-style)
1117    (write-js-array js-stream "CodeParents" *emitted-code-notes* #'write-code-parent)
1118    (write-js-array js-stream "FunctionNotes" (file-coverage-functions coverage) #'write-function-note)
1119    (cond (*coverage-tags*
1120           (write-js-array js-stream "CodeTags" *emitted-code-notes* #'write-code-tags)
1121           (write-js-array js-stream "SourceCodeNotes" *covered-source-notes* #'write-source-notes)
1122           (format js-stream "~&var CodeCoverage;")
1123           (format js-stream "~&var SourceCoverage;"))
1124          (t
1125           (format js-stream "~&var CodeTags;")
1126           (format js-stream "~&var SourceCodeNotes;")
1127           (write-js-array js-stream "CodeCoverage" *emitted-code-notes* #'write-code-coverage)
1128           (write-js-array js-stream "SourceCoverage" *covered-source-notes* #'write-source-coverage)))
1129    (format js-stream $coverage-javascript (file-coverage-index coverage))
1130    (terpri js-stream)))
1131
1132(defstruct coverage-html-state
1133  input
1134  output
1135  prefix
1136  (file-pos 0)
1137  (line-no 0)
1138  (column 0))
1139
1140(defun coverage-html-start-line (s)
1141  (let ((line-no (coverage-html-state-line-no s))
1142        (output (coverage-html-state-output s)))
1143    (when line-no
1144      (setf (coverage-html-state-line-no s) (incf line-no))
1145      (format output "<span class='line'>~a</span>" line-no))
1146    (write-char #\space output)))
1147
1148(defun coverage-html-copy-to (s end &optional end-at-newline-p whitespace-only-p)
1149  (let ((input (coverage-html-state-input s))
1150        (output (coverage-html-state-output s))
1151        (file-pos (coverage-html-state-file-pos s)))
1152    (assert (<= file-pos end))
1153    (loop until (eql file-pos end)
1154          as ch = (read-char input)
1155          do (when (and whitespace-only-p (not (whitespacep ch)))
1156               (unread-char ch input)
1157               (return))
1158             ;; Source note positions are file positions, not character positions, but assume
1159             ;; non-control ascii chars are 1 byte so don't have to call stream-position all the time.
1160          do (setq file-pos (if (< 31 (char-code ch) 127)
1161                              (1+ file-pos)
1162                              (let ((newpos (stream-position input)))
1163                                (assert (<= newpos end))
1164                                newpos)))
1165          do (when (eql (coverage-html-state-column s) 0) (coverage-html-start-line s))
1166          do (case ch
1167               (#\newline
1168                  (write-char #\Newline output)
1169                  (setf (coverage-html-state-column s) 0)
1170                  (when end-at-newline-p (return)))
1171               (#\tab
1172                  (let ((count (- 8 (mod (coverage-html-state-column s) 8))))
1173                    (write-string "        " output :end count)
1174                    (incf (coverage-html-state-column s) count)))
1175               (t
1176                  (incf (coverage-html-state-column s))
1177                  (if (or (alphanumericp ch)  (find ch "()+-:* "));; common and safe
1178                    (write-char ch output)
1179                    (format output "&#~D;" (char-code ch))))))
1180    (assert (eql file-pos (stream-position input)))
1181    (setf (coverage-html-state-file-pos s) file-pos)))
1182
1183(defun output-coverage-html-acode (s note-queue)
1184  (let* ((output (coverage-html-state-output s))
1185         (input (coverage-html-state-input s))
1186         (prefix (coverage-html-state-prefix s))
1187         (end (stream-length input)))
1188    (when (< (coverage-html-state-file-pos s) end)
1189      (iterate output-subnotes ((limit end))
1190        (loop while (and note-queue (<= (code-note-acode-end-pos (car note-queue)) limit))
1191              do (let ((note (pop note-queue)))
1192                   (coverage-html-copy-to s (code-note-acode-start-pos note))
1193                   ;; skip leading whitespace -- this is necessary for acode, else looks weird.
1194                   (coverage-html-copy-to s (code-note-acode-end-pos note) nil t)
1195                   (format output "<span id='~a~d'>" prefix (code-note-index note))
1196                   (output-subnotes (code-note-acode-end-pos note))
1197                   (format output "</span>")))
1198        (coverage-html-copy-to s limit)))))
1199
1200(defun output-coverage-html-source (s start end)
1201  (let* ((output (coverage-html-state-output s))
1202         (input (coverage-html-state-input s))
1203         (prefix (coverage-html-state-prefix s))
1204         (vector *covered-source-notes*)
1205         (len (length vector))
1206         (outer-note (and (< start end) (aref vector start)))
1207         (nextpos (if (< end len) (source-note-start-pos (aref vector end)) (stream-length input))))
1208    (when (< (coverage-html-state-file-pos s) nextpos)
1209      (format output "<div class='source'><code>")
1210      (when outer-note
1211        ;; The first time through this will just do the first note, because that's all that fits.
1212        (iterate output-subnotes ((outer-note outer-note))
1213          (loop with outer-end = (source-note-end-pos outer-note)
1214                as note = (and (< start end) (aref vector start))
1215                while (and note (<= (source-note-end-pos note) outer-end))
1216                do (progn
1217                     (coverage-html-copy-to s (source-note-start-pos note))
1218                     (format output "<span id='~a~d'>" prefix start)
1219                     (incf start)
1220                     (output-subnotes note)
1221                     (format output "</span>"))
1222                finally (coverage-html-copy-to s outer-end))))
1223      ;; Copy the rest of the last line, or to end if called without a note.
1224      (coverage-html-copy-to s nextpos outer-note)
1225      (format output "</code></div>~%"))))
1226
1227(defun output-spanned-html (html-stream coverage external-format)
1228  (with-open-file (source-stream (file-coverage-file coverage) :external-format external-format)
1229    (let* ((queue (file-coverage-html-queue coverage))
1230           (prefix (format nil "f~d" (file-coverage-index coverage)))
1231           (s (make-coverage-html-state :input source-stream
1232                                        :output html-stream
1233                                        :prefix (%str-cat prefix "s"))))
1234      (loop 
1235        for start = 0 then end as (end . acodes) in queue
1236        do (output-coverage-html-source s start end)
1237        do (format html-stream "<a href=javascript:swap('~at~d')><span class='toggle' id='p~2:*~at~d'>Show expansion</span></a>~%~
1238                                        <div class='acode' id='a~2:*~at~d'><code>" prefix start)
1239        do (loop for (acode . notes) in acodes
1240                 do (with-input-from-vector (astream acode :external-format :utf-8)
1241                      (let ((cs (make-coverage-html-state :input astream
1242                                                          :output html-stream
1243                                                          :prefix (%str-cat prefix "c")
1244                                                          :line-no nil)))
1245                        (output-coverage-html-acode cs notes)
1246                        (fresh-line html-stream))))
1247        do (format html-stream "</code></div><hr/>~%")
1248           ;; output the rest of file, no notes.
1249        finally (output-coverage-html-source s start start)))))
1250
1251(defun coverage-stats-head (html-stream stats-stream include-source-p)
1252  (when html-stream
1253    (format html-stream "<tr class='head-row'>")
1254    (when include-source-p (format html-stream "<td></td>"))
1255    (format html-stream "<td class='main-head' colspan='5'>Expressions</td>")
1256    (format html-stream "<td class='main-head' colspan='1'>Branches</td>")
1257    (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>")
1258    (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>")
1259    (format html-stream "<tr class='head-row'>")
1260    (let ((fields '(;; Expressions
1261                    "Total" "Entered" "% entered" "Fully covered" "% fully covered"
1262                    ;; Branches
1263                    "total unreached"
1264                    ;; Code forms
1265                    "Total" "Covered" "% covered"
1266                    ;; Functions
1267                    "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
1268      (when include-source-p (push "Source file" fields))
1269      (format html-stream "~{<td width='60px'>~A</td>~}" fields))
1270    (format html-stream "</tr>"))
1271  (when stats-stream
1272    (format stats-stream "~{~a~^,~}"
1273            `("Source file"
1274              "Expressions Total" "Expressions Entered" "% Expressions Entered"
1275              "Unreached Branches"
1276              "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
1277              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
1278              "Functions Partly Covered" "% Functions Partly Covered"
1279              "Functions Not Entered" "% Functions Not Entered"))))
1280
1281(defun file-coverage-stats-html (html-stream)
1282  (format html-stream "<table class='summary'>")
1283  (coverage-stats-head html-stream nil nil)
1284  (format html-stream "<tr class='odd'>")
1285  (format html-stream "~{<td id='~a'></td>~}"
1286          '("srcTotal" "srcEntered" "srcEnteredPct" "srcCovered" "srcCoveredPct"
1287            "branchUnreached"
1288            "acodeTotal" "acodeCovered" "acodeCoveredPct"
1289            "fnTotal" "fnCovered" "fnCoveredPct" "fnPartly" "fnPartlyPct" "fnUnentered" "fnUnenteredPct"))
1290  (format html-stream "</table>"))
1291 
1292(defun coverage-stats-data (html-stream stats-stream coverage evenp report-name src-name)
1293  (when html-stream
1294    (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
1295    (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name))
1296  (when stats-stream
1297    (format stats-stream "~a," (file-coverage-file coverage)))
1298
1299  (let* ((stats (file-coverage-statistics coverage))
1300         (total (coverage-expressions-total stats))
1301         (entered (coverage-expressions-entered stats))
1302         (covered (coverage-expressions-covered stats))
1303         (exp-counts (list total
1304                           entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
1305                           covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
1306    (when html-stream
1307      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
1308    (when stats-stream
1309      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
1310
1311  (let ((count (coverage-unreached-branches (file-coverage-statistics coverage))))
1312    (when html-stream
1313      (format html-stream "<td>~:[-~;~:*~a~]</td>" count))
1314    (when stats-stream
1315      (format stats-stream "~:[~;~:*~a~]," count)))
1316
1317  (let* ((stats (file-coverage-statistics coverage))
1318         (total (coverage-code-forms-total stats))
1319         (covered (coverage-code-forms-covered stats))
1320         (exp-counts (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
1321    (when html-stream
1322      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
1323    (when stats-stream
1324      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
1325
1326  (let* ((stats (file-coverage-statistics coverage))
1327         (total (coverage-functions-total stats))
1328         (fully (coverage-functions-fully-covered stats))
1329         (partly (coverage-functions-partly-covered stats))
1330         (never (coverage-functions-not-entered stats))
1331         (counts (list fully
1332                       (if (> total 0) (* 100.0 (/ fully total)) '--)
1333                       partly
1334                       (if (> total 0) (* 100.0 (/ partly total)) '--)
1335                       never
1336                       (if (> total 0) (* 100.0 (/ never total)) '--))))
1337    (when html-stream
1338      (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts))
1339    (when stats-stream
1340      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
1341
1342(defun count-covered-aexps (coverage)
1343  (let ((covered 0) (total 0)
1344        (entry-full 0) (entry-part 0) (entry-never 0) (entry-total 0))
1345    (loop for note across *emitted-code-notes*
1346          do (incf total)
1347          do (when (code-note-code-coverage note)
1348               (incf covered))
1349          do (when (entry-code-note-p note)
1350               (incf entry-total)
1351               (case (code-note-code-coverage note)
1352                 ((full) (incf entry-full))
1353                 ((nil) (incf entry-never))
1354                 (t (incf entry-part)))))
1355    (let ((stats (file-coverage-statistics coverage)))
1356      (setf (coverage-code-forms-total stats) total)
1357      (setf (coverage-code-forms-covered stats) covered)
1358      (setf (coverage-functions-total stats) entry-total)
1359      (setf (coverage-functions-fully-covered stats) entry-full)
1360      (setf (coverage-functions-partly-covered stats) entry-part)
1361      (setf (coverage-functions-not-entered stats) entry-never))))
1362
1363
1364(defun count-covered-sexps (coverage)
1365  ;; Count the number of source expressions that have been entered or covered
1366  (let ((entered 0) (covered 0) (total (length *covered-source-notes*)))
1367    (loop for source across *covered-source-notes* as cover = (source-coverage source)
1368          do (when cover
1369               (incf entered)
1370               (when (eq cover 'full) (incf covered))))
1371    (let ((stats (file-coverage-statistics coverage)))
1372      (setf (coverage-expressions-total stats) total)
1373      (setf (coverage-expressions-entered stats) entered)
1374      (setf (coverage-expressions-covered stats) covered))))
1375
1376(defun count-unreached-branches (coverage)
1377  ;; Count the number of maximal unentered code forms, i.e. unentered code forms
1378  ;; whose parent was entered.
1379  (let ((count (loop for note across *emitted-code-notes*
1380                     count (and (null (code-note-code-coverage note));; uncovered
1381                                (not (entry-code-note-p note));; not entry note
1382                                (setq note (code-note-emitted-parent note));; has a parent
1383                                (code-note-code-coverage note)))));; that's covered
1384    (let ((stats (file-coverage-statistics coverage)))
1385      (setf (coverage-unreached-branches stats) count))))
1386
1387(defun write-coverage-styles (html-stream)
1388  (format html-stream "<style type='text/css'>
1389*.st~a { background-color: #ffaaaa }
1390*.st~a { background-color: #aaffaa }
1391*.st~a { background-color: #44dd44 }
1392*.stsource { background-color: #eeeeee; }
1393*.key { margin: 20px; width: 88ex }
1394*.source { width: 120ex; background-color: #eeeeee; padding-left: 5px;
1395             /* border-style: solid none none none; border-width: 1px;
1396             border-color: #dddddd */
1397             white-space: pre; }
1398
1399*.acode { border-left: 1px dashed #c0c0c0;
1400         margin-top: 1ex;
1401         margin-left: 6ex;
1402         margin-bottom: 2ex;
1403         white-space: pre;
1404         display: none; }
1405
1406*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
1407
1408*.toggle { font-size: small; }
1409
1410table.summary tr.head-row { background-color: #aaaaff }
1411table.summary tr td.text-cell { text-align: left }
1412table.summary tr td.main-head { text-align: center }
1413table.summary tr td { text-align: right }
1414table.summary tr.even { background-color: #eeeeff }
1415table.summary tr.subheading { background-color: #aaaaff}
1416table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
1417
1418</style>
1419
1420<script type='text/javascript'>
1421function swap (id) {
1422  var acode = document.getElementById('a' + id);
1423  var prompt = document.getElementById('p' + id);
1424  if (acode.style.display == 'block') {
1425      acode.style.display = 'none';
1426      prompt.innerHTML = 'Show expansion';
1427  } else {
1428    acode.style.display = 'block';
1429    prompt.innerHTML = 'Hide expansion';
1430  }
1431}
1432</script>
1433"
1434          $not-executed-style
1435          $partially-covered-style
1436          $totally-covered-style
1437          ))
1438
Note: See TracBrowser for help on using the repository browser.