]> git.donarmstrong.com Git - lilypond.git/blob - scm/coverage.scm
Formatting from Ralph.
[lilypond.git] / scm / coverage.scm
1 (define-module (scm coverage))
2
3 (use-modules (lily)
4              (ice-9 rdelim)
5              (ice-9 regex)
6              (ice-9 format) ;; needed for ~8@ 
7              )
8
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
11 (define-public (coverage:show-all filter?)
12   (let*
13       ((keys
14         (filter filter?
15                 (sort (map car (hash-table->alist coverage-table)) string<? ))))
16     
17   (newline)
18   (for-each
19    (lambda (k)
20
21      (format #t "Coverage for file: ~a\n" k)
22      (display-coverage
23       k (hash-ref coverage-table k)
24       (format #f "~a.cov" (basename k))))
25    keys)))
26
27
28 (define-public (coverage:enable)
29   (trap-set! memoize-symbol-handler record-coverage)
30   (trap-enable 'memoize-symbol)
31   (trap-enable 'traps))
32
33      
34 (define-public (coverage:disable)
35   (trap-set! memoize-symbol-handler #f)
36   (trap-disable 'memoize-symbol))
37
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39
40 (define coverage-table (make-hash-table 57))
41
42 (define (read-lines port)
43   (string-split (read-delimited "" port) #\newline))
44
45 (define (display-coverage file vec out-file)
46   (let*
47       ((lines (read-lines (open-file file "r")))
48        (format-str "~8@a: ~5@a:~a\n")
49        (out (if out-file (open-output-file out-file)
50                 (current-output-port))))
51
52     (format out format-str "-" 0 (format #f "Source:~a" file))
53     (do
54         ((i 0 (1+ i))
55          (l lines (cdr l)))
56         ((or (null? l) ))
57
58       (format out format-str
59                        (cond
60                         ((and (< i (vector-length vec)) (vector-ref vec i)) "1")
61                         ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l)))
62                          "-")
63                         ((string-match  "^[ \t]*[()'`,]*$" (car l))
64                          "-")
65                         ((string-match  "^[ \t]*;.*$" (car l))
66
67                          "-")
68                         (else "0"))
69                        (1+ i)
70                        (car l)))))
71
72 (define (record-coverage key cont exp env)
73   (let*
74       ((name (source-property exp 'filename))
75        (line (source-property exp 'line))
76        (vec (and name (hash-ref coverage-table name #f)))
77        (veclen (and vec (vector-length vec)))
78        (veccopy (lambda (src dst)
79                   (vector-move-left! src 0 (vector-length src)
80                                      dst 0)
81                   dst)))
82     (if (and line name)
83         (begin
84           (if (or (not vec) (>= line (vector-length vec)))
85               (set! vec
86                     (hash-set! coverage-table name
87                                 (if vec
88                                     (veccopy vec (make-vector (1+ line) #f))
89                                     (make-vector (1+ line) #f)))))
90
91           (vector-set! vec line #t))
92     )))
93
94
95
96
97