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

;;;; 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 (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))

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

\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; --
	2	;;;;
	3	;;;; Copyright (C) 2010 Free Software Foundation, Inc.
	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
	38	\f
	39	(with-test-prefix "instrumented/executed-lines"
	40
	41	(pass-if "instr = exec"
	42	(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
	43	(+ x y)) ;; 1")))
	44	(let-values (((data result)
	45	(with-code-coverage %test-vm
	46	(lambda () (proc 1 2)))))
	47	(and (coverage-data? data)
	48	(= 3 result)
	49	(let-values (((instr exec)
	50	(instrumented/executed-lines data "foo.scm")))
	51	(and (= 2 instr) (= 2 exec)))))))
	52
	53	(pass-if "instr >= exec"
	54	(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
	55	(if (> x y) ;; 1
	56	(begin ;; 2
	57	(display x) ;; 3
	58	(+ x y)))) ;; 4")))
	59	(let-values (((data result)
	60	(with-code-coverage %test-vm
	61	(lambda () (proc 1 2)))))
	62	(and (coverage-data? data)
	63	(let-values (((instr exec)
	64	(instrumented/executed-lines data "foo.scm")))
	65	(and (> instr 0) (>= instr exec))))))))
	66
	67	\f
	68	(with-test-prefix "line-execution-counts"
	69
	70	(pass-if "once"
	71	(let ((proc (code "bar.scm" "(lambda (x y) ;; 0
	72	(+ (/ x y) ;; 1
	73	(* x y))) ;; 2")))
	74	(let-values (((data result)
	75	(with-code-coverage %test-vm
	76	(lambda () (proc 1 2)))))
	77	(let ((counts (line-execution-counts data "bar.scm")))
	78	(and (pair? counts)
	79	(every (lambda (line+count)
	80	(let ((line (car line+count))
	81	(count (cdr line+count)))
	82	(and (>= line 0)
	83	(<= line 2)
	84	(= count 1))))
	85	counts))))))
	86
	87	(pass-if "several times"
	88	(let ((proc (code "fooz.scm" "(lambda (x) ;; 0
89	(format #f \"hello\") ;; 1
90	(let loop ((x x)) ;; 2
91	(cond ((> x 0) ;; 3
92	(begin ;; 4
93	(format #f \"~a\" x)
94	(loop (1- x)))) ;; 6
95	((= x 0) #t) ;; 7
96	((< x 0) 'never))))")))
97	(let-values (((data result)
98	(with-code-coverage %test-vm
99	(lambda () (proc 77)))))
100	(let ((counts (line-execution-counts data "fooz.scm")))
101	(and (pair? counts)
102	(every (lambda (line+count)
103	(let ((line (car line+count))
104	(count (cdr line+count)))
105	(case line
106	((0 1) (= count 1))
107	((2 3) (= count 78))
108	((4 5 6) (= count 77))
109	((7) (= count 1))
e7bee747 LC	110	((8) (= count 0))
e7bee747 LC	111	(else #f))))
36b5e394 LC	112	counts))))))
	113
	114	(pass-if "some"
	115	(let ((proc (code "baz.scm" "(lambda (x y) ;; 0
	116	(if (> x y) ;; 1
	117	(begin ;; 2
	118	(display x) ;; 3
	119	(+ x y)) ;; 4
	120	(+ x y))) ;; 5")))
	121	(let-values (((data result)
	122	(with-code-coverage %test-vm
	123	(lambda () (proc 1 2)))))
	124	(let ((counts (line-execution-counts data "baz.scm")))
	125	(and (pair? counts)
	126	(every (lambda (line+count)
	127	(let ((line (car line+count))
	128	(count (cdr line+count)))
	129	(case line
	130	((0 1 5) (= count 1))
	131	((2 3) (= count 0))
	132	((4) #t) ;; the start of the `else' branch is
	133	;; attributed to line 4
	134	(else #f))))
	135	counts))))))
	136
	137	(pass-if "one proc hit, one proc unused"
	138	(let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0
	139	(or (= x 0) ;; 1
	140	(not (odd? (1- x))))))
	141	(odd? (lambda (x) ;; 3
	142	(not (even? (1- x)))))) ;; 4
	143	even?)")))
	144	(let-values (((data result)
	145	(with-code-coverage %test-vm
	146	(lambda () (proc 0)))))
	147	(let ((counts (line-execution-counts data "baz.scm")))
	148	(and (pair? counts)
	149	(every (lambda (line+count)
	150	(let ((line (car line+count))
	151	(count (cdr line+count)))
	152	(case line
	153	((0 1) (= count 1))
	154	((2 3 4) (= count 0))
	155	((5) (= count 1))
	156	(else #f))))
	157	counts))))))
	158
	159	(pass-if "all code on one line"
	160	;; There are several proc/IP pairs pointing to this source line, yet the hit
	161	;; count for the line should be 1.
	162	(let ((proc (code "one-liner.scm"
	163	"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
	164	(let-values (((data result)
	165	(with-code-coverage %test-vm
	166	(lambda () (proc 451 1884)))))
	167	(let ((counts (line-execution-counts data "one-liner.scm")))
	168	(equal? counts '((0 . 1))))))))
	169
	170	\f
	171	(with-test-prefix "procedure-execution-count"
	172
	173	(pass-if "several times"
	174	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
	175	(let-values (((data result)
176	(with-code-coverage %test-vm
177	(lambda () (+ (proc 1 2) (proc 2 3))))))
178	(and (coverage-data? data)
179	(= 3 result)
180	(= (procedure-execution-count data proc) 2)))))
181
182	(pass-if "never"
183	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
184	(let-values (((data result)
185	(with-code-coverage %test-vm
186	(lambda () (+ 1 2)))))
187	(and (coverage-data? data)
188	(= 3 result)
639b2eb7 LC	189	(not (procedure-execution-count data proc))))))
	190
	191	(pass-if "called from C"
	192	;; The `scm_call_N' functions use the VM returned by `the-vm'. This
	193	;; test makes sure that they get to use %TEST-VM.
	194	(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
	195	(call (pointer->procedure '*
	196	(dynamic-func "scm_call_2"
	197	(dynamic-link))
	198	'(* * *))))
	199	(let-values (((data result)
	200	(with-code-coverage %test-vm
	201	(lambda ()
	202	(call (make-pointer (object-address proc))
	203	(make-pointer (object-address 1))
	204	(make-pointer (object-address 2)))))))
	205	(and (coverage-data? data)
	206	(= (object-address 3) (pointer-address result))
	207	(= (procedure-execution-count data proc) 1))))))
36b5e394 LC	208
	209	\f
	210	(with-test-prefix "instrumented-source-files"
	211
	212	(pass-if "source files are listed as expected"
	213	(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
	214	(let-values (((data result)
	215	(with-code-coverage %test-vm
	216	(lambda () (proc 1 2)))))
	217
	218	(let ((files (map basename (instrumented-source-files data))))
	219	(and (member "boot-9.scm" files)
	220	(member "chbouib.scm" files)
	221	(not (member "foo.scm" files))))))))