Changeset 14044
- Timestamp:
- Jul 26, 2010, 1:18:34 PM (11 years ago)
- Location:
- trunk/source
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/compiler/lambda-list.lisp
r13067 r14044 35 35 (defun function-source-note (fn) 36 36 (getf (%lfun-info fn) '%function-source-note)) 37 38 (defun %function-acode-string (fn) 39 (getf (%lfun-info fn) '%function-acode-string)) 37 40 38 41 (defun uncompile-function (fn) -
trunk/source/compiler/nx-basic.lisp
r13971 r14044 738 738 739 739 (defun nx-record-code-coverage-acode (afunc) 740 (assert (and *nx-current-code-note* (null (afunc-parent afunc))))740 (assert *nx-current-code-note*) 741 741 (let* ((form->note (make-hash-table :test #'eq)) 742 742 (*nx-acode-inner-refs* nil) … … 776 776 (setf (code-note-acode-range note) 777 777 (encode-file-range start pos)))))))))))))) 778 (setf (afunc-lfun-info afunc) (list* '%function-acode-string string (afunc-lfun-info afunc))) 778 (iterate store ((afunc afunc)) 779 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string) 780 (loop for inner in (afunc-inner-functions afunc) 781 unless (getf (afunc-lfun-info inner) '%function-acode-string) 782 do (store inner))) 779 783 afunc)) 780 784 -
trunk/source/library/cover.lisp
r12300 r14044 47 47 without-compiling-code-coverage)) 48 48 49 (defconstant $not-executed-style 2) 50 (defconstant $totally-covered-style 5) 51 (defconstant $partially-covered-style 6) 49 (defconstant $no-style 0) 50 (defconstant $not-executed-style 1) 51 (defconstant $totally-covered-style 2) 52 (defconstant $partially-covered-style 3) 52 53 53 54 (defparameter *file-coverage* ()) … … 55 56 (defparameter *emitted-code-notes* (make-hash-table :test #'eq)) 56 57 (defparameter *entry-code-notes* (make-hash-table :test #'eq)) 57 58 (defparameter *code-note-acode-strings* (make-hash-table :test #'eq)) 59 60 (defparameter *coverage-acode-queue* nil) 58 61 59 62 (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) … … 83 86 (defun entry-code-note-p (note) 84 87 (gethash note *entry-code-notes*)) 88 89 (defun code-note-acode-string (note) 90 (gethash note *code-note-acode-strings*)) 85 91 86 92 (defun map-function-coverage (lfun fn &optional refs) … … 94 100 do (map-function-coverage imm fn refs)))) 95 101 96 (defun get-function-coverage (fn refs )102 (defun get-function-coverage (fn refs acode) 97 103 (let ((entry (function-entry-code-note fn)) 98 (refs (cons fn refs))) 104 (refs (cons fn refs)) 105 (acode (or (%function-acode-string fn) acode))) 99 106 (declare (dynamic-extent refs)) 100 107 (when entry 101 108 (assert (eq fn (gethash entry *entry-code-notes* fn))) 102 (setf (gethash entry *entry-code-notes*) fn)) 109 (setf (gethash entry *entry-code-notes*) fn) 110 (when acode 111 (setf (gethash entry *code-note-acode-strings*) acode))) 103 112 (nconc 104 113 (and entry (list fn)) 105 114 (lfunloop for imm in fn 106 115 when (code-note-p imm) 107 do (setf (gethash imm *emitted-code-notes*) t) 116 do (progn 117 (setf (gethash imm *emitted-code-notes*) t) 118 (when acode 119 (setf (gethash imm *code-note-acode-strings*) acode))) 108 120 when (and (functionp imm) 109 121 (not (memq imm refs))) 110 nconc (get-function-coverage imm refs )))))122 nconc (get-function-coverage imm refs acode))))) 111 123 112 124 (defun get-coverage () … … 115 127 (clrhash *emitted-code-notes*) 116 128 (clrhash *entry-code-notes*) 129 (clrhash *code-note-acode-strings*) 117 130 (loop for data in *code-covered-functions* 118 131 when (consp data) … … 124 137 (delete-duplicates 125 138 (loop for fn across toplevel-functions 126 nconc (get-function-coverage fn nil )))139 nconc (get-function-coverage fn nil nil))) 127 140 toplevel-functions) 128 141 *file-coverage*))) … … 132 145 while parent 133 146 do (pushnew n (gethash parent *coverage-subnotes*)) 134 until (emitted-code-note-p parent)))) 147 until (emitted-code-note-p parent))) 148 (let ((hash (make-hash-table :test #'eq))) 149 ;; distribute entry acode to the toplevel source note it belongs to. 150 (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn) 151 as acode = (code-note-acode-string entry) 152 as sn = (entry-note-unambiguous-source entry) 153 as toplevel-sn = (function-source-form-note fn) 154 do (when sn 155 (assert toplevel-sn) 156 (let* ((pos (source-note-end-pos sn)) 157 (cell (assq acode (gethash toplevel-sn hash)))) 158 (if cell 159 (setf (cdr cell) (max (cdr cell) pos)) 160 (push (cons acode pos) (gethash toplevel-sn hash)))))) 161 (setf *coverage-acode-queue* 162 (sort (loop for sn being the hash-key of hash using (hash-value alist) 163 collect (cons (source-note-end-pos sn) 164 (mapcar #'car (sort alist #'< :key #'cdr)))) 165 #'< :key #'car)))) 135 166 136 167 #+debug … … 145 176 (when (entry-code-note-p note) 146 177 (format t " (Entry to ~s)" (entry-code-note-p note))) 178 (when (code-note-acode-range note) 179 (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note)) 180 (format t " [acode ~a:~a]" s e))) 147 181 (format t "~%") 148 182 (when (code-note-p note) … … 531 565 532 566 567 (defun style-for-coverage (coverage) 568 (case coverage 569 ((full) $totally-covered-style) 570 ((nil) $not-executed-style) 571 (t $partially-covered-style))) 572 533 573 (defun fill-with-text-style (coverage location-note styles) 534 (let ((style (case coverage 535 ((full) $totally-covered-style) 536 ((nil) $not-executed-style) 537 (t $partially-covered-style)))) 538 (fill styles style 539 :start (source-note-start-pos location-note) 540 :end (source-note-end-pos location-note)))) 574 (fill styles (style-for-coverage coverage) 575 :start (source-note-start-pos location-note) 576 :end (source-note-end-pos location-note))) 541 577 542 578 (defun update-text-styles (note styles) … … 600 636 (return sn)))) 601 637 602 603 (defun colorize-function (fn styles &optional refs) 638 (defun colorize-acode (fn acode-styles) 639 (let* ((acode (%function-acode-string fn)) 640 (note (function-entry-code-note fn)) 641 (range (and note (code-note-acode-range note)))) 642 (when (and acode range) 643 (let ((styles (or (gethash acode acode-styles) 644 (setf (gethash acode acode-styles) 645 (make-array (length acode) 646 :initial-element $no-style 647 :element-type '(unsigned-byte 2)))))) 648 (iterate update ((note note)) 649 (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note)) 650 (when (and start 651 (setq start (position-if-not #'whitespacep acode :start start :end end))) 652 (fill styles (style-for-coverage (code-note-code-coverage note)) 653 :start start 654 :end end))) 655 (loop for sub in (coverage-subnotes note) 656 unless (entry-code-note-p sub) 657 do (update sub))))))) 658 659 (defun colorize-function (fn styles acode-styles &optional refs) 604 660 (let* ((note (function-entry-code-note fn)) 605 661 (source (function-source-form-note fn)) … … 608 664 ;; Colorize the body of the function 609 665 (when note 610 (colorize-source-note note styles)) 666 (colorize-source-note note styles) 667 (colorize-acode fn acode-styles)) 611 668 ;; And now any subfunction references 612 669 (lfunloop for imm in fn … … 622 679 (warn "Ignoring ref to ~s from ~s" imm fn) 623 680 nil))) 624 do (colorize-function imm styles refs))))681 do (colorize-function imm styles acode-styles refs)))) 625 682 626 683 (defun report-file-coverage (index-file coverage html-stream external-format) … … 634 691 string))) 635 692 (styles (make-array (length source) 636 :initial-element 0 637 :element-type '(unsigned-byte 2)))) 638 (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) 639 (print-file-coverage-report index-file html-stream coverage styles source) 693 :initial-element $no-style 694 :element-type '(unsigned-byte 2))) 695 (acode-styles (make-hash-table :test #'eq))) 696 (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage)) 697 (print-file-coverage-report index-file html-stream coverage styles acode-styles source) 640 698 (format html-stream "</body></html>"))) 641 699 642 (defun print-file-coverage-report (index-file html-stream coverage styles source)700 (defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source) 643 701 (let ((*print-case* :downcase)) 644 702 (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%" … … 652 710 653 711 (format html-stream "<div class='key'><b>Key</b><br />~%") 654 (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) 655 (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) 656 (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style) 657 (format html-stream "<p></p><div><code>~%") 658 659 (flet ((line (line) 660 (unless (eql line 0) 661 (format html-stream "</span>")) 662 (incf line) 663 (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code> " line) 664 line)) 665 (loop with line = (line 0) with col = 0 666 for last-style = nil then style 667 for char across source 668 for style across styles 669 do (unless (eq style last-style) 670 (when last-style 671 (format html-stream "</span>")) 672 (format html-stream "<span class='state-~a'>" style)) 712 (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) 713 (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) 714 (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style) 715 (format html-stream "</div><p></p>~%") 716 717 ;; Output source intertwined with acode 718 (iterate output ((start 0) (line 0)) 719 (format html-stream "<div class='source'><code>") 720 (let ((next (car *coverage-acode-queue*))) 721 (multiple-value-bind (end last-line) 722 (output-styled html-stream source styles 723 :start start 724 :line line 725 :limit (car next)) 726 (format html-stream "</code></div>~%") 727 (when (and next end (<= (car next) end)) 728 (destructuring-bind (pos . strings) next 729 (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~ 730 <div class='acode' id='a~:*~d'><code>" pos) 731 (loop for acode in strings as styles = (gethash acode acode-styles) 732 do (assert styles) 733 do (output-styled html-stream acode styles) 734 do (fresh-line html-stream)) 735 (format html-stream "</code></div><hr/>~%")) 736 (pop *coverage-acode-queue*) 737 (output (1+ end) last-line))))))) 738 739 (defun output-styled (html-stream source styles &key (start 0) line limit) 740 (let ((last-style $no-style) 741 (col 0) 742 (line line)) 743 (labels ((outch (char) 744 (if (eql char #\Tab) 745 (dotimes (i (- 8 (mod col 8))) 746 (incf col) 747 (write-string " " html-stream)) 748 (progn 749 (incf col) 750 (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe 751 (write-char char html-stream) 752 (format html-stream "&#~D;" (char-code char)))))) 753 (start-line () 754 (when line 755 (incf line) 756 (format html-stream "<span class='line'>~A</span>" line)) 757 (write-char #\space html-stream) 758 (setq col 0)) 759 (set-style (new) 760 (unless (eq last-style new) 761 (unless (eq last-style $no-style) (format html-stream "</span>")) 762 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new)) 763 (setq last-style new))) 764 (end-line () 765 (set-style $no-style) 766 (format html-stream "~%"))) 767 (declare (inline outch start-line end-line)) 768 (unless limit (setq limit (length source))) 769 (start-line) 770 (loop 771 for pos from start below (length source) 772 as char = (aref source pos) as style = (aref styles pos) 773 do (set-style style) 673 774 do (case char 674 775 ((#\Newline) 675 (setq style nil) 676 (setq col 0) 677 (setq line (line line))) 678 ((#\Space) 679 (incf col) 680 (write-string " " html-stream)) 681 ((#\Tab) 682 (dotimes (i (- 8 (mod col 8))) 683 (incf col) 684 (write-string " " html-stream))) 776 (end-line) 777 (when (<= limit pos) 778 (return (values pos line))) 779 (start-line)) 685 780 (t 686 (incf col) 687 (if (alphanumericp char) 688 (write-char char html-stream) 689 (format html-stream "&#~D;" (char-code char)))))) 690 (format html-stream "</code></div>")))) 781 (outch char))) 782 finally (end-line))))) 691 783 692 784 … … 833 925 (defun write-coverage-styles (html-stream) 834 926 (format html-stream "<style type='text/css'> 835 *.st ate-~a { background-color: #ffaaaa }836 *.st ate-~a { background-color: #aaffaa }837 *.st ate-~a { background-color: #44dd44 }838 div.key { margin: 20px; width: 88ex }839 div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;927 *.st~a { background-color: #ffaaaa } 928 *.st~a { background-color: #aaffaa } 929 *.st~a { background-color: #44dd44 } 930 *.key { margin: 20px; width: 88ex } 931 *.source { width: 120ex; background-color: #eeeeee; padding-left: 5px; 840 932 /* border-style: solid none none none; border-width: 1px; 841 border-color: #dddddd */ } 842 843 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } 933 border-color: #dddddd */ 934 white-space: pre; } 935 936 *.acode { border-left: 1px dashed #c0c0c0; 937 margin-top: 1ex; 938 margin-left: 6ex; 939 margin-bottom: 2ex; 940 white-space: pre; 941 display: none; } 942 943 *.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } 944 945 *.toggle { font-size: small; } 844 946 845 947 table.summary tr.head-row { background-color: #aaaaff } … … 850 952 table.summary tr.subheading { background-color: #aaaaff} 851 953 table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; } 852 </style>" 954 955 </style> 956 957 <script type='text/javascript'> 958 function swap (id) { 959 var acode = document.getElementById('a' + id); 960 var prompt = document.getElementById('p' + id); 961 if (acode.style.display == 'block') { 962 acode.style.display = 'none'; 963 prompt.innerHTML = 'Show expansion'; 964 } else { 965 acode.style.display = 'block'; 966 prompt.innerHTML = 'Hide expansion'; 967 } 968 } 969 </script> 970 " 853 971 $not-executed-style 854 972 $partially-covered-style 855 973 $totally-covered-style 856 974 )) 975
Note: See TracChangeset
for help on using the changeset viewer.