[bpt/guile.git] / test-suite / tests / coverage.test

;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011 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 (system foreign)
  #: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))

(define test-procedure
  (compile '(lambda (x)
              (if (> x 2)
                  (- x 2)
                  (+ x 2)))))

\f
(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))))))))

\f
(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))
                            (else    #f))))
                      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))))))))

\f
(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))))))

  (pass-if "called from C"
    ;; The `scm_call_N' functions use the VM returned by `the-vm'.  This
    ;; test makes sure that they get to use %TEST-VM.
    (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
          (call (pointer->procedure '*
                                    (dynamic-func "scm_call_2"
                                                  (dynamic-link))
                                    '(* * *))))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda ()
                        (call (make-pointer (object-address proc))
                              (make-pointer (object-address 1))
                              (make-pointer (object-address 2)))))))
        (and (coverage-data? data)
             (= (object-address 3) (pointer-address result))
             (= (procedure-execution-count data proc) 1)))))

  (pass-if "called from eval"
    (let-values (((data result)
                  (with-code-coverage %test-vm
                    (lambda ()
                      (eval '(test-procedure 123) (current-module))))))
      (and (coverage-data? data)
           (= (test-procedure 123) result)
           (= (procedure-execution-count data test-procedure) 1)))))

\f
(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))))))))
Commit	Line	Data
36b5e394 LC	1	;;;; coverage.test --- Code coverage. -- mode: scheme; coding: utf-8; --
36b5e394 LC	2	;;;;
7c42e426	3	;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
36b5e394 LC	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	(define-module (test-coverage)
	20	#:use-module (test-suite lib)
	21	#:use-module (system vm coverage)
	22	#:use-module (system vm vm)
	23	#:use-module (system base compile)
639b2eb7	24	#:use-module (system foreign)
36b5e394 LC	25	#:use-module (srfi srfi-1)
	26	#:use-module (srfi srfi-11))
	27
	28	(define-syntax code
	29	(syntax-rules ()
	30	((_ filename snippet)
	31	(let ((input (open-input-string snippet)))
	32	(set-port-filename! input filename)
	33	(read-enable 'positions)
	34	(compile (read input))))))
	35
	36	(define %test-vm (make-vm))
	37
7c42e426 LC	38	(define test-procedure
	39	(compile '(lambda (x)
	40	(if (> x 2)
	41	(- x 2)
	42	(+ x 2)))))
	43
36b5e394 LC	44	\f
	45	(with-test-prefix "instrumented/executed-lines"
	46
	47	(pass-if "instr = exec"
	48	(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
	49	(+ x y)) ;; 1")))
	50	(let-values (((data result)
	51	(with-code-coverage %test-vm
	52	(lambda () (proc 1 2)))))
	53	(and (coverage-data? data)
	54	(= 3 result)
	55	(let-values (((instr exec)
	56	(instrumented/executed-lines data "foo.scm")))
	57	(and (= 2 instr) (= 2 exec)))))))
	58
	59	(pass-if "instr >= exec"
	60	(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
	61	(if (> x y) ;; 1
	62	(begin ;; 2
	63	(display x) ;; 3
	64	(+ x y)))) ;; 4")))
	65	(let-values (((data result)
	66	(with-code-coverage %test-vm
	67	(lambda () (proc 1 2)))))
	68	(and (coverage-data? data)
	69	(let-values (((instr exec)
	70	(instrumented/executed-lines data "foo.scm")))
	71	(and (> instr 0) (>= instr exec))))))))
	72
	73	\f
	74	(with-test-prefix "line-execution-counts"
	75
	76	(pass-if "once"
	77	(let ((proc (code "bar.scm" "(lambda (x y) ;; 0
	78	(+ (/ x y) ;; 1
	79	(* x y))) ;; 2")))
	80	(let-values (((data result)
	81	(with-code-coverage %test-vm
	82	(lambda () (proc 1 2)))))
	83	(let ((counts (line-execution-counts data "bar.scm")))
	84	(and (pair? counts)
	85	(every (lambda (line+count)
	86	(let ((line (car line+count))
	87	(count (cdr line+count)))
	88	(and (>= line 0)
	89	(<= line 2)
	90	(= count 1))))
	91	counts))))))
	92
	93	(pass-if "several times"
	94	(let ((proc (code "fooz.scm" "(lambda (x) ;; 0
	95	(format #f \"hello\") ;; 1
	96	(let loop ((x x)) ;; 2
	97	(cond ((> x 0) ;; 3
	98	(begin ;; 4
	99	(format #f \"~a\" x)
	100	(loop (1- x)))) ;; 6
	101	((= x 0) #t) ;; 7
	102	((< x 0) 'never))))")))
	103	(let-values (((data result)
	104	(with-code-coverage %test-vm
	105	(lambda () (proc 77)))))
	106	(let ((counts (line-execution-counts data "fooz.scm")))
	107	(and (pair? counts)
108	(every (lambda (line+count)
109	(let ((line (car line+count))
110	(count (cdr line+count)))
111	(case line
112	((0 1) (= count 1))
113	((2 3) (= count 78))
114	((4 5 6) (= count 77))
115	((7) (= count 1))
e7bee747 LC	116	((8) (= count 0))
e7bee747 LC	117	(else #f))))
36b5e394 LC	118	counts))))))
	119
	120	(pass-if "some"
	121	(let ((proc (code "baz.scm" "(lambda (x y) ;; 0
	122	(if (> x y) ;; 1
	123	(begin ;; 2
	124	(display x) ;; 3
	125	(+ x y)) ;; 4
	126	(+ x y))) ;; 5")))
	127	(let-values (((data result)
	128	(with-code-coverage %test-vm
	129	(lambda () (proc 1 2)))))
	130	(let ((counts (line-execution-counts data "baz.scm")))
	131	(and (pair? counts)
	132	(every (lambda (line+count)
	133	(let ((line (car line+count))
	134	(count (cdr line+count)))
	135	(case line
	136	((0 1 5) (= count 1))
	137	((2 3) (= count 0))
	138	((4) #t) ;; the start of the `else' branch is
	139	;; attributed to line 4
	140	(else #f))))
	141	counts))))))
	142
	143	(pass-if "one proc hit, one proc unused"
	144	(let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0
	145	(or (= x 0) ;; 1
	146	(not (odd? (1- x))))))
	147	(odd? (lambda (x) ;; 3
	148	(not (even? (1- x)))))) ;; 4
	149	even?)")))
	150	(let-values (((data result)
	151	(with-code-coverage %test-vm
	152	(lambda () (proc 0)))))
	153	(let ((counts (line-execution-counts data "baz.scm")))
	154	(and (pair? counts)
	155	(every (lambda (line+count)
	156	(let ((line (car line+count))
	157	(count (cdr line+count)))
	158	(case line
	159	((0 1) (= count 1))
	160	((2 3 4) (= count 0))
	161	((5) (= count 1))
	162	(else #f))))
	163	counts))))))
	164
	165	(pass-if "all code on one line"
	166	;; There are several proc/IP pairs pointing to this source line, yet the hit
	167	;; count for the line should be 1.
	168	(let ((proc (code "one-liner.scm"
	169	"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
	170	(let-values (((data result)
	171	(with-code-coverage %test-vm
	172	(lambda () (proc 451 1884)))))
	173	(let ((counts (line-execution-counts data "one-liner.scm")))
	174	(equal? counts '((0 . 1))))))))
	175
	176	\f
	177	(with-test-prefix "procedure-execution-count"
	178
	179	(pass-if "several times"
	180	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
	181	(let-values (((data result)
182	(with-code-coverage %test-vm
183	(lambda () (+ (proc 1 2) (proc 2 3))))))
184	(and (coverage-data? data)
185	(= 3 result)
186	(= (procedure-execution-count data proc) 2)))))
187
188	(pass-if "never"
189	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
190	(let-values (((data result)
191	(with-code-coverage %test-vm
192	(lambda () (+ 1 2)))))
193	(and (coverage-data? data)
194	(= 3 result)
639b2eb7 LC	195	(not (procedure-execution-count data proc))))))
	196
	197	(pass-if "called from C"
	198	;; The `scm_call_N' functions use the VM returned by `the-vm'. This
	199	;; test makes sure that they get to use %TEST-VM.
	200	(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
	201	(call (pointer->procedure '*
	202	(dynamic-func "scm_call_2"
	203	(dynamic-link))
	204	'(* * *))))
	205	(let-values (((data result)
	206	(with-code-coverage %test-vm
	207	(lambda ()
	208	(call (make-pointer (object-address proc))
	209	(make-pointer (object-address 1))
	210	(make-pointer (object-address 2)))))))
	211	(and (coverage-data? data)
	212	(= (object-address 3) (pointer-address result))
7c42e426 LC	213	(= (procedure-execution-count data proc) 1)))))
	214
	215	(pass-if "called from eval"
	216	(let-values (((data result)
	217	(with-code-coverage %test-vm
	218	(lambda ()
	219	(eval '(test-procedure 123) (current-module))))))
	220	(and (coverage-data? data)
	221	(= (test-procedure 123) result)
	222	(= (procedure-execution-count data test-procedure) 1)))))
36b5e394 LC	223
	224	\f
	225	(with-test-prefix "instrumented-source-files"
	226
	227	(pass-if "source files are listed as expected"
	228	(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
	229	(let-values (((data result)
	230	(with-code-coverage %test-vm
	231	(lambda () (proc 1 2)))))
	232
	233	(let ((files (map basename (instrumented-source-files data))))
	234	(and (member "boot-9.scm" files)
	235	(member "chbouib.scm" files)
	236	(not (member "foo.scm" files))))))))