libguile/frames.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <string.h>
  47 #include "vm-bootstrap.h"
  48 #include "frames.h"
  49
  50 \f
  51 scm_t_bits scm_tc16_vm_frame;
  52
  53 #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
  54
  55 SCM
  56 scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
  57                      scm_byte_t *ip, scm_t_ptrdiff offset)
  58 {
  59   struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
  60                                           "vmframe");
  61   p->stack_holder = stack_holder;
  62   p->fp = fp;
  63   p->sp = sp;
  64   p->ip = ip;
  65   p->offset = offset;
  66   SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
  67 }
  68
  69 static int
  70 vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  71 {
  72   scm_puts ("#<vm-frame ", port);
  73   scm_uintprint (SCM_UNPACK (frame), 16, port);
  74   scm_putc (' ', port);
  75   scm_write (scm_vm_frame_program (frame), port);
  76   /* don't write args, they can get us into trouble. */
  77   scm_puts (">", port);
  78
  79   return 1;
  80 }
  81
  82 static SCM
  83 vm_frame_mark (SCM obj)
  84 {
  85   return SCM_VM_FRAME_STACK_HOLDER (obj);
  86 }
  87
  88 static scm_sizet
  89 vm_frame_free (SCM obj)
  90 {
  91   struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
  92   scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
  93   return 0;
  94 }
  95
  96 /* Scheme interface */
  97
  98 SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
  99             (SCM obj),
 100             "")
 101 #define FUNC_NAME s_scm_vm_frame_p
 102 {
 103   return SCM_BOOL (SCM_VM_FRAME_P (obj));
 104 }
 105 #undef FUNC_NAME
 106
 107 SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
 108             (SCM frame),
 109             "")
 110 #define FUNC_NAME s_scm_vm_frame_program
 111 {
 112   SCM_VALIDATE_VM_FRAME (1, frame);
 113   return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
 114 }
 115 #undef FUNC_NAME
 116
 117 SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
 118             (SCM frame),
 119             "")
 120 #define FUNC_NAME s_scm_vm_frame_arguments
 121 {
 122   SCM *fp;
 123   int i;
 124   struct scm_objcode *bp;
 125   SCM ret;
 126
 127   SCM_VALIDATE_VM_FRAME (1, frame);
 128
 129   fp = SCM_VM_FRAME_FP (frame);
 130   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 131
 132   if (!bp->nargs)
 133     return SCM_EOL;
 134   else if (bp->nrest)
 135     ret = fp[bp->nargs - 1];
 136   else
 137     ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
 138
 139   for (i = bp->nargs - 2; i >= 0; i--)
 140     ret = scm_cons (fp[i], ret);
 141
 142   return ret;
 143 }
 144 #undef FUNC_NAME
 145
 146 SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
 147             (SCM frame),
 148             "")
 149 #define FUNC_NAME s_scm_vm_frame_source
 150 {
 151   SCM *fp;
 152   struct scm_objcode *bp;
 153
 154   SCM_VALIDATE_VM_FRAME (1, frame);
 155
 156   fp = SCM_VM_FRAME_FP (frame);
 157   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 158
 159   return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
 160                                SCM_VM_FRAME_IP (frame) - bp->base);
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
 165             (SCM frame, SCM index),
 166             "")
 167 #define FUNC_NAME s_scm_vm_frame_local_ref
 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   return SCM_FRAME_VARIABLE (fp, i);
 182 }
 183 #undef FUNC_NAME
 184
 185 SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
 186             (SCM frame, SCM index, SCM val),
 187             "")
 188 #define FUNC_NAME s_scm_vm_frame_local_set_x
 189 {
 190   SCM *fp;
 191   unsigned int i;
 192   struct scm_objcode *bp;
 193
 194   SCM_VALIDATE_VM_FRAME (1, frame);
 195
 196   fp = SCM_VM_FRAME_FP (frame);
 197   bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
 198
 199   SCM_VALIDATE_UINT_COPY (2, index, i);
 200   SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
 201
 202   SCM_FRAME_VARIABLE (fp, i) = val;
 203
 204   return SCM_UNSPECIFIED;
 205 }
 206 #undef FUNC_NAME
 207
 208 SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
 209             (SCM frame),
 210             "")
 211 #define FUNC_NAME s_scm_vm_frame_return_address
 212 {
 213   SCM_VALIDATE_VM_FRAME (1, frame);
 214   return scm_from_ulong ((unsigned long)
 215                          (SCM_FRAME_RETURN_ADDRESS
 216                           (SCM_VM_FRAME_FP (frame))));
 217 }
 218 #undef FUNC_NAME
 219
 220 SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
 221             (SCM frame),
 222             "")
 223 #define FUNC_NAME s_scm_vm_frame_mv_return_address
 224 {
 225   SCM_VALIDATE_VM_FRAME (1, frame);
 226   return scm_from_ulong ((unsigned long)
 227                          (SCM_FRAME_MV_RETURN_ADDRESS
 228                           (SCM_VM_FRAME_FP (frame))));
 229 }
 230 #undef FUNC_NAME
 231
 232 SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
 233             (SCM frame),
 234             "")
 235 #define FUNC_NAME s_scm_vm_frame_dynamic_link
 236 {
 237   SCM_VALIDATE_VM_FRAME (1, frame);
 238   /* fixme: munge fp if holder is a continuation */
 239   return scm_from_ulong
 240     ((unsigned long)
 241      RELOC (frame,
 242             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 243 }
 244 #undef FUNC_NAME
 245
 246 SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
 247             (SCM frame),
 248             "")
 249 #define FUNC_NAME s_scm_vm_frame_external_link
 250 {
 251   SCM_VALIDATE_VM_FRAME (1, frame);
 252   return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
 253 }
 254 #undef FUNC_NAME
 255
 256 SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
 257             (SCM frame),
 258             "")
 259 #define FUNC_NAME s_scm_vm_frame_stack
 260 {
 261   SCM *top, *bottom, ret = SCM_EOL;
 262
 263   SCM_VALIDATE_VM_FRAME (1, frame);
 264
 265   top = SCM_VM_FRAME_SP (frame);
 266   bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
 267   while (bottom <= top)
 268     ret = scm_cons (*bottom++, ret);
 269
 270   return ret;
 271 }
 272 #undef FUNC_NAME
 273
 274 extern SCM
 275 scm_c_vm_frame_prev (SCM frame)
 276 {
 277   SCM *this_fp, *new_fp, *new_sp;
 278   this_fp = SCM_VM_FRAME_FP (frame);
 279   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 280   if (new_fp)
 281     { new_fp = RELOC (frame, new_fp);
 282       new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
 283       return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
 284                                   new_fp, new_sp,
 285                                   SCM_FRAME_RETURN_ADDRESS (this_fp),
 286                                   SCM_VM_FRAME_OFFSET (frame));
 287     }
 288   else
 289     return SCM_BOOL_F;
 290 }
 291
 292 \f
 293 void
 294 scm_bootstrap_frames (void)
 295 {
 296   scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
 297   scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
 298   scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
 299   scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
 300 }
 301
 302 void
 303 scm_init_frames (void)
 304 {
 305   scm_bootstrap_vm ();
 306
 307 #ifndef SCM_MAGIC_SNARFER
 308 #include "frames.x"
 309 #endif
 310 }
 311
 312 /*
 313   Local Variables:
 314   c-file-style: "gnu"
 315   End:
 316 */