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