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 - [EMAIL PROTECTED] - http://www.xs4all.nl/~hanwen
_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel
