94 lines
3.7 KiB
Scheme
94 lines
3.7 KiB
Scheme
#!@GUILE@ --no-auto-compile
|
|
-*- scheme -*-
|
|
!#
|
|
|
|
;;; Gash -- Guile As SHell
|
|
;;; Copyright © 2017 Timothy Sample <samplet@ngyro.com>
|
|
;;;
|
|
;;; The 'coverage-data->lcov' procedure was adapted from:
|
|
;;;
|
|
;;; GNU Guile
|
|
;;; Copyright (C) 2010, 2013, 2018 Free Software Foundation, Inc.
|
|
;;;
|
|
;;; This file is part of Gash.
|
|
;;;
|
|
;;; Gash is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation, either version 3 of the License, or
|
|
;;; (at your option) any later version.
|
|
;;;
|
|
;;; Gash 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 General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(use-modules (ice-9 popen)
|
|
(ice-9 receive)
|
|
(ice-9 textual-ports)
|
|
(srfi srfi-11)
|
|
(srfi srfi-26)
|
|
(system vm coverage)
|
|
(system vm vm))
|
|
|
|
;; This is a standard Guile function. However, even though it is
|
|
;; specified in the manual, it does not support the MODULES
|
|
;; keyword. It's only a one-line change, which I've made here.
|
|
(define* (coverage-data->lcov data port #:key (modules #f))
|
|
;; Output per-file coverage data.
|
|
(format port "TN:~%")
|
|
(for-each (lambda (file)
|
|
(let ((path (search-path %load-path file)))
|
|
(if (string? path)
|
|
(begin
|
|
(format port "SF:~A~%" path)
|
|
(for-each (lambda (line+count)
|
|
(let ((line (car line+count))
|
|
(count (cdr line+count)))
|
|
(format port "DA:~A,~A~%"
|
|
(+ 1 line) count)))
|
|
(line-execution-counts data file))
|
|
(let-values (((instr exec)
|
|
(instrumented/executed-lines data file)))
|
|
(format port "LH: ~A~%" exec)
|
|
(format port "LF: ~A~%" instr))
|
|
(format port "end_of_record~%"))
|
|
(begin
|
|
(format (current-error-port)
|
|
"skipping unknown source file: ~a~%"
|
|
file)))))
|
|
(or modules (instrumented-source-files data))))
|
|
|
|
(define (project-file? file)
|
|
"Determine if @var{file} is part of the current project."
|
|
(let ((path (search-path %load-path file)))
|
|
(string-contains path "@abs_top_srcdir@")))
|
|
|
|
(define (list-tests)
|
|
"List the tests specified in the @file{Makefile}."
|
|
(let* ((port (open-pipe* OPEN_READ "make"
|
|
"-f" "@abs_top_srcdir@/Makefile" "test-list"))
|
|
(tests (filter (lambda (x)
|
|
(and (not (string-null? x))
|
|
(string-suffix? ".scm" x)))
|
|
(string-split (get-string-all port)
|
|
char-whitespace?)))
|
|
(status (close-pipe port)))
|
|
(when (not (eqv? 0 (status:exit-val status)))
|
|
(error "Cannot get test list"))
|
|
(map (cut string-append "@abs_top_srcdir@/" <>) tests)))
|
|
|
|
(receive (data result)
|
|
(call-with-vm
|
|
(lambda ()
|
|
(set-vm-engine! 'debug)
|
|
(with-code-coverage
|
|
(lambda ()
|
|
(for-each load (list-tests))))))
|
|
(let ((port (open-output-file "lcov.info"))
|
|
(modules (filter project-file? (instrumented-source-files data))))
|
|
(coverage-data->lcov data port #:modules modules)
|
|
(close port)))
|