Changeset 14110 for branches/qres/ccl
- Timestamp:
- Aug 2, 2010, 9:18:48 PM (9 years ago)
- File:
-
- 1 edited
-
branches/qres/ccl/library/cover.lisp (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/qres/ccl/library/cover.lisp
r14058 r14110 58 58 (defparameter *code-note-acode-strings* (make-hash-table :test #'eq)) 59 59 60 (defparameter *coverage-acode-queue* nil)61 62 60 (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) 63 61 alist) … … 88 86 89 87 (defun code-note-acode-string (note) 90 (gethash note *code-note-acode-strings*)) 88 (and *code-note-acode-strings* 89 (gethash note *code-note-acode-strings*))) 91 90 92 91 (defun map-function-coverage (lfun fn &optional refs) … … 100 99 do (map-function-coverage imm fn refs)))) 101 100 102 (defun get-function-coverage (fn refs acode)101 (defun get-function-coverage (fn refs) 103 102 (let ((entry (function-entry-code-note fn)) 104 103 (refs (cons fn refs)) 105 (acode (or (%function-acode-string fn) acode))) 104 (acode (%function-acode-string fn)) 105 (source (function-source-form-note fn))) 106 106 (declare (dynamic-extent refs)) 107 107 (when entry … … 119 119 (setf (gethash imm *code-note-acode-strings*) acode))) 120 120 when (and (functionp imm) 121 (not (memq imm refs))) 122 nconc (get-function-coverage imm refs acode))))) 121 (not (memq imm refs)) 122 ;; Make sure this fn is in the source we're currently looking at. 123 ;; It might not be, if it is referenced via (load-time-value (foo)) 124 ;; where (foo) returns an lfun from some different source entirely. 125 ;; CL-PPCRE does that. 126 (or (null source) 127 (eq source (function-source-form-note imm)))) 128 nconc (get-function-coverage imm refs))))) 123 129 124 130 (defun code-covered-info.file (data) (and (consp data) (car data))) … … 140 146 (clrhash *emitted-code-notes*) 141 147 (clrhash *entry-code-notes*) 142 ( clrhash *code-note-acode-strings*)148 (when *code-note-acode-strings* (clrhash *code-note-acode-strings*)) 143 149 (loop for data in *code-covered-functions* 144 150 do (let* ((file (code-covered-info.file data)) 145 151 (toplevel-functions (code-covered-info.fns data))) 146 152 (when file 147 (push (list* file 148 ;; Duplicates are possible if you have multiple instances of 149 ;; (load-time-value (foo)) where (foo) returns an lfun. 150 ;; CL-PPCRE does that. 151 (delete-duplicates 152 (loop for fn across toplevel-functions 153 nconc (get-function-coverage fn nil nil))) 154 toplevel-functions) 155 *file-coverage*)))) 153 (let* ((all-functions (delete-duplicates 154 ;; Duplicates are possible if you have multiple instances of 155 ;; (load-time-value (foo)) where (foo) returns an lfun. 156 ;; CL-PPCRE does that. 157 (loop for fn across toplevel-functions 158 nconc (get-function-coverage fn nil)))) 159 (coverage (list* file all-functions toplevel-functions))) 160 (push coverage *file-coverage*))))) 156 161 ;; Now get subnotes, including un-emitted ones. 157 162 (loop for note being the hash-key of *emitted-code-notes* … … 159 164 while parent 160 165 do (pushnew n (gethash parent *coverage-subnotes*)) 161 until (emitted-code-note-p parent))) 162 (let ((hash (make-hash-table :test #'eq))) 163 ;; distribute entry acode to the toplevel source note it belongs to. 164 (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn) 165 as acode = (code-note-acode-string entry) 166 as sn = (entry-note-unambiguous-source entry) 167 as toplevel-sn = (function-source-form-note fn) 168 do (when sn 169 (assert toplevel-sn) 170 (let* ((pos (source-note-end-pos sn)) 171 (cell (assq acode (gethash toplevel-sn hash)))) 172 (if cell 173 (setf (cdr cell) (max (cdr cell) pos)) 174 (push (cons acode pos) (gethash toplevel-sn hash)))))) 175 (setf *coverage-acode-queue* 176 (sort (loop for sn being the hash-key of hash using (hash-value alist) 177 collect (cons (source-note-end-pos sn) 178 (mapcar #'car (sort alist #'< :key #'cdr)))) 179 #'< :key #'car)))) 166 until (emitted-code-note-p parent)))) 167 168 (defun file-coverage-acode-queue (coverage) 169 (loop with hash = (make-hash-table :test #'eq :shared nil) 170 for fn in (file-coverage-functions coverage) 171 as acode = (%function-acode-string fn) 172 as entry = (function-entry-code-note fn) 173 as sn = (entry-note-unambiguous-source entry) 174 as toplevel-sn = (function-source-form-note fn) 175 do (when sn 176 (assert toplevel-sn) 177 (let* ((pos (source-note-end-pos sn)) 178 (cell (assq acode (gethash toplevel-sn hash)))) 179 (if cell 180 (setf (cdr cell) (max (cdr cell) pos)) 181 (push (cons acode pos) (gethash toplevel-sn hash))))) 182 finally (return (sort (loop for sn being the hash-key of hash using (hash-value alist) 183 collect (cons (source-note-end-pos sn) 184 (mapcar #'car (sort alist #'< :key #'cdr)))) 185 #'< :key #'car)))) 180 186 181 187 #+debug … … 456 462 (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) 457 463 (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) 458 (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) 459 (get-coverage) 464 (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) 465 (*code-note-acode-strings* nil)) 466 (get-coverage) 460 467 (loop for coverage in *file-coverage* 461 468 as stats = (make-coverage-statistics :source-file (file-coverage-file coverage)) … … 502 509 (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) 503 510 (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) 511 (*code-note-acode-strings* (make-hash-table :test #'eq :shared nil)) 504 512 (index-file (and html (merge-pathnames output-file "index.html"))) 505 513 (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) … … 712 720 when (and (functionp imm) 713 721 (not (memq imm refs)) 714 ;; Make sure this fn is in the source we're currently looking at. 715 ;; It might not be, if it is referenced via (load-time-value (foo)) 716 ;; where (foo) returns an lfun from some different source entirely. 717 ;; CL-PPCRE does that. 722 ;; See note in get-function-coverage 718 723 (or (null source) 719 724 (eq source (function-source-form-note imm)) … … 736 741 :element-type '(unsigned-byte 2))) 737 742 (acode-styles (make-hash-table :test #'eq))) 738 (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage)) 743 (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) 744 (file-coverage-toplevel-functions coverage)) 739 745 (print-file-coverage-report index-file html-stream coverage styles acode-styles source) 740 746 (format html-stream "</body></html>"))) … … 758 764 759 765 ;; Output source intertwined with acode 760 (iterate output ((start 0) (line 0) )766 (iterate output ((start 0) (line 0) (queue (file-coverage-acode-queue coverage))) 761 767 (format html-stream "<div class='source'><code>") 762 (let ((next (car *coverage-acode-queue*)))768 (let ((next (car queue))) 763 769 (multiple-value-bind (end last-line) 764 765 766 767 770 (output-styled html-stream source styles 771 :start start 772 :line line 773 :limit (car next)) 768 774 (format html-stream "</code></div>~%") 769 775 (when (and next end (<= (car next) end)) … … 772 778 <div class='acode' id='a~:*~d'><code>" pos) 773 779 (loop for acode in strings as styles = (gethash acode acode-styles) 774 do (assert styles) 775 do (output-styled html-stream acode styles) 776 do (fresh-line html-stream)) 777 (format html-stream "</code></div><hr/>~%")) 778 (pop *coverage-acode-queue*) 779 (output (1+ end) last-line))))))) 780 do (assert styles) 781 do (when styles (output-styled html-stream acode styles)) 782 do (fresh-line html-stream)) 783 (format html-stream "</code></div><hr/>~%") 784 (output (1+ end) last-line (cdr queue))))))))) 780 785 781 786 (defun output-styled (html-stream source styles &key (start 0) line limit)
Note: See TracChangeset
for help on using the changeset viewer.
