1 /* Copyright (C) 2001, 2009 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
26 #include "vm-bootstrap.h"
30 scm_t_bits scm_tc16_frame
;
32 #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
35 scm_c_make_frame (SCM stack_holder
, SCM
*fp
, SCM
*sp
,
36 scm_t_uint8
*ip
, scm_t_ptrdiff offset
)
38 struct scm_frame
*p
= scm_gc_malloc (sizeof (struct scm_frame
),
40 p
->stack_holder
= stack_holder
;
45 SCM_RETURN_NEWSMOB (scm_tc16_frame
, p
);
49 frame_print (SCM frame
, SCM port
, scm_print_state
*pstate
)
51 scm_puts ("#<frame ", port
);
52 scm_uintprint (SCM_UNPACK (frame
), 16, port
);
54 scm_write (scm_frame_procedure (frame
), port
);
55 /* don't write args, they can get us into trouble. */
62 /* Scheme interface */
64 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
67 #define FUNC_NAME s_scm_frame_p
69 return scm_from_bool (SCM_VM_FRAME_P (obj
));
73 SCM_DEFINE (scm_frame_procedure
, "frame-procedure", 1, 0, 0,
76 #define FUNC_NAME s_scm_frame_procedure
78 SCM_VALIDATE_VM_FRAME (1, frame
);
79 return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame
));
83 SCM_DEFINE (scm_frame_arguments
, "frame-arguments", 1, 0, 0,
86 #define FUNC_NAME s_scm_frame_arguments
88 static SCM var
= SCM_BOOL_F
;
90 SCM_VALIDATE_VM_FRAME (1, frame
);
92 if (scm_is_false (var
))
93 var
= scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
96 return scm_call_1 (SCM_VARIABLE_REF (var
), frame
);
100 SCM_DEFINE (scm_frame_source
, "frame-source", 1, 0, 0,
103 #define FUNC_NAME s_scm_frame_source
106 struct scm_objcode
*bp
;
108 SCM_VALIDATE_VM_FRAME (1, frame
);
110 fp
= SCM_VM_FRAME_FP (frame
);
111 bp
= SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp
));
113 return scm_c_program_source (SCM_FRAME_PROGRAM (fp
),
114 SCM_VM_FRAME_IP (frame
)
115 - SCM_C_OBJCODE_BASE (bp
));
119 /* The number of locals would be a simple thing to compute, if it weren't for
120 the presence of not-yet-active frames on the stack. So we have a cheap
121 heuristic to detect not-yet-active frames, and skip over them. Perhaps we
122 should represent them more usefully.
124 SCM_DEFINE (scm_frame_num_locals
, "frame-num-locals", 1, 0, 0,
127 #define FUNC_NAME s_scm_frame_num_locals
132 SCM_VALIDATE_VM_FRAME (1, frame
);
134 sp
= SCM_VM_FRAME_SP (frame
);
135 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
138 if (p
+ 1 < sp
&& p
[1] == (SCM
)0)
139 /* skip over not-yet-active frame */
147 return scm_from_uint (n
);
151 /* Need same not-yet-active frame logic here as in frame-num-locals */
152 SCM_DEFINE (scm_frame_local_ref
, "frame-local-ref", 2, 0, 0,
153 (SCM frame
, SCM index
),
155 #define FUNC_NAME s_scm_frame_local_ref
161 SCM_VALIDATE_VM_FRAME (1, frame
);
162 SCM_VALIDATE_UINT_COPY (2, index
, i
);
164 sp
= SCM_VM_FRAME_SP (frame
);
165 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
168 if (p
+ 1 < sp
&& p
[1] == (SCM
)0)
169 /* skip over not-yet-active frame */
179 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
183 /* Need same not-yet-active frame logic here as in frame-num-locals */
184 SCM_DEFINE (scm_frame_local_set_x
, "frame-local-set!", 3, 0, 0,
185 (SCM frame
, SCM index
, SCM val
),
187 #define FUNC_NAME s_scm_frame_local_set_x
193 SCM_VALIDATE_VM_FRAME (1, frame
);
194 SCM_VALIDATE_UINT_COPY (2, index
, i
);
196 sp
= SCM_VM_FRAME_SP (frame
);
197 p
= SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame
));
200 if (p
+ 1 < sp
&& p
[1] == (SCM
)0)
201 /* skip over not-yet-active frame */
206 return SCM_UNSPECIFIED
;
214 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
218 SCM_DEFINE (scm_frame_instruction_pointer
, "frame-instruction-pointer", 1, 0, 0,
221 #define FUNC_NAME s_scm_frame_instruction_pointer
223 const struct scm_objcode
*c_objcode
;
225 SCM_VALIDATE_VM_FRAME (1, frame
);
227 c_objcode
= SCM_PROGRAM_DATA (scm_frame_procedure (frame
));
228 return scm_from_ulong ((unsigned long)
229 (SCM_VM_FRAME_IP (frame
)
230 - SCM_C_OBJCODE_BASE (c_objcode
)));
234 SCM_DEFINE (scm_frame_return_address
, "frame-return-address", 1, 0, 0,
237 #define FUNC_NAME s_scm_frame_return_address
239 SCM_VALIDATE_VM_FRAME (1, frame
);
240 return scm_from_ulong ((unsigned long)
241 (SCM_FRAME_RETURN_ADDRESS
242 (SCM_VM_FRAME_FP (frame
))));
246 SCM_DEFINE (scm_frame_mv_return_address
, "frame-mv-return-address", 1, 0, 0,
249 #define FUNC_NAME s_scm_frame_mv_return_address
251 SCM_VALIDATE_VM_FRAME (1, frame
);
252 return scm_from_ulong ((unsigned long)
253 (SCM_FRAME_MV_RETURN_ADDRESS
254 (SCM_VM_FRAME_FP (frame
))));
258 SCM_DEFINE (scm_frame_dynamic_link
, "frame-dynamic-link", 1, 0, 0,
261 #define FUNC_NAME s_scm_frame_dynamic_link
263 SCM_VALIDATE_VM_FRAME (1, frame
);
264 /* fixme: munge fp if holder is a continuation */
265 return scm_from_ulong
268 SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame
))));
272 SCM_DEFINE (scm_frame_previous
, "frame-previous", 1, 0, 0,
275 #define FUNC_NAME s_scm_frame_previous
277 SCM
*this_fp
, *new_fp
, *new_sp
;
279 SCM_VALIDATE_VM_FRAME (1, frame
);
282 this_fp
= SCM_VM_FRAME_FP (frame
);
283 new_fp
= SCM_FRAME_DYNAMIC_LINK (this_fp
);
285 { new_fp
= RELOC (frame
, new_fp
);
286 new_sp
= SCM_FRAME_LOWER_ADDRESS (this_fp
) - 1;
287 frame
= scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame
),
289 SCM_FRAME_RETURN_ADDRESS (this_fp
),
290 SCM_VM_FRAME_OFFSET (frame
));
291 if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame
)))
303 scm_bootstrap_frames (void)
305 scm_tc16_frame
= scm_make_smob_type ("frame", 0);
306 scm_set_smob_print (scm_tc16_frame
, frame_print
);
310 scm_init_frames (void)
312 #ifndef SCM_MAGIC_SNARFER
313 #include "libguile/frames.x"