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

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

Guard against CL-PPCRE's tricks with load-time-values of closures

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