libguile/frames.c

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