summaryrefslogtreecommitdiff
path: root/test-suite/tests/coverage.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/coverage.test')
-rw-r--r--test-suite/tests/coverage.test41
1 files changed, 39 insertions, 2 deletions
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 6869a3a62..4ac404344 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 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
@@ -35,6 +35,12 @@
(define %test-vm (make-vm))
+(define test-procedure
+ (compile '(lambda (x)
+ (if (> x 2)
+ (- x 2)
+ (+ x 2)))))
+
(with-test-prefix "instrumented/executed-lines"
@@ -156,6 +162,18 @@
(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.
@@ -179,6 +197,16 @@
(= 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)
@@ -204,7 +232,16 @@
(make-pointer (object-address 2)))))))
(and (coverage-data? data)
(= (object-address 3) (pointer-address result))
- (= (procedure-execution-count data proc) 1))))))
+ (= (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)))))
(with-test-prefix "instrumented-source-files"