* stacks.c: Improve selection of relevant stack frames when making

a stack object.  Introduce one level of indirection in the stack
object to make it possible to "narrow" to a certain region of the
stack.  This facilitates making use of more clever algorithms (not
implemented) for selecting relevant frames and gives a cleaner
design since selection of frames can be done independently of
extraction of frames from the real stack.
(scm_stack_id): Also take #t as argument which means look at
current stack.

libguile/stacks.c

@@ -81,9 +81,8 @@
  *
  * Representation:
  *
- * The stack is represented as an ordinary scheme vector.  It is
+ * The stack is represented as a struct with an id slot and a tail
- * logically divided into sections of SCM values.  Each section is an
+ * array of scm_info_frame structs.
- * scm_info_frame struct.
  *
  * A frame is represented as a pair where the car contains a stack and
  * the cdr an inum.  The inum is an index to the first SCM value of
@@ -92,7 +91,8 @@
  * Stacks
  *   Constructor
  *     make-stack
- *   Selector
+ *   Selectors
+ *     stack-id
  *     stack-ref
  *   Inspector
  *     stack-length
@@ -111,8 +111,7 @@
  *     frame-real?
  *     frame-procedure?
  *     frame-evaluating-args?
- *     frame-overflow?
+ *     frame-overflow?  */
- */
 
 
 
@@ -206,12 +205,20 @@ read_frame (dframe, offset, iframe)
  * starting with the first stack frame represented by debug frame
  * DFRAME.
  */
-static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int skip, int n, scm_info_frame *iframes));
+
+#define NEXT_FRAME(iframe, n, quit) \
+{ \
+  ++iframe; \
+  if (--n == 0) \
+    goto quit; \
+} \
+
+
+static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
 static void
-read_frames (dframe, offset, skip, n, iframes)
+read_frames (dframe, offset, n, iframes)
      scm_debug_frame *dframe;
      long offset;
-     int skip;
      int n;
      scm_info_frame *iframes;
 {
@@ -236,14 +243,7 @@ read_frames (dframe, offset, skip, n, iframes)
 	  else if (SCM_OVERFLOWP (*dframe)
 		   && !SCM_UNBNDP (info[1].a.proc))
 	    {
-	      if (skip)
+	      NEXT_FRAME (iframe, n, quit);
-		--skip;
-	      else
-		{
-		  ++iframe;
-		  if (--n == 0)
-		    goto quit;
-		}
 	      iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
 	      iframe->proc = info[1].a.proc;
 	      iframe->args = info[1].a.args;
@@ -251,14 +251,7 @@ read_frames (dframe, offset, skip, n, iframes)
 	  if (SCM_OVERFLOWP (*dframe))
 	    iframe->flags |= SCM_FRAMEF_OVERFLOW;
 	  info -= 2;
-	  if (skip)
+	  NEXT_FRAME (iframe, n, quit);
-	    --skip;
-	  else
-	    {
-	      ++iframe;
-	      if (--n == 0)
-		goto quit;
-	    }
 	  while (info >= dframe->vect)
 	    {
 	      if (!SCM_UNBNDP (info[1].a.proc))
@@ -272,25 +265,12 @@ read_frames (dframe, offset, skip, n, iframes)
 	      iframe->source = scm_make_memoized (info[0].e.exp,
 						  info[0].e.env);
 	      info -= 2;
-	      if (skip)
+	      NEXT_FRAME (iframe, n, quit);
-		--skip;
-	      else
-		{
-		  ++iframe;
-		  if (--n == 0)
-		    goto quit;
-		}
 	    }
 	}
       else
 	{
-	  if (skip)
+	  NEXT_FRAME (iframe, n, quit);
-	    --skip;
-	  else
-	    {
-	      ++iframe;
-	      --n;
-	    }
 	}
     quit:
       if (iframe > iframes)
@@ -298,6 +278,35 @@ read_frames (dframe, offset, skip, n, iframes)
     }
 }
 
+static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));
+
+static void
+narrow_stack (stack, inner, inner_key, outer, outer_key)
+     SCM stack;
+     int inner;
+     SCM inner_key;
+     int outer;
+     SCM outer_key;
+{
+  scm_stack *s = SCM_STACK (stack);
+  int i;
+  int n = s->length;
+  
+  /* Cut inner part. */
+  for (i = 0; inner; --inner)
+    if (s->frames[i++].proc == inner_key)
+      break;
+  s->frames = &s->frames[i];
+  n -= i;
+
+  /* Cut outer part. */
+  for (; n && outer; --outer)
+    if (s->frames[--n].proc == outer_key)
+      break;
+
+  s->length = n;
+}
+
 
 
 /* Stacks
@@ -315,12 +324,12 @@ scm_stack_p (obj)
 
 SCM_PROC (s_make_stack, "make-stack", 0, 3, 0, scm_make_stack);
 SCM
-scm_make_stack (obj, outer_cut, inner_cut)
+scm_make_stack (obj, inner_cut, outer_cut)
      SCM obj;
-     SCM outer_cut;
      SCM inner_cut;
+     SCM outer_cut;
 {
-  int i, n, maxp, size;
+  int n, maxp, size;
   scm_debug_frame *dframe;
   scm_info_frame *iframe;
   long offset = 0;
@@ -330,11 +339,8 @@ scm_make_stack (obj, outer_cut, inner_cut)
     inner_cut = SCM_INUM0;
   if (SCM_UNBNDP (outer_cut))
     outer_cut = SCM_INUM0;
-  SCM_ASSERT (SCM_INUMP (inner_cut), inner_cut, SCM_ARG2, s_make_stack);
-  SCM_ASSERT (SCM_INUMP (outer_cut), outer_cut, SCM_ARG3, s_make_stack);
   
-  if (SCM_IMP (obj)
+  if (obj == SCM_BOOL_T)
-      || (!SCM_DEBUGOBJP (obj) && (scm_tc7_contin != SCM_TYP7 (obj))))
     dframe = scm_last_debug_frame;
   else
     {
@@ -354,27 +360,34 @@ scm_make_stack (obj, outer_cut, inner_cut)
       else scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
     }
 
-  i = SCM_INUM (inner_cut);
   id = SCM_BOOL_F;
   maxp = 0;
-  n = stack_depth (dframe, offset, &id, &maxp) - i - SCM_INUM (outer_cut);
+  n = stack_depth (dframe, offset, &id, &maxp);
-  if (n < 0)
-    n = 0;
   size = n * SCM_FRAME_N_SLOTS;
 
   stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
   SCM_STACK (stack) -> id = id;
-  iframe = (scm_info_frame *) &SCM_STACK (stack) -> frames[0];
+  SCM_STACK (stack) -> length = n;
-  read_frames ((scm_debug_frame *) ((SCM_STACKITEM *) dframe + offset),
+  iframe = &SCM_STACK (stack) -> tail[0];
-	       offset,
+  SCM_STACK (stack) -> frames = iframe;
-	       i,
-	       n,
-	       iframe);
-
-  if (n > 0 && maxp)
-    iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
   
-  return stack;
+  read_frames ((scm_debug_frame *) ((SCM_STACKITEM *) dframe + offset), offset, n, iframe);
+
+  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);
+
+  n = SCM_STACK (stack) -> length;
+  if (n > 0)
+  {
+    if (maxp)
+      iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+    return stack;
+  }
+  else
+    return SCM_BOOL_F;
 }
 
 SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
@@ -382,12 +395,34 @@ SCM
 scm_stack_id (stack)
      SCM stack;
 {
-  SCM_ASSERT (SCM_NIMP (stack)
+  scm_debug_frame *dframe;
-	      && SCM_STACKP (stack),
+  long offset = 0;
-	      stack,
+  if (stack == SCM_BOOL_T)
-	      SCM_ARG1,
+    dframe = scm_last_debug_frame;
-	      s_stack_id);
+  else
-  return SCM_STACK (stack) -> id;
+    {
+      SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
+      if (SCM_DEBUGOBJP (stack))
+	dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
+      else if (scm_tc7_contin == SCM_TYP7 (stack))
+	{
+	  offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs))
+		    - SCM_BASE (stack));
+#ifndef STACK_GROWS_UP
+	  offset += SCM_LENGTH (stack);
+#endif
+	  dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (stack)
+				       + offset);
+	}
+      else if (SCM_STACKP (stack))
+	return SCM_STACK (stack) -> id;
+      else scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
+    }
+  while (dframe && !SCM_VOIDFRAMEP (*dframe))
+    dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset);
+  if (dframe && SCM_VOIDFRAMEP (*dframe))
+    return dframe->vect[0].id;
+  return SCM_BOOL_F;
 }
 
 SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
@@ -441,7 +476,7 @@ scm_last_stack_frame (obj)
 {
   scm_debug_frame *dframe;
   long offset = 0;
-  SCM v;
+  SCM stack;
   
   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
   if (SCM_DEBUGOBJP (obj))
@@ -460,10 +495,12 @@ scm_last_stack_frame (obj)
   if (!dframe || SCM_VOIDFRAMEP (*dframe))
     return SCM_BOOL_F;
 
-  v = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), SCM_EOL);
+  stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), SCM_EOL);
-  read_frame (dframe, offset, (scm_info_frame *) &SCM_STACK (v) -> frames[0]);
+  SCM_STACK (stack) -> length = 1;
+  SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
+  read_frame (dframe, offset, (scm_info_frame *) &SCM_STACK (stack) -> frames[0]);
   
-  return scm_cons (v, SCM_INUM0);;
+  return scm_cons (stack, SCM_INUM0);;
 }
 
 SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);