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                         ((string-match  "^[ \t]*[()'`,]*$" (car l))
  65                          "-")
  66                         ((string-match  "^[ \t]*;.*$" (car l))
  67
  68                          "-")
  69                         (else "0"))
  70                        (1+ i)
  71                        (car l)))))
  72
  73 (define (record-coverage key cont exp env)
  74   (let*
  75       ((name (source-property exp 'filename))
  76        (line (source-property exp 'line))
  77        (vec (and name (hashv-ref coverage-table name #f)))
  78        (veclen (and vec (vector-length vec)))
  79        (veccopy (lambda (src dst)
  80                   (vector-move-left! src 0 (vector-length src)
  81                                      dst 0)
  82                   dst)))
  83     (if (and line name)
  84         (begin
  85           (if (or (not vec) (>= line (vector-length vec)))
  86               (set! vec
  87                     (hashv-set! coverage-table name
  88                                 (if vec
  89                                     (veccopy vec (make-vector (1+ line) #f))
  90                                     (make-vector (1+ line) #f)))))
  91
  92           (vector-set! vec line #t))
  93     )))
  94
  95
  96
  97
  98