X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/58565208bdfe7544f7e4da8762e4c331171f9876..361d0de285587ef4c9f19b9e07c1175424520aa5:/libguile/frames.c

diff --git a/libguile/frames.c b/libguile/frames.c
index b57b1295d..b2973bf67 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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
@@ -104,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) || SCM_RTL_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
 
@@ -122,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)
@@ -237,11 +254,20 @@ 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);
+
+  if (SCM_RTL_PROGRAM_P (program))
+    return scm_from_ptrdiff_t (SCM_VM_FRAME_IP (frame) -
+                               (scm_t_uint8 *) SCM_RTL_PROGRAM_CODE (program));
 
-  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)));
 }
@@ -291,6 +317,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);
 
@@ -298,13 +325,17 @@ 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_RTL_PROGRAM_P (proc))
+          && SCM_PROGRAM_IS_BOOT (proc))
         goto again;
       else
         return frame;