libguile/frames.c

   1 /* Copyright (C) 2001, 2009 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 "vm-bootstrap.h"
  27 #include "frames.h"
  28
  29 \f
  30 scm_t_bits scm_tc16_vm_frame;
  31
  32 #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
  33
  34 SCM
  35 scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
  36                      scm_t_uint8 *ip, scm_t_ptrdiff offset)
  37 {
  38   struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
  39                                           "vmframe");
  40   p->stack_holder = stack_holder;
  41   p->fp = fp;
  42   p->sp = sp;
  43   p->ip = ip;
  44   p->offset = offset;
  45   SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
  46 }
  47
  48 static int
  49 vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  50 {
  51   scm_puts ("#<vm-frame ", port);
  52   scm_uintprint (SCM_UNPACK (frame), 16, port);
  53   scm_putc (' ', port);
  54   scm_write (scm_vm_frame_program (frame), port);
  55   /* don't write args, they can get us into trouble. */
  56   scm_puts (">", port);
  57
  58   return 1;
  59 }
  60
  61 static SCM
  62 vm_frame_mark (SCM obj)
  63 {
  64   return SCM_VM_FRAME_STACK_HOLDER (obj);
  65 }
  66
  67 static size_t
  68 vm_frame_free (SCM obj)
  69 {
  70   struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
  71   scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
  72   return 0;
  73 }
  74
  75 /* Scheme interface */
  76
  77 SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
  78             (SCM obj),
  79             "")
  80 #define FUNC_NAME s_scm_vm_frame_p
  81 {
  82   return SCM_BOOL (SCM_VM_FRAME_P (obj));
  83 }
  84 #undef FUNC_NAME
  85
  86 SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
  87             (SCM frame),
  88             "")
  89 #define FUNC_NAME s_scm_vm_frame_program
  90 {
  91   SCM_VALIDATE_VM_FRAME (1, frame);
  92   return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
  93 }
  94 #undef FUNC_NAME
  95
  96 SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
  97             (SCM frame),
  98             "")
  99 #define FUNC_NAME s_scm_vm_frame_arguments
 100 {
 101   SCM *fp;
 102   int i;
 103   struct scm_objcode *bp;
 104   SCM ret;
 105
 106   SCM_VALIDATE_VM_FRAME (1, frame);
 107
 108   fp = SCM_VM_FRAME_FP (frame);
 109   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 110
 111   if (!bp->nargs)
 112     return SCM_EOL;
 113   else if (bp->nrest)
 114     ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
 115   else
 116     ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
 117
 118   for (i = bp->nargs - 2; i >= 0; i--)
 119     ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
 120
 121   return ret;
 122 }
 123 #undef FUNC_NAME
 124
 125 SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
 126             (SCM frame),
 127             "")
 128 #define FUNC_NAME s_scm_vm_frame_source
 129 {
 130   SCM *fp;
 131   struct scm_objcode *bp;
 132
 133   SCM_VALIDATE_VM_FRAME (1, frame);
 134
 135   fp = SCM_VM_FRAME_FP (frame);
 136   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 137
 138   return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
 139                                SCM_VM_FRAME_IP (frame) - bp->base);
 140 }
 141 #undef FUNC_NAME
 142
 143 SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
 144             (SCM frame, SCM index),
 145             "")
 146 #define FUNC_NAME s_scm_vm_frame_local_ref
 147 {
 148   SCM *fp;
 149   unsigned int i;
 150   struct scm_objcode *bp;
 151
 152   SCM_VALIDATE_VM_FRAME (1, frame);
 153
 154   fp = SCM_VM_FRAME_FP (frame);
 155   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 156
 157   SCM_VALIDATE_UINT_COPY (2, index, i);
 158   SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
 159
 160   return SCM_FRAME_VARIABLE (fp, i);
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
 165             (SCM frame, SCM index, SCM val),
 166             "")
 167 #define FUNC_NAME s_scm_vm_frame_local_set_x
 168 {
 169   SCM *fp;
 170   unsigned int i;
 171   struct scm_objcode *bp;
 172
 173   SCM_VALIDATE_VM_FRAME (1, frame);
 174
 175   fp = SCM_VM_FRAME_FP (frame);
 176   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 177
 178   SCM_VALIDATE_UINT_COPY (2, index, i);
 179   SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
 180
 181   SCM_FRAME_VARIABLE (fp, i) = val;
 182
 183   return SCM_UNSPECIFIED;
 184 }
 185 #undef FUNC_NAME
 186
 187 SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
 188             (SCM frame),
 189             "")
 190 #define FUNC_NAME s_scm_vm_frame_return_address
 191 {
 192   SCM_VALIDATE_VM_FRAME (1, frame);
 193   return scm_from_ulong ((unsigned long)
 194                          (SCM_FRAME_RETURN_ADDRESS
 195                           (SCM_VM_FRAME_FP (frame))));
 196 }
 197 #undef FUNC_NAME
 198
 199 SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
 200             (SCM frame),
 201             "")
 202 #define FUNC_NAME s_scm_vm_frame_mv_return_address
 203 {
 204   SCM_VALIDATE_VM_FRAME (1, frame);
 205   return scm_from_ulong ((unsigned long)
 206                          (SCM_FRAME_MV_RETURN_ADDRESS
 207                           (SCM_VM_FRAME_FP (frame))));
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
 212             (SCM frame),
 213             "")
 214 #define FUNC_NAME s_scm_vm_frame_dynamic_link
 215 {
 216   SCM_VALIDATE_VM_FRAME (1, frame);
 217   /* fixme: munge fp if holder is a continuation */
 218   return scm_from_ulong
 219     ((unsigned long)
 220      RELOC (frame,
 221             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 222 }
 223 #undef FUNC_NAME
 224
 225 SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
 226             (SCM frame),
 227             "")
 228 #define FUNC_NAME s_scm_vm_frame_stack
 229 {
 230   SCM *top, *bottom, ret = SCM_EOL;
 231
 232   SCM_VALIDATE_VM_FRAME (1, frame);
 233
 234   top = SCM_VM_FRAME_SP (frame);
 235   bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
 236   while (bottom <= top)
 237     ret = scm_cons (*bottom++, ret);
 238
 239   return ret;
 240 }
 241 #undef FUNC_NAME
 242
 243 extern SCM
 244 scm_c_vm_frame_prev (SCM frame)
 245 {
 246   SCM *this_fp, *new_fp, *new_sp;
 247   this_fp = SCM_VM_FRAME_FP (frame);
 248   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 249   if (new_fp)
 250     { new_fp = RELOC (frame, new_fp);
 251       new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
 252       return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
 253                                   new_fp, new_sp,
 254                                   SCM_FRAME_RETURN_ADDRESS (this_fp),
 255                                   SCM_VM_FRAME_OFFSET (frame));
 256     }
 257   else
 258     return SCM_BOOL_F;
 259 }
 260
 261 \f
 262 void
 263 scm_bootstrap_frames (void)
 264 {
 265   scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
 266   scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
 267   scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
 268   scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
 269   scm_c_register_extension ("libguile", "scm_init_frames",
 270                             (scm_t_extension_init_func)scm_init_frames, NULL);
 271 }
 272
 273 void
 274 scm_init_frames (void)
 275 {
 276   scm_bootstrap_vm ();
 277
 278 #ifndef SCM_MAGIC_SNARFER
 279 #include "libguile/frames.x"
 280 #endif
 281 }
 282
 283 /*
 284   Local Variables:
 285   c-file-style: "gnu"
 286   End:
 287 */