dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add (system vm coverage).

Browse source 
* module/system/vm/coverage.scm: New file.

* module/Makefile.am (SYSTEM_SOURCES): Add `system/vm/coverage.scm'.

* test-suite/guile-test (main): Use (system vm coverage).  Handle
  `--coverage' and `-c'.

* test-suite/tests/coverage.test: New file.

* test-suite/Makefile.am (SCM_TESTS): Add `tests/coverage.test'.

* doc/ref/Makefile.am (guile_TEXINFOS): Add `api-coverage.texi'.

* doc/ref/api-coverage.texi: New file.

* doc/ref/guile.texi (API Reference): Include it.
This commit is contained in:
Ludovic Courtès 2010-05-02 14:17:41 +02:00
commit 36b5e39407
8 changed files with 668 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

1
test-suite/Makefile.am
View file

@ -35,6 +35,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/common-list.test \
tests/control.test \
tests/continuations.test \
tests/coverage.test \
tests/curried-definitions.test \
tests/ecmascript.test \
tests/elisp.test \

24
test-suite/guile-test
View file

@ -85,6 +85,9 @@
:use-module (ice-9 getopt-long)
:use-module (ice-9 and-let-star)
:use-module (ice-9 rdelim)
:use-module (system vm coverage)
:use-module (srfi srfi-11)
:use-module (system vm vm)
:export (main data-file-name test-file-name))
@ -175,6 +178,8 @@
(log-file
(single-char #\l)
(value #t))
(coverage
(single-char #\c))
(debug
(single-char #\d))))))
(define (opt tag default)
@ -227,11 +232,20 @@
(set! global-pass #f)))))
;; Run the tests.
(for-each (lambda (test)
(display (string-append "Running " test "\n"))
(with-test-prefix test
(load (test-file-name test))))
tests)
(let ((run-tests
(lambda ()
(for-each (lambda (test)
(display (string-append "Running " test "\n"))
(with-test-prefix test
(load (test-file-name test))))
tests))))
(if (opt 'coverage #f)
(let-values (((coverage-data _)
(with-code-coverage (the-vm) run-tests)))
(let ((out (open-output-file "guile.info")))
(coverage-data->lcov coverage-data out)
(close out)))
(run-tests)))
;; Display the final counts, both to the user and in the log
;; file.

201
test-suite/tests/coverage.test Normal file
View file

@ -0,0 +1,201 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-coverage)
#:use-module (test-suite lib)
#:use-module (system vm coverage)
#:use-module (system vm vm)
#:use-module (system base compile)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11))
(define-syntax code
(syntax-rules ()
((_ filename snippet)
(let ((input (open-input-string snippet)))
(set-port-filename! input filename)
(read-enable 'positions)
(compile (read input))))))
(define %test-vm (make-vm))
(with-test-prefix "instrumented/executed-lines"
(pass-if "instr = exec"
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(+ x y)) ;; 1")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(= 3 result)
(let-values (((instr exec)
(instrumented/executed-lines data "foo.scm")))
(and (= 2 instr) (= 2 exec)))))))
(pass-if "instr >= exec"
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(if (> x y) ;; 1
(begin ;; 2
(display x) ;; 3
(+ x y)))) ;; 4")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(let-values (((instr exec)
(instrumented/executed-lines data "foo.scm")))
(and (> instr 0) (>= instr exec))))))))
(with-test-prefix "line-execution-counts"
(pass-if "once"
(let ((proc (code "bar.scm" "(lambda (x y) ;; 0
(+ (/ x y) ;; 1
(* x y))) ;; 2")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "bar.scm")))
(and (pair? counts)
(every (lambda (line+count)
(let ((line (car line+count))
(count (cdr line+count)))
(and (>= line 0)
(<= line 2)
(= count 1))))
counts))))))
(pass-if "several times"
(let ((proc (code "fooz.scm" "(lambda (x) ;; 0
(format #f \"hello\") ;; 1
(let loop ((x x)) ;; 2
(cond ((> x 0) ;; 3
(begin ;; 4
(format #f \"~a\" x)
(loop (1- x)))) ;; 6
((= x 0) #t) ;; 7
((< x 0) 'never))))")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 77)))))
(let ((counts (line-execution-counts data "fooz.scm")))
(and (pair? counts)
(every (lambda (line+count)
(let ((line (car line+count))
(count (cdr line+count)))
(case line
((0 1) (= count 1))
((2 3) (= count 78))
((4 5 6) (= count 77))
((7) (= count 1))
((8) (= count 0)))))
counts))))))
(pass-if "some"
(let ((proc (code "baz.scm" "(lambda (x y) ;; 0
(if (> x y) ;; 1
(begin ;; 2
(display x) ;; 3
(+ x y)) ;; 4
(+ x y))) ;; 5")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
(every (lambda (line+count)
(let ((line (car line+count))
(count (cdr line+count)))
(case line
((0 1 5) (= count 1))
((2 3) (= count 0))
((4) #t) ;; the start of the `else' branch is
;; attributed to line 4
(else #f))))
counts))))))
(pass-if "one proc hit, one proc unused"
(let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0
(or (= x 0) ;; 1
(not (odd? (1- x))))))
(odd? (lambda (x) ;; 3
(not (even? (1- x)))))) ;; 4
even?)")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 0)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
(every (lambda (line+count)
(let ((line (car line+count))
(count (cdr line+count)))
(case line
((0 1) (= count 1))
((2 3 4) (= count 0))
((5) (= count 1))
(else #f))))
counts))))))
(pass-if "all code on one line"
;; There are several proc/IP pairs pointing to this source line, yet the hit
;; count for the line should be 1.
(let ((proc (code "one-liner.scm"
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 451 1884)))))
(let ((counts (line-execution-counts data "one-liner.scm")))
(equal? counts '((0 . 1))))))))
(with-test-prefix "procedure-execution-count"
(pass-if "several times"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (+ (proc 1 2) (proc 2 3))))))
(and (coverage-data? data)
(= 3 result)
(= (procedure-execution-count data proc) 2)))))
(pass-if "never"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
(not (procedure-execution-count data proc)))))))
(with-test-prefix "instrumented-source-files"
(pass-if "source files are listed as expected"
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda () (proc 1 2)))))
(let ((files (map basename (instrumented-source-files data))))
(and (member "boot-9.scm" files)
(member "chbouib.scm" files)
(not (member "foo.scm" files))))))))