Scheme coverage testing

This requires recent GUILE CVS, with support for
memoize-symbol evaluator trap handler.

diff --git a/scm/coverage.scm b/scm/coverage.scm
new file mode 100644 (file)
index 0000000..0b79959
--- /dev/null
+++ b/scm/coverage.scm
@@ -0,0 +1,80 @@
+(define-module (scm coverage))
+
+(use-modules (lily)
+            (ice-9 rdelim)
+            (ice-9 format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (coverage:show-all)
+  (newline)
+  (hash-fold
+   (lambda (key val acc)
+     (if (string-contains key "lilypond")
+        (begin
+          (format #t
+                "
+Coverage for file: ~a
+"
+                key)
+        (display-coverage key val)))
+     #t)
+   #t
+   coverage-table))
+
+(define-public (coverage:enable)
+  (trap-set! memoize-symbol-handler record-coverage)
+  (trap-enable 'memoize-symbol)
+  (trap-enable 'traps))
+
+(define-public (coverage:disable)
+  (trap-set! memoize-symbol-handler #f)
+  (trap-disable 'memoize-symbol))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define coverage-table (make-hash-table 57))
+
+(define (read-lines port)
+  (string-split (read-delimited "" port) #\newline))
+
+(define (display-coverage file vec)
+  (let*
+      ((lines (read-lines (open-file file "r"))))
+
+    (do
+       ((i 0 (1+ i))
+        (l lines (cdr l)))
+       ((or (null? l) (>= i (vector-length vec))))
+
+      (display (format #f "~8a: ~a\n"
+                      (if (vector-ref vec i)
+                          "#t"
+                          "") (car l))))))
+
+(define (record-coverage key cont exp env)
+  (let*
+      ((name (source-property exp 'filename))
+       (line (source-property exp 'line))
+       (vec (and name (hashv-ref coverage-table name #f)))
+       (veclen (and vec (vector-length vec)))
+       (veccopy (lambda (src dst)
+                 (vector-move-left! src 0 (vector-length src)
+                                    dst 0)
+                 dst)))
+    (if (and line name)
+       (begin
+         (if (or (not vec) (>= line (vector-length vec)))
+             (set! vec
+                   (hashv-set! coverage-table name
+                               (if vec
+                                   (veccopy vec (make-vector (1+ line) #f))
+                                   (make-vector (1+ line) #f)))))
+
+         (vector-set! vec line #t))
+    )))
+
+
+
+
+

diff --git a/scm/lily.scm b/scm/lily.scm
index cb1e593e3797010e0744a7c4743dc797756340bd..ebe0cc322428cfabde38ecd652abd0cfbd23131d 100644 (file)
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -71,6 +71,7 @@ on errors, and print a stack trace.")
              (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN.")
              (separate-log-files #f "Output to FILE.log per file.")
              (trace-memory-frequency #f "Record Scheme cell usage this many times per second, and dump to file.")
+             (trace-scheme-coverage #f "Record coverage of Scheme files") 
              (ttf-verbosity 0
                             "how much verbosity for TTF font embedding?")
              (show-available-fonts #f
@@ -108,6 +109,7 @@ on errors, and print a stack trace.")
             (srfi srfi-14)
             (scm clip-region)
             (scm memory-trace)
+            (scm coverage)
             )
 
 ;; my display
@@ -123,13 +125,19 @@ on errors, and print a stack trace.")
 ;;; have a more sensible default.
 
 (if (or (ly:get-option 'verbose)
-       (ly:get-option 'trace-memory-frequencency))
+       (ly:get-option 'trace-memory-frequencency)
+       (ly:get-option 'trace-scheme-coverage)
+       )
     (begin
       (ly:set-option 'protected-scheme-parsing #f)
       (debug-enable 'debug)
       (debug-enable 'backtrace)
       (read-enable 'positions)))
 
+
+(if (ly:get-option 'trace-scheme-coverage)
+    (coverage:enable))
+
 (define-public tex-backend?
   (member (ly:output-backend) '("texstr" "tex")))
 
@@ -618,6 +626,12 @@ The syntax is the same as `define*-public'."
 
   
   (let ((failed (lilypond-all files)))
+    (if (ly:get-option 'trace-scheme-coverage)
+       (begin
+         (coverage:disable)
+         (coverage:show-all)))
+         
+    
     (if (pair? failed)
        (begin
          (ly:error (_ "failed files: ~S") (string-join failed))