libguile/stacks.c

   1 /* A stack holds a frame chain
   2  * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 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/eval.h"
  28 #include "libguile/debug.h"
  29 #include "libguile/continuations.h"
  30 #include "libguile/struct.h"
  31 #include "libguile/macros.h"
  32 #include "libguile/procprop.h"
  33 #include "libguile/modules.h"
  34 #include "libguile/root.h"
  35 #include "libguile/strings.h"
  36 #include "libguile/vm.h" /* to capture vm stacks */
  37 #include "libguile/frames.h" /* vm frames */
  38
  39 #include "libguile/validate.h"
  40 #include "libguile/stacks.h"
  41 #include "libguile/private-options.h"
  42
  43
  44 \f
  45 /* {Stacks}
  46  *
  47  * The stack is represented as a struct that holds a frame. The frame itself is
  48  * linked to the next frame, or #f.
  49  *
  50  * Stacks
  51  *   Constructor
  52  *     make-stack
  53  *   Selectors
  54  *     stack-id
  55  *     stack-ref
  56  *   Inspector
  57  *     stack-length
  58  */
  59
  60 \f
  61
  62 static SCM stack_id_with_fp (SCM frame, SCM **fp);
  63
  64 /* Count number of debug info frames on a stack, beginning with FRAME.
  65  */
  66 static long
  67 stack_depth (SCM frame, SCM *fp)
  68 {
  69   long n;
  70   /* count frames, skipping boot frames */
  71   for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
  72        frame = scm_c_frame_prev (frame))
  73     if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
  74       ++n;
  75   return n;
  76 }
  77
  78 /* Narrow STACK by cutting away stackframes (mutatingly).
  79  *
  80  * Inner frames (most recent) are cut by advancing the frames pointer.
  81  * Outer frames are cut by decreasing the recorded length.
  82  *
  83  * Cut maximally INNER inner frames and OUTER outer frames using
  84  * the keys INNER_KEY and OUTER_KEY.
  85  *
  86  * Frames are cut away starting at the end points and moving towards
  87  * the center of the stack.  The key is normally compared to the
  88  * operator in application frames.  Frames up to and including the key
  89  * are cut.
  90  *
  91  * If INNER_KEY is #t a different scheme is used for inner frames:
  92  *
  93  * Frames up to but excluding the first source frame originating from
  94  * a user module are cut, except for possible application frames
  95  * between the user frame and the last system frame previously
  96  * encountered.
  97  */
  98
  99 static void
 100 narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
 101 {
 102   unsigned long int len;
 103   SCM frame;
 104
 105   len = SCM_STACK_LENGTH (stack);
 106   frame = SCM_STACK_FRAME (stack);
 107
 108   /* Cut inner part. */
 109   if (scm_is_eq (inner_key, SCM_BOOL_T))
 110     {
 111       /* Cut specified number of frames. */
 112       for (; inner && len; --inner)
 113         {
 114           len--;
 115           frame = scm_c_frame_prev (frame);
 116         }
 117     }
 118   else
 119     {
 120       /* Cut until the given procedure is seen. */
 121       for (; inner && len ; --inner)
 122         {
 123           SCM proc = scm_frame_procedure (frame);
 124           len--;
 125           frame = scm_c_frame_prev (frame);
 126           if (scm_is_eq (proc, inner_key))
 127             break;
 128         }
 129     }
 130
 131   SCM_SET_STACK_LENGTH (stack, len);
 132   SCM_SET_STACK_FRAME (stack, frame);
 133
 134   /* Cut outer part. */
 135   for (; outer && len ; --outer)
 136     {
 137       frame = scm_stack_ref (stack, scm_from_long (len - 1));
 138       len--;
 139       if (scm_is_eq (scm_frame_procedure (frame), outer_key))
 140         break;
 141     }
 142
 143   SCM_SET_STACK_LENGTH (stack, len);
 144 }
 145
 146 \f
 147
 148 /* Stacks
 149  */
 150
 151 SCM scm_stack_type;
 152
 153 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 154             (SCM obj),
 155             "Return @code{#t} if @var{obj} is a calling stack.")
 156 #define FUNC_NAME s_scm_stack_p
 157 {
 158   return scm_from_bool(SCM_STACKP (obj));
 159 }
 160 #undef FUNC_NAME
 161
 162 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 163             (SCM obj, SCM args),
 164             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 165             "evaluation stack is used for creating the stack frames,\n"
 166             "otherwise the frames are taken from @var{obj} (which must be\n"
 167             "either a debug object or a continuation).\n\n"
 168             "@var{args} should be a list containing any combination of\n"
 169             "integer, procedure and @code{#t} values.\n\n"
 170             "These values specify various ways of cutting away uninteresting\n"
 171             "stack frames from the top and bottom of the stack that\n"
 172             "@code{make-stack} returns.  They come in pairs like this:\n"
 173             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 174             "@var{outer_cut_2} @dots{})}.\n\n"
 175             "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
 176             "procedure.  @code{#t} means to cut away all frames up to but\n"
 177             "excluding the first user module frame.  An integer means to cut\n"
 178             "away exactly that number of frames.  A procedure means to cut\n"
 179             "away all frames up to but excluding the application frame whose\n"
 180             "procedure matches the specified one.\n\n"
 181             "Each @var{outer_cut_N} can be an integer or a procedure.  An\n"
 182             "integer means to cut away that number of frames.  A procedure\n"
 183             "means to cut away frames down to but excluding the application\n"
 184             "frame whose procedure matches the specified one.\n\n"
 185             "If the @var{outer_cut_N} of the last pair is missing, it is\n"
 186             "taken as 0.")
 187 #define FUNC_NAME s_scm_make_stack
 188 {
 189   long n;
 190   int maxp;
 191   SCM frame;
 192   SCM stack;
 193   SCM id, *id_fp;
 194   SCM inner_cut, outer_cut;
 195
 196   /* Extract a pointer to the innermost frame of whatever object
 197      scm_make_stack was given.  */
 198   if (scm_is_eq (obj, SCM_BOOL_T))
 199     {
 200       SCM cont;
 201       struct scm_vm_cont *c;
 202
 203       cont = scm_cdar (scm_vm_capture_continuations ());
 204       c = SCM_VM_CONT_DATA (cont);
 205
 206       frame = scm_c_make_frame (cont, c->fp + c->reloc,
 207                                 c->sp + c->reloc, c->ip,
 208                                 c->reloc);
 209     }
 210   else if (SCM_VM_FRAME_P (obj))
 211     frame = obj;
 212   else if (SCM_CONTINUATIONP (obj))
 213     {
 214       scm_t_contregs *cont = SCM_CONTREGS (obj);
 215       if (!scm_is_null (cont->vm_conts))
 216         { SCM vm_cont;
 217           struct scm_vm_cont *data;
 218           vm_cont = scm_cdr (scm_car (cont->vm_conts));
 219           data = SCM_VM_CONT_DATA (vm_cont);
 220           frame = scm_c_make_frame (vm_cont,
 221                                     data->fp + data->reloc,
 222                                     data->sp + data->reloc,
 223                                     data->ip,
 224                                     data->reloc);
 225         } else
 226         frame = SCM_BOOL_F;
 227     }
 228   else
 229     {
 230       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 231       /* not reached */
 232     }
 233
 234   if (scm_is_false (frame))
 235     return SCM_BOOL_F;
 236
 237   /* Get ID of the stack corresponding to the given frame. */
 238   id = stack_id_with_fp (frame, &id_fp);
 239
 240   /* Count number of frames.  Also get stack id tag and check whether
 241      there are more stackframes than we want to record
 242      (SCM_BACKTRACE_MAXDEPTH). */
 243   id = SCM_BOOL_F;
 244   maxp = 0;
 245   n = stack_depth (frame, id_fp);
 246
 247   /* Make the stack object. */
 248   stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
 249   SCM_SET_STACK_LENGTH (stack, n);
 250   SCM_SET_STACK_ID (stack, id);
 251   SCM_SET_STACK_FRAME (stack, frame);
 252
 253   /* Narrow the stack according to the arguments given to scm_make_stack. */
 254   SCM_VALIDATE_REST_ARGUMENT (args);
 255   while (n > 0 && !scm_is_null (args))
 256     {
 257       inner_cut = SCM_CAR (args);
 258       args = SCM_CDR (args);
 259       if (scm_is_null (args))
 260         {
 261           outer_cut = SCM_INUM0;
 262         }
 263       else
 264         {
 265           outer_cut = SCM_CAR (args);
 266           args = SCM_CDR (args);
 267         }
 268
 269       narrow_stack (stack,
 270                     scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
 271                     scm_is_integer (inner_cut) ? 0 : inner_cut,
 272                     scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
 273                     scm_is_integer (outer_cut) ? 0 : outer_cut);
 274
 275       n = SCM_STACK_LENGTH (stack);
 276     }
 277
 278   if (n > 0)
 279     return stack;
 280   else
 281     return SCM_BOOL_F;
 282 }
 283 #undef FUNC_NAME
 284
 285 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 286             (SCM stack),
 287             "Return the identifier given to @var{stack} by @code{start-stack}.")
 288 #define FUNC_NAME s_scm_stack_id
 289 {
 290   SCM frame, *id_fp;
 291
 292   if (scm_is_eq (stack, SCM_BOOL_T))
 293     {
 294       struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
 295       frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
 296     }
 297   else if (SCM_VM_FRAME_P (stack))
 298     frame = stack;
 299   else if (SCM_CONTINUATIONP (stack))
 300     {
 301       scm_t_contregs *cont = SCM_CONTREGS (stack);
 302       if (!scm_is_null (cont->vm_conts))
 303         { SCM vm_cont;
 304           struct scm_vm_cont *data;
 305           vm_cont = scm_cdr (scm_car (cont->vm_conts));
 306           data = SCM_VM_CONT_DATA (vm_cont);
 307           frame = scm_c_make_frame (vm_cont,
 308                                     data->fp + data->reloc,
 309                                     data->sp + data->reloc,
 310                                     data->ip,
 311                                     data->reloc);
 312         } else
 313         frame = SCM_BOOL_F;
 314     }
 315   else
 316     {
 317       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
 318       /* not reached */
 319     }
 320
 321   return stack_id_with_fp (frame, &id_fp);
 322 }
 323 #undef FUNC_NAME
 324
 325 static SCM
 326 stack_id_with_fp (SCM frame, SCM **fp)
 327 {
 328   SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
 329
 330   if (SCM_VM_CONT_P (holder))
 331     {
 332       *fp = NULL;
 333       return SCM_BOOL_F;
 334     }
 335   else
 336     {
 337       *fp = NULL;
 338       return SCM_BOOL_F;
 339     }
 340 }
 341
 342 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 343             (SCM stack, SCM index),
 344             "Return the @var{index}'th frame from @var{stack}.")
 345 #define FUNC_NAME s_scm_stack_ref
 346 {
 347   unsigned long int c_index;
 348   SCM frame;
 349
 350   SCM_VALIDATE_STACK (1, stack);
 351   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 352   frame = SCM_STACK_FRAME (stack);
 353   while (c_index--)
 354     {
 355       frame = scm_c_frame_prev (frame);
 356       while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
 357         frame = scm_c_frame_prev (frame);
 358     }
 359   return frame;
 360 }
 361 #undef FUNC_NAME
 362
 363 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 364             (SCM stack),
 365             "Return the length of @var{stack}.")
 366 #define FUNC_NAME s_scm_stack_length
 367 {
 368   SCM_VALIDATE_STACK (1, stack);
 369   return scm_from_long (SCM_STACK_LENGTH (stack));
 370 }
 371 #undef FUNC_NAME
 372
 373 \f
 374
 375 void
 376 scm_init_stacks ()
 377 {
 378   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 379                                     SCM_UNDEFINED);
 380   scm_set_struct_vtable_name_x (scm_stack_type,
 381                                 scm_from_locale_symbol ("stack"));
 382 #include "libguile/stacks.x"
 383 }
 384
 385 /*
 386   Local Variables:
 387   c-file-style: "gnu"
 388   End:
 389 */