1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
29 /* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
30 verify (sizeof (SCM
) == sizeof (SCM
*));
31 verify (sizeof (struct scm_vm_frame
) == 5 * sizeof (SCM
));
32 verify (offsetof (struct scm_vm_frame
, dynamic_link
) == 0);
35 #define RELOC(frame, val) \
36 (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
39 scm_c_make_frame (SCM stack_holder
, SCM
*fp
, SCM
*sp
,
40 scm_t_uint8
*ip
, scm_t_ptrdiff offset
)
42 struct scm_frame
*p
= scm_gc_malloc (sizeof (struct scm_frame
),
44 p
->stack_holder
= stack_holder
;
49 return scm_cell (scm_tc7_frame
, (scm_t_bits
)p
);
53 scm_i_frame_print (SCM frame
, SCM port
, scm_print_state
*pstate
)
55 scm_puts_unlocked ("#<frame ", port
);
56 scm_uintprint (SCM_UNPACK (frame
), 16, port
);
57 scm_putc_unlocked (' ', port
);
58 scm_write (scm_frame_procedure (frame
), port
);
59 /* don't write args, they can get us into trouble. */
60 scm_puts_unlocked (">", port
);
64 /* Scheme interface */
66 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
69 #define FUNC_NAME s_scm_frame_p
71 return scm_from_bool (SCM_VM_FRAME_P (obj
));
75 SCM_DEFINE (scm_frame_procedure
, "frame-procedure", 1, 0, 0,
78 #define FUNC_NAME s_scm_frame_procedure
80 SCM_VALIDATE_VM_FRAME (1, frame
);
81 return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame
));
85 SCM_DEFINE (scm_frame_arguments
, "frame-arguments", 1, 0, 0,
88 #define FUNC_NAME s_scm_frame_arguments
90 static SCM var
= SCM_BOOL_F
;
92 SCM_VALIDATE_VM_FRAME (1, frame
);
94 if (scm_is_false (var
))
95 var
= scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
98 return scm_call_1 (SCM_VARIABLE_REF (var
), frame
);
102 SCM_DEFINE (scm_frame_source
, "frame-source", 1, 0, 0,
105 #define FUNC_NAME s_scm_frame_source
109 SCM_VALIDATE_VM_FRAME (1, frame
);
111 proc
= scm_frame_procedure (frame
);
113 if (SCM_PROGRAM_P (proc
))
114 return scm_program_source (scm_frame_procedure (frame
),
115 scm_frame_instruction_pointer (frame
),
122 /* The number of locals would be a simple thing to compute, if it weren't for
123 the presence of not-yet-active frames on the stack. So we have a cheap
124 heuristic to detect not-yet-active frames, and skip over them. Perhaps we
125 should represent them more usefully.
127 SCM_DEFINE (scm_frame_num_locals
, "frame-num-locals", 1, 0, 0,
130 #define FUNC_NAME s_scm_frame_num_locals
135 SCM_VALIDATE_VM_FRAME (1, frame
);
137 sp
= SCM_VM_FRAME_SP (frame
);
138 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
141 if (SCM_UNPACK (p
[0]) == 0)
142 /* skip over not-yet-active frame */
150 return scm_from_uint (n
);
154 /* Need same not-yet-active frame logic here as in frame-num-locals */
155 SCM_DEFINE (scm_frame_local_ref
, "frame-local-ref", 2, 0, 0,
156 (SCM frame
, SCM index
),
158 #define FUNC_NAME s_scm_frame_local_ref
164 SCM_VALIDATE_VM_FRAME (1, frame
);
165 SCM_VALIDATE_UINT_COPY (2, index
, i
);
167 sp
= SCM_VM_FRAME_SP (frame
);
168 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
171 if (SCM_UNPACK (p
[0]) == 0)
172 /* skip over not-yet-active frame */
182 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
186 /* Need same not-yet-active frame logic here as in frame-num-locals */
187 SCM_DEFINE (scm_frame_local_set_x
, "frame-local-set!", 3, 0, 0,
188 (SCM frame
, SCM index
, SCM val
),
190 #define FUNC_NAME s_scm_frame_local_set_x
196 SCM_VALIDATE_VM_FRAME (1, frame
);
197 SCM_VALIDATE_UINT_COPY (2, index
, i
);
199 sp
= SCM_VM_FRAME_SP (frame
);
200 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
203 if (SCM_UNPACK (p
[0]) == 0)
204 /* skip over not-yet-active frame */
209 return SCM_UNSPECIFIED
;
217 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
221 SCM_DEFINE (scm_frame_address
, "frame-address", 1, 0, 0,
223 "Return the frame pointer for @var{frame}.")
224 #define FUNC_NAME s_scm_frame_address
226 SCM_VALIDATE_VM_FRAME (1, frame
);
227 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_FRAME_FP (frame
));
231 SCM_DEFINE (scm_frame_stack_pointer
, "frame-stack-pointer", 1, 0, 0,
234 #define FUNC_NAME s_scm_frame_stack_pointer
236 SCM_VALIDATE_VM_FRAME (1, frame
);
238 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_FRAME_SP (frame
));
242 SCM_DEFINE (scm_frame_instruction_pointer
, "frame-instruction-pointer", 1, 0, 0,
245 #define FUNC_NAME s_scm_frame_instruction_pointer
248 const struct scm_objcode
*c_objcode
;
250 SCM_VALIDATE_VM_FRAME (1, frame
);
251 program
= scm_frame_procedure (frame
);
253 if (!SCM_PROGRAM_P (program
))
256 c_objcode
= SCM_PROGRAM_DATA (program
);
257 return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame
)
258 - SCM_C_OBJCODE_BASE (c_objcode
)));
262 SCM_DEFINE (scm_frame_return_address
, "frame-return-address", 1, 0, 0,
265 #define FUNC_NAME s_scm_frame_return_address
267 SCM_VALIDATE_VM_FRAME (1, frame
);
268 return scm_from_unsigned_integer ((scm_t_bits
)
269 (SCM_FRAME_RETURN_ADDRESS
270 (SCM_VM_FRAME_FP (frame
))));
274 SCM_DEFINE (scm_frame_mv_return_address
, "frame-mv-return-address", 1, 0, 0,
277 #define FUNC_NAME s_scm_frame_mv_return_address
279 SCM_VALIDATE_VM_FRAME (1, frame
);
280 return scm_from_unsigned_integer ((scm_t_bits
)
281 (SCM_FRAME_MV_RETURN_ADDRESS
282 (SCM_VM_FRAME_FP (frame
))));
286 SCM_DEFINE (scm_frame_dynamic_link
, "frame-dynamic-link", 1, 0, 0,
289 #define FUNC_NAME s_scm_frame_dynamic_link
291 SCM_VALIDATE_VM_FRAME (1, frame
);
292 /* fixme: munge fp if holder is a continuation */
293 return scm_from_ulong
296 SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame
))));
300 SCM_DEFINE (scm_frame_previous
, "frame-previous", 1, 0, 0,
303 #define FUNC_NAME s_scm_frame_previous
305 SCM
*this_fp
, *new_fp
, *new_sp
;
308 SCM_VALIDATE_VM_FRAME (1, frame
);
311 this_fp
= SCM_VM_FRAME_FP (frame
);
312 new_fp
= SCM_FRAME_DYNAMIC_LINK (this_fp
);
315 new_fp
= RELOC (frame
, new_fp
);
316 new_sp
= SCM_FRAME_LOWER_ADDRESS (this_fp
) - 1;
317 frame
= scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame
),
319 SCM_FRAME_RETURN_ADDRESS (this_fp
),
320 SCM_VM_FRAME_OFFSET (frame
));
321 proc
= scm_frame_procedure (frame
);
323 if (SCM_PROGRAM_P (proc
) && SCM_PROGRAM_IS_BOOT (proc
))
335 scm_init_frames (void)
337 #ifndef SCM_MAGIC_SNARFER
338 #include "libguile/frames.x"