diff options
Diffstat (limited to 'libguile/debug.c')
-rw-r--r-- | libguile/debug.c | 310 |
1 files changed, 30 insertions, 280 deletions
diff --git a/libguile/debug.c b/libguile/debug.c index 53eb16b76..f0dd29a0a 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -48,6 +48,7 @@ #include "libguile/root.h" #include "libguile/fluids.h" #include "libguile/programs.h" +#include "libguile/memoize.h" #include "libguile/validate.h" #include "libguile/debug.h" @@ -77,11 +78,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, scm_options (ans, scm_debug_opts, FUNC_NAME); SCM_OUT_OF_RANGE (1, setting); } - SCM_RESET_DEBUG_MODE; #ifdef STACK_CHECKING scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; #endif - scm_debug_eframe_size = 2 * SCM_N_FRAMES; scm_dynwind_end (); return ans; @@ -131,175 +130,6 @@ SCM_SYMBOL (scm_sym_procname, "procname"); SCM_SYMBOL (scm_sym_dots, "..."); SCM_SYMBOL (scm_sym_source, "source"); -/* {Memoized Source} - */ - -scm_t_bits scm_tc16_memoized; - -static int -memoized_print (SCM obj, SCM port, scm_print_state *pstate) -{ - int writingp = SCM_WRITINGP (pstate); - scm_puts ("#<memoized ", port); - SCM_SET_WRITINGP (pstate, 1); - scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate); - SCM_SET_WRITINGP (pstate, writingp); - scm_putc ('>', port); - return 1; -} - -SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is memoized.") -#define FUNC_NAME s_scm_memoized_p -{ - return scm_from_bool(SCM_MEMOIZEDP (obj)); -} -#undef FUNC_NAME - -SCM -scm_make_memoized (SCM exp, SCM env) -{ - /* *fixme* Check that env is a valid environment. */ - SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env))); -} - -#ifdef GUILE_DEBUG -/* - * Some primitives for construction of memoized code - * - * - procedure: memcons CAR CDR [ENV] - * - * Construct a pair, encapsulated in a memoized object. - * - * The CAR and CDR can be either normal or memoized. If ENV isn't - * specified, the top-level environment of the current module will - * be assumed. All environments must match. - * - * - procedure: make-iloc FRAME BINDING CDRP - * - * Return an iloc referring to frame no. FRAME, binding - * no. BINDING. If CDRP is non-#f, the iloc is referring to a - * frame consisting of a single pair, with the value stored in the - * CDR. - * - * - procedure: iloc? OBJECT - * - * Return #t if OBJECT is an iloc. - * - * - procedure: mem->proc MEMOIZED - * - * Construct a closure from the memoized lambda expression MEMOIZED - * - * WARNING! The code is not copied! - * - * - procedure: proc->mem CLOSURE - * - * Turn the closure CLOSURE into a memoized object. - * - * WARNING! The code is not copied! - * - * - constant: SCM_IM_AND - * - constant: SCM_IM_BEGIN - * - constant: SCM_IM_CASE - * - constant: SCM_IM_COND - * - constant: SCM_IM_DO - * - constant: SCM_IM_IF - * - constant: SCM_IM_LAMBDA - * - constant: SCM_IM_LET - * - constant: SCM_IM_LETSTAR - * - constant: SCM_IM_LETREC - * - constant: SCM_IM_OR - * - constant: SCM_IM_QUOTE - * - constant: SCM_IM_SET - * - constant: SCM_IM_DEFINE - * - constant: SCM_IM_APPLY - * - constant: SCM_IM_CONT - * - constant: SCM_IM_DISPATCH - */ - -#include "libguile/variable.h" -#include "libguile/procs.h" - -SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, - (SCM car, SCM cdr, SCM env), - "Return a new memoized cons cell with @var{car} and @var{cdr}\n" - "as members and @var{env} as the environment.") -#define FUNC_NAME s_scm_memcons -{ - if (SCM_MEMOIZEDP (car)) - { - /*fixme* environments may be two different but equal top-level envs */ - if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env) - SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3", - scm_list_2 (car, env)); - else - env = SCM_MEMOIZED_ENV (car); - car = SCM_MEMOIZED_EXP (car); - } - if (SCM_MEMOIZEDP (cdr)) - { - if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env) - SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3", - scm_list_2 (cdr, env)); - else - env = SCM_MEMOIZED_ENV (cdr); - cdr = SCM_MEMOIZED_EXP (cdr); - } - if (SCM_UNBNDP (env)) - env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); - else - SCM_VALIDATE_NULLORCONS (3, env); - return scm_make_memoized (scm_cons (car, cdr), env); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, - (SCM obj), - "Convert a memoized object (which must represent a body)\n" - "to a procedure.") -#define FUNC_NAME s_scm_mem_to_proc -{ - SCM env; - SCM_VALIDATE_MEMOIZED (1, obj); - env = SCM_MEMOIZED_ENV (obj); - obj = SCM_MEMOIZED_EXP (obj); - return scm_closure (obj, env); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0, - (SCM obj), - "Convert a procedure to a memoized object.") -#define FUNC_NAME s_scm_proc_to_mem -{ - SCM_VALIDATE_CLOSURE (1, obj); - return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj)); -} -#undef FUNC_NAME - -#endif /* GUILE_DEBUG */ - -SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0, - (SCM m), - "Unmemoize the memoized expression @var{m},") -#define FUNC_NAME s_scm_i_unmemoize_expr -{ - SCM_VALIDATE_MEMOIZED (1, m); - return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0, - (SCM m), - "Return the environment of the memoized expression @var{m}.") -#define FUNC_NAME s_scm_memoized_environment -{ - SCM_VALIDATE_MEMOIZED (1, m); - return SCM_MEMOIZED_ENV (m); -} -#undef FUNC_NAME - SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, (SCM proc), "Return the name of the procedure @var{proc}") @@ -333,74 +163,32 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, "Return the source of the procedure @var{proc}.") #define FUNC_NAME s_scm_procedure_source { - SCM_VALIDATE_NIM (1, proc); - again: - switch (SCM_TYP7 (proc)) { - case scm_tcs_closures: - { - const SCM formals = SCM_CLOSURE_FORMALS (proc); - const SCM body = SCM_CLOSURE_BODY (proc); - const SCM src = scm_source_property (body, scm_sym_copy); + SCM src; + SCM_VALIDATE_PROC (1, proc); - if (scm_is_true (src)) - { - return scm_cons2 (scm_sym_lambda, formals, src); - } - else - { - const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); - return scm_cons2 (scm_sym_lambda, - scm_i_finite_list_copy (formals), - scm_i_unmemocopy_body (body, env)); - } - } - case scm_tcs_struct: - if (!SCM_STRUCT_APPLICABLE_P (proc)) - break; - proc = SCM_STRUCT_PROCEDURE (proc); - if (SCM_IMP (proc)) - break; - goto procprop; - case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) - break; - case scm_tcs_subrs: - case scm_tc7_program: - procprop: - /* It would indeed be a nice thing if we supplied source even for - built in procedures! */ - return scm_procedure_property (proc, scm_sym_source); - case scm_tc7_pws: + do { - SCM src = scm_procedure_property (proc, scm_sym_source); + src = scm_procedure_property (proc, scm_sym_source); if (scm_is_true (src)) - return src; - proc = SCM_PROCEDURE (proc); - goto again; + return src; + + switch (SCM_TYP7 (proc)) { + case scm_tcs_struct: + if (!SCM_STRUCT_APPLICABLE_P (proc) + || SCM_IMP (SCM_STRUCT_PROCEDURE (proc))) + break; + proc = SCM_STRUCT_PROCEDURE (proc); + continue; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + continue; + default: + break; + } } - default: - ; - } - SCM_WRONG_TYPE_ARG (1, proc); - return SCM_BOOL_F; /* not reached */ -} -#undef FUNC_NAME + while (0); -SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, - (SCM proc), - "Return the environment of the procedure @var{proc}.") -#define FUNC_NAME s_scm_procedure_environment -{ - SCM_VALIDATE_NIM (1, proc); - switch (SCM_TYP7 (proc)) { - case scm_tcs_closures: - return SCM_ENV (proc); - case scm_tcs_subrs: - return SCM_EOL; - default: - SCM_WRONG_TYPE_ARG (1, proc); - /* not reached */ - } + return SCM_BOOL_F; } #undef FUNC_NAME @@ -413,37 +201,21 @@ SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, if (scm_is_true (scm_program_p (proc))) return scm_program_module (proc); + else if (SCM_CLOSUREP (proc)) + { + SCM env = SCM_ENV (proc); + while (scm_is_pair (env)) + env = scm_cdr (env); + return env; + } else - return scm_env_module (scm_procedure_environment (proc)); + return SCM_BOOL_F; } #undef FUNC_NAME -/* Eval in a local environment. We would like to have the ability to - * evaluate in a specified local environment, but due to the - * memoization this isn't normally possible. We solve it by copying - * the code before evaluating. One solution would be to have eval.c - * generate yet another evaluator. They are not very big actually. - */ -SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0, - (SCM exp, SCM env), - "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n" - "it is the environment in which to evaluate @var{exp}. Otherwise,\n" - "@var{exp} must be a memoized code object (in which case, its environment\n" - "is implicit).") -#define FUNC_NAME s_scm_local_eval -{ - if (SCM_UNBNDP (env)) - { - SCM_VALIDATE_MEMOIZED (1, exp); - return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp)); - } - return scm_i_eval (exp, env); -} -#undef FUNC_NAME - #if 0 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); #endif @@ -565,31 +337,9 @@ scm_init_debug () init_stack_limit (); scm_init_opts (scm_debug_options, scm_debug_opts); - scm_tc16_memoized = scm_make_smob_type ("memoized", 0); - scm_set_smob_print (scm_tc16_memoized, memoized_print); - scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); scm_set_smob_print (scm_tc16_debugobj, debugobj_print); -#ifdef GUILE_DEBUG - scm_c_define ("SCM_IM_AND", SCM_IM_AND); - scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); - scm_c_define ("SCM_IM_CASE", SCM_IM_CASE); - scm_c_define ("SCM_IM_COND", SCM_IM_COND); - scm_c_define ("SCM_IM_DO", SCM_IM_DO); - scm_c_define ("SCM_IM_IF", SCM_IM_IF); - scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); - scm_c_define ("SCM_IM_LET", SCM_IM_LET); - scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); - scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC); - scm_c_define ("SCM_IM_OR", SCM_IM_OR); - scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); - scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X); - scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); - scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY); - scm_c_define ("SCM_IM_CONT", SCM_IM_CONT); - scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); -#endif scm_add_feature ("debug-extensions"); #include "libguile/debug.x" |