Ignore:
Timestamp:
May 14, 2011, 3:39:10 PM (8 years ago)
Author:
gz
Message:

Initial support for incremental code coverage info.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/library/cover.lisp

    r14752 r14798  
    1919(in-package :ccl)
    2020
    21 (export '(*compile-code-coverage*
    22           report-coverage
    23           reset-coverage
    24           clear-coverage
    25           save-coverage-in-file
    26           restore-coverage-from-file
    27 
    28           save-coverage
    29           restore-coverage
    30           combine-coverage
    31           read-coverage-from-file
    32           write-coverage-to-file
    33 
    34           coverage-statistics
    35           coverage-source-file
    36           coverage-expressions-total
    37           coverage-expressions-entered
    38           coverage-expressions-covered
    39           coverage-unreached-branches
    40           coverage-code-forms-total
    41           coverage-code-forms-covered
    42           coverage-functions-total
    43           coverage-functions-fully-covered
    44           coverage-functions-partly-covered
    45           coverage-functions-not-entered
    46 
    47           without-compiling-code-coverage))
     21(eval-when (eval load compile)
     22  (export '(*compile-code-coverage*
     23            report-coverage
     24            reset-coverage
     25            clear-coverage
     26            save-coverage-in-file
     27            restore-coverage-from-file
     28           
     29            save-coverage  ;; stupid name, here for backward compatibility
     30            get-coverage
     31            restore-coverage
     32            combine-coverage
     33            read-coverage-from-file
     34            write-coverage-to-file
     35           
     36            reset-incremental-coverage
     37            get-incremental-coverage
     38            incremental-coverage-source-matches
     39            incremental-coverage-svn-matches
     40           
     41            coverage-statistics
     42            coverage-source-file
     43            coverage-expressions-total
     44            coverage-expressions-entered
     45            coverage-expressions-covered
     46            coverage-unreached-branches
     47            coverage-code-forms-total
     48            coverage-code-forms-covered
     49            coverage-functions-total
     50            coverage-functions-fully-covered
     51            coverage-functions-partly-covered
     52            coverage-functions-not-entered
     53           
     54            without-compiling-code-coverage)))
    4855
    4956(defconstant $no-style 0)
     
    5865(defparameter *source-coverage* (make-hash-table :test #'eq))
    5966
     67(defmacro with-decoded-coverage ((&key (cover '*code-covered-functions*) (precompute t)) &body body)
     68  `(let* ((*file-coverage* nil)
     69          (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
     70          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
     71          (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     72          (*source-coverage* ,(and precompute `(make-hash-table :test #'eq :shared nil))))
     73     (decode-coverage :cover ,cover :precompute ,precompute)
     74     ,@body))
     75
     76
    6077(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
    6178  alist)
     79
     80(defstruct incremental-coverage
     81  list)
    6282
    6383;; Wrapper in case we ever want to do dwim on raw alists
     
    106126
    107127(defun map-function-coverage (lfun fn &optional refs)
    108   (let ((refs (cons lfun refs)))
     128  (let ((refs (cons lfun refs))
     129        (source (function-outermost-entry-source lfun)))
    109130    (declare (dynamic-extent refs))
    110131    (lfunloop for imm in lfun
     
    112133              do (funcall fn imm)
    113134              when (and (functionp imm)
    114                         (not (memq imm refs)))
     135                        (not (memq imm refs))
     136                        ;; Make sure this fn is in the source we're currently looking at.
     137                        ;; It might not be, if it is referenced via (load-time-value (foo))
     138                        ;; where (foo) returns an lfun from some different source entirely.
     139                        ;; CL-PPCRE does that.
     140                        (or (null source) (eq source (function-outermost-entry-source imm))))
    115141              do (map-function-coverage imm fn refs))))
    116142
    117 (defun get-function-coverage (fn refs)
    118   (let ((entry (function-entry-code-note fn))
    119         (refs (cons fn refs))
    120         (source (function-source-form-note fn)))
     143(defun decode-coverage-subfunctions (lfun refs)
     144  (let ((refs (cons lfun refs))
     145        (source (function-outermost-entry-source lfun)))
    121146    (declare (dynamic-extent refs))
    122     (when entry
    123       (assert (eq fn (gethash entry *entry-code-notes* fn)))
    124       (setf (gethash entry *entry-code-notes*) fn))
    125147    (nconc
    126      (and entry (list fn))
    127      (lfunloop for imm in fn
    128        when (code-note-p imm)
    129        do (setf (gethash imm *emitted-code-notes*) t)
    130        when (and (functionp imm)
    131                  (not (memq imm refs))
    132                  ;; Make sure this fn is in the source we're currently looking at.
    133                  ;; It might not be, if it is referenced via (load-time-value (foo))
    134                  ;; where (foo) returns an lfun from some different source entirely.
    135                  ;; CL-PPCRE does that.
    136                  (or (null source)
    137                      (eq source (function-source-form-note imm))))
    138        nconc (get-function-coverage imm refs)))))
     148     (and (function-entry-code-note lfun) (list lfun))
     149     (lfunloop for imm in lfun
     150               when (and (functionp imm)
     151                         (not (memq imm refs))
     152                         (or (null source)
     153                             (eq source (function-outermost-entry-source imm))))
     154               nconc (decode-coverage-subfunctions imm refs)))))
     155
     156(defun decode-function-coverage (fn)
     157  (let ((all (decode-coverage-subfunctions fn nil)))
     158    (loop for fn in all as entry = (function-entry-code-note fn)
     159      do (assert (eq fn (gethash entry *entry-code-notes* fn)))
     160      do (setf (gethash entry *entry-code-notes*) fn)
     161      do (lfunloop for imm in fn
     162                   when (code-note-p imm) do (setf (gethash imm *emitted-code-notes*) t)))
     163    all))
    139164
    140165(defun code-covered-info.file (data) (and (consp data) (car data)))
     
    146171  (assert (consp data))
    147172  (if (consp (cdr data))
    148     (cons (car data) new-fns)
    149173    (let ((new (copy-list data)))
    150174      (setf (cadr new) new-fns)
    151       new)))
    152 
    153 (defun get-coverage ()
     175      new)
     176    (cons (car data) new-fns)))
     177
     178(defun decode-coverage (&key (cover *code-covered-functions*) (precompute t))
    154179  (setq *file-coverage* nil)
    155180  (clrhash *coverage-subnotes*)
    156181  (clrhash *emitted-code-notes*)
    157182  (clrhash *entry-code-notes*)
    158   (clrhash *source-coverage*)
    159   (loop for data in *code-covered-functions*
    160         do (let* ((file (code-covered-info.file data))
    161                   (toplevel-functions (code-covered-info.fns data)))
    162              (when file
    163                (let* ((all-functions (delete-duplicates
    164                                       ;; Duplicates are possible if you have multiple instances of
    165                                       ;; (load-time-value (foo)) where (foo) returns an lfun.
    166                                       ;; CL-PPCRE does that.
    167                                       (loop for fn across toplevel-functions
    168                                             nconc (get-function-coverage fn nil))))
    169                       (coverage (list* file
    170                                        all-functions
    171                                        toplevel-functions
    172                                        (make-coverage-statistics :source-file file))))
    173                  (push coverage *file-coverage*)))))
     183  (when precompute (clrhash *source-coverage*))
     184  (loop for data in cover
     185    do (let* ((file (code-covered-info.file data))
     186              (toplevel-functions (code-covered-info.fns data)))
     187         (when file
     188           (let* ((all-functions (delete-duplicates
     189                                  ;; Duplicates are possible if you have multiple instances of
     190                                  ;; (load-time-value (foo)) where (foo) returns an lfun.
     191                                  ;; CL-PPCRE does that.
     192                                  (loop for fn across toplevel-functions
     193                                    nconc (decode-coverage-subfunctions fn nil))))
     194                  (coverage (list* file
     195                                   all-functions
     196                                   toplevel-functions
     197                                   (make-coverage-statistics :source-file file))))
     198             (push coverage *file-coverage*)
     199             ;; record emitted notes
     200             (loop for fn in all-functions as entry = (function-entry-code-note fn)
     201               do (assert (eq fn (gethash entry *entry-code-notes* fn)))
     202               do (setf (gethash entry *entry-code-notes*) fn)
     203               do (lfunloop for imm in fn
     204                            when (code-note-p imm)
     205                            do (setf (gethash imm *emitted-code-notes*) t)))))))
    174206  ;; Now get subnotes, including un-emitted ones.
    175207  (loop for note being the hash-key of *emitted-code-notes*
    176         do (loop for n = note then parent as parent = (code-note-parent-note n)
    177                  while parent
    178                  do (pushnew n (gethash parent *coverage-subnotes*))
    179                  until (emitted-code-note-p parent)))
     208    do (loop for n = note then parent as parent = (code-note-parent-note n)
     209         while parent
     210         do (pushnew n (gethash parent *coverage-subnotes*))
     211         until (emitted-code-note-p parent)))
    180212  ;; Now get source mapping
    181   (loop for coverage in *file-coverage*
    182         do (precompute-source-coverage coverage)
    183         ;; bit of overkill, but we end up always wanting them.
    184         do (compute-file-coverage-statistics coverage)))
     213  (when precompute
     214    (loop for coverage in *file-coverage*
     215      do (precompute-source-coverage coverage)
     216      ;; bit of overkill, but we end up always wanting them.
     217      do (compute-file-coverage-statistics coverage))))
    185218
    186219(defun file-coverage-acode-queue (coverage)
     
    190223        as entry = (function-entry-code-note fn)
    191224        as sn = (entry-note-unambiguous-source entry)
    192         as toplevel-sn = (function-source-form-note fn)
     225        as toplevel-sn = (function-outermost-entry-source fn)
    193226        do (when sn
    194227             (assert toplevel-sn)
     
    231264             alist)))
    232265
    233 (defun covered-functions-for-file (path)
    234   (code-covered-info.fns (assoc-by-filename path *code-covered-functions*)))
    235 
    236266(defun ccl:clear-coverage ()
    237267  "Clear all files from the coverage database. The files will be re-entered
     
    244274  (map-function-coverage lfun #'(lambda (note)
    245275                                  (setf (code-note-code-coverage note) nil))))
     276
     277(defun reset-function-incremental-coverage (lfun)
     278  (map-function-coverage lfun #'(lambda (note)
     279                                  (when (code-note-code-coverage note)
     280                                    (setf (code-note-code-coverage note) :prior)))))
    246281
    247282(defun ccl:reset-coverage ()
     
    254289             (function (reset-function-coverage data)))))
    255290
     291
     292(defun ccl:reset-incremental-coverage ()
     293  "Mark a starting point for recording incremental coverage.
     294   Has no effect on regular coverage recording."
     295  (loop for data in *code-covered-functions*
     296    do (typecase data
     297         (cons
     298          (loop for fn across (code-covered-info.fns data)
     299            do (reset-function-incremental-coverage fn)))
     300         (function (reset-function-incremental-coverage data)))))
     301
     302
    256303;; Name used for consistency checking across file save/restore
    257304(defun function-covered-name (fn)
     
    278325;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage).
    279326(defun save-function-coverage (fn &optional (refs ()))
    280   (let ((refs (cons fn refs)))
     327  (let ((refs (cons fn refs))
     328        (source (function-outermost-entry-source fn)))
    281329    (declare (dynamic-extent refs))
    282330    (cons (function-covered-name fn)
     331          ;; See comments in map-function-coverage
    283332          (lfunloop for imm in fn as i upfrom 0
    284333                    when (and (code-note-p imm)
    285334                              (code-note-code-coverage imm))
    286335                    collect i into list
    287                     when (and (functionp imm) (not (memq imm refs)))
     336                    when (and (functionp imm)
     337                              (not (memq imm refs))
     338                              (or (null source) (eq source (function-outermost-entry-source imm))))
    288339                    collect (cons i (save-function-coverage imm refs)) into list
    289340                    finally (return (and list (coerce list 'vector)))))))
     
    301352(defun restore-function-coverage (fn saved-fn-data &optional (refs ()))
    302353  (let* ((refs (cons fn refs))
     354         (source (function-outermost-entry-source fn))
    303355         (saved-name (car saved-fn-data))
    304356         (saved-imms (cdr saved-fn-data))
     
    308360    (unless (equalp saved-name (function-covered-name fn))
    309361      (coverage-mismatch "had function ~s now have ~s" saved-name fn))
     362    ;; See comments in map-function-coverage
    310363    (lfunloop for imm in fn as i upfrom 0
    311364              when (code-note-p imm)
     
    316369                               (and (eql next i) 'restored))
    317370                     (incf n)))
    318               when (and (functionp imm) (not (memq imm refs)))
     371              when (and (functionp imm)
     372                        (not (memq imm refs))
     373                        (or (null source) (eq source (function-outermost-entry-source imm))))
    319374              do (let* ((next (and (< n nimms) (aref saved-imms n))))
    320375                   (unless (and (consp next) (eql (car next) i))
     
    348403
    349404
    350 (defun ccl:save-coverage ()
     405(defun ccl:get-coverage ()
    351406  "Returns a snapshot of the current coverage state"
    352407  (make-coverage-state
     
    355410                  collect (code-covered-info-with-fns
    356411                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
     412
     413;; Backward compatibility with sbcl name.
     414(setf (symbol-function 'ccl:save-coverage) #'ccl:get-coverage)
    357415
    358416(defun ccl:combine-coverage (coverage-states)
     
    407465                    (map nil #'restore-function-coverage fns saved-fns))))))
    408466
     467(defun ccl:get-incremental-coverage (&key (reset t))
     468  "Return the delta coverage since the last reset of incremental coverage.
     469  If RESET is true (the default), it also resets incremental coverage now."
     470  ;; An incremental coverage snapshot is just a list of covered (i.e. entered) code notes.
     471  ;; It is not savable in a file.
     472  (let ((covered nil))
     473    (flet ((get-fn (note)
     474             (let ((coverage (code-note-code-coverage note)))
     475               (when (and coverage (not (eq coverage :prior)))
     476                 (when reset (setf (code-note-code-coverage note) :prior))
     477                 (push note covered)))))
     478      (loop for data in *code-covered-functions*
     479        when (consp data)
     480        do (loop for fn across (code-covered-info.fns data)
     481             do (map-function-coverage fn #'get-fn)))
     482      (make-incremental-coverage :list covered))))
     483
     484(defun ccl:incremental-coverage-svn-matches (collection &key (directory (current-directory)) (revision :base))
     485  "Given a hash table COLLECTION whose values are incremental coverage deltas, return a list
     486  of all keys corresponding to those deltas that intersect any region in a file in DIRECTORY that
     487  has changed since revision REVISION in subversion."
     488  (incremental-coverage-source-matches collection (get-svn-changes :directory directory
     489                                                                   :revision revision
     490                                                                   :reverse t)))
     491
     492(defun ccl:incremental-coverage-source-matches (collection sources)
     493  "Given a hash table COLLECTION whose values are incremental coverage delta, return a list
     494  of all keys corresponding to deltas that intersect any region in SOURCES.  SOURCES
     495  should be a list of source notes and/or pathnames"
     496  (let ((coverages (remove-duplicates
     497                    (mapcar (lambda (file)
     498                              (or (assoc-by-filename file *code-covered-functions*)
     499                                  (error "There is no coverage info for ~s" file)))
     500                            ;; remove dups for efficiency, since assoc-by-filename can be expensive,
     501                            ;; and the filenames will typically be EQ since all created at once.
     502                            ;; But don't bother with EQUAL testing, since assoc-by-filename will do that.
     503                            ;; Note - source-note-filename accepts pathnames and just returns them.
     504                            (remove-duplicates (mapcar #'source-note-filename sources))))))
     505    (with-decoded-coverage (:cover coverages :precompute nil)
     506      (loop for sn in sources
     507        do (let* ((coverage (assoc-by-filename (source-note-filename sn) coverages))
     508                  (matches (code-notes-for-region coverage
     509                                                  (source-note-start-pos sn)
     510                                                  (source-note-end-pos sn))))
     511             (flet ((matches (delta)
     512                      (loop for note in (incremental-coverage-list delta) thereis (memq note matches))))
     513               (typecase collection
     514                 (hash-table (loop for key being the hash-key of collection using (hash-value delta)
     515                               when (matches delta) collect key))
     516                 (sequence (remove-if-not #'matches collection)))))))))
     517
     518
     519
     520
     521(defun nearest-source-note (note)
     522  (loop for n = note then (code-note-parent-note n)
     523        thereis (and n (code-note-source-note n))))
     524
     525;; Given a region of a file, find a set of code notes that completely covers it, i.e.
     526;; a set such that if none of the code notes in the set have been executed, then it's guaranteed
     527;; that modifying the region is not going to affect execution.  Try to make that set as small
     528;; as possible.
     529(defun code-notes-for-region (coverage start-pos end-pos)
     530  (let* ((notes (loop for fn across (file-coverage-toplevel-functions coverage)
     531                  as note = (function-entry-code-note fn) as source = (nearest-source-note note)
     532                  when (and source
     533                            (or (null end-pos) (< (source-note-start-pos source) end-pos))
     534                            (or (null start-pos) (< start-pos (source-note-end-pos source))))
     535                  ;; This function intersects the region.  Find the smallest subnote that contains all
     536                  ;; of this function's part of the region.
     537                  collect (let ((start (max start-pos (source-note-start-pos source)))
     538                                (end (min end-pos (source-note-end-pos source))))
     539                            (iterate tighten ((note note))
     540                              (loop for subnote in (coverage-subnotes note)
     541                                as subsource = (nearest-source-note subnote)
     542                                do (when (and (<= (source-note-start-pos subsource) start)
     543                                              (<= end (source-note-end-pos subsource)))
     544                                     (return (tighten subnote)))
     545                                finally (return note))))))
     546         (emitted-notes (iterate splat ((notes notes))
     547                          (loop for note in notes
     548                            nconc (if (emitted-code-note-p note)
     549                                    (list note)
     550                                    (splat (coverage-subnotes note)))))))
     551    emitted-notes))
     552
     553
     554;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     555
    409556(defvar *loading-coverage*)
    410557
     
    464611
    465612(defun ccl:coverage-statistics ()
    466   (let* ((*file-coverage* nil)
    467          (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    468          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    469          (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
    470          (*source-coverage* (make-hash-table :test #'eq :shared nil)))
    471     (get-coverage)
     613  (with-decoded-coverage ()
    472614    (mapcar #'file-coverage-statistics *file-coverage*)))
    473615
     
    491633         (directory (make-pathname :name nil :type nil :defaults output-file))
    492634         (coverage-dir (common-coverage-directory))
    493          (*file-coverage* nil)
    494          (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    495          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    496          (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
    497          (*source-coverage* (make-hash-table :test #'eq :shared nil))
    498635         (index-file (and html (merge-pathnames output-file "index.html")))
    499636         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
     
    502639                                                        "statistics.csv")
    503640                                                      output-file))))
    504     (get-coverage)
    505641    (ensure-directories-exist directory)
    506     (loop for coverage in *file-coverage*
    507       as truename = (or (probe-file (file-coverage-file coverage))
    508                     (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
    509                            nil))
    510       do (when truename
    511            (let* ((src-name (enough-namestring truename coverage-dir))
    512                   (html-name (substitute
    513                               #\_ #\: (substitute
    514                                        #\_ #\. (substitute
    515                                                 #\_ #\/ (namestring-unquote src-name)))))
    516                   (file (file-coverage-file coverage)))
    517              (when html
    518                (with-coverage-mismatch-catch (file)
    519                  (let* ((data (assoc-by-filename file *code-covered-functions*))
    520                         (checksum (fcomp-file-checksum (code-covered-info.file data)
    521                                                        :external-format (code-covered-info.ef data))))
    522                    (unless (eql checksum (code-covered-info.id data))
    523                      (cerror "Try coloring anyway"
    524                              "File ~s has changed since coverage source location info was recorded."
    525                              (code-covered-info.file data))))
    526                  (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
    527                                          :direction :output
    528                                          :if-exists :supersede
    529                                          :if-does-not-exist :create)
    530                    (report-file-coverage index-file coverage stream external-format))))
    531              (push (list* src-name html-name coverage) paths))))
    532     (when (null paths)
    533       (error "No code coverage data available"))
    534     (setq paths (sort paths #'(lambda (path1 path2)
    535                                 (let* ((f1 (car path1))
    536                                        (f2 (car path2)))
    537                                   (or (string< (directory-namestring f1)
    538                                                (directory-namestring f2))
    539                                       (and (equal (pathname-directory f1)
    540                                                   (pathname-directory f2))
    541                                            (string< (file-namestring f1)
    542                                                     (file-namestring f2))))))))
    543     (if html
    544       (with-open-file (html-stream index-file
    545                                    :direction :output
    546                                    :if-exists :supersede
    547                                    :if-does-not-exist :create)
     642    (with-decoded-coverage ()
     643      (loop for coverage in *file-coverage*
     644        as truename = (or (probe-file (file-coverage-file coverage))
     645                          (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
     646                            nil))
     647        do (when truename
     648             (let* ((src-name (enough-namestring truename coverage-dir))
     649                    (html-name (substitute
     650                                #\_ #\: (substitute
     651                                         #\_ #\. (substitute
     652                                                  #\_ #\/ (namestring-unquote src-name)))))
     653                    (file (file-coverage-file coverage)))
     654               (when html
     655                 (with-coverage-mismatch-catch (file)
     656                   (let* ((data (assoc-by-filename file *code-covered-functions*))
     657                          (checksum (fcomp-file-checksum (code-covered-info.file data)
     658                                                         :external-format (code-covered-info.ef data))))
     659                     (unless (eql checksum (code-covered-info.id data))
     660                       (cerror "Try coloring anyway"
     661                               "File ~s has changed since coverage source location info was recorded."
     662                               (code-covered-info.file data))))
     663                   (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
     664                                           :direction :output
     665                                           :if-exists :supersede
     666                                           :if-does-not-exist :create)
     667                     (report-file-coverage index-file coverage stream external-format))))
     668               (push (list* src-name html-name coverage) paths))))
     669      (when (null paths)
     670        (error "No code coverage data available"))
     671      (setq paths (sort paths #'(lambda (path1 path2)
     672                                  (let* ((f1 (car path1))
     673                                         (f2 (car path2)))
     674                                    (or (string< (directory-namestring f1)
     675                                                 (directory-namestring f2))
     676                                        (and (equal (pathname-directory f1)
     677                                                    (pathname-directory f2))
     678                                             (string< (file-namestring f1)
     679                                                      (file-namestring f2))))))))
     680      (if html
     681        (with-open-file (html-stream index-file
     682                                     :direction :output
     683                                     :if-exists :supersede
     684                                     :if-does-not-exist :create)
     685          (if stats-file
     686            (with-open-file (stats-stream stats-file
     687                                          :direction :output
     688                                          :if-exists :supersede
     689                                          :if-does-not-exist :create)
     690              (report-coverage-to-streams paths html-stream stats-stream))
     691            (report-coverage-to-streams paths html-stream nil)))
    548692        (if stats-file
    549693          (with-open-file (stats-stream stats-file
     
    551695                                        :if-exists :supersede
    552696                                        :if-does-not-exist :create)
    553             (report-coverage-to-streams paths html-stream stats-stream))
    554           (report-coverage-to-streams paths html-stream nil)))
    555       (if stats-file
    556         (with-open-file (stats-stream stats-file
    557                                       :direction :output
    558                                       :if-exists :supersede
    559                                       :if-does-not-exist :create)
    560           (report-coverage-to-streams paths nil stats-stream))
    561         (error "One of :HTML or :STATISTICS must be non-nil")))
    562     (values index-file stats-file)))
     697            (report-coverage-to-streams paths nil stats-stream))
     698          (error "One of :HTML or :STATISTICS must be non-nil")))
     699      (values index-file stats-file))))
    563700
    564701(defun report-coverage-to-streams (paths html-stream stats-stream)
     
    670807  (update-text-styles note styles))
    671808
    672 (defun function-source-form-note (fn)
     809(defun function-outermost-entry-source (fn)
    673810  ;; Find the outermost source form containing the fn.
    674811  (loop with sn = nil
     
    706843(defun colorize-function (fn styles acode-styles &optional refs)
    707844  (let* ((note (function-entry-code-note fn))
    708          (source (function-source-form-note fn))
     845         (source (function-outermost-entry-source fn))
    709846         (refs (cons fn refs)))
    710847    (declare (dynamic-extent refs))
     
    717854              when (and (functionp imm)
    718855                        (not (memq imm refs))
    719                         ;; See note in get-function-coverage
     856                        ;; See note in decode-function-coverage
    720857                        (or (null source)
    721                             (eq source (function-source-form-note imm))
     858                            (eq source (function-outermost-entry-source imm))
    722859                            #+debug (progn
    723860                                      (warn "Ignoring ref to ~s from ~s" imm fn)
Note: See TracChangeset for help on using the changeset viewer.