[PATCH] experimental lookupcar based coverage testing.

[Han-Wen Nienhuys]

Hi,

See attached patch. This still has rough edges. For some reason, I
don't catch the memoization of display to #<proc: display>.

Also, I'm looking at the orig_x , since the sub-expressions
that are used inside DEVAL don't have source properties.


**
(define (x a b)
  (let*
      ((z (+ a b)))

    (if (<= z 3)
        (display "YES")
        (x (1- a) b))))

(display "HOI\n")

(set-test-flag #t)

(display (x 1 12))
(display (x 1 12))

(set-test-flag #f)

(hash-fold
 (lambda (key val acc)
   (display (list key val)) #t)
 #t
 (get-coverage-table))
**


yields:


(gdb) r
[Thread debugging using libthread_db enabled]
[New Thread -1208576320 (LWP 29195)]
HOI
YES#<unspecified>YES#<unspecified>coverage: called 3 times
(x.scm #(#f #f #f #t #f #t #f #t))
Program exited normally.
(gdb) 


**
The line

  coverage: called 3 times

proves that it succeeds in not introducing significant penalties.




---
 libguile/eval.c |  119 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 116 insertions(+), 3 deletions(-)

diff --git a/libguile/eval.c b/libguile/eval.c
index 26d90f1..21c891c 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -99,6 +99,72 @@ static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
 static SCM unmemoize_builtin_macro (SCM expr, SCM env);
 static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
 
+SCM scm_set_test_flag (SCM);
+SCM scm_get_coverage_table (void);
+int test_flag;
+
+
+
+/* coverage
+ */
+static SCM scm_i_coverage_hash_table;
+static int cov_count; 
+#define NOTICE_COVERAGE(x,origx) (x)
+
+static SCM
+scm_notice_coverage (SCM x, SCM origx)
+{
+  if (!test_flag)
+    return x;
+
+  cov_count ++;
+  SCM source = scm_source_properties (origx);
+  if (scm_is_pair (source))
+    {
+      SCM line = scm_source_property (origx, scm_sym_line);
+      SCM file = scm_source_property (origx, scm_sym_filename);
+      SCM vec = SCM_BOOL_F;
+      int cline = 0;
+      
+      if (!scm_i_coverage_hash_table)
+       {
+         scm_i_coverage_hash_table =
+           scm_gc_protect_object (scm_c_make_hash_table (93));
+       }
+      
+      if (!scm_is_string (file)
+         || !scm_is_integer (line))
+       return x;
+      
+      vec = scm_hashv_ref (scm_i_coverage_hash_table,
+                          file, SCM_BOOL_F);
+      cline = scm_to_int (line);
+      if (!scm_is_vector (vec)
+         || scm_c_vector_length (vec) < cline)
+       {
+         SCM newvec = scm_c_make_vector (cline + 1,
+                                         SCM_BOOL_F);
+         if (scm_is_vector (vec))
+           {
+             int k = 0;
+             int veclen = scm_c_vector_length (vec);
+             
+             for (; k < veclen; k++)
+               scm_c_vector_set_x (newvec, k,
+                                   scm_c_vector_ref (vec, k));
+           }
+         vec = newvec;
+
+         scm_hashv_set_x (scm_i_coverage_hash_table, file, vec);
+       }
+
+      scm_c_vector_set_x (vec, cline, SCM_BOOL_T);
+
+    }
+  
+  return x;
+}
+
 
 
 /* {Syntax Errors}
@@ -2675,6 +2741,17 @@ static SCM deval (SCM x, SCM env);
             ? SCM_CAR (x) \
             :  *scm_lookupcar ((x), (env), 1)))))
 
+#define EVALCAR_COVERAGE(x, env) \
+  (SCM_IMP (SCM_CAR (x)) \
+   ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
+   : (SCM_VARIABLEP (SCM_CAR (x)) \
+      ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+      : (scm_is_pair (SCM_CAR (x)) \
+         ? CEVAL (SCM_CAR (x), (env)) \
+         : (!scm_is_symbol (SCM_CAR (x)) \
+            ? SCM_CAR (x) \
+            :  *scm_lookupcar (NOTICE_COVERAGE(x,origx), (env), 1)))))
+
 scm_i_pthread_mutex_t source_mutex;
 
 
@@ -2996,6 +3073,9 @@ scm_eval_body (SCM code, SCM env)
  */
 
 #ifndef DEVAL
+#undef NOTICE_COVERAGE
+#define NOTICE_COVERAGE(x,o) (x)
+
 
 #define SCM_APPLY scm_apply
 #define PREP_APPLY(proc, args)
@@ -3009,6 +3089,9 @@ scm_eval_body (SCM code, SCM env)
 
 #else /* !DEVAL */
 
+#undef NOTICE_COVERAGE
+#define NOTICE_COVERAGE(x,y) scm_notice_coverage(x,y)
+
 #undef CEVAL
 #define CEVAL deval    /* Substitute all uses of ceval */
 
@@ -3235,6 +3318,8 @@ static SCM
 CEVAL (SCM x, SCM env)
 {
   SCM proc, arg1;
+  SCM origx = x;
+  
 #ifdef DEVAL
   scm_t_debug_frame debug;
   scm_t_debug_info *debug_info_end;
@@ -3266,7 +3351,7 @@ CEVAL (SCM x, SCM env)
 #ifdef DEVAL
   goto start;
 #endif
-
+  (void) origx;
 loop:
 #ifdef DEVAL
   SCM_CLEAR_ARGSREADY (debug);
@@ -4196,7 +4281,7 @@ dispatch:
   /* must handle macros by here */
   x = SCM_CDR (x);
   if (scm_is_pair (x))
-    arg1 = EVALCAR (x, env);
+    arg1 = EVALCAR_COVERAGE (x, env);
   else
     scm_wrong_num_args (proc);
 #ifdef DEVAL
@@ -5649,6 +5734,35 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_set_test_flag, "set-test-flag", 1, 0, 0, 
+            (SCM val),
+           "")
+#define FUNC_NAME s_scm_set_test_flag
+{
+  test_flag = (val == SCM_BOOL_T);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#include <stdio.h>
+
+SCM_DEFINE (scm_get_coverage_table, "get-coverage-table", 0, 0, 0, 
+            (void),
+           "")
+#define FUNC_NAME s_scm_get_coverage_table
+{
+  if (scm_i_coverage_hash_table == NULL)
+    return SCM_BOOL_F;
+      
+  SCM x = scm_i_coverage_hash_table;
+  scm_i_coverage_hash_table = 0;
+  scm_gc_unprotect_object (x);
+  printf ("coverage: called %d times\n", cov_count);
+  return x;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, 
             (SCM obj),
            "Return true if @var{obj} is a promise, i.e. a delayed 
computation\n"
@@ -5978,7 +6092,6 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 #define DEVAL
 #include "eval.c"
 
-
 #if (SCM_ENABLE_DEPRECATED == 1)
 
 /* Deprecated in guile 1.7.0 on 2004-03-29.  */
-- 
1.4.4.2




-- 
 Han-Wen Nienhuys - address@hidden - http://www.xs4all.nl/~hanwen