temporarily disable elisp exception tests

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

diff --git a/libguile/stacks.c b/libguile/stacks.c
index c3ea624..a09c3b9 100644 (file)
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,5 +1,5 @@
 /* A stack holds a frame chain
 /* A stack holds a frame chain

- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License


@@ -65,11 +65,12 @@ static SCM scm_sys_stacks;
 /* Count number of debug info frames on a stack, beginning with FRAME.
  */
 static long
 /* Count number of debug info frames on a stack, beginning with FRAME.
  */
 static long

-stack_depth (SCM frame)
+stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)

 {
 {

-  long n = 0;
-  /* count frames, skipping boot frames */
-  for (; scm_is_true (frame); frame = scm_frame_previous (frame))
+  struct scm_frame tmp;
+  long n = 1;
+  memcpy (&tmp, frame, sizeof tmp);
+  while (scm_c_frame_previous (kind, &tmp))

     ++n;
   return n;
 }
     ++n;
   return n;
 }


@@ -95,27 +96,38 @@ stack_depth (SCM frame)
  * encountered.
  */
 
  * encountered.
  */
 

-static SCM*
+static scm_t_ptrdiff

 find_prompt (SCM key)
 {
 find_prompt (SCM key)
 {

-  SCM *fp;
+  scm_t_ptrdiff fp_offset;

 
   if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
 
   if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,

-                                 NULL, &fp, NULL, NULL, NULL))
+                                 NULL, &fp_offset, NULL, NULL, NULL))

     scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
                     scm_list_1 (key));
 
     scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
                     scm_list_1 (key));
 

-  return fp;
+  return fp_offset;

 }
 
 }
 

-static void
-narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
+static long
+narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
+              SCM inner_cut, SCM outer_cut)

 {
 {

-  unsigned long int len;
-  SCM frame;
-  
-  len = SCM_STACK_LENGTH (stack);
-  frame = SCM_STACK_FRAME (stack);
+  /* Resolve procedure cuts to address ranges, if possible.  If the
+     debug information has been stripped, this might not be
+     possible.  */
+  if (scm_is_true (scm_program_p (inner_cut)))
+    {
+      SCM addr_range = scm_program_address_range (inner_cut);
+      if (scm_is_pair (addr_range))
+        inner_cut = addr_range;
+    }
+  if (scm_is_true (scm_program_p (outer_cut)))
+    {
+      SCM addr_range = scm_program_address_range (outer_cut);
+      if (scm_is_pair (addr_range))
+        outer_cut = addr_range;
+    }

 
   /* Cut inner part. */
   if (scm_is_true (scm_procedure_p (inner_cut)))
 
   /* Cut inner part. */
   if (scm_is_true (scm_procedure_p (inner_cut)))


@@ -123,13 +135,32 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
       /* Cut until the given procedure is seen. */
       for (; len ;)
         {
       /* Cut until the given procedure is seen. */
       for (; len ;)
         {

-          SCM proc = scm_frame_procedure (frame);
+          SCM proc = scm_c_frame_closure (kind, frame);

           len--;
           len--;

-          frame = scm_frame_previous (frame);
+          scm_c_frame_previous (kind, frame);

           if (scm_is_eq (proc, inner_cut))
             break;
         }
     }
           if (scm_is_eq (proc, inner_cut))
             break;
         }
     }

+  else if (scm_is_pair (inner_cut)
+           && scm_is_integer (scm_car (inner_cut))
+           && scm_is_integer (scm_cdr (inner_cut)))
+    {
+      /* Cut until an IP within the given range is found.  */
+      scm_t_uintptr low_pc, high_pc, pc;
+
+      low_pc = scm_to_uintptr_t (scm_car (inner_cut));
+      high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
+
+      for (; len ;)
+        {
+          pc = (scm_t_uintptr) frame->ip;
+          len--;
+          scm_c_frame_previous (kind, frame);
+          if (low_pc <= pc && pc < high_pc)
+            break;
+        }
+    }

   else if (scm_is_integer (inner_cut))
     {
       /* Cut specified number of frames. */
   else if (scm_is_integer (inner_cut))
     {
       /* Cut specified number of frames. */


@@ -138,32 +169,56 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
       for (; inner && len; --inner)
         {
           len--;
       for (; inner && len; --inner)
         {
           len--;

-          frame = scm_frame_previous (frame);
+          scm_c_frame_previous (kind, frame);

         }
     }
   else
     {
       /* Cut until the given prompt tag is seen. */
         }
     }
   else
     {
       /* Cut until the given prompt tag is seen. */

-      SCM *fp = find_prompt (inner_cut);
-      for (; len; len--, frame = scm_frame_previous (frame))
-        if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+      scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
+      for (; len; len--, scm_c_frame_previous (kind, frame))
+        if (fp_offset == frame->fp_offset)

           break;
     }
 
           break;
     }
 

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

   /* Cut outer part. */
   if (scm_is_true (scm_procedure_p (outer_cut)))
     {
   /* Cut outer part. */
   if (scm_is_true (scm_procedure_p (outer_cut)))
     {

+      long i, new_len;
+      struct scm_frame tmp;
+
+      memcpy (&tmp, frame, sizeof tmp);
+

       /* Cut until the given procedure is seen. */
       /* Cut until the given procedure is seen. */

-      for (; len ;)
+      for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+        if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
+          new_len = i;
+
+      len = new_len;
+    }
+  else if (scm_is_pair (outer_cut)
+           && scm_is_integer (scm_car (outer_cut))
+           && scm_is_integer (scm_cdr (outer_cut)))
+    {
+      /* Cut until an IP within the given range is found.  */
+      scm_t_uintptr low_pc, high_pc, pc;
+      long i, new_len;
+      struct scm_frame tmp;
+
+      low_pc = scm_to_uintptr_t (scm_car (outer_cut));
+      high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
+
+      memcpy (&tmp, frame, sizeof tmp);
+
+      /* Cut until the given procedure is seen. */
+      for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))

         {
         {

-          frame = scm_stack_ref (stack, scm_from_long (len - 1));
-          len--;
-          if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
-            break;
+          pc = (scm_t_uintptr) tmp.ip;
+          if (low_pc <= pc && pc < high_pc)
+            new_len = i;

         }
         }

+
+      len = new_len;

     }
   else if (scm_is_integer (outer_cut))
     {
     }
   else if (scm_is_integer (outer_cut))
     {


@@ -178,17 +233,23 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
   else
     {
       /* Cut until the given prompt tag is seen. */
   else
     {
       /* Cut until the given prompt tag is seen. */

-      SCM *fp = find_prompt (outer_cut);
-      while (len)
-        {
-          frame = scm_stack_ref (stack, scm_from_long (len - 1));
-          len--;
-          if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
-            break;
-        }
+      long i;
+      struct scm_frame tmp;
+      scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
+
+      memcpy (&tmp, frame, sizeof tmp);
+
+      for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+        if (tmp.fp_offset == fp_offset)
+          break;
+
+      if (i < len)
+        len = i;
+      else
+        len = 0;

     }
 
     }
 

-  SCM_SET_STACK_LENGTH (stack, len);
+  return len;

 }
 
 \f
 }
 
 \f


@@ -215,7 +276,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
            "a continuation or a frame object).\n"
             "\n"
            "@var{args} should be a list containing any combination of\n"
            "a continuation or a frame object).\n"
             "\n"
            "@var{args} should be a list containing any combination of\n"

-           "integer, procedure, prompt tag and @code{#t} values.\n"
+           "integer, procedure, address range, prompt tag and @code{#t}\n"
+            "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"
             "\n"
            "These values specify various ways of cutting away uninteresting\n"
            "stack frames from the top and bottom of the stack that\n"


@@ -223,30 +285,34 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
            "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
            "@var{outer_cut_2} @dots{})}.\n"
             "\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_i} can be @code{#t}, an integer, a prompt\n"
-            "tag, or a procedure.  @code{#t} means to cut away all frames up\n"
-            "to but excluding the first user module frame.  An integer means\n"
-            "to cut away exactly that number of frames.  A prompt tag means\n"
-            "to cut away all frames that are inside a prompt with the given\n"
-            "tag. A procedure means to cut away all frames up to but\n"
-            "excluding the application frame whose procedure matches the\n"
-            "specified one.\n"
+           "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
+            "address range, or a prompt tag.  An integer means to cut away\n"
+            "exactly that number of frames.  A procedure means to cut\n"
+            "away all frames up to but excluding the frame whose procedure\n"
+            "matches the specified one.  An address range is a pair of\n"
+            "integers indicating the low and high addresses of a procedure's\n"
+            "code, and is the same as cutting away to a procedure (though\n"
+            "with less work).  Anything else is interpreted as a prompt tag\n"
+            "which cuts away all frames that are inside a prompt with the\n"
+            "given tag.\n"

             "\n"
             "\n"

-           "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
-            "procedure.  An integer means to cut away that number of frames.\n"
-            "A prompt tag means to cut away all frames that are outside a\n"
-            "prompt with the given tag. A procedure means to cut away\n"
-            "frames down to but excluding the application frame whose\n"
-            "procedure matches the specified one.\n"
+           "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
+            "address range, or a prompt tag.  An integer means to cut away\n"
+            "that number of frames.  A procedure means to cut away frames\n"
+            "down to but excluding the frame whose procedure matches the\n"
+            "specified one.  An address range is the same, but with the\n"
+            "procedure's code specified as an address range.  Anything else\n"
+            "is taken to be a prompt tag, which cuts away all frames that are\n"
+            "outside a prompt with the given tag.\n"

             "\n"
             "\n"

-           "If the @var{outer_cut_i} of the last pair is missing, it is\n"
-           "taken as 0.")
+            "If the @var{outer_cut_i} of the last pair is missing, it is\n"
+            "taken as 0.")

 #define FUNC_NAME s_scm_make_stack
 {
   long n;
 #define FUNC_NAME s_scm_make_stack
 {
   long n;

-  SCM frame;
-  SCM stack;

   SCM inner_cut, outer_cut;
   SCM inner_cut, outer_cut;

+  enum scm_vm_frame_kind kind;
+  struct scm_frame frame;

 
   /* Extract a pointer to the innermost frame of whatever object
      scm_make_stack was given.  */
 
   /* Extract a pointer to the innermost frame of whatever object
      scm_make_stack was given.  */


@@ -258,42 +324,50 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       cont = scm_i_capture_current_stack ();
       c = SCM_VM_CONT_DATA (cont);
 
       cont = scm_i_capture_current_stack ();
       c = SCM_VM_CONT_DATA (cont);
 

-      frame = scm_c_make_frame (cont, c->fp + c->reloc,
-                                c->sp + c->reloc, c->ra,
-                                c->reloc);
+      kind = SCM_VM_FRAME_KIND_CONT;
+      frame.stack_holder = c;
+      frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
+      frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
+      frame.ip = c->ra;

     }
   else if (SCM_VM_FRAME_P (obj))
     }
   else if (SCM_VM_FRAME_P (obj))

-    frame = obj;
+    {
+      kind = SCM_VM_FRAME_KIND (obj);
+      memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
+    }

   else if (SCM_CONTINUATIONP (obj))
     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
        that were in place when the continuation was captured. */
   else if (SCM_CONTINUATIONP (obj))
     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
        that were in place when the continuation was captured. */

-    frame = scm_i_continuation_to_frame (obj);
+    {
+      kind = SCM_VM_FRAME_KIND_CONT;
+      if (!scm_i_continuation_to_frame (obj, &frame))
+        return SCM_BOOL_F;
+    }
+  else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
+    {
+      kind = SCM_VM_FRAME_KIND_CONT;
+      if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
+                                   &frame))
+        return SCM_BOOL_F;
+    }

   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
       /* not reached */
     }
 
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
       /* not reached */
     }
 

-  /* FIXME: is this even possible? */
-  if (scm_is_true (frame)
-      && SCM_PROGRAM_P (scm_frame_procedure (frame))
-      && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
-    frame = scm_frame_previous (frame);
-  
-  if (scm_is_false (frame))
+  /* Skip initial boot frame, if any.  This is possible if the frame
+     originates from a captured continuation.  */
+  if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
+      && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
+      && !scm_c_frame_previous (kind, &frame))

     return SCM_BOOL_F;
 
   /* Count number of frames.  Also get stack id tag and check whether
      there are more stackframes than we want to record
      (SCM_BACKTRACE_MAXDEPTH). */
     return SCM_BOOL_F;
 
   /* Count number of frames.  Also get stack id tag and check whether
      there are more stackframes than we want to record
      (SCM_BACKTRACE_MAXDEPTH). */

-  n = stack_depth (frame);
+  n = stack_depth (kind, &frame);

 
 

-  /* 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, scm_stack_id (obj));
-  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))
   /* Narrow the stack according to the arguments given to scm_make_stack. */
   SCM_VALIDATE_REST_ARGUMENT (args);
   while (n > 0 && !scm_is_null (args))


@@ -310,15 +384,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
          args = SCM_CDR (args);
        }
       
          args = SCM_CDR (args);
        }
       

-      narrow_stack (stack,
-                    inner_cut,
-                    outer_cut);
-
-      n = SCM_STACK_LENGTH (stack);
+      n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);

     }
   
   if (n > 0)
     }
   
   if (n > 0)

-    return stack;
+    {
+      /* Make the stack object. */
+      SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+      SCM_SET_STACK_LENGTH (stack, n);
+      SCM_SET_STACK_ID (stack, scm_stack_id (obj));
+      SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
+      return stack;
+    }

   else
     return SCM_BOOL_F;
 }
   else
     return SCM_BOOL_F;
 }


@@ -341,6 +418,9 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
   else if (SCM_CONTINUATIONP (stack))
     /* FIXME: implement me */
     return SCM_BOOL_F;
   else if (SCM_CONTINUATIONP (stack))
     /* FIXME: implement me */
     return SCM_BOOL_F;

+  else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
+    /* FIXME: implement me */
+    return SCM_BOOL_F;

   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);