Index: /trunk/source/library/cover.lisp =================================================================== --- /trunk/source/library/cover.lisp (revision 14716) +++ /trunk/source/library/cover.lisp (revision 14717) @@ -56,4 +56,5 @@ (defparameter *emitted-code-notes* (make-hash-table :test #'eq)) (defparameter *entry-code-notes* (make-hash-table :test #'eq)) +(defparameter *source-coverage* (make-hash-table :test #'eq)) (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) @@ -66,4 +67,18 @@ +(defstruct (ccl:coverage-statistics (:conc-name "COVERAGE-")) + source-file + expressions-total + expressions-entered + expressions-covered + unreached-branches + code-forms-total + code-forms-covered + functions-total + functions-fully-covered + functions-partly-covered + functions-not-entered) + + (defun file-coverage-file (entry) (car entry)) @@ -73,5 +88,8 @@ (defun file-coverage-toplevel-functions (entry) - (cddr entry)) + (caddr entry)) + +(defun file-coverage-statistics (entry) + (cdddr entry)) (defun coverage-subnotes (note) ;; reversed parent chain @@ -83,4 +101,7 @@ (defun entry-code-note-p (note) (gethash note *entry-code-notes*)) + +(defun source-coverage (source-note) + (gethash source-note *source-coverage*)) (defun map-function-coverage (lfun fn &optional refs) @@ -135,4 +156,5 @@ (clrhash *emitted-code-notes*) (clrhash *entry-code-notes*) + (clrhash *source-coverage*) (loop for data in *code-covered-functions* do (let* ((file (code-covered-info.file data)) @@ -145,5 +167,8 @@ (loop for fn across toplevel-functions nconc (get-function-coverage fn nil)))) - (coverage (list* file all-functions toplevel-functions))) + (coverage (list* file + all-functions + toplevel-functions + (make-coverage-statistics :source-file file)))) (push coverage *file-coverage*))))) ;; Now get subnotes, including un-emitted ones. @@ -152,5 +177,10 @@ while parent do (pushnew n (gethash parent *coverage-subnotes*)) - until (emitted-code-note-p parent)))) + until (emitted-code-note-p parent))) + ;; Now get source mapping + (loop for coverage in *file-coverage* + do (precompute-source-coverage coverage) + ;; bit of overkill, but we end up always wanting them. + do (compute-file-coverage-statistics coverage))) (defun file-coverage-acode-queue (coverage) @@ -204,5 +234,5 @@ (code-covered-info.fns (assoc-by-filename path *code-covered-functions*))) -(defun clear-coverage () +(defun ccl:clear-coverage () "Clear all files from the coverage database. The files will be re-entered into the database when the FASL files (produced by compiling with @@ -215,5 +245,5 @@ (setf (code-note-code-coverage note) nil)))) -(defun reset-coverage () +(defun ccl:reset-coverage () "Reset all coverage data back to the `Not executed` state." (loop for data in *code-covered-functions* @@ -318,5 +348,5 @@ -(defun save-coverage () +(defun ccl:save-coverage () "Returns a snapshot of the current coverage state" (make-coverage-state @@ -326,5 +356,5 @@ data (map 'vector #'save-function-coverage (code-covered-info.fns data)))))) -(defun combine-coverage (coverage-states) +(defun ccl:combine-coverage (coverage-states) (let ((result nil)) (map nil @@ -355,5 +385,5 @@ -(defun restore-coverage (coverage-state) +(defun ccl:restore-coverage (coverage-state) "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE." (loop for saved-data in (coverage-state-alist coverage-state) @@ -379,5 +409,5 @@ (defvar *loading-coverage*) -(defun write-coverage-to-file (coverage pathname) +(defun ccl:write-coverage-to-file (coverage pathname) "Write the coverage state COVERAGE in the file designated by PATHNAME" (with-open-file (stream pathname @@ -391,5 +421,5 @@ (values))) -(defun read-coverage-from-file (pathname) +(defun ccl:read-coverage-from-file (pathname) " Return the coverage state saved in the file. Doesn't affect the current coverage state." (let ((*package* (pkg-arg "CCL")) @@ -400,9 +430,9 @@ (make-coverage-state :alist *loading-coverage*))) -(defun save-coverage-in-file (pathname) +(defun ccl:save-coverage-in-file (pathname) "Save the current coverage state in the file designed by PATHNAME" (write-coverage-to-file (save-coverage) pathname)) -(defun restore-coverage-from-file (pathname) +(defun ccl:restore-coverage-from-file (pathname) "Set the current coverage state from the file designed by PATHNAME" (restore-coverage (read-coverage-from-file pathname))) @@ -433,52 +463,21 @@ -(defstruct (coverage-statistics (:conc-name "COVERAGE-")) - source-file - expressions-total - expressions-entered - expressions-covered - unreached-branches - code-forms-total - code-forms-covered - functions-total - functions-fully-covered - functions-partly-covered - functions-not-entered) - -(defun coverage-statistics () +(defun ccl:coverage-statistics () (let* ((*file-coverage* nil) (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) - (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) - (get-coverage) - (loop for coverage in *file-coverage* - as stats = (make-coverage-statistics :source-file (file-coverage-file coverage)) - do (map nil (lambda (fn) - (let ((note (function-entry-code-note fn))) - (when note (precompute-note-coverage note)))) - (file-coverage-toplevel-functions coverage)) - do (destructuring-bind (total entered %entered covered %covered) - (count-covered-sexps coverage) - (declare (ignore %entered %covered)) - (setf (coverage-expressions-total stats) total) - (setf (coverage-expressions-entered stats) entered) - (setf (coverage-expressions-covered stats) covered)) - do (let ((count (count-unreached-branches coverage))) - (setf (coverage-unreached-branches stats) count)) - do (destructuring-bind (total covered %covered) (count-covered-aexps coverage) - (declare (ignore %covered)) - (setf (coverage-code-forms-total stats) total) - (setf (coverage-code-forms-covered stats) covered)) - do (destructuring-bind (total fully %fully partly %partly never %never) - (count-covered-entry-notes coverage) - (declare (ignore %fully %partly %never)) - (setf (coverage-functions-total stats) total) - (setf (coverage-functions-fully-covered stats) fully) - (setf (coverage-functions-partly-covered stats) partly) - (setf (coverage-functions-not-entered stats) never)) - collect stats))) - - -(defun report-coverage (output-file &key (external-format :default) (statistics t) (html t)) + (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) + (*source-coverage* (make-hash-table :test #'eq :shared nil))) + (get-coverage) + (mapcar #'file-coverage-statistics *file-coverage*))) + +(defun compute-file-coverage-statistics (coverage) + (count-covered-sexps coverage) + (count-unreached-branches coverage) + (count-covered-aexps coverage) + (count-covered-entry-notes coverage)) + + +(defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t)) "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE and, in the same directory, one html file for each instrumented source file that has been @@ -496,4 +495,5 @@ (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) + (*source-coverage* (make-hash-table :test #'eq :shared nil)) (index-file (and html (merge-pathnames output-file "index.html"))) (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) @@ -583,22 +583,4 @@ (when html-stream (format html-stream ""))) -(defun precompute-note-coverage (note &optional refs) - (when note - (let ((subnotes (coverage-subnotes note)) - (refs (cons note refs))) - (declare (dynamic-extent refs)) - (loop for sub in subnotes - when (member sub refs) - do (break "Circularity!!") - unless (member sub refs) - do (precompute-note-coverage sub refs)) - (when (and (or (not (emitted-code-note-p note)) - (code-note-code-coverage note)) - (loop for sub in subnotes - always (or (eq 'full (code-note-code-coverage sub)) - (entry-code-note-p sub)))) - (setf (code-note-code-coverage note) 'full))))) - - (defun style-for-coverage (coverage) (case coverage @@ -607,13 +589,13 @@ (t $partially-covered-style))) -(defun fill-with-text-style (coverage location-note styles) - (fill styles (style-for-coverage coverage) - :start (source-note-start-pos location-note) - :end (source-note-end-pos location-note))) +(defun fill-with-text-style (source-note styles) + (fill styles (style-for-coverage (source-coverage source-note)) + :start (source-note-start-pos source-note) + :end (source-note-end-pos source-note))) (defun update-text-styles (note styles) (let ((source (code-note-source-note note))) (when source - (fill-with-text-style (code-note-code-coverage note) source styles)) + (fill-with-text-style source styles)) (unless (and (emitted-code-note-p note) (memq (code-note-code-coverage note) '(nil full)) @@ -643,21 +625,47 @@ finally (return (code-note-source-note n)))) +;; In some cases, a single source form may be claimed by multiple code notes. Precompute +;; per-source coverage info so coloring can reflect aggregated info for all coverage points. +;; This also changes coverage flag to 'full if all subforms are called. +(defun precompute-source-coverage (coverage) + (labels + ((record-1 (source note) + (when source + (let ((old (gethash source *source-coverage* :default)) + (new (code-note-code-coverage note))) + (unless (eq old new) + (setf (gethash source *source-coverage*) (if (eq old :default) new t)))))) + (record* (note) + (loop with full = (or (code-note-code-coverage note) + (not (emitted-code-note-p note))) + for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) + do (progn + (record* sub) + (unless (eq (code-note-code-coverage sub) 'full) + (setq full nil))) + finally (when full + (setf (code-note-code-coverage note) 'full))) + (record-1 (code-note-source-note note) note)) + (record-entry (note) + (record* note) + ;; A special kludge for entry notes: + ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " + ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner + ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that + ;; expanded into the above, there isn't a clear way to show the distinction between + ;; just referencing the inner fn and executing it. In practice, the colorization + ;; based on the inner function is more interesting -- consider for example DEFUN, + ;; nobody cares whether the defun form itself got executed. + ;; So when showing the colorization of an inner function, we usurp the whole nearest source + ;; form, provided it can be done unambiguously. + (record-1 (entry-note-unambiguous-source note) note))) + (map-coverage-entry-notes coverage #'record-entry))) + (defun colorize-source-note (note styles) - ;; Change coverage flag to 'full if all subforms are covered. - (precompute-note-coverage note) - ;; Now actually change text styles, from outside in. - ;; But first, a special kludge: - ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " - ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner - ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that - ;; expanded into the above, there isn't a clear way to show the distinction between - ;; just referencing the inner fn and executing it. In practice, the colorization - ;; based on the inner function is more interesting -- consider for example DEFUN, - ;; nobody cares whether the defun form itself got executed. - ;; So when showing the colorization of an inner function, we usurp the whole nearest source - ;; form, provided it can be done unambiguously. - (let ((n (entry-note-unambiguous-source note))) - (when n - (fill-with-text-style (code-note-code-coverage note) n styles))) + ;; See comment in precompute-source-coverage + (let ((source (entry-note-unambiguous-source note))) + (when source + (fill-with-text-style source styles))) (update-text-styles note styles)) @@ -854,5 +862,11 @@ (format stats-stream "~a," (file-coverage-file coverage))) - (let ((exp-counts (count-covered-sexps coverage))) + (let* ((stats (file-coverage-statistics coverage)) + (total (coverage-expressions-total stats)) + (entered (coverage-expressions-entered stats)) + (covered (coverage-expressions-covered stats)) + (exp-counts (list total + entered (if (> total 0) (* 100.0d0 (/ entered total)) '--) + covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) (when html-stream (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) @@ -860,5 +874,5 @@ (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) - (let ((count (count-unreached-branches coverage))) + (let ((count (coverage-unreached-branches (file-coverage-statistics coverage)))) (when html-stream (format html-stream "~:[-~;~:*~a~]" count)) @@ -866,5 +880,8 @@ (format stats-stream "~:[~;~:*~a~]," count))) - (let ((exp-counts (count-covered-aexps coverage))) + (let* ((stats (file-coverage-statistics coverage)) + (total (coverage-code-forms-total stats)) + (covered (coverage-code-forms-covered stats)) + (exp-counts (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) (when html-stream (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) @@ -872,5 +889,15 @@ (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) - (destructuring-bind (total . counts) (count-covered-entry-notes coverage) + (let* ((stats (file-coverage-statistics coverage)) + (total (coverage-functions-total stats)) + (fully (coverage-functions-fully-covered stats)) + (partly (coverage-functions-partly-covered stats)) + (never (coverage-functions-not-entered stats)) + (counts (list fully + (if (> total 0) (* 100.0 (/ fully total)) '--) + partly + (if (> total 0) (* 100.0 (/ partly total)) '--) + never + (if (> total 0) (* 100.0 (/ never total)) '--)))) (when html-stream (format html-stream "~:[-~;~:*~a~]~{~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" total counts)) @@ -899,10 +926,9 @@ ((nil) (incf never)) (t (incf partly))))) - (if (> total 0) - (list total - fully (* 100.0 (/ fully total)) - partly (* 100.0 (/ partly total)) - never (* 100.0 (/ never total))) - '(0 0 -- 0 -- 0 --)))) + (let ((stats (file-coverage-statistics coverage))) + (setf (coverage-functions-total stats) total) + (setf (coverage-functions-fully-covered stats) fully) + (setf (coverage-functions-partly-covered stats) partly) + (setf (coverage-functions-not-entered stats) never)))) (defun count-covered-aexps (coverage) @@ -919,27 +945,33 @@ unless (entry-code-note-p sub) do (rec sub)))) (rec note)))) - (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + (let ((stats (file-coverage-statistics coverage))) + (setf (coverage-code-forms-total stats) total) + (setf (coverage-code-forms-covered stats) covered)))) (defun count-covered-sexps (coverage) ;; Count the number of source expressions that have been entered (regardless ;; of whether or not they are completely covered). - (let ((entered 0) (covered 0) (total 0)) + (let ((entered 0) (covered 0) (total 0) + (done (make-hash-table :test #'eq :shared nil))) (map-coverage-entry-notes coverage (lambda (note) (labels ((rec (note) - (when (code-note-source-note note) - #+debug (format t "~&~s" note) - (incf total) - (when (code-note-code-coverage note) - (incf entered) - (when (eq (code-note-code-coverage note) 'full) - (incf covered)))) - (loop for sub in (coverage-subnotes note) - unless (entry-code-note-p sub) do (rec sub)))) + (let ((source-note (code-note-source-note note))) + (when (and source-note (not (gethash source-note done))) + (setf (gethash source-note done) t) + (incf total) + (let ((data (source-coverage source-note))) + (when data + (incf entered) + (when (eq data 'full) + (incf covered))))) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub))))) (rec note)))) - (list total - entered (if (> total 0) (* 100.0d0 (/ entered total)) '--) - covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + (let ((stats (file-coverage-statistics coverage))) + (setf (coverage-expressions-total stats) total) + (setf (coverage-expressions-entered stats) entered) + (setf (coverage-expressions-covered stats) covered)))) (defun count-unreached-branches (coverage) @@ -956,5 +988,6 @@ unless (entry-code-note-p sub) do (rec sub note)))))) (rec note nil)))) - count)) + (let ((stats (file-coverage-statistics coverage))) + (setf (coverage-unreached-branches stats) count)))) (defun write-coverage-styles (html-stream)