mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
a222cbc9d1
* libguile/vm.h:
* libguile/vm.c (scm_the_vm): Don't expose to Scheme.
(scm_vm_p): Remove, as it is not needed.
* module/system/vm/vm.scm: Remove the-vm and vm? exports.
* doc/ref/api-coverage.texi (Code Coverage):
* test-suite/tests/coverage.test:
* module/system/vm/coverage.scm (with-code-coverage): Don't take a VM
argument. Adapt documentation and tests.
* module/ice-9/command-line.scm: Remove the-vm autoload.
* module/system/vm/trace.scm (trace-calls-to-procedure):
(trace-calls-in-procedure):
(trace-instructions-in-procedure):
(call-with-trace): Remove #:vm kwarg, and adapt to trap changes.
* module/system/vm/trap-state.scm (the-trap-state): Rework to use a
parameter underneath instead of a weak key on (the-vm).
* module/system/vm/traps.scm (new-disabled-trap):
(new-enabled-trap): Remove vm argument.
(trap-at-procedure-call):
(trap-in-procedure):
(trap-instructions-in-procedure):
(trap-at-procedure-ip-in-range):
(trap-at-source-location):
(trap-frame-finish):
(trap-in-dynamic-extent):
(trap-calls-in-dynamic-extent):
(trap-instructions-in-dynamic-extent):
(trap-calls-to-procedure):
(trap-matching-instructions): Remove vm keyword arguments.
* test-suite/tests/control.test ("unwind"): Adapt test.
* test-suite/tests/eval.test (test-suite): Remove the-vm import.
268 lines
11 KiB
Scheme
268 lines
11 KiB
Scheme
;;;; 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-procedure
|
||
(compile '(lambda (x)
|
||
(if (> x 2)
|
||
(- x 2)
|
||
(+ x 2)))))
|
||
|
||
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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
|
||
(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 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 their calls are traced.
|
||
(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
|
||
(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
|
||
(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"
|
||
|
||
(pass-if "source files are listed as expected"
|
||
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
|
||
(let-values (((data result)
|
||
(with-code-coverage
|
||
(lambda () (proc 1 2)))))
|
||
|
||
(let ((files (map basename (instrumented-source-files data))))
|
||
(and (member "boot-9.scm" files)
|
||
(member "chbouib.scm" files)
|
||
#t))))))
|