mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Rearrange SB-COVER::REPORT-FILE
Break it up into pieces, so that we can write unit-ish tests for some of those components. Use that ability to write tests of the computation of character-by-character state for our test files, and include a new test of reading a suppressed form right before end-of-file.
This commit is contained in:
Christophe Rhodes
parent
fb6fca1d8c
commit
fe880f7a79
|
|
@ -367,97 +367,68 @@ report, otherwise ignored. The default value is CL:IDENTITY.
|
|||
(format html-stream "<html><head>")
|
||||
(write-styles html-stream)
|
||||
(format html-stream "</head><body>")
|
||||
(let* ((source (detabify (read-file file external-format)))
|
||||
(states (make-array (length source)
|
||||
:initial-element 0
|
||||
:element-type '(unsigned-byte 4)))
|
||||
(hashtable (code-coverage-hashtable))
|
||||
;; Convert the code coverage records to a more suitable format
|
||||
;; for this function.
|
||||
(expr-records (convert-records (gethash file hashtable) :expression))
|
||||
(branch-records (convert-records (gethash file hashtable) :branch))
|
||||
(multiple-value-bind (counts states source)
|
||||
(compute-file-info file external-format)
|
||||
(print-report html-stream file counts states source)
|
||||
(format html-stream "</body></html>")
|
||||
(list (getf counts :expression) (getf counts :branch))))
|
||||
|
||||
(defun compute-file-info (file external-format)
|
||||
;; Go through all records, find the matching source in the file,
|
||||
;; and update STATES to contain the state of the record in the
|
||||
;; indexes matching the source location.
|
||||
(let* ((source (read-source file external-format))
|
||||
;; Cache the source-maps
|
||||
(maps (with-input-from-string (stream source)
|
||||
(loop with *current-package* = (find-package "CL-USER")
|
||||
with map = nil
|
||||
with form = nil
|
||||
for i from 0
|
||||
do (setf (values form map)
|
||||
(handler-case (read-and-record-source-map stream)
|
||||
(error (error)
|
||||
(warn "Error when recording source map for toplevel form ~A:~% ~A" i error)
|
||||
(values nil (make-hash-table)))))
|
||||
when map collect (cons form map)
|
||||
when (eql form sb-int:*eof-object*) do (loop-finish)))))
|
||||
(mapcar (lambda (map)
|
||||
(maphash (lambda (k locations)
|
||||
(declare (ignore k))
|
||||
(dolist (location locations)
|
||||
(destructuring-bind (start end suppress) location
|
||||
(when suppress
|
||||
(fill-with-state source states 15 (1- start)
|
||||
end)))))
|
||||
(cdr map)))
|
||||
maps)
|
||||
;; Go through all records, find the matching source in the file,
|
||||
;; and update STATES to contain the state of the record in the
|
||||
;; indexes matching the source location. We do this in two stages:
|
||||
;; the first stage records the character ranges, and the second stage
|
||||
;; does the update, in order from shortest to longest ranges. This
|
||||
;; ensures that for each index in STATES will reflect the state of
|
||||
;; the innermost containing form.
|
||||
(let ((counts (list :branch (make-instance 'sample-count :mode :branch)
|
||||
:expression (make-instance 'sample-count
|
||||
:mode :expression))))
|
||||
(let ((records (append branch-records expr-records))
|
||||
(locations nil))
|
||||
(dolist (record records)
|
||||
(destructuring-bind (mode path state) record
|
||||
(let* ((path (reverse path))
|
||||
(tlf (car path))
|
||||
(source-form (car (nth tlf maps)))
|
||||
(source-map (cdr (nth tlf maps)))
|
||||
(source-path (cdr path)))
|
||||
(cond ((eql mode :branch)
|
||||
(let ((count (getf counts :branch)))
|
||||
;; For branches mode each record accounts for two paths
|
||||
(incf (ok-of count)
|
||||
(ecase state
|
||||
(5 2)
|
||||
((6 9) 1)
|
||||
(10 0)))
|
||||
(incf (all-of count) 2)))
|
||||
(t
|
||||
(let ((count (getf counts :expression)))
|
||||
(when (eql state 1)
|
||||
(incf (ok-of count)))
|
||||
(incf (all-of count)))))
|
||||
(if source-map
|
||||
(handler-case
|
||||
(multiple-value-bind (start end)
|
||||
(source-path-source-position (cons 0 source-path)
|
||||
source-form
|
||||
source-map)
|
||||
(push (list start end source state) locations))
|
||||
(error ()
|
||||
(warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
|
||||
(warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file)))))
|
||||
;; Now process the locations, from the shortest range to the longest
|
||||
;; one. If two locations have the same range, the one with the higher
|
||||
;; state takes precedence. The latter condition ensures that if
|
||||
;; there are both normal- and a branch-states for the same form,
|
||||
;; the branch-state will be used.
|
||||
(setf locations (sort locations #'> :key #'fourth))
|
||||
(dolist (location (stable-sort locations #'<
|
||||
:key (lambda (location)
|
||||
(- (second location)
|
||||
(first location)))))
|
||||
(destructuring-bind (start end source state) location
|
||||
(fill-with-state source states state start end))))
|
||||
(print-report html-stream file counts states source)
|
||||
(format html-stream "</body></html>")
|
||||
(list (getf counts :expression)
|
||||
(getf counts :branch)))))
|
||||
(maps (read-and-record-source-maps source))
|
||||
(states (initial-states source maps))
|
||||
(counts (list :branch (make-instance 'sample-count :mode :branch)
|
||||
:expression (make-instance 'sample-count :mode :expression)))
|
||||
(records (get-records file))
|
||||
;; We do this in two stages: the first stage records the
|
||||
;; character ranges, and the second stage does the update, in
|
||||
;; order from shortest to longest ranges. This ensures that
|
||||
;; for each index in STATES will reflect the state of the
|
||||
;; innermost containing form.
|
||||
(locations (get-locations-recording-counts records maps counts file)))
|
||||
;; Now process the locations, from the shortest range to the longest
|
||||
;; one. If two locations have the same range, the one with the higher
|
||||
;; state takes precedence. The latter condition ensures that if
|
||||
;; there are both normal- and branch-states for the same form,
|
||||
;; the branch-state will be used.
|
||||
(fill-states-from-locations source states locations)
|
||||
(values counts states source)))
|
||||
|
||||
(defun read-and-record-source-maps (source)
|
||||
(with-input-from-string (stream source)
|
||||
(loop with *current-package* = (find-package "CL-USER")
|
||||
with map = nil
|
||||
with form = nil
|
||||
for i from 0
|
||||
do (setf (values form map)
|
||||
(handler-case (read-and-record-source-map stream)
|
||||
(error (error)
|
||||
(warn "Error when recording source map for toplevel form ~A:~% ~A" i error)
|
||||
(values nil (make-hash-table)))))
|
||||
when map collect (cons form map)
|
||||
when (eql form sb-int:*eof-object*) do (loop-finish))))
|
||||
|
||||
(defun initial-states (source maps)
|
||||
(let ((states (make-array (length source) :initial-element 0 :element-type '(unsigned-byte 4))))
|
||||
;; we have read the source with our location-tracking reader; we
|
||||
;; now know what parts of the source were *READ-SUPPRESS*ed.
|
||||
(note-suppressions source states maps)
|
||||
states))
|
||||
|
||||
(defun note-suppressions (source states maps)
|
||||
(mapcar (lambda (map)
|
||||
(maphash (lambda (k locations)
|
||||
(declare (ignore k))
|
||||
(dolist (location locations)
|
||||
(destructuring-bind (start end suppress) location
|
||||
(when suppress
|
||||
(fill-with-state source states 15 (1- start) end)))))
|
||||
(cdr map)))
|
||||
maps))
|
||||
|
||||
(defun fill-with-state (source states state start end)
|
||||
(let* ((pos (position #\Newline source
|
||||
|
|
@ -503,6 +474,54 @@ report, otherwise ignored. The default value is CL:IDENTITY.
|
|||
(setf col -1))
|
||||
(write-char char stream))))))
|
||||
|
||||
(defun get-records (file)
|
||||
(let ((hashtable (code-coverage-hashtable)))
|
||||
;; Convert the code coverage records to a more suitable format for
|
||||
;; this function.
|
||||
(append (convert-records (gethash file hashtable) :expression)
|
||||
(convert-records (gethash file hashtable) :branch))))
|
||||
|
||||
(defun get-locations-recording-counts (records maps counts file)
|
||||
(let (locations)
|
||||
(dolist (record records locations)
|
||||
(destructuring-bind (mode path state) record
|
||||
(let* ((path (reverse path))
|
||||
(tlf (car path))
|
||||
(source-form (car (nth tlf maps)))
|
||||
(source-map (cdr (nth tlf maps)))
|
||||
(source-path (cdr path)))
|
||||
(cond ((eql mode :branch)
|
||||
(let ((count (getf counts :branch)))
|
||||
;; For branches mode each record accounts for two paths
|
||||
(incf (ok-of count)
|
||||
(ecase state
|
||||
(5 2)
|
||||
((6 9) 1)
|
||||
(10 0)))
|
||||
(incf (all-of count) 2)))
|
||||
(t
|
||||
(let ((count (getf counts :expression)))
|
||||
(when (eql state 1)
|
||||
(incf (ok-of count)))
|
||||
(incf (all-of count)))))
|
||||
(if source-map
|
||||
(handler-case
|
||||
(multiple-value-bind (start end)
|
||||
(source-path-source-position (cons 0 source-path) source-form source-map)
|
||||
(push (list start end state) locations))
|
||||
(error ()
|
||||
(warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
|
||||
(warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file)))))))
|
||||
|
||||
(defun fill-states-from-locations (source states locations)
|
||||
(setf locations (sort (copy-list locations) #'> :key #'third))
|
||||
(dolist (location (stable-sort locations #'<
|
||||
:key (lambda (location)
|
||||
(- (second location)
|
||||
(first location)))))
|
||||
(destructuring-bind (start end state) location
|
||||
(fill-with-state source states state start end))))
|
||||
|
||||
(defvar *counts* nil)
|
||||
|
||||
(defun print-report (html-stream file counts states source)
|
||||
|
|
@ -620,6 +639,9 @@ table.summary tr.subheading td { text-align: left; font-weight: bold; padding-le
|
|||
|
||||
;;;; A mutant version of swank-source-path-parser from Swank/Slime.
|
||||
|
||||
(defun read-source (filename external-format)
|
||||
(detabify (read-file filename external-format)))
|
||||
|
||||
(defun read-file (filename external-format)
|
||||
"Return the entire contents of FILENAME as a string."
|
||||
(with-open-file (s filename :direction :input
|
||||
|
|
|
|||
88
contrib/sb-cover/file-info-tests.lisp
Normal file
88
contrib/sb-cover/file-info-tests.lisp
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
;;;; Tests that we compute the right character-by-character state
|
||||
|
||||
(in-package "SB-COVER-TEST")
|
||||
|
||||
(sb-cover:clear-coverage)
|
||||
|
||||
(proclaim '(optimize sb-cover:store-coverage-data))
|
||||
(compile-load "test-data-1")
|
||||
(assert (equalp (get-states "test-data-1")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;( d e f u n t e s t 1 ( )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( + 1 2 ) )
|
||||
0 1 1 2 2 2 2 2 2 2 1 0)))
|
||||
|
||||
(test1)
|
||||
(assert (equalp (get-states "test-data-1")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;( d e f u n t e s t 1 ( )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( + 1 2 ) )
|
||||
0 1 1 1 1 1 1 1 1 1 1 0)))
|
||||
|
||||
(sb-cover:clear-coverage)
|
||||
(compile-load "test-data-2-only")
|
||||
(assert (equalp (get-states "test-data-2-only")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;( d e f u n t e s t 2 ( x )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( l e t ( ( a 0 ) )
|
||||
0 1 1 2 2 2 2 2 2 2 2 2 2 2 2
|
||||
;; ( w h e n ( p l u s p x )
|
||||
0 1 1 2 2 2 2 2 2 2 2 10 10 10 10 10 10 10 10 10
|
||||
;; ( i n c f a ) )
|
||||
0 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2
|
||||
;; a ) )
|
||||
0 1 1 2 2 2 2 1)))
|
||||
|
||||
(test2 1)
|
||||
(assert (equalp (get-states "test-data-2-only")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;( d e f u n t e s t 2 ( x )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( l e t ( ( a 0 ) )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( w h e n ( p l u s p x )
|
||||
0 1 1 1 1 1 1 1 1 1 1 9 9 9 9 9 9 9 9 9
|
||||
;; ( i n c f a ) )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; a ) )
|
||||
0 1 1 1 1 1 1 1)))
|
||||
|
||||
(test2 -1)
|
||||
(assert (equalp (get-states "test-data-2-only")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;( d e f u n t e s t 2 ( x )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( l e t ( ( a 0 ) )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; ( w h e n ( p l u s p x )
|
||||
0 1 1 1 1 1 1 1 1 1 1 5 5 5 5 5 5 5 5 5
|
||||
;; ( i n c f a ) )
|
||||
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
;; a ) )
|
||||
0 1 1 1 1 1 1 1)))
|
||||
|
||||
(sb-cover:clear-coverage)
|
||||
(compile-load "test-data-suppressed")
|
||||
(assert (equalp (get-states "test-data-suppressed")
|
||||
;;( i n - p a c k a g e s b - c o v e r - t e s t )
|
||||
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
0
|
||||
;;# - s b c l
|
||||
0 0 0 0 0 0 0
|
||||
;;( d e f u n s u p p r e s s e d ( x )
|
||||
0 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15 15
|
||||
;; ( 1 + x ) )
|
||||
0 15 15 15 15 15 15 15 15 15)))
|
||||
7
contrib/sb-cover/test-data-2-only.lisp
Normal file
7
contrib/sb-cover/test-data-2-only.lisp
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(in-package sb-cover-test)
|
||||
|
||||
(defun test2 (x)
|
||||
(let ((a 0))
|
||||
(when (plusp x)
|
||||
(incf a))
|
||||
a))
|
||||
5
contrib/sb-cover/test-data-suppressed.lisp
Normal file
5
contrib/sb-cover/test-data-suppressed.lisp
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
(in-package sb-cover-test)
|
||||
|
||||
#-sbcl
|
||||
(defun suppressed (x)
|
||||
(1+ x))
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
(defpackage "SB-COVER-TEST"
|
||||
(:export
|
||||
"*OUTPUT-DIRECTORY*" "*SOURCE-DIRECTORY*"
|
||||
"COMPILE-LOAD" "REPORT" "REPORT-EXPECT-FAILURE" "SOURCE-PATHNAME")
|
||||
"COMPILE-LOAD" "GET-STATES" "REPORT" "REPORT-EXPECT-FAILURE" "SOURCE-PATHNAME")
|
||||
(:use "CL"))
|
||||
|
||||
(defvar sb-cover-test:*output-directory*)
|
||||
|
|
@ -30,8 +30,14 @@
|
|||
(error "Should've signaled a warning"))
|
||||
(warning ())))
|
||||
|
||||
(defun sb-cover-test:get-states (x)
|
||||
(sb-cover::refresh-coverage-info)
|
||||
(nth-value 1 (sb-cover::compute-file-info (namestring (sb-cover-test:source-pathname x)) :default)))
|
||||
|
||||
(with-test (:name :sb-cover)
|
||||
(test-util:with-test-directory (sb-cover-test:*output-directory*)
|
||||
;; Weak pointers to toplevel forms need to survive the entire test run
|
||||
(sb-sys:without-gcing
|
||||
(load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*)))))
|
||||
(test-util:with-test-directory (sb-cover-test:*output-directory*)
|
||||
;; Weak pointers to toplevel forms need to survive the entire test run
|
||||
(sb-sys:without-gcing
|
||||
(load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*)))
|
||||
(sb-sys:without-gcing
|
||||
(load (merge-pathnames "file-info-tests.lisp" sb-cover-test:*source-directory*)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue