Changeset 14884 for release/1.7


Ignore:
Timestamp:
Jul 14, 2011, 7:07:18 PM (8 years ago)
Author:
rme
Message:

Merge trunk changes.

Location:
release/1.7/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.7/source

  • release/1.7/source/library/cover.lisp

    r14798 r14884  
    5959(defconstant $partially-covered-style 3)
    6060
     61;; These global values are for use in debugging only.  Exported functions always shadow these with thread-local tables.
    6162(defparameter *file-coverage* ())
    62 (defparameter *coverage-subnotes* (make-hash-table :test #'eq))
    63 (defparameter *emitted-code-notes* (make-hash-table :test #'eq))
    64 (defparameter *entry-code-notes* (make-hash-table :test #'eq))
    65 (defparameter *source-coverage* (make-hash-table :test #'eq))
    66 
    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)
     63(defparameter *coverage-tags* nil)
     64(defparameter *code-note-tags* nil)
     65
     66(defparameter *code-note-subnotes* (make-hash-table :test #'eq))
     67(defparameter *code-note-function* (make-hash-table :test #'eq))
     68(defparameter *entry-note-function* (make-hash-table :test #'eq))
     69(defparameter *code-note-index* (make-hash-table :test #'eq))
     70(defparameter *emitted-code-notes* (make-array 10 :adjustable t :fill-pointer 0))
     71
     72(defparameter *source-note-index* (make-hash-table :test #'eq))
     73(defparameter *source-code-notes* (make-hash-table :test #'eq))
     74(defparameter *covered-source-notes* (make-array 10 :adjustable t :fill-pointer 0))
     75
     76
     77(defmacro with-coverage-decoding ((&key tags (precompute t)) &body body)
     78  ;; Set up thread-local environment, and decode tags, since those aren't file-specific
     79  `(let* ((*coverage-tags* nil)
     80          (*code-note-tags* nil)
     81          (*file-coverage* nil)
     82          (*code-note-subnotes* (make-hash-table :test #'eq :shared nil))
     83          (*code-note-function* (make-hash-table :test #'eq :shared nil))
     84          (*entry-note-function* (make-hash-table :test #'eq :shared nil))
     85          (*code-note-index* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
     86          (*emitted-code-notes* ,(when precompute `(make-array 100 :adjustable t :fill-pointer 0)))
     87          (*source-note-index* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
     88          (*source-code-notes* ,(when precompute `(make-hash-table :test #'eq :shared nil)))
     89          (*covered-source-notes* ,(when precompute `(make-array 100 :adjustable t :fill-pointer 0))))
     90     ,@(when tags `((decode-coverage-tags ,tags)))
    7491     ,@body))
     92
     93
     94(defmacro with-decoded-file-coverage ((coveragevar data &key) &body body)
     95  `(progn
     96     ;; Wonder if it'd be faster to make new tables instead of clrhash...
     97     (clrhash *code-note-subnotes*)
     98     (clrhash *code-note-function*)
     99     (clrhash *entry-note-function*)
     100     (when *code-note-index* (clrhash *code-note-index*))
     101     (when *emitted-code-notes* (setf (fill-pointer *emitted-code-notes*) 0))
     102     (when *source-note-index* (clrhash *source-note-index*))
     103     (when *covered-source-notes* (setf (fill-pointer *covered-source-notes*) 0))
     104     (when *source-code-notes* (clrhash *source-code-notes*))
     105     (let ((,coveragevar (decode-file-coverage ,data)))
     106       (push ,coveragevar *file-coverage*)
     107       ,@body)))
    75108
    76109
     
    113146  (cdddr entry))
    114147
    115 (defun coverage-subnotes (note) ;; reversed parent chain
    116   (gethash note *coverage-subnotes*))
     148(defun file-coverage-index (entry)
     149  (position entry *file-coverage*))
     150
     151(defun code-note-subnotes (note) ;; reversed parent chain
     152  (gethash note *code-note-subnotes*))
    117153
    118154(defun emitted-code-note-p (note)
    119   (gethash note *emitted-code-notes*))
     155  (gethash note *code-note-function*))
     156
     157(defun code-note-function (note)
     158  (gethash note *code-note-function*))
    120159
    121160(defun entry-code-note-p (note)
    122   (gethash note *entry-code-notes*))
    123 
    124 (defun source-coverage (source-note)
    125   (gethash source-note *source-coverage*))
     161  (gethash note *entry-note-function*))
     162
     163(defun code-note-index (code-note)
     164  (gethash code-note *code-note-index*))
     165
     166(defun code-note-tags (code-note)
     167  (gethash code-note *code-note-tags*))
     168
     169(defun source-code-notes (source-note)
     170  (gethash source-note *source-code-notes*))
     171
     172(defun source-note-index (source-note)
     173  (gethash source-note *source-note-index*))
     174
     175(defun source-coverage (source)
     176  (loop with entered = nil and covered = t
     177        for note in  (source-code-notes source)
     178        do (case (code-note-code-coverage note)
     179             ((nil) (setq covered nil))
     180             ((full) (setq entered t))
     181             (t (setq entered t covered nil)))
     182        finally (return (and entered (if covered 'full t)))))
    126183
    127184(defun map-function-coverage (lfun fn &optional refs)
     
    130187    (declare (dynamic-extent refs))
    131188    (lfunloop for imm in lfun
    132               when (code-note-p imm)
    133               do (funcall fn imm)
    134               when (and (functionp imm)
    135                         (not (memq imm refs))
    136                         ;; Make sure this fn is in the source we're currently looking at.
     189              when (code-note-p imm)
     190              do (funcall fn imm)
     191              when (and (functionp imm)
     192                        (not (memq imm refs))
     193                        ;; Make sure this fn is in the source we're currently looking at.
    137194                        ;; It might not be, if it is referenced via (load-time-value (foo))
    138195                        ;; where (foo) returns an lfun from some different source entirely.
    139196                        ;; CL-PPCRE does that.
    140197                        (or (null source) (eq source (function-outermost-entry-source imm))))
    141               do (map-function-coverage imm fn refs))))
    142 
    143 (defun decode-coverage-subfunctions (lfun refs)
     198              do (map-function-coverage imm fn refs))))
     199
     200(defun collect-coverage-subfunctions (lfun refs)
    144201  (let ((refs (cons lfun refs))
    145202        (source (function-outermost-entry-source lfun)))
    146203    (declare (dynamic-extent refs))
     204    (assert source) ;; all source-less functions have been eliminated.
    147205    (nconc
    148206     (and (function-entry-code-note lfun) (list lfun))
     
    150208               when (and (functionp imm)
    151209                         (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))
     210                         (eq source (function-outermost-entry-source imm)))
     211               nconc (collect-coverage-subfunctions imm refs)))))
    164212
    165213(defun code-covered-info.file (data) (and (consp data) (car data)))
     
    176224    (cons (car data) new-fns)))
    177225
    178 (defun decode-coverage (&key (cover *code-covered-functions*) (precompute t))
    179   (setq *file-coverage* nil)
    180   (clrhash *coverage-subnotes*)
    181   (clrhash *emitted-code-notes*)
    182   (clrhash *entry-code-notes*)
    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)))))))
    206   ;; Now get subnotes, including un-emitted ones.
    207   (loop for note being the hash-key of *emitted-code-notes*
    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)))
    212   ;; Now get source mapping
    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))))
    218 
    219 (defun file-coverage-acode-queue (coverage)
    220   (loop with hash = (make-hash-table :test #'eq :shared nil)
    221         for fn in (file-coverage-functions coverage)
    222         as acode = (%function-acode-string fn)
    223         as entry = (function-entry-code-note fn)
    224         as sn = (entry-note-unambiguous-source entry)
    225         as toplevel-sn = (function-outermost-entry-source fn)
    226         do (when sn
    227              (assert toplevel-sn)
    228              (let* ((pos (source-note-end-pos sn))
    229                     (cell (assq acode (gethash toplevel-sn hash))))
    230                (if cell
    231                  (setf (cdr cell) (max (cdr cell) pos))
    232                  (push (cons acode pos) (gethash toplevel-sn hash)))))
    233         finally (return (sort (loop for sn being the hash-key of hash using (hash-value alist)
    234                                     collect (cons (source-note-end-pos sn)
    235                                                   (mapcar #'car (sort alist #'< :key #'cdr))))
    236                               #'< :key #'car))))
     226
     227(defun decode-file-coverage (data &key (precompute t))
     228  (let ((file (code-covered-info.file data)))
     229    (when file
     230      (let* ((file-name (pathname-name file))
     231             (file-type (pathname-type file))
     232             (toplevel-functions (loop for fn across (code-covered-info.fns data)
     233                                       nconc (iterate flatten ((fn fn))
     234                                               (let* ((entry (function-entry-code-note fn))
     235                                                      (source (and entry (nearest-source-note entry))))
     236                                                 (if source
     237                                                   (let ((source-file (source-note-filename source)))
     238                                                     ;; ignore fns from other files, as could happen through '#.(fun).
     239                                                     ;; Unfortunately, can't do this reliably since source-note-filename can involve
     240                                                     ;; a logical host not defined in this image, use a heuristic.
     241                                                     (when (and (equalp (pathname-name source-file) file-name)
     242                                                                (equalp (pathname-type source-file) file-type))
     243                                                       (list fn)))
     244                                                   ;; A top level function without source must be a compiler-generated toplevel
     245                                                   ;; form, ignore it and treat its subfunctions as top level.
     246                                                   (lfunloop for imm in fn
     247                                                     when (functionp imm) nconc (flatten imm)))))))
     248             (all-functions (delete-duplicates
     249                             ;; Duplicates are possible if you have multiple instances of
     250                             ;; (load-time-value (foo)) where (foo) returns an lfun.
     251                             ;; CL-PPCRE does that.
     252                             (loop for fn in toplevel-functions
     253                                   nconc (collect-coverage-subfunctions fn nil))))
     254             (coverage (list* file
     255                              all-functions
     256                              toplevel-functions
     257                              (make-coverage-statistics :source-file file))))
     258        ;; record emitted notes
     259        (loop for fn in all-functions as entry = (function-entry-code-note fn)
     260              do (assert (eq fn (gethash entry *entry-note-function* fn)))
     261              do (setf (gethash entry *entry-note-function*) fn)
     262              do (lfunloop for imm in fn
     263                   when (code-note-p imm)
     264                   do (setf (gethash imm *code-note-function*) fn)))
     265        ;; Now get the emitted subnotes of any note (including emitted subnotes of unemitted notes)
     266        (loop for note being the hash-key of *code-note-function*
     267              do (loop for n = note then parent as parent = (code-note-parent-note n)
     268                       do (push note (gethash parent *code-note-subnotes*));; parent = nil collects toplevel notes
     269                       while (and parent (not (gethash parent *code-note-function*)))))
     270        ;; Now get source mapping
     271        (when precompute
     272          (precompute-source-coverage coverage)
     273          ;; bit of overkill, but we end up always wanting them.
     274          (compute-file-coverage-statistics coverage))
     275        coverage))))
    237276
    238277#+debug
     
    241280    (setq note (function-entry-code-note note)))
    242281  (labels ((show (note indent label)
    243              (dotimes (i indent) (write-char #\space))
    244              (format t "~a ~a" label note)
    245              (unless (emitted-code-note-p note)
    246                (format t " [Not Emitted]"))
    247              (when (entry-code-note-p note)
    248                (format t " (Entry to ~s)" (entry-code-note-p note)))
     282             (dotimes (i indent) (write-char #\space))
     283             (format t "~a ~a" label note)
     284             (unless (emitted-code-note-p note)
     285               (format t " [Not Emitted]"))
     286             (when (entry-code-note-p note)
     287               (format t " (Entry to ~s)" (entry-code-note-p note)))
    249288             (when (code-note-acode-range note)
    250289               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
    251290                 (format t " [acode ~a:~a]" s e)))
    252              (format t "~%")
    253              (when (code-note-p note)
    254                (loop with subindent = (+ indent 3)
    255                      for sub in (coverage-subnotes note) as i upfrom 1
    256                      do (show sub subindent (format nil "~a~d." label i))))))
     291             (format t "~%")
     292             (when (code-note-p note)
     293               (loop with subindent = (+ indent 3)
     294                     for sub in (code-note-subnotes note) as i upfrom 1
     295                     do (show sub subindent (format nil "~a~d." label i))))))
    257296    (show note 0 "")))
    258297
     
    285324        do (typecase data
    286325             (cons
    287                 (loop for fn across (code-covered-info.fns data)
    288                       do (reset-function-coverage fn)))
     326                (loop for fn across (code-covered-info.fns data)
     327                      do (reset-function-coverage fn)))
    289328             (function (reset-function-coverage data)))))
    290329
     
    294333   Has no effect on regular coverage recording."
    295334  (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)))))
     335        do (typecase data
     336             (cons
     337                (loop for fn across (code-covered-info.fns data)
     338                      do (reset-function-incremental-coverage fn)))
     339             (function (reset-function-incremental-coverage data)))))
    301340
    302341
     
    477516                 (push note covered)))))
    478517      (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)))
     518            when (consp data)
     519              do (loop for fn across (code-covered-info.fns data)
     520                       do (map-function-coverage fn #'get-fn)))
    482521      (make-incremental-coverage :list covered))))
     522
     523(defun decode-coverage-tags (tags)
     524  (when tags
     525    (let ((note->tags (make-hash-table :test #'eq :shared nil)))
     526      (flet ((register (i delta)
     527               (loop for note in (incremental-coverage-list delta) do (push i (gethash note note->tags)))))
     528        (etypecase tags
     529          (hash-table
     530           (let* ((count (hash-table-count tags))
     531                  (tags-vector (make-array count)))
     532             (enumerate-hash-keys-and-values tags tags-vector nil)
     533             (loop for i from 0 below count
     534                   do (register i (gethash (aref tags-vector i) tags)))
     535             (setq *coverage-tags* tags-vector)))
     536        (list
     537         (loop for i upfrom 0 as delta in tags do (register i delta)
     538               finally (setq *coverage-tags* i)))
     539        (vector
     540         (loop for i from 0 below (length tags) do (register i (aref tags i))
     541               finally (setq *coverage-tags* i)))))
     542      (setq *code-note-tags* note->tags))))
     543
    483544
    484545(defun ccl:incremental-coverage-svn-matches (collection &key (directory (current-directory)) (revision :base))
     
    494555  of all keys corresponding to deltas that intersect any region in SOURCES.  SOURCES
    495556  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)))))))))
     557  (let ((alist ()))
     558    (loop for source in sources
     559          as file = (source-note-filename source)
     560          ;; Typically source notes will have eq filenames since created all at once, so the
     561          ;; assq will find it after the first time.
     562          as cell = (or (assq file alist)
     563                        (assoc-by-filename file alist)
     564                        (let* ((data (or (assoc-by-filename file *code-covered-functions*)
     565                                         (error "There is no coverage info for ~s" file)))
     566                               (cell (list* file data nil)))
     567                          (push cell alist)
     568                          cell))
     569          do (push source (cddr cell)))
     570    (with-coverage-decoding (:precompute nil)
     571      (loop for (nil data . sources) in alist
     572            do (with-decoded-file-coverage (coverage data)
     573                 (loop for sn in sources
     574                       as matches = (code-notes-for-region coverage (source-note-start-pos sn) (source-note-end-pos sn))
     575                       nconc (flet ((matches (delta)
     576                                      (loop for note in (incremental-coverage-list delta) thereis (memq note matches))))
     577                               (typecase collection
     578                                 (hash-table (loop for key being the hash-key of collection using (hash-value delta)
     579                                                   when (matches delta) collect key))
     580                                 (sequence (coerce (remove-if-not #'matches collection) 'list))))))))))
    517581
    518582
     
    522586  (loop for n = note then (code-note-parent-note n)
    523587        thereis (and n (code-note-source-note n))))
     588
     589(defun code-note-emitted-parent (note)
     590  (loop while (setq note (code-note-parent-note note))
     591        when (emitted-code-note-p note) return note))
    524592
    525593;; Given a region of a file, find a set of code notes that completely covers it, i.e.
     
    528596;; as possible.
    529597(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))))))
     598  (let* ((notes (loop for fn in (file-coverage-toplevel-functions coverage)
     599                      as note = (function-entry-code-note fn) as source = (nearest-source-note note)
     600                      when (and (or (null end-pos) (< (source-note-start-pos source) end-pos))
     601                                (or (null start-pos) (< start-pos (source-note-end-pos source))))
     602                        ;; This function intersects the region.  Find the smallest subnote that contains all
     603                        ;; of this function's part of the region.
     604                        collect (let ((start (max start-pos (source-note-start-pos source)))
     605                                      (end (min end-pos (source-note-end-pos source))))
     606                                  (iterate tighten ((note note))
     607                                    (loop for subnote in (code-note-subnotes note)
     608                                          as subsource = (nearest-source-note subnote)
     609                                          do (when (and (<= (source-note-start-pos subsource) start)
     610                                                        (<= end (source-note-end-pos subsource)))
     611                                               (return (tighten subnote)))
     612                                          finally (return note))))))
    546613         (emitted-notes (iterate splat ((notes notes))
    547614                          (loop for note in notes
    548                             nconc (if (emitted-code-note-p note)
    549                                     (list note)
    550                                     (splat (coverage-subnotes note)))))))
     615                                nconc (if (emitted-code-note-p note)
     616                                        (list note)
     617                                        (splat (code-note-subnotes note)))))))
    551618    emitted-notes))
    552619
     
    587654(defun common-coverage-directory ()
    588655  (let* ((host :unknown)
    589         (rev-dir ()))
     656        (rev-dir ()))
    590657    (loop for data in *code-covered-functions*
    591        when (consp data)
    592        do (let ((file (probe-file (code-covered-info.file data))))
    593             (when file
    594               (cond ((eq host :unknown)
    595                      (setq host (pathname-host file)
    596                            rev-dir (reverse (pathname-directory file))))
    597                     ((not (equalp host (pathname-host file)))
    598                      (return-from common-coverage-directory nil))
    599                     (t
    600                      (let* ((path (pathname-directory file))
    601                             (dir-len (length rev-dir))
    602                             (len (length path)))
    603                        (if (< len dir-len)
    604                         (setq rev-dir (nthcdr (- dir-len len) rev-dir))
    605                         (setq path (subseq path 0 dir-len)))
    606                        (loop for pp on (reverse path) until (equalp pp rev-dir)
    607                           do (pop rev-dir))))))))
     658          when (consp data)
     659            do (let ((file (probe-file (code-covered-info.file data))))
     660                 (when file
     661                   (cond ((eq host :unknown)
     662                          (setq host (pathname-host file)
     663                                rev-dir (reverse (pathname-directory file))))
     664                         ((not (equalp host (pathname-host file)))
     665                          (return-from common-coverage-directory nil))
     666                         (t
     667                          (let* ((path (pathname-directory file))
     668                                 (dir-len (length rev-dir))
     669                                 (len (length path)))
     670                            (if (< len dir-len)
     671                              (setq rev-dir (nthcdr (- dir-len len) rev-dir))
     672                              (setq path (subseq path 0 dir-len)))
     673                            (loop for pp on (reverse path) until (equalp pp rev-dir)
     674                                  do (pop rev-dir))))))))
    608675    (unless (eq host :unknown)
    609676      (make-pathname :host host :directory (reverse rev-dir)))))
     
    611678
    612679(defun ccl:coverage-statistics ()
    613   (with-decoded-coverage ()
    614     (mapcar #'file-coverage-statistics *file-coverage*)))
     680  (with-coverage-decoding ()
     681    (loop for data in *code-covered-functions*
     682          do (with-decoded-file-coverage (coverage data)
     683               (file-coverage-statistics coverage)))))
    615684
    616685(defun compute-file-coverage-statistics (coverage)
    617   (count-covered-sexps coverage)
    618686  (count-unreached-branches coverage)
    619687  (count-covered-aexps coverage)
    620   (count-covered-entry-notes coverage))
    621 
    622 
    623 (defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t))
     688  (count-covered-sexps coverage))
     689
     690(defun native-file-namestring (file)
     691  (native-translated-namestring (make-pathname :name (pathname-name file)
     692                                               :type (pathname-type file))))
     693
     694
     695(defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t) (tags nil))
    624696  "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE
    625697and, in the same directory, one html file for each instrumented source file that has been
     
    629701:STATISTICS is a filename, that file is used, else 'statistics.csv' is
    630702written to the output directory.
    631 "
     703If :TAGS is non-nil, it must be a hash table whose values are incremental coverage snapshots. This
     704causes the HTML report to include incremental coverage information"
     705  ;; TODO: *** How to present incremental coverage info in statistics file?
    632706  (let* ((paths)
    633707         (directory (make-pathname :name nil :type nil :defaults output-file))
     
    636710         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
    637711                                                              (pathnamep statistics))
    638                                                         (merge-pathnames statistics "statistics.csv")
    639                                                         "statistics.csv")
     712                                                          (merge-pathnames statistics "statistics.csv")
     713                                                          "statistics.csv")
    640714                                                      output-file))))
    641715    (ensure-directories-exist directory)
    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))))
     716    (with-coverage-decoding (:tags tags)
     717      (loop for data in *code-covered-functions* as file = (code-covered-info.file data)
     718            as truename =  (and file (or (probe-file file)
     719                                         (progn (warn "Cannot find ~s, won't report coverage" file)
     720                                                nil)))
     721            do (when truename
     722                 (let* ((src-name (enough-namestring truename coverage-dir))
     723                        (html-name (substitute
     724                                    #\_ #\: (substitute
     725                                             #\_ #\. (substitute
     726                                                      #\_ #\/ (namestring-unquote src-name))))))
     727                   (with-decoded-file-coverage (coverage data)
     728                     (when html
     729                       (let* ((checksum (fcomp-file-checksum file :external-format (code-covered-info.ef data))))
     730                         (unless (eql checksum (code-covered-info.id data))
     731                           (cerror "Try coloring anyway"
     732                                   "File ~s has changed since coverage source location info was recorded."
     733                                   file)))
     734                       (report-file-coverage index-file coverage directory html-name external-format))
     735                     (push (list* src-name html-name coverage) paths)))))
    669736      (when (null paths)
    670737        (error "No code coverage data available"))
     
    696763                                        :if-does-not-exist :create)
    697764            (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))))
     765          (error "One of :HTML or :STATISTICS must be non-nil"))))
     766    (values index-file stats-file)))
     767
    700768
    701769(defun report-coverage-to-streams (paths html-stream stats-stream)
    702   (when html-stream (write-coverage-styles html-stream))
     770  (when html-stream
     771    (format html-stream "<html><head>~%")
     772    (write-coverage-styles html-stream)
     773    (format html-stream "~%</head>~%<body>"))
    703774  (unless paths
    704775    (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
     
    707778    (return-from report-coverage-to-streams))
    708779  (when html-stream (format html-stream "<table class='summary'>"))
    709   (coverage-stats-head html-stream stats-stream)
     780  (coverage-stats-head html-stream stats-stream t)
    710781  (loop for prev = nil then src-name
    711         for (src-name report-name . coverage) in paths
    712         for even = nil then (not even)
    713         do (when (or (null prev)
    714                      (not (equal (pathname-directory (pathname src-name))
    715                                 (pathname-directory (pathname prev)))))
    716              (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
    717                (when html-stream (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir))
    718                (when stats-stream (format stats-stream "~a~%" dir))))
    719         do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
    720   (when html-stream (format html-stream "</table>")))
     782        for (src-name report-name . coverage) in paths
     783        for even = nil then (not even)
     784        do (when (or (null prev)
     785                     (not (equal (pathname-directory (pathname src-name))
     786                                (pathname-directory (pathname prev)))))
     787             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
     788               (when html-stream (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir))
     789               (when stats-stream (format stats-stream "~a~%" dir))))
     790        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
     791  (when html-stream (format html-stream "</table></body></html>")))
    721792
    722793(defun style-for-coverage (coverage)
     
    726797    (t $partially-covered-style)))
    727798 
    728 (defun fill-with-text-style (source-note styles)
    729   (fill styles (style-for-coverage (source-coverage source-note))
    730         :start (source-note-start-pos source-note)
    731         :end (source-note-end-pos source-note)))
    732 
    733 (defun update-text-styles (note styles)
    734   (let ((source (code-note-source-note note)))
    735     (when source
    736       (fill-with-text-style source styles))
    737     (unless (and (emitted-code-note-p note)
    738                  (memq (code-note-code-coverage note) '(nil full))
    739                  ;; If not a source note, descend in case have some subnotes
    740                  ;; that can be shown
    741                  source)
    742       (loop for sub in (coverage-subnotes note)
    743             unless (entry-code-note-p sub)
    744             do (update-text-styles sub styles)))))
    745 
    746 (defun entry-note-unambiguous-source (entry-note)
    747   ;; Return the nearest containing source note provided it can be done unambiguously.
    748   (loop for n = entry-note then parent until (code-note-source-note n)
    749         as parent = (code-note-parent-note n)
    750         do (unless (and parent
    751                         (labels ((no-other-entry-subnotes (n refs)
    752                                    (let ((subs (coverage-subnotes n))
    753                                          (refs (cons n refs)))
    754                                      (declare (dynamic-extent refs))
    755                                      (loop for sub in subs
    756                                            always (or (memq sub refs)
    757                                                       (eq sub entry-note)
    758                                                       (and (not (entry-code-note-p sub))
    759                                                            (no-other-entry-subnotes sub refs)))))))
    760                           (no-other-entry-subnotes parent ())))
    761              (return nil))
    762         finally (return (code-note-source-note n))))
    763 
    764 ;; In some cases, a single source form may be claimed by multiple code notes.  Precompute
    765 ;; per-source coverage info so coloring can reflect aggregated info for all coverage points.
    766 ;; This also changes coverage flag to 'full if all subforms are called.
    767799(defun precompute-source-coverage (coverage)
    768   (labels
    769       ((record-1 (source note)
    770          (when source
    771            (let ((old (gethash source *source-coverage* :default))
    772                  (new (code-note-code-coverage note)))
    773              (unless (eq old new)
    774                (setf (gethash source *source-coverage*) (if (eq old :default) new t))))))
    775        (record* (note)
    776          (loop with full = (or (code-note-code-coverage note)
    777                                (not (emitted-code-note-p note)))
    778                for sub in (coverage-subnotes note)
    779                unless (entry-code-note-p sub)
    780                  do (progn
    781                       (record* sub)
    782                       (unless (eq (code-note-code-coverage sub) 'full)
    783                         (setq full nil)))
    784                finally (when full
    785                          (setf (code-note-code-coverage note) 'full)))
    786          (record-1 (code-note-source-note note) note))
    787        (record-entry (note)
    788          (record* note)
    789          ;; A special kludge for entry notes:
    790          ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
    791          ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
    792          ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
    793          ;; expanded into the above, there isn't a clear way to show the distinction between
    794          ;; just referencing the inner fn and executing it.  In practice, the colorization
    795          ;; based on the inner function is more interesting -- consider for example DEFUN,
    796          ;; nobody cares whether the defun form itself got executed.
    797          ;; So when showing the colorization of an inner function, we usurp the whole nearest source
    798          ;; form, provided it can be done unambiguously.
    799          (record-1 (entry-note-unambiguous-source note) note)))
    800     (map-coverage-entry-notes coverage #'record-entry)))
    801 
    802 (defun colorize-source-note (note styles)
    803   ;; See comment in precompute-source-coverage
    804   (let ((source (entry-note-unambiguous-source note)))
    805     (when source
    806       (fill-with-text-style source styles)))
    807   (update-text-styles note styles))
     800  ;; linearize emitted notes with children preceding parents, and mark up fully covered ones.
     801  ;; This assumes code notes are never individually reset, so once something is fully
     802  ;; covered, it stays fully covered, so no need to reinit the setting, just update.
     803  (let ((subnotes *code-note-subnotes*)
     804        (vector *emitted-code-notes*)
     805        (index-hash *code-note-index*))
     806    (iterate descend ((note nil))
     807      (let ((full-p (and note (code-note-code-coverage note))))
     808        (loop for subnote in (gethash note subnotes)
     809              do (unless (descend subnote) (setq full-p nil))
     810              do (setf (gethash subnote index-hash) (vector-push-extend subnote vector)))
     811        (when full-p         ;; return true if full, nil if not.
     812          (setf (code-note-code-coverage note) 'full)))))
     813  ;; Find all source notes
     814  ;; Note that can't compute a source hierarchy because the reader flattens the backpointers
     815  ;; so each subnote points directly to the toplevel note.
     816  (labels ((subnotep (a b)
     817             (or (eq a b) (and a (subnotep (code-note-parent-note a) b))))
     818           (register (source emitted-notes)
     819             (assert emitted-notes)
     820             (let ((prior-notes (gethash source *source-code-notes*)))
     821               (if prior-notes
     822                 ;; In some cases, a single source form may be claimed by multiple code notes,
     823                 (setq emitted-notes
     824                       (nconc
     825                        (setq emitted-notes
     826                              (remove-if (lambda (new)
     827                                           (some (lambda (old) (subnotep new old)) prior-notes))
     828                                         emitted-notes))
     829                        (if emitted-notes
     830                          (remove-if (lambda (old)
     831                                       (some (lambda (new) (subnotep old new)) emitted-notes))
     832                                     prior-notes)
     833                          prior-notes)))
     834                 ;; Else this is the first time, record it
     835                 (vector-push-extend source *covered-source-notes*)))
     836             (setf (gethash source *source-code-notes*) emitted-notes)))
     837    (loop for note across *emitted-code-notes*
     838          as source = (code-note-source-note note)
     839          when source do (register source (list note))
     840            ;; want to look at all notes, even unemitted, so can get all source forms
     841            do (loop while (and (setq note (code-note-parent-note note))
     842                                (not (emitted-code-note-p note)))
     843                     when (setq source (code-note-source-note note))
     844                       do (register source (code-note-subnotes note))))
     845    (setf *covered-source-notes*
     846          (sort *covered-source-notes* #'< :key #'source-note-start-pos)) ;; this puts parents before children
     847    (loop for source across *covered-source-notes* as index upfrom 0
     848          do (setf (gethash source *source-note-index*) index)))
     849  (assert (eql (length *covered-source-notes*) (hash-table-count *source-code-notes*)))
     850  coverage)
     851
     852(defun file-coverage-html-queue (coverage)
     853  (declare (ignore coverage)) ;; turns out everything we need is already in global variables
     854  ;; Collect top-level sources.  *covered-source-notes* is sorted by start address.
     855  (let ((queue (loop with vector = *covered-source-notes* with len = (length vector)
     856                     for start = 0 then end while (< start len)
     857                     as sn = (aref vector start)
     858                     as end = (loop with limit = (source-note-end-pos sn)
     859                                    for i from (1+ start) below len
     860                                    until (<= limit (source-note-start-pos (aref vector i)))
     861                                    finally (return i))
     862                     collect (list* end nil (source-note-end-pos sn)))));; (end-index acodes . end-pos)
     863    ;; Find all acode strings, assign them to appropriate toplevel source form, and collect
     864    ;; all code notes for each acode.
     865    (loop for note across *emitted-code-notes*
     866          when (code-note-acode-range note)
     867            do (let* ((source (nearest-source-note note))
     868                      (pos (source-note-start-pos source))
     869                      (cell (loop for cell in queue while (<= (cddr cell) pos) finally (return cell)))
     870                      (acode (%function-acode-string (code-note-function note)))
     871                      (acell (or (assq acode (cadr cell))
     872                                 (car (push (list* acode nil 0) (cadr cell))))));; (acode notes . src-pos)
     873                 (assert (and cell acode))
     874                 (setf (cddr acell) (min (cddr acell) pos));; earliest known source for this acode
     875                 (push note (cadr acell))))
     876    ;; Sort acode by source position within source form, sort notes by position within the acode,
     877    ;; get rid of the end-pos/src-pos fields since no longer needed.
     878    (loop for cell in queue
     879          do (setf (cdr cell) (sort (cadr cell) #'< :key #'cddr));; (end-index . acodes)
     880          do (loop for acell in (cdr cell)
     881                   do (setf (cdr acell) (sort (cadr acell) #'< :key #'code-note-acode-start-pos)))) ; (acode . notes)
     882    queue))
     883
    808884
    809885(defun function-outermost-entry-source (fn)
     
    811887  (loop with sn = nil
    812888        for n = (function-entry-code-note fn) then (code-note-parent-note n)
    813         do (when (null n) (return nil))
    814         do (when (setq sn (code-note-source-note n))
    815              (loop for s = (source-note-source sn) while (source-note-p s)
    816                    do (setq sn s))
    817              (return sn))))
    818 
    819 (defun colorize-acode (fn acode-styles)
    820   (let* ((acode (%function-acode-string fn))
    821          (note (function-entry-code-note fn))
    822          (range (and note (code-note-acode-range note))))
    823     (when (and acode range)
    824       (let* ((cell (or (gethash acode acode-styles)
    825                        (setf (gethash acode acode-styles)
    826                              (let ((string (decode-string-from-octets acode :external-format :utf-8)))
    827                                (cons string
    828                                      (make-array (length string)
    829                                                  :initial-element $no-style
    830                                                  :element-type '(unsigned-byte 2)))))))
    831              (styles (cdr cell)))
    832         (iterate update ((note note))
    833           (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
    834             (when (and start
    835                        (setq start (position-if-not #'whitespacep acode :start start :end end :key #'code-char)))
    836               (fill styles (style-for-coverage (code-note-code-coverage note))
    837                     :start start
    838                     :end end)))
    839           (loop for sub in (coverage-subnotes note)
    840             unless (entry-code-note-p sub)
    841             do (update sub)))))))
    842 
    843 (defun colorize-function (fn styles acode-styles &optional refs)
    844   (let* ((note (function-entry-code-note fn))
    845          (source (function-outermost-entry-source fn))
    846          (refs (cons fn refs)))
    847     (declare (dynamic-extent refs))
    848     ;; Colorize the body of the function
    849     (when note
    850       (colorize-source-note note styles)
    851       (colorize-acode fn acode-styles))
    852     ;; And now any subfunction references
    853     (lfunloop for imm in fn
    854               when (and (functionp imm)
    855                         (not (memq imm refs))
    856                         ;; See note in decode-function-coverage
    857                         (or (null source)
    858                             (eq source (function-outermost-entry-source imm))
    859                             #+debug (progn
    860                                       (warn "Ignoring ref to ~s from ~s" imm fn)
    861                                       nil)))
    862               do (colorize-function imm styles acode-styles refs))))
    863 
    864 (defun report-file-coverage (index-file coverage html-stream external-format)
    865   "Print a code coverage report of FILE into the stream HTML-STREAM."
    866   (format html-stream "<html><head>")
    867   (write-coverage-styles html-stream)
    868   (format html-stream "</head><body>")
    869   (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format)
    870                    (let ((string (make-string (file-length s))))
    871                      (read-sequence string s)
    872                      string)))
    873          (styles (make-array (length source)
    874                              :initial-element $no-style
    875                              :element-type '(unsigned-byte 2)))
    876          (acode-styles (make-hash-table :test #'eq)))
    877     (map nil #'(lambda (fn) (colorize-function fn styles acode-styles))
    878          (file-coverage-toplevel-functions coverage))
    879     (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
    880     (format html-stream "</body></html>")))
    881 
    882 (defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
     889        do (when (null n) (return nil))
     890        do (when (setq sn (code-note-source-note n))
     891             (loop for s = (source-note-source sn) while (source-note-p s)
     892                   do (setq sn s))
     893             (return sn))))
     894
     895
     896(defun report-file-coverage (index-file coverage directory html-name external-format)
     897  (with-open-file (js-stream (make-pathname :name html-name :type "js" :defaults directory)
     898                             :direction :output
     899                             :if-exists :supersede
     900                             :if-does-not-exist :create)
     901    (write-coverage-js-file js-stream coverage))
     902  (with-open-file (html-stream (make-pathname :name html-name :type "html" :defaults directory)
     903                               :direction :output
     904                               :if-exists :supersede
     905                               :if-does-not-exist :create)
     906    (write-coverage-html-file index-file html-name html-stream coverage external-format)))
     907
     908(defun write-coverage-html-file (index-file html-name html-stream coverage source-external-format)
    883909  (let ((*print-case* :downcase))
     910
     911    (format html-stream "<html><head>")
     912    (write-coverage-styles html-stream)
     913    (format html-stream "<script src='~a.js'></script>~%" html-name)
     914    (format html-stream "</head><body onload='colorize(true)'>")
     915
    884916    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
    885             (native-translated-namestring (make-pathname :name (pathname-name index-file)
    886                                                          :type (pathname-type index-file)))
     917            (native-file-namestring index-file)
    887918            (file-coverage-file coverage))
    888919    (format html-stream "<table class='summary'>")
    889     (coverage-stats-head html-stream nil)
    890     (coverage-stats-data html-stream nil coverage)
     920    (file-coverage-stats-html html-stream)
    891921    (format html-stream "</table>")
     922
     923    ;;(format html-stream "~2%<a href='javascript:DEBUG_OUT(CodeParents)'>Doit</a><div id='foo'>Debug output here</div>")
    892924
    893925    (format html-stream "<div class='key'><b>Key</b><br />~%")
     
    898930    (format html-stream "</div><p></p>~%")
    899931
    900     ;; Output source intertwined with acode
    901     (iterate output ((start 0) (line 0) (queue (file-coverage-acode-queue coverage)))
    902       (format html-stream "<div class='source'><code>")
    903       (let ((next (car queue)))
    904         (multiple-value-bind (end last-line)
    905             (output-styled html-stream source styles
    906                            :start start
    907                            :line line
    908                            :limit (car next))
    909           (format html-stream "</code></div>~%")
    910           (when (and next end (<= (car next) end))
    911             (destructuring-bind (pos . strings) next
    912               (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
    913                                    <div class='acode' id='a~:*~d'><code>" pos)
    914               (loop for acode in strings as (string . styles) = (gethash acode acode-styles)
    915                     do (output-styled html-stream string styles)
    916                     do (fresh-line html-stream))
    917               (format html-stream "</code></div><hr/>~%")
    918               (output (1+ end) last-line (cdr queue)))))))))
    919 
    920 (defun output-styled (html-stream source styles &key (start 0) line limit)
    921   (let ((last-style $no-style)
    922         (col 0)
    923         (line line))
    924     (labels ((outch (char)
    925                (if (eql char #\Tab)
    926                  (dotimes (i (- 8 (mod col 8)))
    927                    (incf col)
    928                    (write-string " " html-stream))
    929                  (progn
    930                    (incf col)
    931                    (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
    932                      (write-char char html-stream)
    933                      (format html-stream "&#~D;" (char-code char))))))
    934              (start-line ()
    935                (when line
    936                  (incf line)
    937                  (format html-stream "<span class='line'>~A</span>" line))
    938                (write-char #\space html-stream)
    939                (setq col 0))
    940              (set-style (new)
    941                (unless (eq last-style new)
    942                  (unless (eq last-style $no-style) (format html-stream "</span>"))
    943                  (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
    944                  (setq last-style new)))
    945              (end-line ()
    946                (set-style $no-style)
    947                (format html-stream "~%")))
    948       (declare (inline outch start-line end-line))
    949       (unless limit (setq limit (length source)))
    950       (start-line)
    951       (loop
    952         for pos from start below (length source)
    953         as char = (aref source pos) as style = (aref styles pos)
    954         do (set-style style)
    955         do (case char
    956              ((#\Newline)
    957               (end-line)
    958               (when (<= limit pos)
    959                 (return (values pos line)))
    960               (start-line))
    961              (t
    962               (outch char)))
    963         finally (end-line)))))
    964 
    965 
    966 (defun coverage-stats-head (html-stream stats-stream)
     932    (output-spanned-html html-stream coverage source-external-format)
     933
     934    (format html-stream "</body></html>")))
     935
     936#|
     937var COV = ['unknown', 'not', 'all', 'some'];
     938function DEBUG_OUT(text) {
     939  var msg = document.getElementById('foo');
     940  msg.innerHTML = msg.innerHTML + '<br />' + text;
     941}
     942|#
     943
     944;; This goes in each file.
     945(defparameter $coverage-javascript "
     946
     947function tags_intersect (tags1, tags2) {   // tags2 = true means all tags.
     948  if (tags2 === true)
     949    return (tags1.length > 0);
     950  for (var i = 0; i < tags1.length; i++) {
     951    var tag1 = tags1[i];
     952    for (var j = 0; j < tags2.length; j++)
     953      if (tag1 == tags2[j]) return true;
     954  }
     955  return false;
     956}
     957
     958function is_member (elt, vec) {
     959  for (var i = 0; i < vec.length; i++) {
     960    if (vec[i] == elt) return true;
     961  }
     962  return false;
     963}
     964
     965function set_stats_with_pct(name, count, total) {
     966  var pct;
     967
     968  if (total > 0) {
     969    var pct = (count * 100) / total;
     970    pct = pct.toFixed(1) + '&#37;';
     971  }
     972  else {
     973    pct = '--';
     974  }
     975 
     976  document.getElementById(name).innerHTML = count;
     977
     978  document.getElementById(name + 'Pct').innerHTML =  pct;
     979}
     980
     981function colorize (tags_to_show) {
     982  var style;
     983
     984  // Compute acode coverage and colorize acode
     985  var total = (CodeTags ? CodeTags.length : CodeCoverage.length) - 1;
     986  var num_entered = 0;
     987  var coverage = new Array(total);
     988
     989  for (var cn = 0; cn < total; cn++) {
     990    var covered = (CodeTags ? tags_intersect(CodeTags[cn], tags_to_show) : CodeCoverage[cn]);
     991    style = (covered ? ALL_COVERED : NOT_COVERED);
     992
     993    var sub_style = coverage[cn];
     994    if (sub_style && (style != sub_style)) style = PARTLY_COVERED;
     995
     996    coverage[cn] = style; // save for source coloring use below
     997    if (style != NOT_COVERED) num_entered++;
     998    var parent = CodeParents[cn];
     999    if (parent) {
     1000      var sibs_style = coverage[parent];
     1001      if (sibs_style != style) coverage[parent] = (!sibs_style ? style : PARTLY_COVERED);
     1002    }
     1003
     1004  var elt = document.getElementById('f~dc' + cn);  // some notes don't have a matched up source.
     1005  if (elt) elt.className = 'st' + style;
     1006  }
     1007
     1008
     1009  document.getElementById('acodeTotal').innerHTML = total;
     1010  set_stats_with_pct('acodeCovered', num_entered, total);
     1011
     1012  // Count unreached branches (aka maximal unentered forms)
     1013  var total = coverage.length;
     1014  var num_branches = 0;
     1015  var parent;
     1016  for (var cn = 0; cn < total; cn++) {
     1017    if ((coverage[cn] == NOT_COVERED) && // not covered
     1018        (parent = CodeParents[cn]) &&  // has a parent
     1019        (coverage[parent] != NOT_COVERED) &&  // that's covered
     1020        (!is_member(cn, FunctionNotes))) // and not an entry note
     1021      num_branches++;
     1022  }
     1023
     1024  document.getElementById('branchUnreached').innerHTML = num_branches;
     1025
     1026
     1027  // Colorize Source
     1028  var total = (SourceCodeNotes ? SourceCodeNotes.length : SourceCoverage.length) - 1;
     1029  var num_all = 0, num_partly = 0;
     1030
     1031  for (var sn = 0; sn < total; sn++) {
     1032    if (SourceCodeNotes) {
     1033      var notes = SourceCoverage[sn];
     1034      for (var i = 0, style = NO_DATA; i < notes.length; i++) {
     1035        var note_style = coverage[notes[i]];
     1036        if (style != note_style) style = (style == NO_DATA ? note_style : PARTLY_COVERED);
     1037      }
     1038    }
     1039    else {
     1040      style = SourceCoverage[sn];
     1041    }
     1042
     1043    switch (style) {
     1044      case ALL_COVERED: num_all++; break;
     1045      case PARTLY_COVERED: num_partly++; break;
     1046    }
     1047
     1048   document.getElementById('f~:*~ds' + sn).className = 'st' + style;
     1049
     1050  }
     1051  document.getElementById('srcTotal').innerHTML = total;
     1052  set_stats_with_pct('srcEntered', num_all + num_partly, total);
     1053  set_stats_with_pct('srcCovered', num_all, total);
     1054
     1055  var total = FunctionNotes.length - 1;
     1056  var num_all = 0, num_partly = 0, num_not = 0;
     1057
     1058  for (var i = 0; i < total; i++) {
     1059    var cn = FunctionNotes[i];
     1060    switch (coverage[FunctionNotes[i]]) {
     1061      case ALL_COVERED: num_all++; break;
     1062      case PARTLY_COVERED: num_partly++; break;
     1063      case NOT_COVERED: num_not++; break;
     1064    }
     1065  }
     1066
     1067  document.getElementById('fnTotal').innerHTML = total;
     1068  set_stats_with_pct('fnCovered', num_all, total);
     1069  set_stats_with_pct('fnPartly', num_partly, total);
     1070  set_stats_with_pct('fnUnentered', num_not, total);
     1071
     1072
     1073}
     1074")
     1075
     1076
     1077(defmacro write-js-array (js-stream-expr var-expr data-expr writer)
     1078  (let ((js-stream (gensym))
     1079        (var (gensym))
     1080        (data (gensym)))
     1081    `(let ((,js-stream ,js-stream-expr)
     1082           (,var ,var-expr)
     1083           (,data ,data-expr))
     1084       (when ,var (format ,js-stream "~2&var ~a = " ,var))
     1085       (format ,js-stream "[")
     1086       (loop with len = (and (vectorp ,data) (length ,data))
     1087             for index upfrom 0
     1088             while (if len (< index len) ,data)
     1089             as note = (if len (aref ,data index) (pop ,data))
     1090             do (funcall ,writer ,js-stream note)
     1091             do (write-string (if (eql 0 (mod index 50)) #.(format nil ",~% ") ", ") ,js-stream))
     1092       ;; Add an element at the end because otherwise get the wrong length if last element is empty
     1093       (format ,js-stream "'end']")
     1094       (when ,var (format ,js-stream ";~%")))))
     1095
     1096;; output with a line break every 100 entries
     1097(defun write-coverage-js-file (js-stream coverage)
     1098  (flet ((write-code-parent (js-stream cn)
     1099           (let* ((parent (code-note-emitted-parent cn)))
     1100             (when parent
     1101               (format js-stream "~a" (code-note-index parent)))))
     1102         (write-function-note (js-stream fn)
     1103           (format js-stream "~a" (code-note-index (function-entry-code-note fn))))
     1104         (write-source-coverage (js-stream sn)
     1105           (format js-stream "~a" (style-for-coverage (source-coverage sn))))
     1106         (write-code-coverage (js-stream cn)
     1107           (when (code-note-code-coverage cn) (format js-stream "1")))
     1108         (write-source-notes (js-stream sn)
     1109           (write-js-array js-stream nil (source-code-notes sn)
     1110                           (lambda (js-stream cn) (format js-stream "~a" (code-note-index cn)))))
     1111         (write-code-tags (js-stream cn)
     1112           (write-js-array js-stream nil (code-note-tags cn)
     1113                           (lambda (js-stream tag) (format js-stream "~a" tag)))))
     1114
     1115    (format js-stream "~&var NO_DATA = ~d, NOT_COVERED = ~d, ALL_COVERED = ~d, PARTLY_COVERED = ~d;~2%"
     1116            $not-executed-style $not-executed-style $totally-covered-style $partially-covered-style)
     1117    (write-js-array js-stream "CodeParents" *emitted-code-notes* #'write-code-parent)
     1118    (write-js-array js-stream "FunctionNotes" (file-coverage-functions coverage) #'write-function-note)
     1119    (cond (*coverage-tags*
     1120           (write-js-array js-stream "CodeTags" *emitted-code-notes* #'write-code-tags)
     1121           (write-js-array js-stream "SourceCodeNotes" *covered-source-notes* #'write-source-notes)
     1122           (format js-stream "~&var CodeCoverage;")
     1123           (format js-stream "~&var SourceCoverage;"))
     1124          (t
     1125           (format js-stream "~&var CodeTags;")
     1126           (format js-stream "~&var SourceCodeNotes;")
     1127           (write-js-array js-stream "CodeCoverage" *emitted-code-notes* #'write-code-coverage)
     1128           (write-js-array js-stream "SourceCoverage" *covered-source-notes* #'write-source-coverage)))
     1129    (format js-stream $coverage-javascript (file-coverage-index coverage))
     1130    (terpri js-stream)))
     1131
     1132(defstruct coverage-html-state
     1133  input
     1134  output
     1135  prefix
     1136  (file-pos 0)
     1137  (line-no 0)
     1138  (column 0))
     1139
     1140(defun coverage-html-start-line (s)
     1141  (let ((line-no (coverage-html-state-line-no s))
     1142        (output (coverage-html-state-output s)))
     1143    (when line-no
     1144      (setf (coverage-html-state-line-no s) (incf line-no))
     1145      (format output "<span class='line'>~a</span>" line-no))
     1146    (write-char #\space output)))
     1147
     1148(defun coverage-html-copy-to (s end &optional end-at-newline-p whitespace-only-p)
     1149  (let ((input (coverage-html-state-input s))
     1150        (output (coverage-html-state-output s))
     1151        (file-pos (coverage-html-state-file-pos s)))
     1152    (assert (<= file-pos end))
     1153    (loop until (eql file-pos end)
     1154          as ch = (read-char input)
     1155          do (when (and whitespace-only-p (not (whitespacep ch)))
     1156               (unread-char ch input)
     1157               (return))
     1158             ;; Source note positions are file positions, not character positions, but assume
     1159             ;; non-control ascii chars are 1 byte so don't have to call stream-position all the time.
     1160          do (setq file-pos (if (< 31 (char-code ch) 127)
     1161                              (1+ file-pos)
     1162                              (let ((newpos (stream-position input)))
     1163                                (assert (<= newpos end))
     1164                                newpos)))
     1165          do (when (eql (coverage-html-state-column s) 0) (coverage-html-start-line s))
     1166          do (case ch
     1167               (#\newline
     1168                  (write-char #\Newline output)
     1169                  (setf (coverage-html-state-column s) 0)
     1170                  (when end-at-newline-p (return)))
     1171               (#\tab
     1172                  (let ((count (- 8 (mod (coverage-html-state-column s) 8))))
     1173                    (write-string "        " output :end count)
     1174                    (incf (coverage-html-state-column s) count)))
     1175               (t
     1176                  (incf (coverage-html-state-column s))
     1177                  (if (or (alphanumericp ch)  (find ch "()+-:* "));; common and safe
     1178                    (write-char ch output)
     1179                    (format output "&#~D;" (char-code ch))))))
     1180    (assert (eql file-pos (stream-position input)))
     1181    (setf (coverage-html-state-file-pos s) file-pos)))
     1182
     1183(defun output-coverage-html-acode (s note-queue)
     1184  (let* ((output (coverage-html-state-output s))
     1185         (input (coverage-html-state-input s))
     1186         (prefix (coverage-html-state-prefix s))
     1187         (end (stream-length input)))
     1188    (when (< (coverage-html-state-file-pos s) end)
     1189      (iterate output-subnotes ((limit end))
     1190        (loop while (and note-queue (<= (code-note-acode-end-pos (car note-queue)) limit))
     1191              do (let ((note (pop note-queue)))
     1192                   (coverage-html-copy-to s (code-note-acode-start-pos note))
     1193                   ;; skip leading whitespace -- this is necessary for acode, else looks weird.
     1194                   (coverage-html-copy-to s (code-note-acode-end-pos note) nil t)
     1195                   (format output "<span id='~a~d'>" prefix (code-note-index note))
     1196                   (output-subnotes (code-note-acode-end-pos note))
     1197                   (format output "</span>")))
     1198        (coverage-html-copy-to s limit)))))
     1199
     1200(defun output-coverage-html-source (s start end)
     1201  (let* ((output (coverage-html-state-output s))
     1202         (input (coverage-html-state-input s))
     1203         (prefix (coverage-html-state-prefix s))
     1204         (vector *covered-source-notes*)
     1205         (len (length vector))
     1206         (outer-note (and (< start end) (aref vector start)))
     1207         (nextpos (if (< end len) (source-note-start-pos (aref vector end)) (stream-length input))))
     1208    (when (< (coverage-html-state-file-pos s) nextpos)
     1209      (format output "<div class='source'><code>")
     1210      (when outer-note
     1211        ;; The first time through this will just do the first note, because that's all that fits.
     1212        (iterate output-subnotes ((outer-note outer-note))
     1213          (loop with outer-end = (source-note-end-pos outer-note)
     1214                as note = (and (< start end) (aref vector start))
     1215                while (and note (<= (source-note-end-pos note) outer-end))
     1216                do (progn
     1217                     (coverage-html-copy-to s (source-note-start-pos note))
     1218                     (format output "<span id='~a~d'>" prefix start)
     1219                     (incf start)
     1220                     (output-subnotes note)
     1221                     (format output "</span>"))
     1222                finally (coverage-html-copy-to s outer-end))))
     1223      ;; Copy the rest of the last line, or to end if called without a note.
     1224      (coverage-html-copy-to s nextpos outer-note)
     1225      (format output "</code></div>~%"))))
     1226
     1227(defun output-spanned-html (html-stream coverage external-format)
     1228  (with-open-file (source-stream (file-coverage-file coverage) :external-format external-format)
     1229    (let* ((queue (file-coverage-html-queue coverage))
     1230           (prefix (format nil "f~d" (file-coverage-index coverage)))
     1231           (s (make-coverage-html-state :input source-stream
     1232                                        :output html-stream
     1233                                        :prefix (%str-cat prefix "s"))))
     1234      (loop
     1235        for start = 0 then end as (end . acodes) in queue
     1236        do (output-coverage-html-source s start end)
     1237        do (format html-stream "<a href=javascript:swap('~at~d')><span class='toggle' id='p~2:*~at~d'>Show expansion</span></a>~%~
     1238                                        <div class='acode' id='a~2:*~at~d'><code>" prefix start)
     1239        do (loop for (acode . notes) in acodes
     1240                 do (with-input-from-vector (astream acode :external-format :utf-8)
     1241                      (let ((cs (make-coverage-html-state :input astream
     1242                                                          :output html-stream
     1243                                                          :prefix (%str-cat prefix "c")
     1244                                                          :line-no nil)))
     1245                        (output-coverage-html-acode cs notes)
     1246                        (fresh-line html-stream))))
     1247        do (format html-stream "</code></div><hr/>~%")
     1248           ;; output the rest of file, no notes.
     1249        finally (output-coverage-html-source s start start)))))
     1250
     1251(defun coverage-stats-head (html-stream stats-stream include-source-p)
    9671252  (when html-stream
    968     (format html-stream "<tr class='head-row'><td></td>")
     1253    (format html-stream "<tr class='head-row'>")
     1254    (when include-source-p (format html-stream "<td></td>"))
    9691255    (format html-stream "<td class='main-head' colspan='5'>Expressions</td>")
    9701256    (format html-stream "<td class='main-head' colspan='1'>Branches</td>")
    9711257    (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>")
    9721258    (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>")
    973     (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
    974             '("Source file"
    975               ;; Expressions
    976               "Total" "Entered" "% entered" "Fully covered" "% fully covered"
    977               ;; Branches
    978               "total unreached"
    979               ;; Code forms
    980               "Total" "Covered" "% covered"
    981               ;; Functions
    982               "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
     1259    (format html-stream "<tr class='head-row'>")
     1260    (let ((fields '(;; Expressions
     1261                    "Total" "Entered" "% entered" "Fully covered" "% fully covered"
     1262                    ;; Branches
     1263                    "total unreached"
     1264                    ;; Code forms
     1265                    "Total" "Covered" "% covered"
     1266                    ;; Functions
     1267                    "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
     1268      (when include-source-p (push "Source file" fields))
     1269      (format html-stream "~{<td width='60px'>~A</td>~}" fields))
     1270    (format html-stream "</tr>"))
    9831271  (when stats-stream
    9841272    (format stats-stream "~{~a~^,~}"
    985             `("Source file"
     1273            `("Source file"
    9861274              "Expressions Total" "Expressions Entered" "% Expressions Entered"
    9871275              "Unreached Branches"
    9881276              "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
    9891277              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
    990               "Functions Partly Covered" "% Functions Partly Covered"
    991               "Functions Not Entered" "% Functions Not Entered"))))
    992 
    993 (defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name)
     1278              "Functions Partly Covered" "% Functions Partly Covered"
     1279              "Functions Not Entered" "% Functions Not Entered"))))
     1280
     1281(defun file-coverage-stats-html (html-stream)
     1282  (format html-stream "<table class='summary'>")
     1283  (coverage-stats-head html-stream nil nil)
     1284  (format html-stream "<tr class='odd'>")
     1285  (format html-stream "~{<td id='~a'></td>~}"
     1286          '("srcTotal" "srcEntered" "srcEnteredPct" "srcCovered" "srcCoveredPct"
     1287            "branchUnreached"
     1288            "acodeTotal" "acodeCovered" "acodeCoveredPct"
     1289            "fnTotal" "fnCovered" "fnCoveredPct" "fnPartly" "fnPartlyPct" "fnUnentered" "fnUnenteredPct"))
     1290  (format html-stream "</table>"))
     1291 
     1292(defun coverage-stats-data (html-stream stats-stream coverage evenp report-name src-name)
    9941293  (when html-stream
    9951294    (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
    996     (if report-name
    997       (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name)
    998       (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage))))
     1295    (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name))
    9991296  (when stats-stream
    10001297    (format stats-stream "~a," (file-coverage-file coverage)))
     
    10431340      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
    10441341
    1045 (defun map-coverage-entry-notes (coverage fn)
    1046   (map nil #'(lambda (function)
    1047                  (let ((note (function-entry-code-note function)))
    1048                    (when (and note
    1049                               ;; Ignore toplevel functions created by the compiler.
    1050                               (or (code-note-source-note note)
    1051                                   (code-note-parent-note note)))
    1052                      (funcall fn note))))
    1053        (file-coverage-functions coverage)))
    1054 
    1055 
    1056 (defun count-covered-entry-notes (coverage)
    1057   (let ((fully 0) (partly 0) (never 0) (total 0))
    1058     (map-coverage-entry-notes
    1059      coverage
    1060      #'(lambda (note)
    1061          (incf total)
    1062          (case (code-note-code-coverage note)
    1063            ((full) (incf fully))
    1064            ((nil) (incf never))
    1065            (t (incf partly)))))
    1066     (let ((stats (file-coverage-statistics coverage)))
    1067       (setf (coverage-functions-total stats) total)
    1068       (setf (coverage-functions-fully-covered stats) fully)
    1069       (setf (coverage-functions-partly-covered stats) partly)
    1070       (setf (coverage-functions-not-entered stats) never))))
    1071 
    10721342(defun count-covered-aexps (coverage)
    1073   (let ((covered 0) (total 0))
    1074     (map-coverage-entry-notes
    1075      coverage
    1076      (lambda (note)
    1077        (labels ((rec (note)
    1078                   (when (emitted-code-note-p note)
    1079                     (incf total)
    1080                     (when (code-note-code-coverage note)
    1081                       (incf covered)))
    1082                   (loop for sub in (coverage-subnotes note)
    1083                         unless (entry-code-note-p sub) do (rec sub))))
    1084          (rec note))))
     1343  (let ((covered 0) (total 0)
     1344        (entry-full 0) (entry-part 0) (entry-never 0) (entry-total 0))
     1345    (loop for note across *emitted-code-notes*
     1346          do (incf total)
     1347          do (when (code-note-code-coverage note)
     1348               (incf covered))
     1349          do (when (entry-code-note-p note)
     1350               (incf entry-total)
     1351               (case (code-note-code-coverage note)
     1352                 ((full) (incf entry-full))
     1353                 ((nil) (incf entry-never))
     1354                 (t (incf entry-part)))))
    10851355    (let ((stats (file-coverage-statistics coverage)))
    10861356      (setf (coverage-code-forms-total stats) total)
    1087       (setf (coverage-code-forms-covered stats) covered))))
     1357      (setf (coverage-code-forms-covered stats) covered)
     1358      (setf (coverage-functions-total stats) entry-total)
     1359      (setf (coverage-functions-fully-covered stats) entry-full)
     1360      (setf (coverage-functions-partly-covered stats) entry-part)
     1361      (setf (coverage-functions-not-entered stats) entry-never))))
     1362
    10881363
    10891364(defun count-covered-sexps (coverage)
    1090   ;; Count the number of source expressions that have been entered (regardless
    1091   ;; of whether or not they are completely covered).
    1092   (let ((entered 0) (covered 0) (total 0)
    1093         (done (make-hash-table :test #'eq :shared nil)))
    1094     (map-coverage-entry-notes
    1095      coverage
    1096      (lambda (note)
    1097        (labels ((rec (note)
    1098                   (let ((source-note (code-note-source-note note)))
    1099                     (when (and source-note (not (gethash source-note done)))
    1100                       (setf (gethash source-note done) t)
    1101                       (incf total)
    1102                       (let ((data (source-coverage source-note)))
    1103                         (when data
    1104                           (incf entered)
    1105                           (when (eq data 'full)
    1106                             (incf covered)))))
    1107                     (loop for sub in (coverage-subnotes note)
    1108                           unless (entry-code-note-p sub) do (rec sub)))))
    1109          (rec note))))
     1365  ;; Count the number of source expressions that have been entered or covered
     1366  (let ((entered 0) (covered 0) (total (length *covered-source-notes*)))
     1367    (loop for source across *covered-source-notes* as cover = (source-coverage source)
     1368          do (when cover
     1369               (incf entered)
     1370               (when (eq cover 'full) (incf covered))))
    11101371    (let ((stats (file-coverage-statistics coverage)))
    11111372      (setf (coverage-expressions-total stats) total)
     
    11141375
    11151376(defun count-unreached-branches (coverage)
    1116   ;; Count the number of maximal unentered forms
    1117   (let ((count 0))
    1118     (map-coverage-entry-notes
    1119      coverage
    1120      (lambda (note)
    1121        (labels ((rec (note parent)
    1122                   (case (code-note-code-coverage note)
    1123                     ((full) nil)
    1124                     ((nil) (when parent (incf count)))
    1125                     (t (loop for sub in (coverage-subnotes note)
    1126                              unless (entry-code-note-p sub) do (rec sub note))))))
    1127          (rec note nil))))
     1377  ;; Count the number of maximal unentered code forms, i.e. unentered code forms
     1378  ;; whose parent was entered.
     1379  (let ((count (loop for note across *emitted-code-notes*
     1380                     count (and (null (code-note-code-coverage note));; uncovered
     1381                                (not (entry-code-note-p note));; not entry note
     1382                                (setq note (code-note-emitted-parent note));; has a parent
     1383                                (code-note-code-coverage note)))));; that's covered
    11281384    (let ((stats (file-coverage-statistics coverage)))
    11291385      (setf (coverage-unreached-branches stats) count))))
Note: See TracChangeset for help on using the changeset viewer.