libguile/stacks.c

   1 /* A stack holds a frame chain
   2  * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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_t_prompt_registers *regs;
 102
 103   if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
 104                                  &regs, NULL))
 105     scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
 106                     scm_list_1 (key));
 107
 108   return regs->fp;
 109 }
 110
 111 static void
 112 narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
 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_key)))
 122     {
 123       /* Cut until the given procedure is seen. */
 124       for (; inner && len ; --inner)
 125         {
 126           SCM proc = scm_frame_procedure (frame);
 127           len--;
 128           frame = scm_frame_previous (frame);
 129           if (scm_is_eq (proc, inner_key))
 130             break;
 131         }
 132     }
 133   else if (scm_is_symbol (inner_key))
 134     {
 135       /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
 136          symbols. */
 137       SCM *fp = find_prompt (inner_key);
 138       for (; len; len--, frame = scm_frame_previous (frame))
 139         if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 140           break;
 141     }
 142   else
 143     {
 144       /* Cut specified number of frames. */
 145       for (; inner && len; --inner)
 146         {
 147           len--;
 148           frame = scm_frame_previous (frame);
 149         }
 150     }
 151
 152   SCM_SET_STACK_LENGTH (stack, len);
 153   SCM_SET_STACK_FRAME (stack, frame);
 154
 155   /* Cut outer part. */
 156   if (scm_is_true (scm_procedure_p (outer_key)))
 157     {
 158       /* Cut until the given procedure is seen. */
 159       for (; outer && len ; --outer)
 160         {
 161           frame = scm_stack_ref (stack, scm_from_long (len - 1));
 162           len--;
 163           if (scm_is_eq (scm_frame_procedure (frame), outer_key))
 164             break;
 165         }
 166     }
 167   else if (scm_is_symbol (outer_key))
 168     {
 169       /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
 170          symbols. */
 171       SCM *fp = find_prompt (outer_key);
 172       while (len)
 173         {
 174           frame = scm_stack_ref (stack, scm_from_long (len - 1));
 175           len--;
 176           if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 177             break;
 178         }
 179     }
 180   else
 181     {
 182       /* Cut specified number of frames. */
 183       if (outer < len)
 184         len -= outer;
 185       else
 186         len = 0;
 187     }
 188
 189   SCM_SET_STACK_LENGTH (stack, len);
 190 }
 191
 192 \f
 193
 194 /* Stacks
 195  */
 196
 197 SCM scm_stack_type;
 198
 199 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 200             (SCM obj),
 201             "Return @code{#t} if @var{obj} is a calling stack.")
 202 #define FUNC_NAME s_scm_stack_p
 203 {
 204   return scm_from_bool(SCM_STACKP (obj));
 205 }
 206 #undef FUNC_NAME
 207
 208 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 209             (SCM obj, SCM args),
 210             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 211             "evaluation stack is used for creating the stack frames,\n"
 212             "otherwise the frames are taken from @var{obj} (which must be\n"
 213             "a continuation or a frame object).\n"
 214             "\n"
 215             "@var{args} should be a list containing any combination of\n"
 216             "integer, procedure, prompt tag and @code{#t} values.\n"
 217             "\n"
 218             "These values specify various ways of cutting away uninteresting\n"
 219             "stack frames from the top and bottom of the stack that\n"
 220             "@code{make-stack} returns.  They come in pairs like this:\n"
 221             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 222             "@var{outer_cut_2} @dots{})}.\n"
 223             "\n"
 224             "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n"
 225             "tag, or a procedure.  @code{#t} means to cut away all frames up\n"
 226             "to but excluding the first user module frame.  An integer means\n"
 227             "to cut away exactly that number of frames.  A prompt tag means\n"
 228             "to cut away all frames that are inside a prompt with the given\n"
 229             "tag. A procedure means to cut away all frames up to but\n"
 230             "excluding the application frame whose procedure matches the\n"
 231             "specified one.\n"
 232             "\n"
 233             "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
 234             "procedure.  An integer means to cut away that number of frames.\n"
 235             "A prompt tag means to cut away all frames that are outside a\n"
 236             "prompt with the given tag. A procedure means to cut away\n"
 237             "frames down to but excluding the application frame whose\n"
 238             "procedure matches the specified one.\n"
 239             "\n"
 240             "If the @var{outer_cut_i} of the last pair is missing, it is\n"
 241             "taken as 0.")
 242 #define FUNC_NAME s_scm_make_stack
 243 {
 244   long n;
 245   SCM frame;
 246   SCM stack;
 247   SCM inner_cut, outer_cut;
 248
 249   /* Extract a pointer to the innermost frame of whatever object
 250      scm_make_stack was given.  */
 251   if (scm_is_eq (obj, SCM_BOOL_T))
 252     {
 253       SCM cont;
 254       struct scm_vm_cont *c;
 255
 256       cont = scm_i_capture_current_stack ();
 257       c = SCM_VM_CONT_DATA (cont);
 258
 259       frame = scm_c_make_frame (cont, c->fp + c->reloc,
 260                                 c->sp + c->reloc, c->ra,
 261                                 c->reloc);
 262     }
 263   else if (SCM_VM_FRAME_P (obj))
 264     frame = obj;
 265   else if (SCM_CONTINUATIONP (obj))
 266     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
 267        that were in place when the continuation was captured. */
 268     frame = scm_i_continuation_to_frame (obj);
 269   else
 270     {
 271       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 272       /* not reached */
 273     }
 274
 275   /* FIXME: is this even possible? */
 276   if (scm_is_true (frame)
 277       && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
 278     frame = scm_frame_previous (frame);
 279
 280   if (scm_is_false (frame))
 281     return SCM_BOOL_F;
 282
 283   /* Count number of frames.  Also get stack id tag and check whether
 284      there are more stackframes than we want to record
 285      (SCM_BACKTRACE_MAXDEPTH). */
 286   n = stack_depth (frame);
 287
 288   /* Make the stack object. */
 289   stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
 290   SCM_SET_STACK_LENGTH (stack, n);
 291   SCM_SET_STACK_ID (stack, scm_stack_id (obj));
 292   SCM_SET_STACK_FRAME (stack, frame);
 293
 294   /* Narrow the stack according to the arguments given to scm_make_stack. */
 295   SCM_VALIDATE_REST_ARGUMENT (args);
 296   while (n > 0 && !scm_is_null (args))
 297     {
 298       inner_cut = SCM_CAR (args);
 299       args = SCM_CDR (args);
 300       if (scm_is_null (args))
 301         {
 302           outer_cut = SCM_INUM0;
 303         }
 304       else
 305         {
 306           outer_cut = SCM_CAR (args);
 307           args = SCM_CDR (args);
 308         }
 309
 310       narrow_stack (stack,
 311                     scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
 312                     scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
 313                     scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
 314                     scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
 315
 316       n = SCM_STACK_LENGTH (stack);
 317     }
 318
 319   if (n > 0)
 320     return stack;
 321   else
 322     return SCM_BOOL_F;
 323 }
 324 #undef FUNC_NAME
 325
 326 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 327             (SCM stack),
 328             "Return the identifier given to @var{stack} by @code{start-stack}.")
 329 #define FUNC_NAME s_scm_stack_id
 330 {
 331   if (scm_is_eq (stack, SCM_BOOL_T)
 332       /* FIXME: frame case assumes frame still live on the stack, and no
 333          intervening start-stack. Hmm... */
 334       || SCM_VM_FRAME_P (stack))
 335     {
 336       /* Fetch most recent start-stack tag. */
 337       SCM stacks = scm_fluid_ref (scm_sys_stacks);
 338       return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
 339     }
 340   else if (SCM_CONTINUATIONP (stack))
 341     /* FIXME: implement me */
 342     return SCM_BOOL_F;
 343   else
 344     {
 345       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
 346       /* not reached */
 347     }
 348 }
 349 #undef FUNC_NAME
 350
 351 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 352             (SCM stack, SCM index),
 353             "Return the @var{index}'th frame from @var{stack}.")
 354 #define FUNC_NAME s_scm_stack_ref
 355 {
 356   unsigned long int c_index;
 357   SCM frame;
 358
 359   SCM_VALIDATE_STACK (1, stack);
 360   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 361   frame = SCM_STACK_FRAME (stack);
 362   while (c_index--)
 363     frame = scm_frame_previous (frame);
 364   return frame;
 365 }
 366 #undef FUNC_NAME
 367
 368 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 369             (SCM stack),
 370             "Return the length of @var{stack}.")
 371 #define FUNC_NAME s_scm_stack_length
 372 {
 373   SCM_VALIDATE_STACK (1, stack);
 374   return scm_from_long (SCM_STACK_LENGTH (stack));
 375 }
 376 #undef FUNC_NAME
 377
 378 \f
 379
 380 void
 381 scm_init_stacks ()
 382 {
 383   scm_sys_stacks = scm_make_fluid ();
 384   scm_c_define ("%stacks", scm_sys_stacks);
 385
 386   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 387                                     SCM_UNDEFINED);
 388   scm_set_struct_vtable_name_x (scm_stack_type,
 389                                 scm_from_latin1_symbol ("stack"));
 390 #include "libguile/stacks.x"
 391 }
 392
 393 /*
 394   Local Variables:
 395   c-file-style: "gnu"
 396   End:
 397 */