Fix test environment issue with ltdl from Libtool 2.2.6b.

[bpt/guile.git] / libguile / stacks.c

/* A stack holds a frame chain
 * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
 *
 * 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 3 of
 * the License, or (at your option) any later version.
 *
 * 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
 * Lesser General Public License for more details.
 *
 * 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/debug.h"
#include "libguile/continuations.h"
#include "libguile/struct.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/modules.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vm.h" /* to capture vm stacks */
#include "libguile/frames.h" /* vm frames */

#include "libguile/validate.h"
#include "libguile/stacks.h"
#include "libguile/private-options.h"


\f
/* {Stacks}
 *
 * The stack is represented as a struct that holds a frame. The frame itself is
 * linked to the next frame, or #f.
 *
 * Stacks
 *   Constructor
 *     make-stack
 *   Selectors
 *     stack-id
 *     stack-ref
 *   Inspector
 *     stack-length
 */

\f

static SCM stack_id_with_fp (SCM frame, SCM **fp);

/* Count number of debug info frames on a stack, beginning with FRAME.
 */
static long
stack_depth (SCM frame, SCM *fp)
{
  long n;
  /* count frames, skipping boot frames */
  for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
       frame = scm_c_frame_prev (frame))
    if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
      ++n;
  return n;
}

/* Narrow STACK by cutting away stackframes (mutatingly).
 *
 * Inner frames (most recent) are cut by advancing the frames pointer.
 * Outer frames are cut by decreasing the recorded length.
 *
 * Cut maximally INNER inner frames and OUTER outer frames using
 * the keys INNER_KEY and OUTER_KEY.
 *
 * Frames are cut away starting at the end points and moving towards
 * the center of the stack.  The key is normally compared to the
 * operator in application frames.  Frames up to and including the key
 * are cut.
 *
 * If INNER_KEY is #t a different scheme is used for inner frames:
 *
 * Frames up to but excluding the first source frame originating from
 * a user module are cut, except for possible application frames
 * between the user frame and the last system frame previously
 * encountered.
 */

static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
  unsigned long int len;
  SCM frame;
  
  len = SCM_STACK_LENGTH (stack);
  frame = SCM_STACK_FRAME (stack);

  /* Cut inner part. */
  if (scm_is_eq (inner_key, SCM_BOOL_T))
    {
      /* Cut specified number of frames. */
      for (; inner && len; --inner)
        {
          len--;
          frame = scm_c_frame_prev (frame);
        }
    }
  else
    {
      /* Cut until the given procedure is seen. */
      for (; inner && len ; --inner)
        {
          SCM proc = scm_frame_procedure (frame);
          len--;
          frame = scm_c_frame_prev (frame);
          if (scm_is_eq (proc, inner_key))
            break;
        }
    }

  SCM_SET_STACK_LENGTH (stack, len);
  SCM_SET_STACK_FRAME (stack, frame);

  /* Cut outer part. */
  for (; outer && len ; --outer)
    {
      frame = scm_stack_ref (stack, scm_from_long (len - 1));
      len--;
      if (scm_is_eq (scm_frame_procedure (frame), outer_key))
        break;
    }

  SCM_SET_STACK_LENGTH (stack, len);
}

\f

/* Stacks
 */

SCM scm_stack_type;

SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, 
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a calling stack.")
#define FUNC_NAME s_scm_stack_p
{
  return scm_from_bool(SCM_STACKP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, 
            (SCM obj, SCM args),
	    "Create a new stack. If @var{obj} is @code{#t}, the current\n"
	    "evaluation stack is used for creating the stack frames,\n"
	    "otherwise the frames are taken from @var{obj} (which must be\n"
	    "either a debug object or a continuation).\n\n"
	    "@var{args} should be a list containing any combination of\n"
	    "integer, procedure and @code{#t} values.\n\n"
	    "These values specify various ways of cutting away uninteresting\n"
	    "stack frames from the top and bottom of the stack that\n"
	    "@code{make-stack} returns.  They come in pairs like this:\n"
	    "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
	    "@var{outer_cut_2} @dots{})}.\n\n"
	    "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
	    "procedure.  @code{#t} means to cut away all frames up to but\n"
	    "excluding the first user module frame.  An integer means to cut\n"
	    "away exactly that number of frames.  A procedure means to cut\n"
	    "away all frames up to but excluding the application frame whose\n"
	    "procedure matches the specified one.\n\n"
	    "Each @var{outer_cut_N} can be an integer or a procedure.  An\n"
	    "integer means to cut away that number of frames.  A procedure\n"
	    "means to cut away frames down to but excluding the application\n"
	    "frame whose procedure matches the specified one.\n\n"
	    "If the @var{outer_cut_N} of the last pair is missing, it is\n"
	    "taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
  long n;
  int maxp;
  SCM frame;
  SCM stack;
  SCM id, *id_fp;
  SCM inner_cut, outer_cut;

  /* Extract a pointer to the innermost frame of whatever object
     scm_make_stack was given.  */
  if (scm_is_eq (obj, SCM_BOOL_T))
    {
      SCM cont;
      struct scm_vm_cont *c;

      cont = scm_cdar (scm_vm_capture_continuations ());
      c = SCM_VM_CONT_DATA (cont);

      frame = scm_c_make_frame (cont, c->fp + c->reloc,
                                c->sp + c->reloc, c->ip,
                                c->reloc);
    }
  else if (SCM_VM_FRAME_P (obj))
    frame = obj;
  else if (SCM_CONTINUATIONP (obj))
    {
      scm_t_contregs *cont = SCM_CONTREGS (obj);
      if (!scm_is_null (cont->vm_conts))
        { SCM vm_cont;
          struct scm_vm_cont *data;
          vm_cont = scm_cdr (scm_car (cont->vm_conts));
          data = SCM_VM_CONT_DATA (vm_cont);
          frame = scm_c_make_frame (vm_cont,
                                    data->fp + data->reloc,
                                    data->sp + data->reloc,
                                    data->ip,
                                    data->reloc);
        } else 
        frame = SCM_BOOL_F;
    }
  else
    {
      SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
      /* not reached */
    }

  if (scm_is_false (frame))
    return SCM_BOOL_F;

  /* Get ID of the stack corresponding to the given frame. */
  id = stack_id_with_fp (frame, &id_fp);

  /* Count number of frames.  Also get stack id tag and check whether
     there are more stackframes than we want to record
     (SCM_BACKTRACE_MAXDEPTH). */
  id = SCM_BOOL_F;
  maxp = 0;
  n = stack_depth (frame, id_fp);

  /* Make the stack object. */
  stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
  SCM_SET_STACK_LENGTH (stack, n);
  SCM_SET_STACK_ID (stack, id);
  SCM_SET_STACK_FRAME (stack, frame);
  
  /* Narrow the stack according to the arguments given to scm_make_stack. */
  SCM_VALIDATE_REST_ARGUMENT (args);
  while (n > 0 && !scm_is_null (args))
    {
      inner_cut = SCM_CAR (args);
      args = SCM_CDR (args);
      if (scm_is_null (args)) 
	{
	  outer_cut = SCM_INUM0;
	} 
      else
	{
	  outer_cut = SCM_CAR (args);
	  args = SCM_CDR (args);
	}
      
      narrow_stack (stack,
		    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_LENGTH (stack);
    }
  
  if (n > 0)
    return stack;
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, 
            (SCM stack),
	    "Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id
{
  SCM frame, *id_fp;
  
  if (scm_is_eq (stack, SCM_BOOL_T))
    {
      struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
      frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
    }
  else if (SCM_VM_FRAME_P (stack))
    frame = stack;
  else if (SCM_CONTINUATIONP (stack))
    {
      scm_t_contregs *cont = SCM_CONTREGS (stack);
      if (!scm_is_null (cont->vm_conts))
        { SCM vm_cont;
          struct scm_vm_cont *data;
          vm_cont = scm_cdr (scm_car (cont->vm_conts));
          data = SCM_VM_CONT_DATA (vm_cont);
          frame = scm_c_make_frame (vm_cont,
                                    data->fp + data->reloc,
                                    data->sp + data->reloc,
                                    data->ip,
                                    data->reloc);
        } else 
        frame = SCM_BOOL_F;
    }
  else
    {
      SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
      /* not reached */
    }

  return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME

static SCM
stack_id_with_fp (SCM frame, SCM **fp)
{
  SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);

  if (SCM_VM_CONT_P (holder))
    {
      *fp = NULL;
      return SCM_BOOL_F;
    }
  else
    {
      *fp = NULL;
      return SCM_BOOL_F;
    }
}

SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
            (SCM stack, SCM index),
	    "Return the @var{index}'th frame from @var{stack}.")
#define FUNC_NAME s_scm_stack_ref
{
  unsigned long int c_index;
  SCM frame;

  SCM_VALIDATE_STACK (1, stack);
  c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
  frame = SCM_STACK_FRAME (stack);
  while (c_index--)
    {
      frame = scm_c_frame_prev (frame);
      while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
        frame = scm_c_frame_prev (frame);
    }
  return frame;
}
#undef FUNC_NAME

SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, 
	    (SCM stack),
	    "Return the length of @var{stack}.")
#define FUNC_NAME s_scm_stack_length
{
  SCM_VALIDATE_STACK (1, stack);
  return scm_from_long (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME

\f

void
scm_init_stacks ()
{
  scm_stack_type = 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"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/