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