source: release/1.9/source/library/cover.lisp @ 15706

Last change on this file since 15706 was 14937, checked in by gz, 8 years ago

Update coloring when change selection

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