libguile/stacks.c

   1 /* A stack holds a frame chain
   2  * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/control.h"
  28 #include "libguile/eval.h"
  29 #include "libguile/debug.h"
  30 #include "libguile/continuations.h"
  31 #include "libguile/struct.h"
  32 #include "libguile/macros.h"
  33 #include "libguile/procprop.h"
  34 #include "libguile/modules.h"
  35 #include "libguile/root.h"
  36 #include "libguile/strings.h"
  37 #include "libguile/vm.h" /* to capture vm stacks */
  38 #include "libguile/frames.h" /* vm frames */
  39
  40 #include "libguile/validate.h"
  41 #include "libguile/stacks.h"
  42 #include "libguile/private-options.h"
  43
  44
  45 static SCM scm_sys_stacks;
  46
  47 \f
  48 /* {Stacks}
  49  *
  50  * The stack is represented as a struct that holds a frame. The frame itself is
  51  * linked to the next frame, or #f.
  52  *
  53  * Stacks
  54  *   Constructor
  55  *     make-stack
  56  *   Selectors
  57  *     stack-id
  58  *     stack-ref
  59  *   Inspector
  60  *     stack-length
  61  */
  62
  63 \f
  64
  65 /* Count number of debug info frames on a stack, beginning with FRAME.
  66  */
  67 static long
  68 stack_depth (SCM frame)
  69 {
  70   long n = 0;
  71   /* count frames, skipping boot frames */
  72   for (; scm_is_true (frame); frame = scm_frame_previous (frame))
  73     ++n;
  74   return n;
  75 }
  76
  77 /* Narrow STACK by cutting away stackframes (mutatingly).
  78  *
  79  * Inner frames (most recent) are cut by advancing the frames pointer.
  80  * Outer frames are cut by decreasing the recorded length.
  81  *
  82  * Cut maximally INNER inner frames and OUTER outer frames using
  83  * the keys INNER_KEY and OUTER_KEY.
  84  *
  85  * Frames are cut away starting at the end points and moving towards
  86  * the center of the stack.  The key is normally compared to the
  87  * operator in application frames.  Frames up to and including the key
  88  * are cut.
  89  *
  90  * If INNER_KEY is #t a different scheme is used for inner frames:
  91  *
  92  * Frames up to but excluding the first source frame originating from
  93  * a user module are cut, except for possible application frames
  94  * between the user frame and the last system frame previously
  95  * encountered.
  96  */
  97
  98 static SCM*
  99 find_prompt (SCM key)
 100 {
 101   SCM *fp;
 102
 103   if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
 104                                  NULL, &fp, NULL, NULL, NULL))
 105     scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
 106                     scm_list_1 (key));
 107
 108   return fp;
 109 }
 110
 111 static void
 112 narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
 113 {
 114   unsigned long int len;
 115   SCM frame;
 116
 117   len = SCM_STACK_LENGTH (stack);
 118   frame = SCM_STACK_FRAME (stack);
 119
 120   /* Cut inner part. */
 121   if (scm_is_true (scm_procedure_p (inner_cut)))
 122     {
 123       /* Cut until the given procedure is seen. */
 124       for (; len ;)
 125         {
 126           SCM proc = scm_frame_procedure (frame);
 127           len--;
 128           frame = scm_frame_previous (frame);
 129           if (scm_is_eq (proc, inner_cut))
 130             break;
 131         }
 132     }
 133   else if (scm_is_integer (inner_cut))
 134     {
 135       /* Cut specified number of frames. */
 136       long inner = scm_to_int (inner_cut);
 137
 138       for (; inner && len; --inner)
 139         {
 140           len--;
 141           frame = scm_frame_previous (frame);
 142         }
 143     }
 144   else
 145     {
 146       /* Cut until the given prompt tag is seen. */
 147       SCM *fp = find_prompt (inner_cut);
 148       for (; len; len--, frame = scm_frame_previous (frame))
 149         if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 150           break;
 151     }
 152
 153   SCM_SET_STACK_LENGTH (stack, len);
 154   SCM_SET_STACK_FRAME (stack, frame);
 155
 156   /* Cut outer part. */
 157   if (scm_is_true (scm_procedure_p (outer_cut)))
 158     {
 159       /* Cut until the given procedure is seen. */
 160       for (; len ;)
 161         {
 162           frame = scm_stack_ref (stack, scm_from_long (len - 1));
 163           len--;
 164           if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
 165             break;
 166         }
 167     }
 168   else if (scm_is_integer (outer_cut))
 169     {
 170       /* Cut specified number of frames. */
 171       long outer = scm_to_int (outer_cut);
 172
 173       if (outer < len)
 174         len -= outer;
 175       else
 176         len = 0;
 177     }
 178   else
 179     {
 180       /* Cut until the given prompt tag is seen. */
 181       SCM *fp = find_prompt (outer_cut);
 182       while (len)
 183         {
 184           frame = scm_stack_ref (stack, scm_from_long (len - 1));
 185           len--;
 186           if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 187             break;
 188         }
 189     }
 190
 191   SCM_SET_STACK_LENGTH (stack, len);
 192 }
 193
 194 \f
 195
 196 /* Stacks
 197  */
 198
 199 SCM scm_stack_type;
 200
 201 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 202             (SCM obj),
 203             "Return @code{#t} if @var{obj} is a calling stack.")
 204 #define FUNC_NAME s_scm_stack_p
 205 {
 206   return scm_from_bool(SCM_STACKP (obj));
 207 }
 208 #undef FUNC_NAME
 209
 210 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 211             (SCM obj, SCM args),
 212             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 213             "evaluation stack is used for creating the stack frames,\n"
 214             "otherwise the frames are taken from @var{obj} (which must be\n"
 215             "a continuation or a frame object).\n"
 216             "\n"
 217             "@var{args} should be a list containing any combination of\n"
 218             "integer, procedure, prompt tag and @code{#t} values.\n"
 219             "\n"
 220             "These values specify various ways of cutting away uninteresting\n"
 221             "stack frames from the top and bottom of the stack that\n"
 222             "@code{make-stack} returns.  They come in pairs like this:\n"
 223             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 224             "@var{outer_cut_2} @dots{})}.\n"
 225             "\n"
 226             "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n"
 227             "tag, or a procedure.  @code{#t} means to cut away all frames up\n"
 228             "to but excluding the first user module frame.  An integer means\n"
 229             "to cut away exactly that number of frames.  A prompt tag means\n"
 230             "to cut away all frames that are inside a prompt with the given\n"
 231             "tag. A procedure means to cut away all frames up to but\n"
 232             "excluding the application frame whose procedure matches the\n"
 233             "specified one.\n"
 234             "\n"
 235             "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
 236             "procedure.  An integer means to cut away that number of frames.\n"
 237             "A prompt tag means to cut away all frames that are outside a\n"
 238             "prompt with the given tag. A procedure means to cut away\n"
 239             "frames down to but excluding the application frame whose\n"
 240             "procedure matches the specified one.\n"
 241             "\n"
 242             "If the @var{outer_cut_i} of the last pair is missing, it is\n"
 243             "taken as 0.")
 244 #define FUNC_NAME s_scm_make_stack
 245 {
 246   long n;
 247   SCM frame;
 248   SCM stack;
 249   SCM inner_cut, outer_cut;
 250
 251   /* Extract a pointer to the innermost frame of whatever object
 252      scm_make_stack was given.  */
 253   if (scm_is_eq (obj, SCM_BOOL_T))
 254     {
 255       SCM cont;
 256       struct scm_vm_cont *c;
 257
 258       cont = scm_i_capture_current_stack ();
 259       c = SCM_VM_CONT_DATA (cont);
 260
 261       frame = scm_c_make_frame (cont, c->fp + c->reloc,
 262                                 c->sp + c->reloc, c->ra,
 263                                 c->reloc);
 264     }
 265   else if (SCM_VM_FRAME_P (obj))
 266     frame = obj;
 267   else if (SCM_CONTINUATIONP (obj))
 268     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
 269        that were in place when the continuation was captured. */
 270     frame = scm_i_continuation_to_frame (obj);
 271   else
 272     {
 273       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 274       /* not reached */
 275     }
 276
 277   /* FIXME: is this even possible? */
 278   if (scm_is_true (frame)
 279       && SCM_PROGRAM_P (scm_frame_procedure (frame))
 280       && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
 281     frame = scm_frame_previous (frame);
 282
 283   if (scm_is_false (frame))
 284     return SCM_BOOL_F;
 285
 286   /* Count number of frames.  Also get stack id tag and check whether
 287      there are more stackframes than we want to record
 288      (SCM_BACKTRACE_MAXDEPTH). */
 289   n = stack_depth (frame);
 290
 291   /* Make the stack object. */
 292   stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
 293   SCM_SET_STACK_LENGTH (stack, n);
 294   SCM_SET_STACK_ID (stack, scm_stack_id (obj));
 295   SCM_SET_STACK_FRAME (stack, frame);
 296
 297   /* Narrow the stack according to the arguments given to scm_make_stack. */
 298   SCM_VALIDATE_REST_ARGUMENT (args);
 299   while (n > 0 && !scm_is_null (args))
 300     {
 301       inner_cut = SCM_CAR (args);
 302       args = SCM_CDR (args);
 303       if (scm_is_null (args))
 304         {
 305           outer_cut = SCM_INUM0;
 306         }
 307       else
 308         {
 309           outer_cut = SCM_CAR (args);
 310           args = SCM_CDR (args);
 311         }
 312
 313       narrow_stack (stack,
 314                     inner_cut,
 315                     outer_cut);
 316
 317       n = SCM_STACK_LENGTH (stack);
 318     }
 319
 320   if (n > 0)
 321     return stack;
 322   else
 323     return SCM_BOOL_F;
 324 }
 325 #undef FUNC_NAME
 326
 327 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 328             (SCM stack),
 329             "Return the identifier given to @var{stack} by @code{start-stack}.")
 330 #define FUNC_NAME s_scm_stack_id
 331 {
 332   if (scm_is_eq (stack, SCM_BOOL_T)
 333       /* FIXME: frame case assumes frame still live on the stack, and no
 334          intervening start-stack. Hmm... */
 335       || SCM_VM_FRAME_P (stack))
 336     {
 337       /* Fetch most recent start-stack tag. */
 338       SCM stacks = scm_fluid_ref (scm_sys_stacks);
 339       return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
 340     }
 341   else if (SCM_CONTINUATIONP (stack))
 342     /* FIXME: implement me */
 343     return SCM_BOOL_F;
 344   else
 345     {
 346       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
 347       /* not reached */
 348     }
 349 }
 350 #undef FUNC_NAME
 351
 352 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 353             (SCM stack, SCM index),
 354             "Return the @var{index}'th frame from @var{stack}.")
 355 #define FUNC_NAME s_scm_stack_ref
 356 {
 357   unsigned long int c_index;
 358   SCM frame;
 359
 360   SCM_VALIDATE_STACK (1, stack);
 361   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 362   frame = SCM_STACK_FRAME (stack);
 363   while (c_index--)
 364     frame = scm_frame_previous (frame);
 365   return frame;
 366 }
 367 #undef FUNC_NAME
 368
 369 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 370             (SCM stack),
 371             "Return the length of @var{stack}.")
 372 #define FUNC_NAME s_scm_stack_length
 373 {
 374   SCM_VALIDATE_STACK (1, stack);
 375   return scm_from_long (SCM_STACK_LENGTH (stack));
 376 }
 377 #undef FUNC_NAME
 378
 379 \f
 380
 381 void
 382 scm_init_stacks ()
 383 {
 384   scm_sys_stacks = scm_make_fluid ();
 385   scm_c_define ("%stacks", scm_sys_stacks);
 386
 387   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 388                                     SCM_UNDEFINED);
 389   scm_set_struct_vtable_name_x (scm_stack_type,
 390                                 scm_from_latin1_symbol ("stack"));
 391 #include "libguile/stacks.x"
 392 }
 393
 394 /*
 395   Local Variables:
 396   c-file-style: "gnu"
 397   End:
 398 */