Changeset 14110 for branches


Ignore:
Timestamp:
Aug 2, 2010, 9:18:48 PM (9 years ago)
Author:
gz
Message:

acode coverage reporting: remember to init *code-note-acode-strings*. Be more conscientious about ignoring embedded functions from other files. Finally, acode-queue needs to be per file, duh.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl/library/cover.lisp

    r14058 r14110  
    5858(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
    5959
    60 (defparameter *coverage-acode-queue* nil)
    61 
    6260(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
    6361  alist)
     
    8886
    8987(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*)))
    9190
    9291(defun map-function-coverage (lfun fn &optional refs)
     
    10099              do (map-function-coverage imm fn refs))))
    101100
    102 (defun get-function-coverage (fn refs acode)
     101(defun get-function-coverage (fn refs)
    103102  (let ((entry (function-entry-code-note fn))
    104103        (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)))
    106106    (declare (dynamic-extent refs))
    107107    (when entry
     
    119119              (setf (gethash imm *code-note-acode-strings*) acode)))
    120120       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)))))
    123129
    124130(defun code-covered-info.file (data) (and (consp data) (car data)))
     
    140146  (clrhash *emitted-code-notes*)
    141147  (clrhash *entry-code-notes*)
    142   (clrhash *code-note-acode-strings*)
     148  (when *code-note-acode-strings* (clrhash *code-note-acode-strings*))
    143149  (loop for data in *code-covered-functions*
    144150        do (let* ((file (code-covered-info.file data))
    145151                  (toplevel-functions (code-covered-info.fns data)))
    146152             (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*)))))
    156161  ;; Now get subnotes, including un-emitted ones.
    157162  (loop for note being the hash-key of *emitted-code-notes*
     
    159164                 while parent
    160165                 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))))
    180186
    181187#+debug
     
    456462         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    457463         (*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)
    460467    (loop for coverage in *file-coverage*
    461468          as stats = (make-coverage-statistics :source-file (file-coverage-file coverage))
     
    502509         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    503510         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     511         (*code-note-acode-strings* (make-hash-table :test #'eq :shared nil))
    504512         (index-file (and html (merge-pathnames output-file "index.html")))
    505513         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
     
    712720              when (and (functionp imm)
    713721                        (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
    718723                        (or (null source)
    719724                            (eq source (function-source-form-note imm))
     
    736741                             :element-type '(unsigned-byte 2)))
    737742         (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))
    739745    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
    740746    (format html-stream "</body></html>")))
     
    758764
    759765    ;; 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)))
    761767      (format html-stream "<div class='source'><code>")
    762       (let ((next (car *coverage-acode-queue*)))
     768      (let ((next (car queue)))
    763769        (multiple-value-bind (end last-line)
    764                              (output-styled html-stream source styles
    765                                             :start start
    766                                             :line line
    767                                             :limit (car next))
     770            (output-styled html-stream source styles
     771                           :start start
     772                           :line line
     773                           :limit (car next))
    768774          (format html-stream "</code></div>~%")
    769775          (when (and next end (<= (car next) end))
     
    772778                                   <div class='acode' id='a~:*~d'><code>" pos)
    773779              (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)))))))))
    780785
    781786(defun output-styled (html-stream source styles &key (start 0) line limit)
Note: See TracChangeset for help on using the changeset viewer.