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