Fix sequence type derivation in the presence of negation types.
[sbcl.git] / contrib / sb-cover / cover.lisp
blob78a09c54e63d46a1ab165eb03258d664e80849e7
1 ;;; A frontend for the SBCL code coverage facility. Written by Juho
2 ;;; Snellman, and placed under public domain.
4 ;;; This module includes a modified version of the source path parsing
5 ;;; routines from Swank. That code was written by Helmut Eller, and
6 ;;; was placed under Public Domain
8 (defpackage #:sb-cover
9 (:use #:cl #:sb-c)
10 (:export #:report
11 #:reset-coverage #:clear-coverage
12 #:restore-coverage #:restore-coverage-from-file
13 #:save-coverage #:save-coverage-in-file
14 #:store-coverage-data))
16 (in-package #:sb-cover)
18 (declaim (type (member :whole :car) *source-path-mode*))
19 (defvar *source-path-mode* :whole)
21 (defclass sample-count ()
22 ((mode :accessor mode-of :initarg :mode)
23 (all :accessor all-of :initform 0)
24 (ok :accessor ok-of :initform 0)))
26 (defun clear-coverage ()
27 "Clear all files from the coverage database. The files will be re-entered
28 into the database when the FASL files (produced by compiling
29 STORE-COVERAGE-DATA optimization policy set to 3) are loaded again into the
30 image."
31 (sb-c::clear-code-coverage))
33 (defun reset-coverage ()
34 "Reset all coverage data back to the `Not executed` state."
35 (sb-c::reset-code-coverage))
37 (defun save-coverage ()
38 "Returns an opaque representation of the current code coverage state.
39 The only operation that may be done on the state is passing it to
40 RESTORE-COVERAGE. The representation is guaranteed to be readably printable.
41 A representation that has been printed and read back will work identically
42 in RESTORE-COVERAGE."
43 (loop for file being the hash-keys of sb-c::*code-coverage-info*
44 using (hash-value states)
45 collect (cons file states)))
47 (defun restore-coverage (coverage-state)
48 "Restore the code coverage data back to an earlier state produced by
49 SAVE-COVERAGE."
50 (loop for (file . states) in coverage-state
51 do (let ((image-states (gethash file sb-c::*code-coverage-info*))
52 (table (make-hash-table :test 'equal)))
53 (when image-states
54 (loop for cons in image-states
55 do (setf (gethash (car cons) table) cons))
56 (loop for (key . value) in states
57 do (let ((state (gethash key table)))
58 (when state
59 (setf (cdr state) value))))))))
61 (defun save-coverage-in-file (pathname)
62 "Call SAVE-COVERAGE and write the results of that operation into the
63 file designated by PATHNAME."
64 (with-open-file (stream pathname
65 :direction :output
66 :if-exists :supersede
67 :if-does-not-exist :create)
68 (with-standard-io-syntax
69 (let ((*package* (find-package :sb-cover)))
70 (write (save-coverage) :stream stream)))
71 (values)))
73 (defun restore-coverage-from-file (pathname)
74 "READ the contents of the file designated by PATHNAME and pass the
75 result to RESTORE-COVERAGE."
76 (with-open-file (stream pathname :direction :input)
77 (with-standard-io-syntax
78 (let ((*package* (find-package :sb-cover)))
79 (restore-coverage (read stream))))
80 (values)))
82 (defun pathname-as-directory (pathname &optional (errorp t))
83 (let ((pathname (merge-pathnames pathname)))
84 (if (and (member (pathname-name pathname) '(nil :unspecific))
85 (member (pathname-type pathname) '(nil :unspecific)))
86 pathname
87 (if errorp
88 (error "~S does not designate a directory" pathname)
89 (make-pathname :directory (append (or (pathname-directory pathname)
90 (list :relative))
91 (list (file-namestring pathname)))
92 :name nil :type nil :version nil
93 :defaults pathname)))))
95 (defun report (directory &key ((:form-mode *source-path-mode*) :whole)
96 (external-format :default))
97 "Print a code coverage report of all instrumented files into DIRECTORY.
98 If DIRECTORY does not exist, it will be created. The main report will be
99 printed to the file cover-index.html. The external format of the source
100 files can be specified with the EXTERNAL-FORMAT parameter.
102 If the keyword argument FORM-MODE has the value :CAR, the annotations in
103 the coverage report will be placed on the CARs of any cons-forms, while if
104 it has the value :WHOLE the whole form will be annotated (the default).
105 The former mode shows explicitly which forms were instrumented, while the
106 latter mode is generally easier to read."
107 (let* ((paths)
108 (directory (pathname-as-directory directory))
109 (*default-pathname-defaults* (translate-logical-pathname directory)))
110 (ensure-directories-exist *default-pathname-defaults*)
111 (maphash (lambda (k v)
112 (declare (ignore v))
113 (let* ((pk (translate-logical-pathname k))
114 (n (format nil "~(~{~2,'0X~}~)"
115 (coerce (sb-md5:md5sum-string
116 (sb-ext:native-namestring pk))
117 'list)))
118 (path (make-pathname :name n :type "html" :defaults directory)))
119 (when (probe-file k)
120 (ensure-directories-exist pk)
121 (with-open-file (stream path
122 :direction :output
123 :if-exists :supersede
124 :if-does-not-exist :create)
125 (push (list* k n (report-file k stream external-format))
126 paths)))))
127 *code-coverage-info*)
128 (let ((report-file (make-pathname :name "cover-index" :type "html" :defaults directory)))
129 (with-open-file (stream report-file
130 :direction :output :if-exists :supersede
131 :if-does-not-exist :create)
132 (write-styles stream)
133 (unless paths
134 (warn "No coverage data found for any file, producing an empty report. Maybe you~%forgot to (DECLAIM (OPTIMIZE SB-COVER:STORE-COVERAGE-DATA))?")
135 (format stream "<h3>No code coverage data found.</h3>")
136 (close stream)
137 (return-from report))
138 (format stream "<table class='summary'>")
139 (format stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expression</td><td class='main-head' colspan='3'>Branch</td></tr>")
140 (format stream "<tr class='head-row'>~{<td width='80px'>~A</td>~}</tr>"
141 (list "Source file"
142 "Covered" "Total" "%"
143 "Covered" "Total" "%"))
144 (setf paths (sort paths #'string< :key #'car))
145 (loop for prev = nil then source-file
146 for (source-file report-file expression branch) in paths
147 for even = nil then (not even)
148 do (when (or (null prev)
149 (not (equal (pathname-directory (pathname source-file))
150 (pathname-directory (pathname prev)))))
151 (format stream "<tr class='subheading'><td colspan='7'>~A</td></tr>~%"
152 (namestring (make-pathname :directory (pathname-directory (pathname source-file))))))
153 do (format stream "<tr class='~:[odd~;even~]'><td class='text-cell'><a href='~a.html'>~a</a></td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f~]</td>~}</tr>"
154 even
155 report-file
156 (enough-namestring (pathname source-file)
157 (pathname source-file))
158 (list (ok-of expression)
159 (all-of expression)
160 (percent expression)
161 (ok-of branch)
162 (all-of branch)
163 (percent branch))))
164 (format stream "</table>"))
165 report-file)))
167 (defun percent (count)
168 (unless (zerop (all-of count))
169 (* 100
170 (/ (ok-of count) (all-of count)))))
172 (defun report-file (file html-stream external-format)
173 "Print a code coverage report of FILE into the stream HTML-STREAM."
174 (format html-stream "<html><head>")
175 (write-styles html-stream)
176 (format html-stream "</head><body>")
177 (let* ((source (detabify (read-file file external-format)))
178 (states (make-array (length source)
179 :initial-element 0
180 :element-type '(unsigned-byte 4)))
181 ;; Convert the code coverage records to a more suitable format
182 ;; for this function.
183 (expr-records (convert-records (gethash file *code-coverage-info*)
184 :expression))
185 (branch-records (convert-records (gethash file *code-coverage-info*)
186 :branch))
187 ;; Cache the source-maps
188 (maps (with-input-from-string (stream source)
189 (loop with map = nil
190 with form = nil
191 with eof = nil
192 for i from 0
193 do (setf (values form map)
194 (handler-case
195 (read-and-record-source-map stream)
196 (end-of-file ()
197 (setf eof t))
198 (error (error)
199 (warn "Error when recording source map for toplevel form ~A:~% ~A" i error)
200 (values nil
201 (make-hash-table)))))
202 until eof
203 when map
204 collect (cons form map)))))
205 (mapcar (lambda (map)
206 (maphash (lambda (k locations)
207 (declare (ignore k))
208 (dolist (location locations)
209 (destructuring-bind (start end suppress) location
210 (when suppress
211 (fill-with-state source states 15 (1- start)
212 end)))))
213 (cdr map)))
214 maps)
215 ;; Go through all records, find the matching source in the file,
216 ;; and update STATES to contain the state of the record in the
217 ;; indexes matching the source location. We do this in two stages:
218 ;; the first stage records the character ranges, and the second stage
219 ;; does the update, in order from shortest to longest ranges. This
220 ;; ensures that for each index in STATES will reflect the state of
221 ;; the innermost containing form.
222 (let ((counts (list :branch (make-instance 'sample-count :mode :branch)
223 :expression (make-instance 'sample-count
224 :mode :expression))))
225 (let ((records (append branch-records expr-records))
226 (locations nil))
227 (dolist (record records)
228 (destructuring-bind (mode path state) record
229 (let* ((path (reverse path))
230 (tlf (car path))
231 (source-form (car (nth tlf maps)))
232 (source-map (cdr (nth tlf maps)))
233 (source-path (cdr path)))
234 (cond ((eql mode :branch)
235 (let ((count (getf counts :branch)))
236 ;; For branches mode each record accounts for two paths
237 (incf (ok-of count)
238 (ecase state
239 (5 2)
240 ((6 9) 1)
241 (10 0)))
242 (incf (all-of count) 2)))
244 (let ((count (getf counts :expression)))
245 (when (eql state 1)
246 (incf (ok-of count)))
247 (incf (all-of count)))))
248 (if source-map
249 (handler-case
250 (multiple-value-bind (start end)
251 (source-path-source-position (cons 0 source-path)
252 source-form
253 source-map)
254 (push (list start end source state) locations))
255 (error ()
256 (warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
257 (warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file)))))
258 ;; Now process the locations, from the shortest range to the longest
259 ;; one. If two locations have the same range, the one with the higher
260 ;; state takes precedence. The latter condition ensures that if
261 ;; there are both normal- and a branch-states for the same form,
262 ;; the branch-state will be used.
263 (setf locations (sort locations #'> :key #'fourth))
264 (dolist (location (stable-sort locations #'<
265 :key (lambda (location)
266 (- (second location)
267 (first location)))))
268 (destructuring-bind (start end source state) location
269 (fill-with-state source states state start end))))
270 (print-report html-stream file counts states source)
271 (format html-stream "</body></html>")
272 (list (getf counts :expression)
273 (getf counts :branch)))))
275 (defun fill-with-state (source states state start end)
276 (let* ((pos (position #\Newline source
277 :end start
278 :from-end t))
279 (start-column (if pos
280 (- start 1 pos)
282 (end-column 0))
283 (loop for i from start below end
284 for col from start-column
285 for char = (aref source i)
286 do (cond ((eql char #\Newline)
287 (setf col -1))
288 ((not (eql char #\Space))
289 (setf end-column (max end-column col)))))
290 (loop for i from start below end
291 for col from start-column
292 for char = (aref source i)
293 do (if (eql char #\Newline)
294 (setf col -1)
295 (when (and (zerop (aref states i))
296 #+nil (<= col end-column)
297 (>= col start-column))
298 (setf (aref states i) state))))))
300 ;;; Convert tabs to spaces
301 (defun detabify (source)
302 (with-output-to-string (stream)
303 (loop for char across source
304 for col from 0
305 for i from 0
306 do (if (eql char #\Tab)
307 (loop repeat (- 8 (mod col 8))
308 do (write-char #\Space stream)
309 do (incf col)
310 finally (decf col))
311 (progn
312 (when (eql char #\Newline)
313 ;; Filter out empty last line
314 (when (eql i (1- (length source)))
315 (return))
316 (setf col -1))
317 (write-char char stream))))))
319 (defvar *counts* nil)
321 (defun print-report (html-stream file counts states source)
322 ;; Just used for testing
323 (setf *counts* counts)
324 (let ((*print-case* :downcase))
325 (format html-stream
326 "<h3>Coverage report: ~a <br />~%</h3>~%" file)
327 (when (zerop (all-of (getf counts :expression)))
328 (format html-stream "<b>File has no instrumented forms</b>")
329 (return-from print-report))
330 (format html-stream "<table class='summary'><tr class='head-row'>~{<td width='80px'>~a</td>~}"
331 (list "Kind" "Covered" "All" "%"))
332 (dolist (mode '(:expression :branch))
333 (let ((count (getf counts mode)))
334 (format html-stream "<tr class='~:[odd~;even~]'><td>~A</td><td>~a</td><td>~a</td><td>~5,1F</td></tr>~%"
335 (eql mode :branch)
336 mode
337 (ok-of count)
338 (all-of count)
339 (percent count))))
340 (format html-stream "</table>"))
341 (format html-stream "<div class='key'><b>Key</b><br />~%")
342 (format html-stream "<div class='state-0'>Not instrumented</div>")
343 (format html-stream "<div class='state-15'>Conditionalized out</div>")
344 (format html-stream "<div class='state-1'>Executed</div>")
345 (format html-stream "<div class='state-2'>Not executed</div>")
346 (format html-stream "<div>&#160;</div>")
347 (format html-stream "<div class='state-5'>Both branches taken</div>")
348 (format html-stream "<div class='state-6'>One branch taken</div>")
349 (format html-stream "<div class='state-10''>Neither branch taken</div>")
350 (format html-stream "</div>")
351 (format html-stream "<nobr><div><code>~%")
352 (flet ((line (line)
353 (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
354 line))
355 (loop for last-state = nil then state
356 with line = (line 1)
357 for col from 1
358 for char across source
359 for state across states
360 do (unless (eq state last-state)
361 (when last-state
362 (format html-stream "</span>"))
363 (format html-stream "<span class='state-~a'>" state))
364 do (case char
365 ((#\Newline)
366 (setf state nil)
367 (setf col 0)
368 (format html-stream "</span>")
369 (line (incf line)))
370 ((#\Space)
371 (format html-stream "&#160;"))
372 ((#\Tab)
373 (error "tab"))
375 (if (alphanumericp char)
376 (write-char char html-stream)
377 (format html-stream "&#~A;" (char-code char))))))
378 (format html-stream "</code></div>")))
380 (defun write-styles (html-stream)
381 (format html-stream "<style type='text/css'>
382 *.state-0 { background-color: #eeeeee }
383 *.state-1 { background-color: #aaffaa }
384 *.state-5 { background-color: #44dd44 }
385 *.state-2 { background-color: #ffaaaa }
386 *.state-10 { background-color: #ee6666 }
387 *.state-15 { color: #aaaaaa; background-color: #eeeeee }
388 *.state-9,*.state-6 { background-color: #ffffaa }
389 div.key { margin: 20px; width: 200px }
390 div.source { width: 88ex; background-color: #eeeeee; padding-left: 5px;
391 /* border-style: solid none none none; border-width: 1px;
392 border-color: #dddddd */ }
394 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
396 table.summary tr.head-row { background-color: #aaaaff }
397 table.summary tr td.text-cell { text-align: left }
398 table.summary tr td.main-head { text-align: center }
399 table.summary tr td { text-align: right }
400 table.summary tr.even { background-color: #eeeeff }
401 table.summary tr.subheading { background-color: #aaaaff}
402 table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
403 </style>"))
405 (defun convert-records (records mode)
406 (ecase mode
407 (:expression
408 (loop for record in records
409 unless (member (caar record) '(:then :else))
410 collect (list mode
411 (car record)
412 (if (sb-c::code-coverage-record-marked record)
414 2))))
415 (:branch
416 (let ((hash (make-hash-table :test 'equal)))
417 (dolist (record records)
418 (let ((path (car record)))
419 (when (member (car path) '(:then :else))
420 (setf (gethash (cdr path) hash)
421 (logior (gethash (cdr path) hash 0)
422 (ash (if (sb-c::code-coverage-record-marked record)
425 (if (eql (car path) :then)
427 2)))))))
428 (let ((list nil))
429 (maphash (lambda (k v)
430 (push (list mode k v) list))
431 hash)
432 list)))))
434 ;;;; A mutant version of swank-source-path-parser from Swank/Slime.
436 (defun read-file (filename external-format)
437 "Return the entire contents of FILENAME as a string."
438 (with-open-file (s filename :direction :input
439 :external-format external-format)
440 (let ((string (make-string (file-length s))))
441 (read-sequence string s)
442 string)))
444 (defun make-source-recorder (fn source-map)
445 "Return a macro character function that does the same as FN, but
446 additionally stores the result together with the stream positions
447 before and after of calling FN in the hashtable SOURCE-MAP."
448 (declare (type (or function symbol) fn))
449 (lambda (stream char)
450 (declare (optimize debug safety))
451 (let ((start (file-position stream))
452 (values (multiple-value-list (funcall fn stream char)))
453 (end (file-position stream)))
454 (unless (null values)
455 (push (list start end *read-suppress*)
456 (gethash (car values) source-map)))
457 (values-list values))))
459 (defun make-source-recording-readtable (readtable source-map)
460 "Return a source position recording copy of READTABLE.
461 The source locations are stored in SOURCE-MAP."
462 (let* ((tab (copy-readtable readtable))
463 (*readtable* tab))
464 ;; It is unspecified whether doing (SET-MACRO-CHARACTER c1 fn)
465 ;; and then (SET-DISPATCH-MACRO-CHARACTER c1 c2 fn) should be allowed.
466 ;; Portability concerns aside, it doesn't work in the latest code,
467 ;; but first changing the function for #. and then # in that order works.
468 (suppress-sharp-dot tab)
469 (dotimes (code 128)
470 (let ((char (code-char code)))
471 (multiple-value-bind (fn term) (get-macro-character char tab)
472 (when fn
473 (set-macro-character char (make-source-recorder fn source-map)
474 term tab)))))
475 (set-macro-character #\(
476 (make-source-recorder
477 (make-recording-read-list source-map)
478 source-map))
479 tab))
481 ;;; Ripped from SB-IMPL, since location recording on a cons-cell level
482 ;;; can't be done just by simple read-table tricks.
483 (defun make-recording-read-list (source-map)
484 (lambda (stream ignore)
485 (block return
486 (when (eql *package* (find-package :keyword))
487 (return-from return
488 (sb-impl::read-list stream ignore)))
489 (let* ((thelist (list nil))
490 (listtail thelist))
491 (do ((firstchar (sb-impl::flush-whitespace stream)
492 (sb-impl::flush-whitespace stream)))
493 ((char= firstchar #\) ) (cdr thelist))
494 (when (char= firstchar #\.)
495 (let ((nextchar (read-char stream t)))
496 (cond ((sb-impl::token-delimiterp nextchar)
497 (cond ((eq listtail thelist)
498 (unless *read-suppress*
499 (sb-int:simple-reader-error
500 stream
501 "Nothing appears before . in list.")))
502 ((sb-impl::whitespace[2]p nextchar)
503 (setq nextchar (sb-impl::flush-whitespace stream))))
504 (rplacd listtail
505 (sb-impl::read-after-dot
506 stream nextchar (if *read-suppress* 0 -1)))
507 (return (cdr thelist)))
508 ;; Put back NEXTCHAR so that we can read it normally.
509 (t (unread-char nextchar stream)))))
510 ;; Next thing is not an isolated dot.
511 (sb-int:binding*
512 ((start (file-position stream))
513 ((winp obj) (sb-impl::read-maybe-nothing stream firstchar))
514 (listobj (if (not (zerop winp)) (list obj)))
515 (end (file-position stream)))
516 ;; allows the possibility that a comment was read
517 (when listobj
518 (unless (consp (car listobj))
519 (setf (car listobj) (gensym))
520 (push (list start end *read-suppress*)
521 (gethash (car listobj) source-map)))
522 (rplacd listtail listobj)
523 (setq listtail listobj))))))))
525 (defun suppress-sharp-dot (readtable)
526 (when (get-macro-character #\# readtable)
527 (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
528 (set-dispatch-macro-character #\# #\.
529 (lambda (&rest args)
530 (let ((*read-suppress* t))
531 (apply sharp-dot args)))
532 readtable))))
534 (defun read-and-record-source-map (stream)
535 "Read the next object from STREAM.
536 Return the object together with a hashtable that maps
537 subexpressions of the object to stream positions."
538 (let* ((source-map (make-hash-table :test #'eq))
539 (*readtable* (make-source-recording-readtable *readtable* source-map))
540 (start (file-position stream))
541 (form (read stream))
542 (end (file-position stream)))
543 ;; ensure that at least FORM is in the source-map
544 (unless (gethash form source-map)
545 (push (list start end nil)
546 (gethash form source-map)))
547 (values form source-map)))
549 (defun read-source-form (n stream)
550 "Read the Nth toplevel form number with source location recording.
551 Return the form and the source-map."
552 (let ((*read-suppress* t))
553 (dotimes (i n)
554 (read stream)))
555 (let ((*read-suppress* nil)
556 (*read-eval* nil))
557 (read-and-record-source-map stream)))
559 (defun source-path-stream-position (path stream)
560 "Search the source-path PATH in STREAM and return its position."
561 (check-source-path path)
562 (destructuring-bind (tlf-number . path) path
563 (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
564 (source-path-source-position (cons 0 path) form source-map))))
566 (defun check-source-path (path)
567 (unless (and (consp path)
568 (every #'integerp path))
569 (error "The source-path ~S is not valid." path)))
571 (defun source-path-string-position (path string)
572 (with-input-from-string (s string)
573 (source-path-stream-position path s)))
575 (defun source-path-file-position (path filename)
576 (with-open-file (file filename)
577 (source-path-stream-position path file)))
579 (defun source-path-source-position (path form source-map)
580 "Return the start position of PATH from FORM and SOURCE-MAP. All
581 subforms along the path are considered and the start and end position
582 of the deepest (i.e. smallest) possible form is returned."
583 ;; compute all subforms along path
584 (let ((forms (loop for n in path
585 for f = form then (nth n f)
586 collect f into forms
587 finally (return forms))))
588 ;; select the first subform present in source-map
589 (loop for real-form in (reverse forms)
590 for form = (if (or (eql *source-path-mode* :whole)
591 (not (consp real-form)))
592 real-form
593 (car real-form))
594 for positions = (gethash form source-map)
595 until (and positions (null (cdr positions)))
596 finally (destructuring-bind ((start end suppress)) positions
597 (declare (ignore suppress))
598 (return (values (1- start) end))))))