source: branches/working-0711/ccl/library/cover.lisp @ 8937

Last change on this file since 8937 was 8937, checked in by gz, 12 years ago

only verify interned function names

File size: 24.1 KB
Line 
1;;; Code coverage reporting facility, based on the SBCL's
2;;; sb-cover written by Juho Snellman, and placed under public domain.
3;;; Port to ccl by gz@clozure.com
4
5(in-package :ccl)
6
7(export '(*compile-code-coverage*
8          report-coverage
9          reset-coverage
10          clear-coverage
11          save-coverage-in-file
12          restore-coverage-from-file))
13
14(defconstant $not-executed-style 2)
15(defconstant $totally-covered-style 5)
16(defconstant $partially-covered-style 6)
17
18(defparameter *file-coverage* ())
19(defparameter *coverage-subnotes* (make-hash-table :test #'eq))
20(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
21(defparameter *entry-code-notes* (make-hash-table :test #'eq))
22
23
24(defun file-coverage-file (entry)
25  (car entry))
26
27(defun file-coverage-functions (entry)
28  (cadr entry))
29
30(defun file-coverage-toplevel-functions (entry)
31  (cddr entry))
32
33(defun coverage-subnotes (note)
34  (gethash note *coverage-subnotes*))
35
36(defun emitted-code-note-p (note)
37  (gethash note *emitted-code-notes*))
38
39(defun entry-code-note-p (note)
40  (gethash note *entry-code-notes*))
41
42(defmacro lfunloop (for var in function &body loop-body)
43  (assert (and (memq for '(for as)) (eq in 'in)))
44  (let ((fn (gensym))
45        (lfv (gensym))
46        (i (gensym)))
47    `(loop with ,fn = ,function
48           with ,lfv = (function-to-function-vector ,fn)
49           for ,i from #+ppc-target 0 #+x86-target (%function-code-words fn) below (uvsize  ,lfv)
50           as ,var = (uvref ,lfv ,i)
51           ,@loop-body)))
52
53
54(defun map-function-coverage (lfun fn &optional refs)
55  (let ((refs (cons lfun refs)))
56    (lfunloop for imm in lfun
57              when (code-note-p imm)
58              do (funcall fn imm)
59              when (and (functionp imm)
60                        (not (memq imm refs)))
61              do (map-function-coverage imm fn refs))))
62
63(defun get-function-coverage (fn refs)
64  (let ((entry (function-entry-code-note fn))
65        (refs (cons fn refs)))
66    (declare (dynamic-extent refs))
67    (when entry
68      ;; This can occur legitimately when the same source is used multiple times,
69      ;; as when 'body' contains local fn defs in something like:
70      ;; (defmacro define-twice (defn) (defun fn-1 ,@defn) (defun fn-2 ,@defn))
71      #+never-mind
72      (when (and (gethash entry *entry-code-notes*)
73                 (neq fn (gethash entry *entry-code-notes*)))
74        (cerror "ignore" "Note ~s is entry note for both ~s and ~s"
75                entry fn (gethash entry *entry-code-notes*)))
76      (setf (gethash entry *entry-code-notes*) fn))
77    (nconc
78     (and entry (list fn))
79     (lfunloop for imm in fn
80               when (code-note-p imm)
81               do (let ((parent (code-note-parent-note imm)))
82                    (setf (gethash imm *emitted-code-notes*) t)
83                    (when parent
84                      (if (consp parent)
85                          (loop for p in parent
86                                do (pushnew imm (gethash p *coverage-subnotes*)))
87                          (pushnew imm (gethash parent *coverage-subnotes*)))))
88               when (and (functionp imm)
89                         (not (memq imm refs)))
90               nconc (get-function-coverage imm refs)))))
91
92
93(defun get-coverage ()
94  (setq *file-coverage* nil)
95  (clrhash *coverage-subnotes*)
96  (clrhash *emitted-code-notes*)
97  (clrhash *entry-code-notes*)
98  (loop for data in *code-covered-functions*
99        when (consp data)
100        do (destructuring-bind (file . toplevel-functions) data
101             (push (list* file
102                          ;; Duplicates are possible if you have multiple instances of
103                          ;; (load-time-value (foo)) where (foo) returns an lfun.
104                          ;; CL-PPCRE does that.
105                          (delete-duplicates
106                           (loop for fn across toplevel-functions
107                                nconc (get-function-coverage fn nil)))
108                          toplevel-functions)
109                   *file-coverage*))))
110
111(defun show-notes (note)
112  (when (functionp note)
113    (setq note (function-entry-code-note note)))
114  (labels ((show (note indent label)
115             (dotimes (i indent) (write-char #\space))
116             (format t "~a ~a" label note)
117             (unless (emitted-code-note-p note)
118               (format t " [Not Emitted]"))
119             (when (entry-code-note-p note)
120               (format t " (Entry to ~s)" (entry-code-note-p note)))
121             (format t "~%")
122             (when (code-note-p note)
123               (loop with subindent = (+ indent 3)
124                     for sub in (coverage-subnotes note) as i upfrom 1
125                     do (show sub subindent (format nil "~a~d." label i))))))
126    (show note 0 "")))
127
128(defun covered-functions-for-file (path)
129  (let* ((true-path (probe-file path))
130         (data (find-if #'(lambda (data)
131                            (or (equalp (car data) path)
132                                (and true-path (equalp (probe-file (car data)) true-path))))
133                        *code-covered-functions*)))
134    (cdr data)))
135
136(defun clear-coverage ()
137  "Clear all files from the coverage database. The files will be re-entered
138into the database when the FASL files (produced by compiling with
139CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
140image."
141  (setq *code-covered-functions* nil))
142
143(defun reset-coverage ()
144  "Reset all coverage data back to the `Not executed` state."
145  (flet ((reset (note) (setf (code-note-code-coverage note) nil)))
146    (loop for data in *code-covered-functions*
147          do (typecase data
148               (cons ;; (source-file . functions)
149                (loop for fn across (cdr data)
150                      do (map-function-coverage fn #'reset)))
151               (function (map-function-coverage data #'reset))))))
152
153(defun save-function-coverage (fn &optional (refs ()))
154  (push fn refs)
155  (cons (let ((name (function-name fn)))
156          (and (symbolp name)
157               (symbol-package name)
158               name))
159        (lfunloop for imm in fn
160                  when (code-note-p imm)
161                  collect (code-note-code-coverage imm)
162                  when (and (functionp imm) (not (memq imm refs)))
163                  collect (save-function-coverage imm refs))))
164
165
166
167(defun save-coverage ()
168  "Returns an opaque representation of the current code coverage state.
169The only operation that may be done on the state is passing it to
170RESTORE-COVERAGE. The representation is guaranteed to be readably printable.
171A representation that has been printed and read back will work identically
172in RESTORE-COVERAGE."
173  (loop for data in *code-covered-functions*
174        when (consp data)
175        collect (cons (car data)
176                      (map 'vector #'save-function-coverage (cdr data)))))
177
178(defun restore-coverage (coverage-state)
179  "Restore the code coverage data back to an earlier state produced by
180SAVE-COVERAGE."
181  (loop for (saved-file . saved-fns) in coverage-state
182        as fns = (covered-functions-for-file saved-file)
183        do (flet ((mismatched (why &rest args)
184                    (error "Mismatched coverage data for ~s, ~?" saved-file why args)))
185             (cond ((null fns)
186                    (warn "Couldn't restore saved coverage for ~s, no matching file present"
187                          saved-file))
188                   ((not (eql (length fns) (length saved-fns)))
189                    (mismatched "was ~s functions, now ~s" (length saved-fns) (length fns)))
190                   (t
191                    (loop for fn across fns
192                          for saved-data across saved-fns
193                          do (labels
194                                 ((rec (fn saved-data refs)
195                                    (push fn refs)
196                                    (let* ((name (car saved-data))
197                                           (saved-imms (cdr saved-data)))
198                                      (unless (equalp name 
199                                                      (let ((name (function-name fn)))
200                                                        (and (symbolp name) name)))
201                                        (mismatched "had ~s now have ~s" name (function-name fn)))
202                                      (lfunloop for imm in fn
203                                                when (code-note-p imm)
204                                                do (if (or (null saved-imms) (consp (car saved-imms)))
205                                                       (mismatched "in ~s" name)
206                                                       (setf (code-note-code-coverage imm) (pop saved-imms)))
207                                                when (and (functionp imm)
208                                                          (not (memq imm refs)))
209                                                do (if (or (null saved-imms) (atom (car saved-imms)))
210                                                       (mismatched "in ~s" name)
211                                                       (rec imm (pop saved-imms) refs))))))
212                               (rec fn saved-data nil))))))))
213
214(defun save-coverage-in-file (pathname)
215  "Call SAVE-COVERAGE and write the results of that operation into the
216file designated by PATHNAME."
217  (with-open-file (stream pathname
218                          :direction :output
219                          :if-exists :supersede
220                          :if-does-not-exist :create)
221    (with-standard-io-syntax
222      (let ((*package* *ccl-package*))
223        (write (save-coverage) :stream stream)))
224    (values)))
225
226(defun restore-coverage-from-file (pathname)
227  "READ the contents of the file designated by PATHNAME and pass the
228result to RESTORE-COVERAGE."
229  (with-open-file (stream pathname :direction :input)
230    (with-standard-io-syntax
231      (let ((*package* *ccl-package*))
232        (restore-coverage (read stream))))
233    (values)))
234
235(defun common-coverage-directory ()
236  (let* ((host :unknown)
237         (rev-dir ()))
238    (loop for data in *code-covered-functions*
239       when (consp data)
240       do (let ((file (probe-file (car data))))
241            (when file
242              (cond ((eq host :unknown)
243                     (setq host (pathname-host file)
244                           rev-dir (reverse (pathname-directory file))))
245                    ((not (equalp host (pathname-host file)))
246                     (return-from common-coverage-directory nil))
247                    (t
248                     (let* ((path (pathname-directory file))
249                            (dir-len (length rev-dir))
250                            (len (length path)))
251                       (if (< len dir-len)
252                         (setq rev-dir (nthcdr (- dir-len len) rev-dir))
253                         (setq path (subseq path 0 dir-len)))
254                       (loop for pp on (reverse path) until (equalp pp rev-dir)
255                          do (pop rev-dir))))))))
256    (unless (eq host :unknown)
257      (make-pathname :host host :directory (reverse rev-dir)))))
258
259
260(defun report-coverage (output-file &key (external-format :default) (statistics t))
261  "Print a code coverage report of all instrumented files into DIRECTORY.
262If DIRECTORY does not exist, it will be created. The main report will be
263printed to the file cover-index.html. The external format of the source
264files can be specified with the EXTERNAL-FORMAT parameter.
265If :STATISTICS is non-nil, a CSV file is generated with a table.  If
266:STATISTICS is a filename, that file is used, else 'statistics.csv' is
267written to the output directory.
268"
269  (let* ((paths)
270         (directory (make-pathname :name nil :type nil :defaults output-file))
271         (coverage-dir (common-coverage-directory))
272         (*file-coverage* nil)
273         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
274         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
275         (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
276    (get-coverage)
277    (ensure-directories-exist directory)
278    (loop for coverage in *file-coverage*
279      as file = (or (probe-file (file-coverage-file coverage))
280                    (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
281                           nil))
282      do (when file
283           (let* ((src-name (enough-namestring file coverage-dir))
284                  (html-name (substitute #\_ #\: (substitute #\_ #\. (substitute #\_ #\/ src-name)))))
285             (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
286                                     :direction :output
287                                     :if-exists :supersede
288                                     :if-does-not-exist :create)
289               (report-file-coverage coverage stream external-format))
290             (push (list* src-name html-name coverage) paths))))
291    (setq paths (sort paths #'string< :key #'car))
292    (when (null paths)
293      (error "No code coverage data available"))
294    (let* ((index-file (merge-pathnames output-file "index.html"))
295           (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
296                                                                (pathnamep statistics))
297                                                            (merge-pathnames statistics "statistics.csv")
298                                                            "statistics.csv")
299                                                        output-file))))
300      (with-open-file (html-stream index-file
301                                   :direction :output
302                                   :if-exists :supersede
303                                   :if-does-not-exist :create)
304        (if stats-file
305            (with-open-file (stats-stream stats-file
306                                          :direction :output
307                                          :if-exists :supersede
308                                          :if-does-not-exist :create)
309              (report-coverage-to-streams paths html-stream stats-stream))
310            (report-coverage-to-streams paths html-stream nil)))
311      (values index-file stats-file))))
312
313(defun report-coverage-to-streams (paths html-stream stats-stream)
314  (write-coverage-styles html-stream)
315  (unless paths
316    (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
317    (format html-stream "<h3>No code coverage data found.</h3>~%")
318    (when stats-stream (format stats-stream "No code coverage data found.~%"))
319    (return-from report-coverage-to-streams))
320  (format html-stream "<table class='summary'>")
321  (coverage-stats-head html-stream stats-stream)
322  (loop for prev = nil then src-name
323        for (src-name report-name . coverage) in paths
324        for even = nil then (not even)
325        do (when (or (null prev)
326                     (not (equal (pathname-directory (pathname src-name))
327                                 (pathname-directory (pathname prev)))))
328             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
329               (format html-stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%" dir)
330               (when stats-stream (format stats-stream "~a~%" dir))))
331        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
332  (format html-stream "</table>"))
333
334(defun precompute-note-coverage (note &optional refs)
335  (when note
336    (let ((subnotes (coverage-subnotes note))
337          (refs (cons note refs)))
338      (declare (dynamic-extent refs))
339      (loop for sub in subnotes
340            when (member sub refs)
341            do (break "Circularity!!")
342            unless (member sub refs)
343            do (precompute-note-coverage sub refs))
344      (when (and (or (not (emitted-code-note-p note))
345                     (code-note-code-coverage note))
346                 (loop for sub in subnotes
347                       always (or (eq 'full (code-note-code-coverage sub))
348                                  (entry-code-note-p sub))))
349        (setf (code-note-code-coverage note) 'full)))))
350
351
352(defun fill-with-text-style (coverage location-note styles)
353  (let ((style (case coverage
354                 ((full) $totally-covered-style)
355                 ((nil) $not-executed-style)
356                 (t $partially-covered-style))))
357    (fill styles style
358          :start (source-note-start-pos location-note)
359          :end (source-note-end-pos location-note))))
360
361(defun update-text-styles (note styles)
362  (when (source-note-p note)
363    (fill-with-text-style (code-note-code-coverage note) note styles))
364  (unless (and (emitted-code-note-p note)
365               (memq (code-note-code-coverage note) '(nil full))
366               ;; If not a source note, descend in case have some subnotes
367               ;; that can be shown
368               (source-note-p note))
369    (loop for sub in (coverage-subnotes note)
370          unless (entry-code-note-p sub)
371          do (update-text-styles sub styles))))
372 
373(defun colorize-source-note (note styles)
374  ;; Change coverage flag to 'full if all subforms are covered.
375  (precompute-note-coverage note)
376  ;; Now actually change text styles, from outside in.
377  ;; But first, a special kludge:
378  ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
379  ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
380  ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
381  ;; expanded into the above, there isn't a clear way to show the distinction between
382  ;; just referencing the inner fn and executing it.  In practice, the colorization
383  ;; based on the inner function is more interesting -- consider for example DEFUN,
384  ;; nobody cares if the defun form itself got executed.
385  ;; So when showing the colorization of an inner function, we usurp the whole nearest source
386  ;; form, provided it can be done unambiguously.
387  (loop for n = note then parent until (source-note-p n)
388        as parent = (code-note-parent-note n)
389        do (unless (and parent
390                        (labels ((no-other-entry-subnotes (n refs)
391                                   (let ((subs (coverage-subnotes n))
392                                         (refs (cons n refs)))
393                                     (declare (dynamic-extent refs))
394                                     (loop for sub in subs
395                                           always (or (memq sub refs)
396                                                      (eq sub note)
397                                                      (and (not (entry-code-note-p sub))
398                                                           (no-other-entry-subnotes sub refs)))))))
399                          (no-other-entry-subnotes parent ())))
400             (return nil))
401        finally (fill-with-text-style (code-note-code-coverage note) n styles))
402  (update-text-styles note styles))
403
404(defun function-source-form-note (fn)
405  (loop for n = (function-entry-code-note fn) then (code-note-parent-note n)
406        do (when (null n) (return nil))
407        do (when (source-note-p n)
408             (loop for s = (code-note-source n) while (source-note-p s)
409                   do (setq n s))
410             (return n))))
411
412 
413(defun colorize-function (fn styles &optional refs)
414  (let* ((note (function-entry-code-note fn))
415         (source (function-source-form-note fn))
416         (refs (cons fn refs)))
417    (declare (dynamic-extent refs))
418    ;; Colorize the body of the function
419    (when note
420      (colorize-source-note note styles))
421    ;; And now any subfunction references
422    (lfunloop for imm in fn
423              when (and (functionp imm)
424                        (not (memq imm refs))
425                        ;; Make sure this fn is in the source we're currently looking at.
426                        ;; It might not be, if it is referenced via (load-time-value (foo))
427                        ;; where (foo) returns an lfun from some different source entirely.
428                        ;; CL-PPCRE does that.
429                        (or (null source)
430                            (eq source (function-source-form-note imm))
431                            #+debug (progn
432                                      (warn "Ignoring ref to ~s from ~s" imm fn)
433                                      nil)))
434              do (colorize-function imm styles refs))))
435
436(defun report-file-coverage (coverage html-stream external-format)
437  "Print a code coverage report of FILE into the stream HTML-STREAM."
438  (format html-stream "<html><head>")
439  (write-coverage-styles html-stream)
440  (format html-stream "</head><body>")
441  (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format)
442                   (let ((string (make-string (file-length s))))
443                     (read-sequence string s)
444                     string)))
445         (styles (make-array (length source)
446                             :initial-element 0
447                             :element-type '(unsigned-byte 2))))
448    (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
449    (print-coverage-report html-stream coverage styles source)
450    (format html-stream "</body></html>")))
451
452(defun print-coverage-report (html-stream coverage styles source)
453  (let ((*print-case* :downcase))
454    (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" (file-coverage-file coverage))
455
456    (format html-stream "<table class='summary'>")
457    (coverage-stats-head html-stream nil)
458    (coverage-stats-data html-stream nil coverage)
459    (format html-stream "</table>")
460
461    (format html-stream "<div class='key'><b>Key</b><br />~%")
462    (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
463    (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
464    (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
465    (format html-stream "<p></p><div><code>~%")
466
467    (flet ((line (line)
468             (unless (eql line 0)
469               (format html-stream "</span>"))
470             (incf line)
471             (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
472             line))
473      (loop with line = (line 0) with col = 0
474        for last-style = nil then style
475        for char across source
476        for style across styles
477        do (unless (eq style last-style)
478             (when last-style
479               (format html-stream "</span>"))
480             (format html-stream "<span class='state-~a'>" style))
481        do (case char
482             ((#\Newline)
483              (setq style nil)
484              (setq col 0)
485              (setq line (line line)))
486             ((#\Space)
487              (incf col)
488              (write-string "&#160;" html-stream))
489             ((#\Tab)
490              (dotimes (i (- 8 (mod col 8)))
491                (incf col)
492                (write-string "&#160;" html-stream)))
493             (t
494              (incf col)
495              (if (alphanumericp char)
496                (write-char char html-stream)
497                (format html-stream "&#~D;" (char-code char))))))
498      (format html-stream "</code></div>"))))
499
500
501(defun coverage-stats-head (html-stream stats-stream)
502  (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>")
503  (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
504          '("Source file"
505            "Total" "Covered" "% covered"
506            "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))
507  (when stats-stream
508    (format stats-stream "~{~a~^,~}"
509            '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered"
510              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
511              "Functions Partly Covered" "% Functions Partly Covered"
512              "Functions Not Entered" "% Functions Not Entered"))))
513
514(defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name)
515  (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
516  (if report-name
517    (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name)
518    (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage)))
519  (when stats-stream
520    (format stats-stream "~a," (file-coverage-file coverage)))
521  (let ((exp-counts (count-covered-expressions coverage)))
522    (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts)
523    (when stats-stream
524      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
525  (destructuring-bind (total . counts) (count-covered-functions coverage)
526    (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts)
527    (when stats-stream
528      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
529
530(defun count-covered-functions (coverage)
531  (let ((fully 0) (partly 0) (never 0) (total 0))
532    (map nil #'(lambda (function)
533                 (let ((note (function-entry-code-note function)))
534                   (when (and note
535                              ;; Ignore toplevel functions created by the compiler.
536                              (or (source-note-p note)
537                                  (code-note-parent-note note)
538                                  (code-note-source note)))
539                     (incf total)
540                     (case (code-note-code-coverage note)
541                       ((full) (incf fully))
542                       ((nil) (incf never))
543                       (t (incf partly))))))
544         (file-coverage-functions coverage))
545    (if (> total 0)
546        (list total
547              fully (* 100.0 (/ fully total))
548              partly (* 100.0 (/ partly total))
549              never (* 100.0 (/ never total)))
550        '(0 0 -- 0 -- 0 --))))
551
552(defun count-covered-expressions (coverage)
553  (let ((covered 0) (total 0))
554    (map nil #'(lambda (function)
555                 (let ((note (function-entry-code-note function)))
556                   (when (and note
557                              ;; Ignore toplevel functions created by the compiler.
558                              (or (source-note-p note)
559                                  (code-note-parent-note note)
560                                  (code-note-source note)))
561                     (labels ((rec (note)
562                                (incf total)
563                                (when (code-note-code-coverage note)
564                                  (incf covered))
565                                (loop for sub in (coverage-subnotes note)
566                                      unless (entry-code-note-p sub) do (rec sub))))
567                       (rec note)))))
568         (file-coverage-functions coverage))
569    (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
570
571
572(defun write-coverage-styles (html-stream)
573  (format html-stream "<style type='text/css'>
574*.state-~a { background-color: #ffaaaa }
575*.state-~a { background-color: #aaffaa }
576*.state-~a { background-color: #44dd44 }
577div.key { margin: 20px; width: 88ex }
578div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;
579             /* border-style: solid none none none; border-width: 1px;
580             border-color: #dddddd */ }
581
582*.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
583
584table.summary tr.head-row { background-color: #aaaaff }
585table.summary tr td.text-cell { text-align: left }
586table.summary tr td.main-head { text-align: center }
587table.summary tr td { text-align: right }
588table.summary tr.even { background-color: #eeeeff }
589table.summary tr.subheading { background-color: #aaaaff}
590table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
591</style>"
592          $not-executed-style
593          $partially-covered-style
594          $totally-covered-style
595          ))
Note: See TracBrowser for help on using the repository browser.