X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e2806c1000054f765c46bd14f8fb64a4d74d4eea..af1f9aa293d2fe45a8c1642a58fafd70bc5907e1:/libguile/debug.c diff --git a/libguile/debug.c b/libguile/debug.c index a7a7704a7..f5c9f8c55 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,5 +1,5 @@ /* Debugging extensions for Guile - * Copyright (C) 1995, 1996 Mikael Djurfeldt + * Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -13,7 +13,8 @@ * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -40,14 +41,15 @@ * If you do not wish that, delete this exception notice. * * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ + * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ #include #include "_scm.h" #include "eval.h" +#include "stackchk.h" #include "throw.h" #include "genio.h" +#include "macros.h" #include "smob.h" #include "procprop.h" #include "srcprop.h" @@ -56,6 +58,8 @@ #include "strports.h" #include "read.h" #include "feature.h" +#include "dynwind.h" +#include "modules.h" #include "debug.h" @@ -64,14 +68,10 @@ */ SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options); -#ifdef __STDC__ -SCM -scm_debug_options (SCM setting) -#else + SCM scm_debug_options (setting) SCM setting; -#endif { SCM ans; SCM_DEFER_INTS; @@ -83,53 +83,53 @@ scm_debug_options (setting) if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) { scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options); - /* *fixme* Should SCM_ALLOW_INTS be called here? */ - scm_wta (setting, (char *) SCM_OUTOFRANGE, "frames"); + scm_out_of_range (s_debug_options, setting); } #endif SCM_RESET_DEBUG_MODE; + scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; scm_debug_eframe_size = 2 * SCM_N_FRAMES; SCM_ALLOW_INTS return ans; } -SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps); -#ifdef __STDC__ -SCM -scm_evaluator_traps (SCM setting) -#else -SCM -scm_evaluator_traps (setting) - SCM setting; -#endif +SCM_PROC (s_with_traps, "with-traps", 1, 0, 0, scm_with_traps); + +static void +with_traps_before (void *data) { - SCM ans; - SCM_DEFER_INTS; - ans = scm_options (setting, - scm_evaluator_trap_table, - SCM_N_EVALUATOR_TRAPS, - s_evaluator_traps); - SCM_RESET_DEBUG_MODE; - SCM_ALLOW_INTS - return ans; + int *trap_flag = data; + *trap_flag = SCM_TRAPS_P; + SCM_TRAPS_P = 1; +} + +static void +with_traps_after (void *data) +{ + int *trap_flag = data; + SCM_TRAPS_P = *trap_flag; +} + +static SCM +with_traps_inner (void *data) +{ + SCM thunk = (SCM) data; + return scm_apply (thunk, SCM_EOL, SCM_EOL); } -SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step); -#ifdef __STDC__ -SCM -scm_single_step (SCM cont, SCM val) -#else SCM -scm_single_step (cont, val) - SCM cont, SCM val; -#endif +scm_with_traps (SCM thunk) { - SCM_DEFER_INTS; - SCM_ENTER_FRAME_P = SCM_EXIT_FRAME_P = 1; - SCM_RESET_DEBUG_MODE; - SCM_ALLOW_INTS; - scm_throw (cont, val); - return SCM_BOOL_F; /* never returns */ + int trap_flag; + SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), + thunk, + SCM_ARG1, + s_with_traps); + return scm_internal_dynamic_wind (with_traps_before, + with_traps_inner, + with_traps_after, + (void *) thunk, + &trap_flag); } @@ -142,20 +142,25 @@ static SCM scm_i_procname; long scm_tc16_memoized; -#ifdef __STDC__ -static int -prinmemoized (SCM obj, SCM port, int writing) -#else + +static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); + static int -prinmemoized (obj, port, writing) +prinmemoized (obj, port, pstate) SCM obj; SCM port; - int writing; -#endif + scm_print_state *pstate; { - scm_gen_puts (scm_regular_string, "#', port); + int writingp = SCM_WRITINGP (pstate); + scm_puts ("#', port); return 1; } @@ -163,109 +168,293 @@ static scm_smobfuns memoizedsmob = {scm_markcdr, scm_free0, prinmemoized, 0}; SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p); -#ifdef __STDC__ -SCM -scm_memoized_p (SCM obj) -#else + SCM scm_memoized_p (obj) SCM obj; -#endif { return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } -#ifdef __STDC__ -SCM -scm_make_memoized (SCM exp, SCM env) -#else SCM scm_make_memoized (exp, env) - SCM exp, SCM env; -#endif + SCM exp; + SCM env; { + /* *fixme* Check that env is a valid environment. */ register SCM z, ans; - SCM_DEFER_INTS; + SCM_ENTER_A_SECTION; SCM_NEWCELL (z); - SCM_CAR (z) = exp; - SCM_CDR (z) = env; + SCM_SETCDR (z, env); + SCM_SETCAR (z, exp); SCM_NEWCELL (ans); - SCM_CAR (ans) = scm_tc16_memoized; - SCM_CDR (ans) = z; - SCM_ALLOW_INTS; + SCM_SETCDR (ans, z); + SCM_SETCAR (ans, scm_tc16_memoized); + SCM_EXIT_A_SECTION; return ans; } -SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize); -#ifdef __STDC__ +#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-gloc VARIABLE [ENV] + * + * Return a gloc, encapsulated in a memoized object. + * + * (Glocs can't exist in normal list structures, since they will + * be mistaken for structs.) + * + * - procedure: gloc? OBJECT + * + * Return #t if OBJECT is a memoized gloc. + * + * - 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 "variable.h" +#include "procs.h" + +SCM_PROC (s_make_gloc, "make-gloc", 1, 1, 0, scm_make_gloc); + SCM -scm_unmemoize (SCM m) -#else +scm_make_gloc (var, env) + SCM var; + SCM env; +{ +#if 1 /* Unsafe */ + if (SCM_NIMP (var) && SCM_CONSP (var)) + var = scm_cons (SCM_BOOL_F, var); + else +#endif + SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var), + var, + SCM_ARG1, + s_make_gloc); + if (SCM_UNBNDP (env)) + env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); + else + SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), + env, + SCM_ARG2, + s_make_gloc); + return scm_make_memoized (SCM_VARVCELL (var) + 1, env); +} + +SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p); + +SCM +scm_gloc_p (obj) + SCM obj; +{ + return ((SCM_NIMP (obj) + && SCM_MEMOIZEDP (obj) + && (SCM_MEMOIZED_EXP (obj) & 7) == 1) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + +SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc); + +SCM +scm_make_iloc (frame, binding, cdrp) + SCM frame; + SCM binding; + SCM cdrp; +{ + SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc); + SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc); + return (SCM_ILOC00 + + SCM_IFRINC * SCM_INUM (frame) + + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0) + + SCM_IDINC * SCM_INUM (binding)); +} + +SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p); + +SCM +scm_iloc_p (obj) + SCM obj; +{ + return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons); + +SCM +scm_memcons (car, cdr, env) + SCM car; + SCM cdr; + SCM env; +{ + if (SCM_NIMP (car) && 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 (s_memcons, + "environment mismatch arg1 <-> arg3", + scm_cons2 (car, env, SCM_EOL)); + else + env = SCM_MEMOIZED_ENV (car); + car = SCM_MEMOIZED_EXP (car); + } + if (SCM_NIMP (cdr) && SCM_MEMOIZEDP (cdr)) + { + if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env) + scm_misc_error (s_memcons, + "environment mismatch arg2 <-> arg3", + scm_cons2 (cdr, env, SCM_EOL)); + else + env = SCM_MEMOIZED_ENV (cdr); + cdr = SCM_MEMOIZED_EXP (cdr); + } + if (SCM_UNBNDP (env)) + env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); + else + SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), + env, + SCM_ARG3, + s_make_iloc); + return scm_make_memoized (scm_cons (car, cdr), env); +} + +SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc); + +SCM +scm_mem_to_proc (obj) + SCM obj; +{ + SCM env; + SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj), + obj, + SCM_ARG1, + s_mem_to_proc); + env = SCM_MEMOIZED_ENV (obj); + obj = SCM_MEMOIZED_EXP (obj); + if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA)) + scm_misc_error (s_mem_to_proc, + "expected lambda expression", + scm_cons (obj, SCM_EOL)); + return scm_closure (SCM_CDR (obj), env); +} + +SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem); + +SCM +scm_proc_to_mem (obj) + SCM obj; +{ + SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj), + obj, + SCM_ARG1, + s_proc_to_mem); + return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)), + SCM_ENV (obj)); +} + +#endif /* GUILE_DEBUG */ + +SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize); + SCM scm_unmemoize (m) SCM m; -#endif { - SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); - return scm_unmemocopy (SCM_MEMOEXP (m), SCM_MEMOENV (m)); + SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); + return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); } SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment); -#ifdef __STDC__ -SCM -scm_memoized_environment (SCM m) -#else + SCM scm_memoized_environment (m) SCM m; -#endif { - SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); - return SCM_MEMOENV (m); + SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); + return SCM_MEMOIZED_ENV (m); } SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name); -#ifdef __STDC__ -SCM -scm_procedure_name (SCM proc) -#else + SCM scm_procedure_name (proc) SCM proc; -#endif { SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T, proc, SCM_ARG1, s_procedure_name); switch (SCM_TYP7 (proc)) { - case scm_tcs_closures: + case scm_tcs_subrs: + return SCM_SNAME (proc); + default: { SCM name = scm_procedure_property (proc, scm_i_name); #if 0 - /* Procedure property scm_i_procname not implemented yet... */ + /* Source property scm_i_procname not implemented yet... */ SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname); if (SCM_FALSEP (name)) name = scm_procedure_property (proc, scm_i_name); #endif + if (SCM_FALSEP (name)) + name = scm_procedure_property (proc, scm_i_inner_name); return name; } - case scm_tcs_subrs: - return SCM_SNAME (proc); - default: - return SCM_BOOL_F; } } SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source); -#ifdef __STDC__ -SCM -scm_procedure_source (SCM proc) -#else + SCM scm_procedure_source (proc) SCM proc; -#endif { SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source); switch (SCM_TYP7 (proc)) { @@ -297,14 +486,10 @@ scm_procedure_source (proc) } SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment); -#ifdef __STDC__ -SCM -scm_procedure_environment (SCM proc) -#else + SCM scm_procedure_environment (proc) SCM proc; -#endif { SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment); switch (SCM_TYP7 (proc)) { @@ -322,51 +507,66 @@ scm_procedure_environment (proc) } } + /* 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. Probably the best solution would be to have eval.c generate - * yet another evaluator. They are not very big actually. + * 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_PROC (s_local_eval, "local-eval", 2, 0, 0, scm_local_eval); -#ifdef __STDC__ -SCM -scm_local_eval (SCM exp, SCM env) -#else +SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval); + SCM scm_local_eval (exp, env) SCM exp; SCM env; -#endif { + if (SCM_UNBNDP (env)) + { + SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval); + return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); + } return scm_eval_3 (exp, 1, env); } -/* {Stack Frames} - * - * The stack is a list of stackframes, from root to current. - * - * A stackframe is a list of virtual stackframes, which occur due to - * the evaluators tail recursion. A virtual stackframe normally - * corresponds to an eval/apply pair, but macros and special forms - * (which are implemented as macros in scm...) only have eval - * information and apply calls leads to apply only frames. - * - * A virtual stackframe is either a property list or the symbol - * ... which marks the location of virtual stackframes which could not - * be stored with the current debug-depth. - * - * Property Type Description - * - * These three only present in eval frames: - * - * sexpr memoized Source code expression and environment. - * proc procedure The procedure being applied. - * (Not present if pre-apply state.) - * args list The arguments evaluated so far. - * eval-args boolean True if evaluation of arguments not finished. - */ +SCM +scm_start_stack (id, exp, env) + SCM id; + SCM exp; + SCM env; +{ + SCM answer; + scm_debug_frame vframe; + scm_debug_info vframe_vect_body; + vframe.prev = scm_last_debug_frame; + vframe.status = SCM_VOIDFRAME; + vframe.vect = &vframe_vect_body; + vframe.vect[0].id = id; + scm_last_debug_frame = &vframe; + answer = scm_eval_3 (exp, 1, env); + scm_last_debug_frame = vframe.prev; + return answer; +} + +SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); + +static SCM +scm_m_start_stack (exp, env) + SCM exp; + SCM env; +{ + exp = SCM_CDR (exp); + SCM_ASSERT (SCM_NIMP (exp) + && SCM_ECONSP (exp) + && SCM_NIMP (SCM_CDR (exp)) + && SCM_ECONSP (SCM_CDR (exp)) + && SCM_NULLP (SCM_CDDR (exp)), + exp, + SCM_WNA, + s_start_stack); + return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); +} /* {Debug Objects} * @@ -375,226 +575,61 @@ scm_local_eval (exp, env) long scm_tc16_debugobj; -#define DEBUGOBJP(x) (scm_tc16_debugobj == SCM_TYP16 (x)) -#define DBGFRAME(x) SCM_CDR (x) +static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); -#ifdef __STDC__ -static int -prindebugobj (SCM obj, SCM port, int writing) -#else static int -prindebugobj (writing) - SCM obj, SCM port, int writing; -#endif +prindebugobj (obj, port, pstate) + SCM obj; + SCM port; + scm_print_state *pstate; { - scm_gen_puts (scm_regular_string, "#', port); + scm_puts ("#', port); return 1; } static scm_smobfuns debugobjsmob = -{scm_mark0, scm_free0, prindebugobj, 0}; +{0, scm_free0, prindebugobj, 0}; SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p); -#ifdef __STDC__ -SCM -scm_debug_object_p (SCM obj) -#else + SCM scm_debug_object_p (obj) SCM obj; -#endif { - return SCM_NIMP (obj) && DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } -#ifdef __STDC__ -SCM -scm_make_debugobj (scm_debug_frame *frame) -#else + SCM scm_make_debugobj (frame) scm_debug_frame *frame; -#endif { register SCM z; - SCM_DEFER_INTS; SCM_NEWCELL (z); - SCM_CAR (z) = scm_tc16_debugobj; - DBGFRAME (z) = (SCM) frame; - SCM_ALLOW_INTS; + SCM_ENTER_A_SECTION; + SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame); + SCM_SETCAR (z, scm_tc16_debugobj); + SCM_EXIT_A_SECTION; return z; } -#ifdef __STDC__ -static SCM -_scm_stack_frame_to_plist (scm_debug_frame *frame, long offset) -#else -static SCM -_scm_stack_frame_to_plist (frame, offset) - scm_debug_frame *frame; - long offset; -#endif -{ - int size; - scm_debug_info *info; - if (SCM_EVALFRAMEP (*frame)) - { - size = frame->status & SCM_MAX_FRAME_SIZE; - info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset); - if ((info - frame->vect) & 1) - { - /* Debug.vect ends with apply info. */ - SCM p; - --info; - if (info[1].a.proc == SCM_UNDEFINED) - p = SCM_EOL; - else - p = scm_acons (scm_i_proc, - info[1].a.proc, - scm_acons (scm_i_args, - info[1].a.args, - SCM_ARGS_READY_P (*frame) - ? SCM_EOL - : scm_acons (scm_i_eval_args, - SCM_BOOL_T, - SCM_EOL))); - return scm_acons (scm_i_source, - scm_make_memoized (info[0].e.exp, info[0].e.env), - p); - } - else - /* Debug.vect ends with eval info. */ - return scm_acons (scm_i_source, - scm_make_memoized (info[0].e.exp, info[0].e.env), - SCM_EOL); - } - else - return scm_acons (scm_i_proc, - frame->vect[0].a.proc, - scm_acons (scm_i_args, frame->vect[0].a.args, SCM_EOL)); -} - -SCM_PROC (s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame); -#ifdef __STDC__ -SCM -scm_last_stack_frame (SCM obj) -#else -SCM -scm_last_stack_frame (obj) - SCM obj; -#endif -{ - scm_debug_frame *frame; - long offset = 0; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame); - if (scm_tc16_debugobj == SCM_TYP16 (obj)) - frame = (scm_debug_frame *) DBGFRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) - { - frame = SCM_DFRAME (obj); - offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj); -#ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); -#endif - } - else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame); - if (!frame) - return SCM_BOOL_F; - return _scm_stack_frame_to_plist ((scm_debug_frame *) ((SCM_STACKITEM *) frame + offset), offset); -} + -/* Make a scheme object of the current evaluation stack. - */ +/* Undocumented debugging procedure */ +#ifdef GUILE_DEBUG +SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang); -SCM_PROC (s_expr_stack, "expr-stack", 0, 1, 0, scm_expr_stack); -#ifdef __STDC__ -SCM -scm_expr_stack (SCM obj) -#else SCM -scm_expr_stack (obj) +scm_debug_hang (obj) SCM obj; -#endif { - SCM frs = SCM_EOL, vfrs, p; - int size; - int max_vfrs = SCM_BACKTRACE_DEPTH; - scm_debug_info *info; - scm_debug_frame *frame; - long offset = 0; - if (SCM_UNBNDP (obj)) - frame = last_debug_info_frame; - else - { - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_expr_stack); - if (scm_tc16_debugobj == SCM_TYP16 (obj)) - frame = (scm_debug_frame *) DBGFRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) - { - frame = SCM_DFRAME (obj); - offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj); -#ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); -#endif - } - else scm_wta (obj, (char *) SCM_ARG1, s_expr_stack); - } - for (; frame && max_vfrs > 0; frame = frame->prev) - { - frame = (scm_debug_frame *) ((SCM_STACKITEM *) frame + offset); - p = _scm_stack_frame_to_plist (frame, offset); - if (SCM_EVALFRAMEP (*frame)) - { - size = frame->status & SCM_MAX_FRAME_SIZE; - info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset); - vfrs = SCM_EOL; - if ((info - frame->vect) & 1) - --info; - /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_debug_info vector is overflowed. */ - else if (SCM_OVERFLOWP (*frame) - && !SCM_UNBNDP (info[1].a.proc)) - { - vfrs = scm_cons (p, SCM_EOL); - --max_vfrs; - p = scm_acons (scm_i_proc, - info[1].a.proc, - scm_acons (scm_i_args, info[1].a.args, SCM_EOL)); - } - info -= 2; - vfrs = scm_cons (p, vfrs); - --max_vfrs; - if (SCM_OVERFLOWP (*frame)) - vfrs = scm_cons (scm_i_more, vfrs); - while (info >= frame->vect) - { - p = SCM_EOL; - if (!SCM_UNBNDP (info[1].a.proc)) - p = scm_acons (scm_i_proc, - info[1].a.proc, - scm_acons (scm_i_args, info[1].a.args, SCM_EOL)); - p = scm_acons (scm_i_source, - scm_make_memoized (info[0].e.exp, info[0].e.env), - p); - info -= 2; - vfrs = scm_cons (p, vfrs); - --max_vfrs; - } - } - else - { - vfrs = scm_cons (p, SCM_EOL); - --max_vfrs; - } - frs = scm_cons (vfrs, frs); - } - if (max_vfrs <= 0) - frs = scm_cons (scm_i_more, frs); - return frs; + int go = 0; + while (!go) ; + return SCM_UNSPECIFIED; } - +#endif @@ -602,9 +637,6 @@ void scm_init_debug () { scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); - scm_init_opts (scm_evaluator_traps, - scm_evaluator_trap_table, - SCM_N_EVALUATOR_TRAPS); scm_tc16_memoized = scm_newsmob (&memoizedsmob); scm_tc16_debugobj = scm_newsmob (&debugobjsmob); @@ -616,6 +648,25 @@ scm_init_debug () scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED)); scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED)); +#ifdef GUILE_DEBUG + scm_sysintern ("SCM_IM_AND", SCM_IM_AND); + scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN); + scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE); + scm_sysintern ("SCM_IM_COND", SCM_IM_COND); + scm_sysintern ("SCM_IM_DO", SCM_IM_DO); + scm_sysintern ("SCM_IM_IF", SCM_IM_IF); + scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); + scm_sysintern ("SCM_IM_LET", SCM_IM_LET); + scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); + scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC); + scm_sysintern ("SCM_IM_OR", SCM_IM_OR); + scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE); + scm_sysintern ("SCM_IM_SET_X", SCM_IM_SET_X); + scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE); + scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY); + scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT); + scm_sysintern ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); +#endif scm_add_feature ("debug-extensions"); #include "debug.x"