Re: [PATCH] experimental lookupcar based coverage testing.

[Han-Wen Nienhuys]

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

This is fixed in attached patch. 

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

    (if (>= z 3)
        (begin
          (write z
                 (current-output-port))
          (x (1- a) b))
        (write "YES" (current-output-port))
        )

))

(set-test-flag #t)

(x 1 7)
(do
    ((i 0 (1+ i)))
    ((> i 5))

  (display i) 
  )

(set-test-flag #f)

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

yields

****************
876543"YES"012345
coverage: called 17 times
        : (define (x a b)
        :   (let*
#t      :       ((z (+ a b)))
        : 
#t      :     (if (>= z 3)
        :       (begin
#t      :         (write z
#t      :                (current-output-port))
#t      :         (x (1- a) b))
#t      :       (write "YES" (current-output-port))
        :       )
        : 
        : ))
        : 
        : (set-test-flag #t)
        : 
#t      : (x 1 7)
#t      : (do
#t      :     ((i 0 (1+ i)))
#t      :     ((> i 5))
        : 
#t      :   (display i) 
        :   )
        : 
#t      : (set-test-flag #f)
****************


patch: 

diff --git a/libguile/eval.c b/libguile/eval.c
index 26d90f1..9067670 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -99,6 +99,70 @@ 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) 
+
+static void
+scm_notice_coverage (SCM origx)
+{
+  if (!test_flag)
+    return ;
+
+  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;
+      
+      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);
+
+    }
+}
+
 
 
 /* {Syntax Errors}
@@ -2996,6 +3060,9 @@ scm_eval_body (SCM code, SCM env)
  */
 
 #ifndef DEVAL
+#undef NOTICE_COVERAGE
+#define NOTICE_COVERAGE(x) 
+
 
 #define SCM_APPLY scm_apply
 #define PREP_APPLY(proc, args)
@@ -3009,6 +3076,9 @@ scm_eval_body (SCM code, SCM env)
 
 #else /* !DEVAL */
 
+#undef NOTICE_COVERAGE
+#define NOTICE_COVERAGE(x) scm_notice_coverage(x)
+
 #undef CEVAL
 #define CEVAL deval    /* Substitute all uses of ceval */
 
@@ -3024,7 +3094,7 @@ scm_eval_body (SCM code, SCM env)
 do { \
   SCM_SET_ARGSREADY (debug);\
   if (scm_check_apply_p && SCM_TRAPS_P)\
-    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
+    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
       {\
        SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
        SCM_SET_TRACED_FRAME (debug); \
@@ -3235,6 +3305,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 +3338,7 @@ CEVAL (SCM x, SCM env)
 #ifdef DEVAL
   goto start;
 #endif
-
+  (void) origx;
 loop:
 #ifdef DEVAL
   SCM_CLEAR_ARGSREADY (debug);
@@ -4031,6 +4103,7 @@ dispatch:
                goto dispatch;
              }
            proc = *location;
+           NOTICE_COVERAGE(origx);
          }
 
          if (SCM_MACROP (proc))
@@ -4095,7 +4168,9 @@ dispatch:
            }
        }
       else
-        proc = SCM_CAR (x);
+       {
+         proc = SCM_CAR (x);
+       }
 
       if (SCM_MACROP (proc))
        goto handle_a_macro;
@@ -4111,6 +4186,7 @@ dispatch:
    * level.  If the number of arguments does not match the number of arguments
    * that are allowed to be passed to proc, also an error on the scheme level
    * will be signalled.  */
+
   PREP_APPLY (proc, SCM_EOL);
   if (scm_is_null (SCM_CDR (x))) {
     ENTER_APPLY;
@@ -4199,6 +4275,8 @@ dispatch:
     arg1 = EVALCAR (x, env);
   else
     scm_wrong_num_args (proc);
+  
+
 #ifdef DEVAL
   debug.info->a.args = scm_list_1 (arg1);
 #endif
@@ -5649,6 +5727,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 +6085,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.  */



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