From dee82b1d0bcaf37a6a771417fe8f400a4b962131 Mon Sep 17 00:00:00 2001
From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Fri, 19 Jan 2007 21:45:44 +0100
Subject: [PATCH] Scheme coverage testing

This requires recent GUILE CVS, with support for
memoize-symbol evaluator trap handler.
---
 scm/coverage.scm | 80 ++++++++++++++++++++++++++++++++++++++++++++++++
 scm/lily.scm     | 16 +++++++++-
 2 files changed, 95 insertions(+), 1 deletion(-)
 create mode 100644 scm/coverage.scm

diff --git a/scm/coverage.scm b/scm/coverage.scm
new file mode 100644
index 0000000000..0b799599e1
--- /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 cb1e593e37..ebe0cc3224 100644
--- 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))
-- 
2.39.2