summaryrefslogtreecommitdiff
path: root/libguile/frames.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/frames.c')
-rw-r--r--libguile/frames.c152
1 files changed, 94 insertions, 58 deletions
diff --git a/libguile/frames.c b/libguile/frames.c
index a6835fbb4..39f78e09a 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -80,32 +80,19 @@ SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_arguments
+SCM
+scm_vm_frame_arguments (SCM frame)
+#define FUNC_NAME "vm-frame-arguments"
{
- SCM *fp;
- int i;
- struct scm_objcode *bp;
- SCM ret;
+ static SCM var = SCM_BOOL_F;
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "vm-frame-arguments");
- if (!bp->nargs)
- return SCM_EOL;
- else if (bp->nrest)
- ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
- else
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
-
- for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
-
- return ret;
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
@@ -127,47 +114,114 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
}
#undef FUNC_NAME
+/* The number of locals would be a simple thing to compute, if it weren't for
+ the presence of not-yet-active frames on the stack. So we have a cheap
+ heuristic to detect not-yet-active frames, and skip over them. Perhaps we
+ should represent them more usefully.
+ */
+SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_num_locals
+{
+ SCM *sp, *p;
+ unsigned int n = 0;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ return scm_from_uint (n);
+}
+#undef FUNC_NAME
+
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_vm_frame_local_ref
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- return SCM_FRAME_VARIABLE (fp, i);
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ return *p;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
#define FUNC_NAME s_scm_vm_frame_local_set_x
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- SCM_FRAME_VARIABLE (fp, i) = val;
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ {
+ *p = val;
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
+}
+#undef FUNC_NAME
- return SCM_UNSPECIFIED;
+SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_instruction_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_VM_FRAME_IP (frame)
+ - SCM_PROGRAM_DATA (scm_vm_frame_program (frame))->base));
}
#undef FUNC_NAME
@@ -209,24 +263,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_stack
-{
- SCM *top, *bottom, ret = SCM_EOL;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- top = SCM_VM_FRAME_SP (frame);
- bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (bottom <= top)
- ret = scm_cons (*bottom++, ret);
-
- return ret;
-}
-#undef FUNC_NAME
-
extern SCM
scm_c_vm_frame_prev (SCM frame)
{