elisp @@ macro

[bpt/guile.git] / libguile / frames.c

diff --git a/libguile/frames.c b/libguile/frames.c
index 3a2d01b..2162f49 100644 (file)
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -35,17 +35,15 @@ verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
 \f
 
 SCM
-scm_c_make_frame (enum scm_vm_frame_kind frame_kind, void *stack_holder,
-                  scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
-                  scm_t_uint32 *ip)
+scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
   struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
                                        "vmframe");
-  p->stack_holder = stack_holder;
-  p->fp_offset = fp_offset;
-  p->sp_offset = sp_offset;
-  p->ip = ip;
-  return scm_cell (scm_tc7_frame | (frame_kind << 8), (scm_t_bits)p);
+  p->stack_holder = frame->stack_holder;
+  p->fp_offset = frame->fp_offset;
+  p->sp_offset = frame->sp_offset;
+  p->ip = frame->ip;
+  return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
 }
 
 void
@@ -60,7 +58,7 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
 }
 
 static SCM*
-frame_stack_base (enum scm_vm_frame_kind kind, struct scm_frame *frame)
+frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
   switch (kind)
     {
@@ -76,7 +74,7 @@ frame_stack_base (enum scm_vm_frame_kind kind, struct scm_frame *frame)
 }
 
 static scm_t_ptrdiff
-frame_offset (enum scm_vm_frame_kind kind, struct scm_frame *frame)
+frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
   switch (kind)
     {
@@ -126,13 +124,33 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+/* Retrieve the local in slot 0, which may or may not actually be a
+   procedure, and may or may not actually be the procedure being
+   applied.  If you want the procedure, look it up from the IP.  */
+SCM
+scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+  SCM *fp, *sp;
+
+  fp = frame_stack_base (kind, frame) + frame->fp_offset;
+  sp = frame_stack_base (kind, frame) + frame->sp_offset;
+
+  if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
+    return SCM_FRAME_LOCAL (fp, 0);
+
+  return SCM_BOOL_F;
+}
+
 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
            (SCM frame),
            "")
 #define FUNC_NAME s_scm_frame_procedure
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
-  return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+
+  /* FIXME: Retrieve procedure from address?  */
+  return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
+                              SCM_VM_FRAME_DATA (frame));
 }
 #undef FUNC_NAME
 
@@ -159,6 +177,27 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+static SCM frame_call_representation_var;
+
+static void
+init_frame_call_representation_var (void)
+{
+  frame_call_representation_var
+    = scm_c_private_lookup ("system vm frame", "frame-call-representation");
+}
+
+SCM scm_frame_call_representation (SCM frame)
+#define FUNC_NAME "frame-call-representation"
+{
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_frame_call_representation_var);
+
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
            (SCM frame),
            "")
@@ -238,7 +277,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_address
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
-  return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
+  return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
 }
 #undef FUNC_NAME
 
@@ -249,7 +288,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
 
-  return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
+  return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
 }
 #undef FUNC_NAME
 
@@ -296,29 +335,36 @@ int
 scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
 {
   SCM *this_fp, *new_fp, *new_sp;
-  SCM proc;
+  SCM *stack_base = frame_stack_base (kind, frame);
 
  again:
-  this_fp = frame->fp_offset + frame_stack_base (kind, frame);
+  this_fp = frame->fp_offset + stack_base;
+
+  if (this_fp == stack_base)
+    return 0;
+
   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
-  if (new_fp) 
-    {
-      SCM *stack_base = frame_stack_base (kind, frame);
-      new_fp = RELOC (kind, frame, new_fp);
-      new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
-      frame->fp_offset = new_fp - stack_base;
-      frame->sp_offset = new_sp - stack_base;
-      frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
-
-      proc = SCM_FRAME_PROGRAM (new_fp);
-
-      if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
-        goto again;
-      else
-        return 1;
-    }
-  else
+
+  if (!new_fp)
+    return 0;
+
+  new_fp = RELOC (kind, frame, new_fp);
+
+  if (new_fp < stack_base)
     return 0;
+
+  new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
+  frame->fp_offset = new_fp - stack_base;
+  frame->sp_offset = new_sp - stack_base;
+  frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
+
+  {
+    SCM proc = scm_c_frame_closure (kind, frame);
+    if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
+      goto again;
+  }
+
+  return 1;
 }
 
 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
@@ -337,8 +383,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
   if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
     return SCM_BOOL_F;
 
-  return scm_c_make_frame (kind, tmp.stack_holder, tmp.fp_offset,
-                           tmp.sp_offset, tmp.ip);
+  return scm_c_make_frame (kind, &tmp);
 }
 #undef FUNC_NAME