From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Han-Wen Nienhuys Newsgroups: gmane.lisp.guile.devel Subject: Re: [PATCH] experimental lookupcar based coverage testing. Date: Fri, 19 Jan 2007 13:56:50 +0100 Message-ID: <45B0C012.7080606@xs4all.nl> References: <45AFCEFD.5030203@xs4all.nl> Reply-To: hanwen@xs4all.nl NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 7bit X-Trace: sea.gmane.org 1169211435 19655 80.91.229.12 (19 Jan 2007 12:57:15 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Fri, 19 Jan 2007 12:57:15 +0000 (UTC) Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Jan 19 13:57:14 2007 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1H7tIs-0004rb-TX for guile-devel@m.gmane.org; Fri, 19 Jan 2007 13:57:11 +0100 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1H7tIs-0006Wb-5W for guile-devel@m.gmane.org; Fri, 19 Jan 2007 07:57:10 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1H7tIo-0006Tl-1f for guile-devel@gnu.org; Fri, 19 Jan 2007 07:57:06 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1H7tIl-0006PS-Cb for guile-devel@gnu.org; Fri, 19 Jan 2007 07:57:05 -0500 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1H7tIl-0006PK-7f for guile-devel@gnu.org; Fri, 19 Jan 2007 07:57:03 -0500 Original-Received: from [80.91.229.2] (helo=ciao.gmane.org) by monty-python.gnu.org with esmtps (TLS-1.0:RSA_AES_256_CBC_SHA:32) (Exim 4.52) id 1H7tIk-0001Pi-9X for guile-devel@gnu.org; Fri, 19 Jan 2007 07:57:02 -0500 Original-Received: from list by ciao.gmane.org with local (Exim 4.43) id 1H7tIc-0004xD-GG for guile-devel@gnu.org; Fri, 19 Jan 2007 13:56:54 +0100 Original-Received: from muurbloem.xs4all.nl ([213.84.26.127]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Fri, 19 Jan 2007 13:56:54 +0100 Original-Received: from hanwen by muurbloem.xs4all.nl with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Fri, 19 Jan 2007 13:56:54 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-To: guile-devel@gnu.org Original-Lines: 286 Original-X-Complaints-To: usenet@sea.gmane.org X-Gmane-NNTP-Posting-Host: muurbloem.xs4all.nl User-Agent: Thunderbird 1.5.0.9 (X11/20061219) In-Reply-To: <45AFCEFD.5030203@xs4all.nl> X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:6453 Archived-At: 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 #. 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 + +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 - hanwen@xs4all.nl - http://www.xs4all.nl/~hanwen _______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://lists.gnu.org/mailman/listinfo/guile-devel