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

;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011, 2012, 2013 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 5) (= count 0))
                            (else      #f))))
                      counts))))))

  (pass-if "case-lambda"
    (let ((proc (code "cl.scm"  "(case-lambda       ;; 0
                                   ((x)   (+ x 3))  ;; 1
                                   ((x y) (+ x y))) ;; 2")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda ()
                        (+ (proc 1) (proc 2 3))))))
        (let ((counts (line-execution-counts data "cl.scm")))
          (and (pair? counts)
               (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) 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 "case-lambda"
    (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
      (let-values (((data result)
                    (with-code-coverage %test-vm
                      (lambda ()
                        (+ (proc 1) (proc 2 3))))))
        (and (coverage-data? data)
             (= 6 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)
             (zero? (procedure-execution-count data proc))))))

  (pass-if "applicable struct"
    (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
           (proc  (lambda args (length args)))
           (b     (make-struct <box> 0 proc)))
      (let-values (((data result)
                    (with-code-coverage %test-vm b)))
        (and (coverage-data? data)
             (= 0 result)
             (= (procedure-execution-count data proc) 1)))))

  (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 (false-if-exception       ; can we resolve `scm_call_2'?
                 (pointer->procedure '*
                                     (dynamic-func "scm_call_2"
                                                   (dynamic-link))
                                     '(* * *)))))
      (if call
          (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)))
          (throw 'unresolved))))

  (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	;;;;
41f2f14b	3	;;;; Copyright (C) 2010, 2011, 2012, 2013 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
7a5a5335 AW	159	((0 1) (= count 1))
	160	((2 3 4 5) (= count 0))
	161	(else #f))))
36b5e394 LC	162	counts))))))
36b5e394 LC	163
01291304 LC	164	(pass-if "case-lambda"
	165	(let ((proc (code "cl.scm" "(case-lambda ;; 0
	166	((x) (+ x 3)) ;; 1
	167	((x y) (+ x y))) ;; 2")))
	168	(let-values (((data result)
	169	(with-code-coverage %test-vm
	170	(lambda ()
	171	(+ (proc 1) (proc 2 3))))))
	172	(let ((counts (line-execution-counts data "cl.scm")))
	173	(and (pair? counts)
	174	(lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))
	175
36b5e394 LC	176	(pass-if "all code on one line"
	177	;; There are several proc/IP pairs pointing to this source line, yet the hit
	178	;; count for the line should be 1.
	179	(let ((proc (code "one-liner.scm"
	180	"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
	181	(let-values (((data result)
	182	(with-code-coverage %test-vm
	183	(lambda () (proc 451 1884)))))
	184	(let ((counts (line-execution-counts data "one-liner.scm")))
	185	(equal? counts '((0 . 1))))))))
	186
	187	\f
	188	(with-test-prefix "procedure-execution-count"
	189
	190	(pass-if "several times"
	191	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
	192	(let-values (((data result)
	193	(with-code-coverage %test-vm
	194	(lambda () (+ (proc 1 2) (proc 2 3))))))
	195	(and (coverage-data? data)
	196	(= 3 result)
	197	(= (procedure-execution-count data proc) 2)))))
	198
01291304 LC	199	(pass-if "case-lambda"
	200	(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
	201	(let-values (((data result)
	202	(with-code-coverage %test-vm
	203	(lambda ()
	204	(+ (proc 1) (proc 2 3))))))
	205	(and (coverage-data? data)
	206	(= 6 result)
	207	(= (procedure-execution-count data proc) 2)))))
	208
36b5e394 LC	209	(pass-if "never"
	210	(let ((proc (code "foo.scm" "(lambda (x y) x)")))
	211	(let-values (((data result)
	212	(with-code-coverage %test-vm
	213	(lambda () (+ 1 2)))))
	214	(and (coverage-data? data)
	215	(= 3 result)
697c4f29	216	(zero? (procedure-execution-count data proc))))))
639b2eb7	217
1a6ff60d LC	218	(pass-if "applicable struct"
	219	(let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
	220	(proc (lambda args (length args)))
	221	(b (make-struct <box> 0 proc)))
	222	(let-values (((data result)
	223	(with-code-coverage %test-vm b)))
	224	(and (coverage-data? data)
	225	(= 0 result)
	226	(= (procedure-execution-count data proc) 1)))))
	227
639b2eb7 LC	228	(pass-if "called from C"
	229	;; The `scm_call_N' functions use the VM returned by `the-vm'. This
	230	;; test makes sure that they get to use %TEST-VM.
	231	(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
41f2f14b LC	232	(call (false-if-exception ; can we resolve `scm_call_2'?
	233	(pointer->procedure '*
	234	(dynamic-func "scm_call_2"
	235	(dynamic-link))
	236	'(* * *)))))
	237	(if call
	238	(let-values (((data result)
	239	(with-code-coverage %test-vm
	240	(lambda ()
	241	(call (make-pointer (object-address proc))
	242	(make-pointer (object-address 1))
	243	(make-pointer (object-address 2)))))))
	244	(and (coverage-data? data)
	245	(= (object-address 3) (pointer-address result))
	246	(= (procedure-execution-count data proc) 1)))
	247	(throw 'unresolved))))
7c42e426 LC	248
	249	(pass-if "called from eval"
	250	(let-values (((data result)
	251	(with-code-coverage %test-vm
	252	(lambda ()
	253	(eval '(test-procedure 123) (current-module))))))
	254	(and (coverage-data? data)
	255	(= (test-procedure 123) result)
	256	(= (procedure-execution-count data test-procedure) 1)))))
36b5e394 LC	257
	258	\f
	259	(with-test-prefix "instrumented-source-files"
	260
	261	(pass-if "source files are listed as expected"
	262	(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
	263	(let-values (((data result)
	264	(with-code-coverage %test-vm
	265	(lambda () (proc 1 2)))))
	266
	267	(let ((files (map basename (instrumented-source-files data))))
	268	(and (member "boot-9.scm" files)
	269	(member "chbouib.scm" files)
	270	(not (member "foo.scm" files))))))))