/* Representation of stack frame debug information
- * Copyright (C) 1996,1997,2000,2001 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 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
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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, 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.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * 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 */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/validate.h"
#include "libguile/stacks.h"
+#include "libguile/private-options.h"
+
\f
/* {Frames and stacks}
* is read from a continuation.
*/
static scm_t_bits
-stack_depth (scm_t_debug_frame *dframe,long offset,SCM *id,int *maxp)
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ SCM *id, int *maxp)
{
long n;
long max_depth = SCM_BACKTRACE_MAXDEPTH;
{
if (SCM_EVALFRAMEP (*dframe))
{
- scm_t_debug_info * info = RELOC_INFO (dframe->info, offset);
- n += (info - dframe->vect) / 2 + 1;
+ scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ n += (info - vect) / 2 + 1;
/* Data in the apply part of an eval info frame comes from previous
stack frame if the scm_t_debug_info vector is overflowed. */
- if ((((info - dframe->vect) & 1) == 0)
+ if ((((info - vect) & 1) == 0)
&& SCM_OVERFLOWP (*dframe)
&& !SCM_UNBNDP (info[1].a.proc))
++n;
++n;
}
if (dframe && SCM_VOIDFRAMEP (*dframe))
- *id = dframe->vect[0].id;
+ *id = RELOC_INFO(dframe->vect, offset)[0].id;
else if (dframe)
*maxp = 1;
return n;
/* Read debug info from DFRAME into IFRAME.
*/
static void
-read_frame (scm_t_debug_frame *dframe,long offset,scm_t_info_frame *iframe)
+read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ scm_t_info_frame *iframe)
{
scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
if (SCM_EVALFRAMEP (*dframe))
{
- scm_t_debug_info * info = RELOC_INFO (dframe->info, offset);
- if ((info - dframe->vect) & 1)
+ scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ if ((info - vect) & 1)
{
/* Debug.vect ends with apply info. */
--info;
}
else
{
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
flags |= SCM_FRAMEF_PROC;
- iframe->proc = dframe->vect[0].a.proc;
- iframe->args = dframe->vect[0].a.args;
+ iframe->proc = vect[0].a.proc;
+ iframe->args = vect[0].a.args;
}
iframe->flags = flags;
}
#define NEXT_FRAME(iframe, n, quit) \
do { \
if (SCM_MEMOIZEDP (iframe->source) \
- && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
+ && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
{ \
iframe->source = SCM_BOOL_F; \
- if (SCM_FALSEP (iframe->proc)) \
+ if (scm_is_false (iframe->proc)) \
{ \
--iframe; \
++n; \
*/
static scm_t_bits
-read_frames (scm_t_debug_frame *dframe,long offset,long n,scm_t_info_frame *iframes)
+read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ long n, scm_t_info_frame *iframes)
{
scm_t_info_frame *iframe = iframes;
- scm_t_debug_info *info;
+ scm_t_debug_info *info, *vect;
static SCM applybody = SCM_UNDEFINED;
/* The value of applybody has to be setup after r4rs.scm has executed. */
--iframe;
}
info = RELOC_INFO (dframe->info, offset);
- if ((info - dframe->vect) & 1)
+ vect = RELOC_INFO (dframe->vect, offset);
+ if ((info - vect) & 1)
--info;
/* Data in the apply part of an eval info frame comes from
previous stack frame if the scm_t_debug_info vector is
iframe->flags |= SCM_FRAMEF_OVERFLOW;
info -= 2;
NEXT_FRAME (iframe, n, quit);
- while (info >= dframe->vect)
+ while (info >= vect)
{
if (!SCM_UNBNDP (info[1].a.proc))
{
NEXT_FRAME (iframe, n, quit);
}
}
- else if (SCM_EQ_P (iframe->proc, scm_f_gsubr_apply))
+ else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
/* Skip gsubr apply frames. */
continue;
else
*/
static void
-narrow_stack (SCM stack,long inner,SCM inner_key,long outer,SCM outer_key)
+narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
scm_t_stack *s = SCM_STACK (stack);
unsigned long int i;
long n = s->length;
/* Cut inner part. */
- if (SCM_EQ_P (inner_key, SCM_BOOL_T))
+ if (scm_is_eq (inner_key, SCM_BOOL_T))
{
/* Cut all frames up to user module code */
for (i = 0; inner; ++i, --inner)
SCM m = s->frames[i].source;
if (SCM_MEMOIZEDP (m)
&& !SCM_IMP (SCM_MEMOIZED_ENV (m))
- && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
+ && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
{
/* Back up in order to include any non-source frames */
while (i > 0)
break;
m = s->frames[i - 1].proc;
- if (!SCM_FALSEP (scm_procedure_p (m))
- && !SCM_FALSEP (scm_procedure_property
+ if (scm_is_true (scm_procedure_p (m))
+ && scm_is_true (scm_procedure_property
(m, scm_sym_system_procedure)))
break;
/* Use standard cutting procedure. */
{
for (i = 0; inner; --inner)
- if (SCM_EQ_P (s->frames[i++].proc, inner_key))
+ if (scm_is_eq (s->frames[i++].proc, inner_key))
break;
}
s->frames = &s->frames[i];
/* Cut outer part. */
for (; n && outer; --outer)
- if (SCM_EQ_P (s->frames[--n].proc, outer_key))
+ if (scm_is_eq (s->frames[--n].proc, outer_key))
break;
s->length = n;
"Return @code{#t} if @var{obj} is a calling stack.")
#define FUNC_NAME s_scm_stack_p
{
- return SCM_BOOL(SCM_STACKP (obj));
+ return scm_from_bool(SCM_STACKP (obj));
}
#undef FUNC_NAME
/* Extract a pointer to the innermost frame of whatever object
scm_make_stack was given. */
- if (SCM_EQ_P (obj, SCM_BOOL_T))
+ if (scm_is_eq (obj, SCM_BOOL_T))
{
- dframe = scm_last_debug_frame;
+ dframe = scm_i_last_debug_frame ();
}
else if (SCM_DEBUGOBJP (obj))
{
}
else if (SCM_CONTINUATIONP (obj))
{
- offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs))
- - SCM_BASE (obj));
-#ifndef STACK_GROWS_UP
- offset += SCM_CONTINUATION_LENGTH (obj);
-#endif
- dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ scm_t_contregs *cont = SCM_CONTREGS (obj);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
}
else
{
size = n * SCM_FRAME_N_SLOTS;
/* Make the stack object. */
- stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
+ stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
SCM_STACK (stack) -> id = id;
iframe = &SCM_STACK (stack) -> tail[0];
SCM_STACK (stack) -> frames = iframe;
/* Translate the current chain of stack frames into debugging information. */
- n = read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe);
+ n = read_frames (dframe, offset, n, iframe);
SCM_STACK (stack) -> length = n;
/* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (args);
- while (n > 0 && !SCM_NULLP (args))
+ while (n > 0 && !scm_is_null (args))
{
inner_cut = SCM_CAR (args);
args = SCM_CDR (args);
- if (SCM_NULLP (args))
+ if (scm_is_null (args))
{
outer_cut = SCM_INUM0;
}
}
narrow_stack (stack,
- SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n,
- SCM_INUMP (inner_cut) ? 0 : inner_cut,
- SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n,
- SCM_INUMP (outer_cut) ? 0 : outer_cut);
+ scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
+ scm_is_integer (inner_cut) ? 0 : inner_cut,
+ scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
+ scm_is_integer (outer_cut) ? 0 : outer_cut);
n = SCM_STACK (stack) -> length;
}
{
scm_t_debug_frame *dframe;
long offset = 0;
- if (SCM_EQ_P (stack, SCM_BOOL_T))
+ if (scm_is_eq (stack, SCM_BOOL_T))
{
- dframe = scm_last_debug_frame;
+ dframe = scm_i_last_debug_frame ();
}
else if (SCM_DEBUGOBJP (stack))
{
}
else if (SCM_CONTINUATIONP (stack))
{
- offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_t_contregs))
- - SCM_BASE (stack));
-#ifndef STACK_GROWS_UP
- offset += SCM_CONTINUATION_LENGTH (stack);
-#endif
- dframe = RELOC_FRAME (SCM_DFRAME (stack), offset);
+ scm_t_contregs *cont = SCM_CONTREGS (stack);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
}
else if (SCM_STACKP (stack))
{
while (dframe && !SCM_VOIDFRAMEP (*dframe))
dframe = RELOC_FRAME (dframe->prev, offset);
if (dframe && SCM_VOIDFRAMEP (*dframe))
- return dframe->vect[0].id;
+ return RELOC_INFO (dframe->vect, offset)[0].id;
return SCM_BOOL_F;
}
#undef FUNC_NAME
unsigned long int c_index;
SCM_VALIDATE_STACK (1, stack);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (1, index, SCM_INUM (index) >= 0);
- c_index = SCM_INUM (index);
- SCM_ASSERT_RANGE (1, index, c_index < SCM_STACK_LENGTH (stack));
+ c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
return scm_cons (stack, index);
}
#undef FUNC_NAME
"Return the length of @var{stack}.")
#define FUNC_NAME s_scm_stack_length
{
- SCM_VALIDATE_STACK (1,stack);
- return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
+ SCM_VALIDATE_STACK (1, stack);
+ return scm_from_int (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME
"Return @code{#t} if @var{obj} is a stack frame.")
#define FUNC_NAME s_scm_frame_p
{
- return SCM_BOOL(SCM_FRAMEP (obj));
+ return scm_from_bool(SCM_FRAMEP (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
(SCM obj),
- "Return a stack which consists of a single frame, which is the\n"
- "last stack frame for @var{obj}. @var{obj} must be either a\n"
- "debug object or a continuation.")
+ "Return the last (innermost) frame of @var{obj}, which must be\n"
+ "either a debug object or a continuation.")
#define FUNC_NAME s_scm_last_stack_frame
{
scm_t_debug_frame *dframe;
}
else if (SCM_CONTINUATIONP (obj))
{
- offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs))
- - SCM_BASE (obj));
-#ifndef STACK_GROWS_UP
- offset += SCM_CONTINUATION_LENGTH (obj);
-#endif
- dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ scm_t_contregs *cont = SCM_CONTREGS (obj);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
}
else
{
if (!dframe || SCM_VOIDFRAMEP (*dframe))
return SCM_BOOL_F;
- stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS),
+ stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
SCM_EOL);
SCM_STACK (stack) -> length = 1;
SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
"Return the frame number of @var{frame}.")
#define FUNC_NAME s_scm_frame_number
{
- SCM_VALIDATE_FRAME (1,frame);
- return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_int (SCM_FRAME_NUMBER (frame));
}
#undef FUNC_NAME
"Return the source of @var{frame}.")
#define FUNC_NAME s_scm_frame_source
{
- SCM_VALIDATE_FRAME (1,frame);
+ SCM_VALIDATE_FRAME (1, frame);
return SCM_FRAME_SOURCE (frame);
}
#undef FUNC_NAME
"procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure
{
- SCM_VALIDATE_FRAME (1,frame);
+ SCM_VALIDATE_FRAME (1, frame);
return (SCM_FRAME_PROC_P (frame)
? SCM_FRAME_PROC (frame)
: SCM_BOOL_F);
"Return the arguments of @var{frame}.")
#define FUNC_NAME s_scm_frame_arguments
{
- SCM_VALIDATE_FRAME (1,frame);
+ SCM_VALIDATE_FRAME (1, frame);
return SCM_FRAME_ARGS (frame);
}
#undef FUNC_NAME
{
unsigned long int n;
SCM_VALIDATE_FRAME (1, frame);
- n = SCM_INUM (SCM_CDR (frame)) + 1;
+ n = scm_to_ulong (SCM_CDR (frame)) + 1;
if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
return SCM_BOOL_F;
else
- return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
+ return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
}
#undef FUNC_NAME
{
unsigned long int n;
SCM_VALIDATE_FRAME (1, frame);
- n = SCM_INUM (SCM_CDR (frame));
+ n = scm_to_ulong (SCM_CDR (frame));
if (n == 0)
return SCM_BOOL_F;
else
- return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n - 1));
+ return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
}
#undef FUNC_NAME
"Return @code{#t} if @var{frame} is a real frame.")
#define FUNC_NAME s_scm_frame_real_p
{
- SCM_VALIDATE_FRAME (1,frame);
- return SCM_BOOL(SCM_FRAME_REAL_P (frame));
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_REAL_P (frame));
}
#undef FUNC_NAME
"Return @code{#t} if a procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure_p
{
- SCM_VALIDATE_FRAME (1,frame);
- return SCM_BOOL(SCM_FRAME_PROC_P (frame));
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_PROC_P (frame));
}
#undef FUNC_NAME
"Return @code{#t} if @var{frame} contains evaluated arguments.")
#define FUNC_NAME s_scm_frame_evaluating_args_p
{
- SCM_VALIDATE_FRAME (1,frame);
- return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame));
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
}
#undef FUNC_NAME
"Return @code{#t} if @var{frame} is an overflow frame.")
#define FUNC_NAME s_scm_frame_overflow_p
{
- SCM_VALIDATE_FRAME (1,frame);
- return SCM_BOOL(SCM_FRAME_OVERFLOW_P (frame));
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
}
#undef FUNC_NAME
void
scm_init_stacks ()
{
- SCM vtable;
- SCM stack_layout
- = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT));
- vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
- scm_stack_type
- = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0,
- scm_cons (stack_layout,
- SCM_EOL)));
- scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack"));
-#ifndef SCM_MAGIC_SNARFER
+ scm_stack_type =
+ scm_permanent_object
+ (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
+ SCM_UNDEFINED));
+ scm_set_struct_vtable_name_x (scm_stack_type,
+ scm_from_locale_symbol ("stack"));
#include "libguile/stacks.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff