1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
31 verify (sizeof (SCM
) == sizeof (SCM
*));
32 verify (sizeof (struct scm_vm_frame
) == 3 * sizeof (SCM
));
33 verify (offsetof (struct scm_vm_frame
, dynamic_link
) == 0);
36 #define RELOC(frame, val) \
37 (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
40 scm_c_make_frame (enum scm_vm_frame_kind frame_kind
, void *stack_holder
,
41 scm_t_ptrdiff fp_offset
, scm_t_ptrdiff sp_offset
,
44 struct scm_frame
*p
= scm_gc_malloc (sizeof (struct scm_frame
),
46 p
->stack_holder
= stack_holder
;
47 p
->fp_offset
= fp_offset
;
48 p
->sp_offset
= sp_offset
;
50 return scm_cell (scm_tc7_frame
| (frame_kind
<< 8), (scm_t_bits
)p
);
54 scm_i_frame_print (SCM frame
, SCM port
, scm_print_state
*pstate
)
56 scm_puts_unlocked ("#<frame ", port
);
57 scm_uintprint (SCM_UNPACK (frame
), 16, port
);
58 scm_putc_unlocked (' ', port
);
59 scm_write (scm_frame_procedure (frame
), port
);
60 /* don't write args, they can get us into trouble. */
61 scm_puts_unlocked (">", port
);
65 scm_i_frame_stack_base (SCM frame
)
66 #define FUNC_NAME "frame-stack-base"
70 SCM_VALIDATE_VM_FRAME (1, frame
);
72 stack_holder
= SCM_VM_FRAME_STACK_HOLDER (frame
);
74 switch (SCM_VM_FRAME_KIND (frame
))
76 case SCM_VM_FRAME_KIND_CONT
:
77 return ((struct scm_vm_cont
*) stack_holder
)->stack_base
;
79 case SCM_VM_FRAME_KIND_VM
:
80 return ((struct scm_vm
*) stack_holder
)->stack_base
;
89 scm_i_frame_offset (SCM frame
)
90 #define FUNC_NAME "frame-offset"
94 SCM_VALIDATE_VM_FRAME (1, frame
);
96 stack_holder
= SCM_VM_FRAME_STACK_HOLDER (frame
);
98 switch (SCM_VM_FRAME_KIND (frame
))
100 case SCM_VM_FRAME_KIND_CONT
:
101 return ((struct scm_vm_cont
*) stack_holder
)->reloc
;
103 case SCM_VM_FRAME_KIND_VM
:
113 /* Scheme interface */
115 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
118 #define FUNC_NAME s_scm_frame_p
120 return scm_from_bool (SCM_VM_FRAME_P (obj
));
124 SCM_DEFINE (scm_frame_procedure
, "frame-procedure", 1, 0, 0,
127 #define FUNC_NAME s_scm_frame_procedure
129 SCM_VALIDATE_VM_FRAME (1, frame
);
130 return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame
));
134 SCM_DEFINE (scm_frame_arguments
, "frame-arguments", 1, 0, 0,
137 #define FUNC_NAME s_scm_frame_arguments
139 static SCM var
= SCM_BOOL_F
;
141 SCM_VALIDATE_VM_FRAME (1, frame
);
143 if (scm_is_false (var
))
144 var
= scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
147 return scm_call_1 (SCM_VARIABLE_REF (var
), frame
);
151 SCM_DEFINE (scm_frame_source
, "frame-source", 1, 0, 0,
154 #define FUNC_NAME s_scm_frame_source
156 SCM_VALIDATE_VM_FRAME (1, frame
);
158 return scm_find_source_for_addr (scm_frame_instruction_pointer (frame
));
162 SCM_DEFINE (scm_frame_num_locals
, "frame-num-locals", 1, 0, 0,
165 #define FUNC_NAME s_scm_frame_num_locals
169 SCM_VALIDATE_VM_FRAME (1, frame
);
171 fp
= SCM_VM_FRAME_FP (frame
);
172 sp
= SCM_VM_FRAME_SP (frame
);
174 return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp
, sp
));
178 SCM_DEFINE (scm_frame_local_ref
, "frame-local-ref", 2, 0, 0,
179 (SCM frame
, SCM index
),
181 #define FUNC_NAME s_scm_frame_local_ref
186 SCM_VALIDATE_VM_FRAME (1, frame
);
187 SCM_VALIDATE_UINT_COPY (2, index
, i
);
189 fp
= SCM_VM_FRAME_FP (frame
);
190 sp
= SCM_VM_FRAME_SP (frame
);
192 if (i
< SCM_FRAME_NUM_LOCALS (fp
, sp
))
193 return SCM_FRAME_LOCAL (fp
, i
);
195 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
199 /* Need same not-yet-active frame logic here as in frame-num-locals */
200 SCM_DEFINE (scm_frame_local_set_x
, "frame-local-set!", 3, 0, 0,
201 (SCM frame
, SCM index
, SCM val
),
203 #define FUNC_NAME s_scm_frame_local_set_x
208 SCM_VALIDATE_VM_FRAME (1, frame
);
209 SCM_VALIDATE_UINT_COPY (2, index
, i
);
211 fp
= SCM_VM_FRAME_FP (frame
);
212 sp
= SCM_VM_FRAME_SP (frame
);
214 if (i
< SCM_FRAME_NUM_LOCALS (fp
, sp
))
216 SCM_FRAME_LOCAL (fp
, i
) = val
;
217 return SCM_UNSPECIFIED
;
220 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
224 SCM_DEFINE (scm_frame_address
, "frame-address", 1, 0, 0,
226 "Return the frame pointer for @var{frame}.")
227 #define FUNC_NAME s_scm_frame_address
229 SCM_VALIDATE_VM_FRAME (1, frame
);
230 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_VM_FRAME_FP (frame
));
234 SCM_DEFINE (scm_frame_stack_pointer
, "frame-stack-pointer", 1, 0, 0,
237 #define FUNC_NAME s_scm_frame_stack_pointer
239 SCM_VALIDATE_VM_FRAME (1, frame
);
241 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_VM_FRAME_SP (frame
));
245 SCM_DEFINE (scm_frame_instruction_pointer
, "frame-instruction-pointer", 1, 0, 0,
248 #define FUNC_NAME s_scm_frame_instruction_pointer
250 SCM_VALIDATE_VM_FRAME (1, frame
);
252 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_VM_FRAME_IP (frame
));
256 SCM_DEFINE (scm_frame_return_address
, "frame-return-address", 1, 0, 0,
259 #define FUNC_NAME s_scm_frame_return_address
261 SCM_VALIDATE_VM_FRAME (1, frame
);
262 return scm_from_uintptr_t ((scm_t_uintptr
) (SCM_FRAME_RETURN_ADDRESS
263 (SCM_VM_FRAME_FP (frame
))));
267 SCM_DEFINE (scm_frame_dynamic_link
, "frame-dynamic-link", 1, 0, 0,
270 #define FUNC_NAME s_scm_frame_dynamic_link
272 SCM_VALIDATE_VM_FRAME (1, frame
);
273 /* fixme: munge fp if holder is a continuation */
274 return scm_from_uintptr_t
277 SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame
))));
281 SCM_DEFINE (scm_frame_previous
, "frame-previous", 1, 0, 0,
284 #define FUNC_NAME s_scm_frame_previous
286 SCM
*this_fp
, *new_fp
, *new_sp
;
289 SCM_VALIDATE_VM_FRAME (1, frame
);
292 this_fp
= SCM_VM_FRAME_FP (frame
);
293 new_fp
= SCM_FRAME_DYNAMIC_LINK (this_fp
);
296 SCM
*stack_base
= scm_i_frame_stack_base (frame
);
297 new_fp
= RELOC (frame
, new_fp
);
298 new_sp
= SCM_FRAME_PREVIOUS_SP (this_fp
);
299 frame
= scm_c_make_frame (SCM_VM_FRAME_KIND (frame
),
300 SCM_VM_FRAME_STACK_HOLDER (frame
),
301 new_fp
- stack_base
, new_sp
- stack_base
,
302 SCM_FRAME_RETURN_ADDRESS (this_fp
));
303 proc
= scm_frame_procedure (frame
);
305 if (SCM_PROGRAM_P (proc
) && SCM_PROGRAM_IS_BOOT (proc
))
317 scm_init_frames (void)
319 #ifndef SCM_MAGIC_SNARFER
320 #include "libguile/frames.x"