libguile/frames.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <stdlib.h>
  24 #include <string.h>
  25 #include "_scm.h"
  26 #include "frames.h"
  27 #include <verify.h>
  28
  29 /* Make sure assumptions on the layout of `struct scm_vm_frame' hold.  */
  30 verify (sizeof (SCM) == sizeof (SCM *));
  31 verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM));
  32 verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
  33
  34 \f
  35 #define RELOC(frame, val)                               \
  36   (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
  37
  38 SCM
  39 scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
  40                   scm_t_uint8 *ip, scm_t_ptrdiff offset)
  41 {
  42   struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  43                                        "vmframe");
  44   p->stack_holder = stack_holder;
  45   p->fp = fp;
  46   p->sp = sp;
  47   p->ip = ip;
  48   p->offset = offset;
  49   return scm_cell (scm_tc7_frame, (scm_t_bits)p);
  50 }
  51
  52 void
  53 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  54 {
  55   scm_puts_unlocked ("#<frame ", port);
  56   scm_uintprint (SCM_UNPACK (frame), 16, port);
  57   scm_putc_unlocked (' ', port);
  58   scm_write (scm_frame_procedure (frame), port);
  59   /* don't write args, they can get us into trouble. */
  60   scm_puts_unlocked (">", port);
  61 }
  62
  63 \f
  64 /* Scheme interface */
  65
  66 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
  67             (SCM obj),
  68             "")
  69 #define FUNC_NAME s_scm_frame_p
  70 {
  71   return scm_from_bool (SCM_VM_FRAME_P (obj));
  72 }
  73 #undef FUNC_NAME
  74
  75 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
  76             (SCM frame),
  77             "")
  78 #define FUNC_NAME s_scm_frame_procedure
  79 {
  80   SCM_VALIDATE_VM_FRAME (1, frame);
  81   return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
  82 }
  83 #undef FUNC_NAME
  84
  85 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
  86             (SCM frame),
  87             "")
  88 #define FUNC_NAME s_scm_frame_arguments
  89 {
  90   static SCM var = SCM_BOOL_F;
  91
  92   SCM_VALIDATE_VM_FRAME (1, frame);
  93
  94   if (scm_is_false (var))
  95     var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
  96                                "frame-arguments");
  97
  98   return scm_call_1 (SCM_VARIABLE_REF (var), frame);
  99 }
 100 #undef FUNC_NAME
 101
 102 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 103             (SCM frame),
 104             "")
 105 #define FUNC_NAME s_scm_frame_source
 106 {
 107   SCM_VALIDATE_VM_FRAME (1, frame);
 108
 109   return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
 110 }
 111 #undef FUNC_NAME
 112
 113 SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 114             (SCM frame),
 115             "")
 116 #define FUNC_NAME s_scm_frame_num_locals
 117 {
 118   SCM *fp, *sp;
 119
 120   SCM_VALIDATE_VM_FRAME (1, frame);
 121
 122   fp = SCM_VM_FRAME_FP (frame);
 123   sp = SCM_VM_FRAME_SP (frame);
 124
 125   return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
 126 }
 127 #undef FUNC_NAME
 128
 129 SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
 130             (SCM frame, SCM index),
 131             "")
 132 #define FUNC_NAME s_scm_frame_local_ref
 133 {
 134   SCM *fp, *sp;
 135   unsigned int i;
 136
 137   SCM_VALIDATE_VM_FRAME (1, frame);
 138   SCM_VALIDATE_UINT_COPY (2, index, i);
 139
 140   fp = SCM_VM_FRAME_FP (frame);
 141   sp = SCM_VM_FRAME_SP (frame);
 142
 143   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 144     return SCM_FRAME_LOCAL (fp, i);
 145
 146   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 147 }
 148 #undef FUNC_NAME
 149
 150 /* Need same not-yet-active frame logic here as in frame-num-locals */
 151 SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 152             (SCM frame, SCM index, SCM val),
 153             "")
 154 #define FUNC_NAME s_scm_frame_local_set_x
 155 {
 156   SCM *fp, *sp;
 157   unsigned int i;
 158
 159   SCM_VALIDATE_VM_FRAME (1, frame);
 160   SCM_VALIDATE_UINT_COPY (2, index, i);
 161
 162   fp = SCM_VM_FRAME_FP (frame);
 163   sp = SCM_VM_FRAME_SP (frame);
 164
 165   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 166     {
 167       SCM_FRAME_LOCAL (fp, i) = val;
 168       return SCM_UNSPECIFIED;
 169     }
 170
 171   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 172 }
 173 #undef FUNC_NAME
 174
 175 SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 176             (SCM frame),
 177             "Return the frame pointer for @var{frame}.")
 178 #define FUNC_NAME s_scm_frame_address
 179 {
 180   SCM_VALIDATE_VM_FRAME (1, frame);
 181   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
 182 }
 183 #undef FUNC_NAME
 184
 185 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
 186             (SCM frame),
 187             "")
 188 #define FUNC_NAME s_scm_frame_stack_pointer
 189 {
 190   SCM_VALIDATE_VM_FRAME (1, frame);
 191
 192   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
 193 }
 194 #undef FUNC_NAME
 195
 196 SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
 197             (SCM frame),
 198             "")
 199 #define FUNC_NAME s_scm_frame_instruction_pointer
 200 {
 201   SCM_VALIDATE_VM_FRAME (1, frame);
 202
 203   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
 204 }
 205 #undef FUNC_NAME
 206
 207 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 208             (SCM frame),
 209             "")
 210 #define FUNC_NAME s_scm_frame_return_address
 211 {
 212   SCM_VALIDATE_VM_FRAME (1, frame);
 213   return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
 214                                               (SCM_VM_FRAME_FP (frame))));
 215 }
 216 #undef FUNC_NAME
 217
 218 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 219             (SCM frame),
 220             "")
 221 #define FUNC_NAME s_scm_frame_dynamic_link
 222 {
 223   SCM_VALIDATE_VM_FRAME (1, frame);
 224   /* fixme: munge fp if holder is a continuation */
 225   return scm_from_uintptr_t
 226     ((scm_t_uintptr)
 227      RELOC (frame,
 228             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 229 }
 230 #undef FUNC_NAME
 231
 232 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 233             (SCM frame),
 234             "")
 235 #define FUNC_NAME s_scm_frame_previous
 236 {
 237   SCM *this_fp, *new_fp, *new_sp;
 238   SCM proc;
 239
 240   SCM_VALIDATE_VM_FRAME (1, frame);
 241
 242  again:
 243   this_fp = SCM_VM_FRAME_FP (frame);
 244   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 245   if (new_fp)
 246     {
 247       new_fp = RELOC (frame, new_fp);
 248       new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
 249       frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
 250                                 new_fp, new_sp,
 251                                 SCM_FRAME_RETURN_ADDRESS (this_fp),
 252                                 SCM_VM_FRAME_OFFSET (frame));
 253       proc = scm_frame_procedure (frame);
 254
 255       if (SCM_RTL_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
 256         goto again;
 257       else
 258         return frame;
 259     }
 260   else
 261     return SCM_BOOL_F;
 262 }
 263 #undef FUNC_NAME
 264
 265 \f
 266 void
 267 scm_init_frames (void)
 268 {
 269 #ifndef SCM_MAGIC_SNARFER
 270 #include "libguile/frames.x"
 271 #endif
 272 }
 273
 274 /*
 275   Local Variables:
 276   c-file-style: "gnu"
 277   End:
 278 */