Merge remote-tracking branch 'origin/stable-2.0'

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

diff --git a/libguile/frames.c b/libguile/frames.c
index b805137..8ce5aa0 100644 (file)
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -24,9 +24,16 @@
 #include <string.h>
 #include "_scm.h"
 #include "frames.h"
+#include <verify.h>
+
+/* Make sure assumptions on the layout of `struct scm_vm_frame' hold.  */
+verify (sizeof (SCM) == sizeof (SCM *));
+verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM));
+verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
 
 \f
-#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
+#define RELOC(frame, val)                              \
+  (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
 
 SCM
 scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
@@ -97,11 +104,18 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
            "")
 #define FUNC_NAME s_scm_frame_source
 {
+  SCM proc;
+
   SCM_VALIDATE_VM_FRAME (1, frame);
 
-  return scm_program_source (scm_frame_procedure (frame),
-                             scm_frame_instruction_pointer (frame),
-                             SCM_UNDEFINED);
+  proc = scm_frame_procedure (frame);
+
+  if (SCM_PROGRAM_P (proc))
+    return scm_program_source (scm_frame_procedure (frame),
+                               scm_frame_instruction_pointer (frame),
+                               SCM_UNDEFINED);
+
+  return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -115,11 +129,21 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
            "")
 #define FUNC_NAME s_scm_frame_num_locals
 {
-  SCM *sp, *p;
+  SCM *fp, *sp, *p;
   unsigned int n = 0;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
 
+  fp = SCM_VM_FRAME_FP (frame);
+  sp = SCM_VM_FRAME_SP (frame);
+  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+
+  if (SCM_RTL_PROGRAM_P (fp[-1]))
+    /* The frame size of an RTL program is fixed, except in the case of
+       passing a wrong number of arguments to the program.  So we do
+       need to use an SP for determining the number of locals.  */
+    return scm_from_uint32 (sp + 1 - p);
+
   sp = SCM_VM_FRAME_SP (frame);
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)
@@ -230,11 +254,16 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
            "")
 #define FUNC_NAME s_scm_frame_instruction_pointer
 {
+  SCM program;
   const struct scm_objcode *c_objcode;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
+  program = scm_frame_procedure (frame);
 
-  c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
+  if (!SCM_PROGRAM_P (program))
+    return SCM_INUM0;
+
+  c_objcode = SCM_PROGRAM_DATA (program);
   return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
                                      - SCM_C_OBJCODE_BASE (c_objcode)));
 }
@@ -284,6 +313,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_previous
 {
   SCM *this_fp, *new_fp, *new_sp;
+  SCM proc;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
 
@@ -291,13 +321,16 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
   this_fp = SCM_VM_FRAME_FP (frame);
   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
   if (new_fp) 
-    { new_fp = RELOC (frame, new_fp);
+    {
+      new_fp = RELOC (frame, new_fp);
       new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
       frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
                                 new_fp, new_sp,
                                 SCM_FRAME_RETURN_ADDRESS (this_fp),
                                 SCM_VM_FRAME_OFFSET (frame));
-      if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+      proc = scm_frame_procedure (frame);
+
+      if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
         goto again;
       else
         return frame;