Changeset 14798


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

Initial support for incremental code coverage info.

Location:
trunk/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/doc/src/using.xml

    r14794 r14798  
    29332933(progn
    29342934  (do-this)
    2935   (setq that ...) ...))
    2936   </programlisting>
     2935  (setq that ...) ...))</programlisting>
    29372936  do:
    29382937  <programlisting>
     
    29402939  (do-this)
    29412940  (setq that ...)  ...)
    2942 (init-this-and-that)
    2943   </programlisting>
     2941(init-this-and-that)</programlisting>
     2942
    29442943Then you can see the coverage information in the definition of
    29452944<literal>init-this-and-that</literal>.
     
    29562955  <programlisting>
    29572956(setq ccl:*compile-code-coverage* t)
    2958 (recompile-all-your-files)
    2959   </programlisting>
     2957(recompile-all-your-files)</programlisting>
    29602958</para>
    29612959<para>
     
    29642962</para>
    29652963<para>
    2966   When you execute function loaded from instrumented fasl files, they
    2967   will record coverage information every time they are executed. The
    2968   system keeps track of which instrumented files have been loaded.
     2964  When you execute functions loaded from instrumented fasl files, they
     2965  will record coverage information every time they are executed.
     2966  You can examine that information by calling <literal>ccl:report-coverage</literal>
     2967  or <literal>ccl:coverage-statistics</literal>.
    29692968</para>
     2969 <para>
     2970   While recording coverage, you can collect incremental coverage deltas between any two points
     2971   in time.  You might do this while running a test suite, to record the coverage for
     2972   each test, for example:
     2973  <programlisting>
     2974(ccl:reset-incremental-coverage)
     2975(loop with coverage = (make-hash-table)
     2976      for test in (tests-to-run)
     2977      do (run-test test)
     2978      do (setf (gethash test coverage) (ccl:get-incremental-coverage))
     2979      finally (return coverage))</programlisting>creates a hash table mapping a test to a representation of all coverage recorded while running the
     2980   test.  This hash table can then be passed to <literal>ccl:incremental-coverage-svn-matches</literal>
     2981   or <literal>ccl:incremental-coverage-source-matches</literal>.
     2982</para>
     2983</sect2>
     2984
     2985<sect2 id="code-coverage-functions-and-variables"><title>Functions and Variables</title>
    29702986<para>
    29712987  The following functions can be used to manage the coverage data:
     
    30873103    <para>
    30883104      Gets rid of the information about which instrumented files have
    3089       been loaded, so ccl:report-coverage will not report any files,
    3090       and ccl:save-coverage-in-file will not save any info, until more
     3105      been loaded, so <literal>ccl:report-coverage</literal> will not report any files,
     3106      and <literal>ccl:save-coverage-in-file</literal> will not save any info, until more
    30913107      instrumented files are loaded.
    30923108    </para>
     
    31173133      coverage state later. This allows you to combine multiple runs
    31183134      or continue in a later session. Equivalent to
    3119       (ccl:write-coverage-to-file (ccl:save-coverage) pathname).
     3135      <literal>(ccl:write-coverage-to-file (ccl:get-coverage) pathname)</literal>.
    31203136    </para>
    31213137  </refsect1>
     
    31473163      info is only restored for files that have been loaded in this
    31483164      session. For example if in a previous session you had loaded
    3149       "foo.lx86fsl" and then saved the coverage info, in this session
    3150       you must load the same "foo.lx86fsl" before calling
    3151       restore-coverage-from-file in order to retrieve the stored
    3152       coverage info for "foo".  Equivalent to (ccl:restore-coverage
    3153       (ccl:read-coverage-from-file pathname)).
     3165      <filename>"foo.lx86fsl"</filename> and then saved the coverage info, in this session
     3166      you must load the same <filename>"foo.lx86fsl"</filename> before calling
     3167      <literal>restore-coverage-from-file</literal> in order to retrieve the stored
     3168      coverage info for "foo".  Equivalent to <literal>(ccl:restore-coverage
     3169      (ccl:read-coverage-from-file pathname))</literal>.
    31543170    </para>
    31553171  </refsect1>
    31563172</refentry>
    31573173
    3158 <refentry id="f_save-coverage">
    3159   <indexterm zone="f_save-coverage">
    3160     <primary>save-coverage</primary>
     3174<refentry id="f_get-coverage">
     3175  <indexterm zone="f_get-coverage">
     3176    <primary>get-coverage</primary>
    31613177  </indexterm>
    31623178 
    31633179  <refnamediv>
    3164     <refname>SAVE-COVERAGE</refname>
     3180    <refname>GET-COVERAGE</refname>
    31653181    <refpurpose>
    31663182      Returns a snapshot of the current coverage data.
     
    31733189      Returns a snapshot of the current coverage data. A snapshot is a
    31743190      copy of the current coverage state. It can be saved in a file
    3175       with ccl:write-coverage-to-file, reinstated back as the current
    3176       state with ccl:restore-coverage, or combined with other
    3177       snapshots with ccl:combine-coverage.
     3191      with <literal>ccl:write-coverage-to-file</literal>, reinstated back as the current
     3192      state with <literal>ccl:restore-coverage</literal>, or combined with other
     3193      snapshots with <literal>ccl:combine-coverage</literal>.
    31783194    </para>
    31793195  </refsect1>
     
    32533269    <para>
    32543270      Saves the coverage snapshot in a file. The snapshot can be
    3255       loaded back with ccl:read-coverage-from-file or loaded and
    3256       restored with ccl:restore-coverage-from-file. Note that the file
     3271      loaded back with <literal>ccl:read-coverage-from-file</literal> or loaded and
     3272      restored with <literal>ccl:restore-coverage-from-file</literal>. Note that the file
    32573273      created is actually a lisp source file and can be compiled for
    32583274      faster loading.
     
    32833299      Returns the snapshot saved in pathname. Doesn't affect the
    32843300      current coverage state. pathname can be the file previously
    3285       created with ccl:write-coverage-to-file or
    3286       ccl:save-coverage-in-file, or it can be the name of the fasl
     3301      created with <literal>ccl:write-coverage-to-file</literal> or
     3302      <literal>ccl:save-coverage-in-file</literal>, or it can be the name of the fasl
    32873303      created from compiling such a file.
    32883304    </para>
     
    32983314    <refname>COVERAGE-STATISTICS</refname>
    32993315    <refpurpose>
    3300       Returns a sequence of ccl:coverage-statistics objects, one per source file.
     3316      Returns a sequence of <literal>ccl:coverage-statistics</literal> objects, one per source file.
    33013317    </refpurpose>
    33023318    <refclass>Function</refclass>
     
    33103326  <refsect1><title>Description</title>
    33113327    <para>
    3312       Returns a sequence ccl:coverage-statistics objects, one for each
     3328      Returns a sequence of <literal>ccl:coverage-statistics</literal> objects, one for each
    33133329      source file, containing the same information as that written to
    3314       the statistics file by ccl:report-coverage. The following
    3315       accessors are defined for ccl:coverage-statistics objects:
     3330      the statistics file by <literal>ccl:report-coverage</literal>. The following
     3331      accessors are defined for <literal>ccl:coverage-statistics</literal> objects:
    33163332      <variablelist>
    33173333      <varlistentry>
     
    34103426  </refsect1>
    34113427</refentry>
     3428
     3429<refentry id="f_reset-incremental-coverage">
     3430  <indexterm zone="f_reset-incremental-coverage">
     3431    <primary>reset-incremental-coverage</primary>
     3432  </indexterm>
     3433 
     3434  <refnamediv>
     3435    <refname>RESET-INCREMENTAL-COVERAGE</refname>
     3436    <refpurpose>
     3437      Reset incremental coverage.
     3438    </refpurpose>
     3439    <refclass>Function</refclass>
     3440  </refnamediv>
     3441
     3442  <refsynopsisdiv>
     3443    <synopsis><function>reset-incremental-coverage</function>
     3444    </synopsis>
     3445  </refsynopsisdiv>
     3446
     3447  <refsect1><title>Description</title>
     3448    <para>
     3449      Marks a starting point for recording incremental coverage.
     3450      Note that calling
     3451      this function does not affect regular coverage data (whereas calling
     3452      <literal>ccl:reset-coverage</literal> resets incremental coverage as well).
     3453    </para>
     3454  </refsect1>
     3455</refentry>
     3456
     3457
     3458<refentry id="f_get-incremental-coverage">
     3459  <indexterm zone="f_get-incremental-coverage">
     3460    <primary>get-incremental-coverage</primary>
     3461  </indexterm>
     3462 
     3463  <refnamediv>
     3464    <refname>GET-INCREMENTAL-COVERAGE</refname>
     3465    <refpurpose>
     3466      Returns the delta of coverage since the last incremental reset.
     3467    </refpurpose>
     3468    <refclass>Function</refclass>
     3469  </refnamediv>
     3470
     3471  <refsynopsisdiv>
     3472    <synopsis><function>get-incremental-coverage</function> &key; (reset t)
     3473    </synopsis>
     3474  </refsynopsisdiv>
     3475
     3476  <refsect1><title>Description</title>
     3477    <para>
     3478      Returns the delta of coverage since the last reset of incremental coverage.
     3479     If <literal>reset</literal> is true (the default), it also resets incremental coverage
     3480     now, so that the next call to <literal>get-incremental-coverage</literal> will return
     3481     the delta from this point.
     3482     </para>
     3483     <para>
     3484      Incremental coverage deltas are represented differently than the full coverage snapshots
     3485      returned by functions such as <literal>ccl:get-coverage</literal>.  Incremental
     3486      coverage uses an abbreviated format
     3487      and is missing some of the information in a full snapshot, and therefore cannot be passed to
     3488      functions documented to accept a <variable>snapshot</variable>, only to functions
     3489      specifically documented to accept incremental coverage deltas.
     3490     </para>
     3491  </refsect1>
     3492</refentry>
     3493
     3494<refentry id="f_incremental-coverage-source-matches">
     3495  <indexterm zone="f_incremental-coverage-source-matches">
     3496    <primary>incremental-coverage-source-matches</primary>
     3497  </indexterm>
     3498 
     3499  <refnamediv>
     3500    <refname>INCREMENTAL-COVERAGE-SOURCE-MATCHES</refname>
     3501    <refpurpose>
     3502      Find incremental coverage deltas intersecting source regions.
     3503    </refpurpose>
     3504    <refclass>Function</refclass>
     3505  </refnamediv>
     3506
     3507  <refsynopsisdiv>
     3508    <synopsis><function>incremental-coverage-source-matches</function> collection sources
     3509    </synopsis>
     3510  </refsynopsisdiv>
     3511
     3512  <refsect1><title>Arguments and Values</title>
     3513  <variablelist>
     3514    <varlistentry>
     3515      <term>collection</term>
     3516       <listitem>
     3517         <para>
     3518          A hash table mapping arbitrary keys to incremental coverage deltas, or a sequence of
     3519          incremental coverage deltas.
     3520         </para>
     3521        </listitem>
     3522    </varlistentry>
     3523    <varlistentry>
     3524      <term>sources</term>
     3525       <listitem>
     3526         <para>
     3527          A list of pathnames and/or source-notes, the latter representing a range within a file.
     3528         </para>
     3529        </listitem>
     3530    </varlistentry>
     3531   </variablelist>
     3532   </refsect1>
     3533
     3534  <refsect1><title>Description</title>
     3535    <para>
     3536     Given a hash table <literal>collection</literal> whose values are incremental coverage
     3537     deltas, return a list of all keys corresponding to those deltas that intersect any region
     3538     in <literal>sources</literal>.
     3539     </para>
     3540     <para>
     3541     For example if the deltas represent tests, then the returned value is a list of all tests
     3542     that cover some part of the source regions.
     3543     </para>
     3544     <para>
     3545     <literal>collection</literal> can also be a sequence of deltas, in which case a subsequence
     3546      of matching deltas is returned.  In particular you can test whether any particular delta
     3547      intersects the sources by passing it in as a single-element list.
     3548     </para>
     3549  </refsect1>
     3550</refentry>
     3551
     3552<refentry id="f_incremental-coverage-svn-matches">
     3553  <indexterm zone="f_incremental-coverage-svn-matches">
     3554    <primary>incremental-coverage-svn-matches</primary>
     3555  </indexterm>
     3556 
     3557  <refnamediv>
     3558    <refname>INCREMENTAL-COVERAGE-SVN-MATCHES</refname>
     3559    <refpurpose>
     3560      Find incremental coverage deltas matching changes from a particular subversion revision.
     3561    </refpurpose>
     3562    <refclass>Function</refclass>
     3563  </refnamediv>
     3564
     3565  <refsynopsisdiv>
     3566    <synopsis><function>incremental-coverage-svn-matches</function> collection &key; (directory (current-directory)) (revision :base)
     3567    </synopsis>
     3568  </refsynopsisdiv>
     3569
     3570  <refsect1><title>Arguments and Values</title>
     3571  <variablelist>
     3572    <varlistentry>
     3573      <term>collection</term>
     3574       <listitem>
     3575         <para>
     3576          A hash table mapping arbitrary keys to incremental coverage deltas, or a sequence of
     3577          incremental coverage deltas.
     3578         </para>
     3579        </listitem>
     3580    </varlistentry>
     3581    <varlistentry>
     3582      <term>directory</term>
     3583       <listitem>
     3584         <para>
     3585          The pathname of a subversion working directory.
     3586         </para>
     3587        </listitem>
     3588    </varlistentry>
     3589    <varlistentry>
     3590      <term>revision</term>
     3591       <listitem>
     3592         <para>
     3593          The revision to compare to the working directory, an integer or another
     3594          value whose printed representation is suitable for passing as the
     3595          <literal>--revision</literal> argument
     3596          to <filename>svn</filename>.
     3597         </para>
     3598        </listitem>
     3599    </varlistentry>
     3600   </variablelist>
     3601   </refsect1>
     3602
     3603  <refsect1><title>Description</title>
     3604    <para>
     3605     Given a hash table <literal>collection</literal> whose values are incremental coverage
     3606     deltas, return a list of all keys corresponding to those deltas that intersect any changed
     3607     source in <literal>directory</literal> since revision <literal>revision</literal> in subversion.
     3608     </para>
     3609     <para>
     3610     For example if the deltas represent tests, then the returned value is a list of all tests
     3611     that might be affected by the changes.
     3612     </para>
     3613     <para>
     3614     <literal>collection</literal> can also be a sequence of deltas, in which case a subsequence
     3615      of matching deltas is returned.  In particular you can test whether any particular delta
     3616      is affected by the changes by passing it in as a single-element list.
     3617     </para>
     3618  </refsect1>
     3619</refentry>
     3620
     3621
    34123622
    34133623<refentry id="v_compile-code-coverage">
     
    34603670      This macro arranges so that body doesn't record internal details
    34613671      of code coverage. It will be considered totally covered if it's
    3462       entered at all. The Common Lisp macros ASSERT and CHECK-TYPE use
     3672      entered at all. The Common Lisp macros <literal>ASSERT</literal> and <literal>CHECK-TYPE</literal> use
    34633673      this macro.
    34643674    </para>
     
    34903700 form will have the outer form's coverage color. If the syntax of outer form involves some non-executable
    34913701 forms, or forms that do not have coverage info of their own for whatever reason, then they will just
    3492  inherit the color of the outer form, because it doesn't get replaced with a color of its own.
     3702 inherit the color of the outer form, because they don't get repainted with a color of their own.
    34933703</para>
    34943704
  • 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.