Commit | Line | Data |
---|---|---|
20d47c39 | 1 | /* Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
ac99cb0c | 2 | * |
560b9c25 | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
ac99cb0c | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
560b9c25 AW |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
ac99cb0c | 12 | * |
560b9c25 AW |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
560b9c25 | 17 | */ |
ac99cb0c | 18 | |
13c47753 AW |
19 | #if HAVE_CONFIG_H |
20 | # include <config.h> | |
21 | #endif | |
22 | ||
da8b4747 | 23 | #include <stdlib.h> |
ac99cb0c | 24 | #include <string.h> |
560b9c25 | 25 | #include "_scm.h" |
83495480 | 26 | #include "vm-bootstrap.h" |
ac99cb0c KN |
27 | #include "frames.h" |
28 | ||
29 | \f | |
b1b942b7 AW |
30 | scm_t_bits scm_tc16_vm_frame; |
31 | ||
32 | #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame)) | |
ac99cb0c KN |
33 | |
34 | SCM | |
b1b942b7 | 35 | scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, |
2fb924f6 | 36 | scm_t_uint8 *ip, scm_t_ptrdiff offset) |
ac99cb0c | 37 | { |
b1b942b7 AW |
38 | struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame), |
39 | "vmframe"); | |
40 | p->stack_holder = stack_holder; | |
41 | p->fp = fp; | |
42 | p->sp = sp; | |
43 | p->ip = ip; | |
44 | p->offset = offset; | |
45 | SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p); | |
ac99cb0c KN |
46 | } |
47 | ||
2f9769b6 AW |
48 | static int |
49 | vm_frame_print (SCM frame, SCM port, scm_print_state *pstate) | |
50 | { | |
51 | scm_puts ("#<vm-frame ", port); | |
52 | scm_uintprint (SCM_UNPACK (frame), 16, port); | |
53 | scm_putc (' ', port); | |
54 | scm_write (scm_vm_frame_program (frame), port); | |
55 | /* don't write args, they can get us into trouble. */ | |
56 | scm_puts (">", port); | |
57 | ||
58 | return 1; | |
59 | } | |
60 | ||
3d94d862 | 61 | \f |
ac99cb0c KN |
62 | /* Scheme interface */ |
63 | ||
b1b942b7 | 64 | SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0, |
ac99cb0c KN |
65 | (SCM obj), |
66 | "") | |
b1b942b7 | 67 | #define FUNC_NAME s_scm_vm_frame_p |
ac99cb0c | 68 | { |
b1b942b7 AW |
69 | return SCM_BOOL (SCM_VM_FRAME_P (obj)); |
70 | } | |
71 | #undef FUNC_NAME | |
72 | ||
73 | SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0, | |
74 | (SCM frame), | |
75 | "") | |
76 | #define FUNC_NAME s_scm_vm_frame_program | |
77 | { | |
78 | SCM_VALIDATE_VM_FRAME (1, frame); | |
79 | return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame)); | |
80 | } | |
81 | #undef FUNC_NAME | |
82 | ||
6c6a4439 AW |
83 | SCM |
84 | scm_vm_frame_arguments (SCM frame) | |
85 | #define FUNC_NAME "vm-frame-arguments" | |
b1b942b7 | 86 | { |
6c6a4439 | 87 | static SCM var = SCM_BOOL_F; |
b1b942b7 AW |
88 | |
89 | SCM_VALIDATE_VM_FRAME (1, frame); | |
90 | ||
6c6a4439 AW |
91 | if (scm_is_false (var)) |
92 | var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"), | |
93 | "vm-frame-arguments"); | |
b1b942b7 | 94 | |
6c6a4439 | 95 | return scm_call_1 (SCM_VARIABLE_REF (var), frame); |
ac99cb0c KN |
96 | } |
97 | #undef FUNC_NAME | |
98 | ||
b1b942b7 | 99 | SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0, |
ac99cb0c KN |
100 | (SCM frame), |
101 | "") | |
b1b942b7 | 102 | #define FUNC_NAME s_scm_vm_frame_source |
ac99cb0c | 103 | { |
b1b942b7 | 104 | SCM *fp; |
53e28ed9 | 105 | struct scm_objcode *bp; |
b1b942b7 AW |
106 | |
107 | SCM_VALIDATE_VM_FRAME (1, frame); | |
108 | ||
109 | fp = SCM_VM_FRAME_FP (frame); | |
110 | bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp)); | |
111 | ||
53e28ed9 AW |
112 | return scm_c_program_source (SCM_FRAME_PROGRAM (fp), |
113 | SCM_VM_FRAME_IP (frame) - bp->base); | |
ac99cb0c KN |
114 | } |
115 | #undef FUNC_NAME | |
116 | ||
6c6a4439 AW |
117 | /* The number of locals would be a simple thing to compute, if it weren't for |
118 | the presence of not-yet-active frames on the stack. So we have a cheap | |
119 | heuristic to detect not-yet-active frames, and skip over them. Perhaps we | |
120 | should represent them more usefully. | |
121 | */ | |
122 | SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0, | |
123 | (SCM frame), | |
124 | "") | |
125 | #define FUNC_NAME s_scm_vm_frame_num_locals | |
126 | { | |
127 | SCM *sp, *p; | |
128 | unsigned int n = 0; | |
129 | ||
130 | SCM_VALIDATE_VM_FRAME (1, frame); | |
131 | ||
132 | sp = SCM_VM_FRAME_SP (frame); | |
133 | p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); | |
134 | while (p <= sp) | |
135 | { | |
136 | if (p + 1 < sp && p[1] == (SCM)0) | |
137 | /* skip over not-yet-active frame */ | |
138 | p += 3; | |
139 | else | |
140 | { | |
141 | p++; | |
142 | n++; | |
143 | } | |
144 | } | |
145 | return scm_from_uint (n); | |
146 | } | |
147 | #undef FUNC_NAME | |
148 | ||
149 | /* Need same not-yet-active frame logic here as in vm-frame-num-locals */ | |
b1b942b7 | 150 | SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0, |
af988bbf | 151 | (SCM frame, SCM index), |
ac99cb0c | 152 | "") |
b1b942b7 | 153 | #define FUNC_NAME s_scm_vm_frame_local_ref |
ac99cb0c | 154 | { |
6c6a4439 AW |
155 | SCM *sp, *p; |
156 | unsigned int n = 0; | |
b1b942b7 | 157 | unsigned int i; |
b1b942b7 | 158 | |
6c6a4439 | 159 | SCM_VALIDATE_VM_FRAME (1, frame); |
b1b942b7 | 160 | SCM_VALIDATE_UINT_COPY (2, index, i); |
b1b942b7 | 161 | |
6c6a4439 AW |
162 | sp = SCM_VM_FRAME_SP (frame); |
163 | p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); | |
164 | while (p <= sp) | |
165 | { | |
166 | if (p + 1 < sp && p[1] == (SCM)0) | |
167 | /* skip over not-yet-active frame */ | |
168 | p += 3; | |
169 | else if (n == i) | |
170 | return *p; | |
171 | else | |
172 | { | |
173 | p++; | |
174 | n++; | |
175 | } | |
176 | } | |
177 | SCM_OUT_OF_RANGE (SCM_ARG2, index); | |
af988bbf KN |
178 | } |
179 | #undef FUNC_NAME | |
ac99cb0c | 180 | |
6c6a4439 | 181 | /* Need same not-yet-active frame logic here as in vm-frame-num-locals */ |
b1b942b7 | 182 | SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0, |
af988bbf KN |
183 | (SCM frame, SCM index, SCM val), |
184 | "") | |
b1b942b7 | 185 | #define FUNC_NAME s_scm_vm_frame_local_set_x |
af988bbf | 186 | { |
6c6a4439 AW |
187 | SCM *sp, *p; |
188 | unsigned int n = 0; | |
b1b942b7 | 189 | unsigned int i; |
b1b942b7 | 190 | |
6c6a4439 | 191 | SCM_VALIDATE_VM_FRAME (1, frame); |
b1b942b7 | 192 | SCM_VALIDATE_UINT_COPY (2, index, i); |
b1b942b7 | 193 | |
6c6a4439 AW |
194 | sp = SCM_VM_FRAME_SP (frame); |
195 | p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); | |
196 | while (p <= sp) | |
197 | { | |
198 | if (p + 1 < sp && p[1] == (SCM)0) | |
199 | /* skip over not-yet-active frame */ | |
200 | p += 3; | |
201 | else if (n == i) | |
202 | { | |
203 | *p = val; | |
204 | return SCM_UNSPECIFIED; | |
205 | } | |
206 | else | |
207 | { | |
208 | p++; | |
209 | n++; | |
210 | } | |
211 | } | |
212 | SCM_OUT_OF_RANGE (SCM_ARG2, index); | |
213 | } | |
214 | #undef FUNC_NAME | |
b1b942b7 | 215 | |
6c6a4439 AW |
216 | SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer", 1, 0, 0, |
217 | (SCM frame), | |
218 | "") | |
219 | #define FUNC_NAME s_scm_vm_frame_instruction_pointer | |
220 | { | |
221 | SCM_VALIDATE_VM_FRAME (1, frame); | |
222 | return scm_from_ulong ((unsigned long) | |
223 | (SCM_VM_FRAME_IP (frame) | |
224 | - SCM_PROGRAM_DATA (scm_vm_frame_program (frame))->base)); | |
ac99cb0c KN |
225 | } |
226 | #undef FUNC_NAME | |
227 | ||
b1b942b7 | 228 | SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0, |
ac99cb0c KN |
229 | (SCM frame), |
230 | "") | |
b1b942b7 | 231 | #define FUNC_NAME s_scm_vm_frame_return_address |
ac99cb0c | 232 | { |
b1b942b7 | 233 | SCM_VALIDATE_VM_FRAME (1, frame); |
b6368dbb LC |
234 | return scm_from_ulong ((unsigned long) |
235 | (SCM_FRAME_RETURN_ADDRESS | |
b1b942b7 | 236 | (SCM_VM_FRAME_FP (frame)))); |
ac99cb0c KN |
237 | } |
238 | #undef FUNC_NAME | |
239 | ||
b1b942b7 | 240 | SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0, |
da320011 AW |
241 | (SCM frame), |
242 | "") | |
b1b942b7 | 243 | #define FUNC_NAME s_scm_vm_frame_mv_return_address |
da320011 | 244 | { |
b1b942b7 | 245 | SCM_VALIDATE_VM_FRAME (1, frame); |
da320011 AW |
246 | return scm_from_ulong ((unsigned long) |
247 | (SCM_FRAME_MV_RETURN_ADDRESS | |
b1b942b7 | 248 | (SCM_VM_FRAME_FP (frame)))); |
da320011 AW |
249 | } |
250 | #undef FUNC_NAME | |
251 | ||
b1b942b7 | 252 | SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0, |
ac99cb0c KN |
253 | (SCM frame), |
254 | "") | |
b1b942b7 | 255 | #define FUNC_NAME s_scm_vm_frame_dynamic_link |
ac99cb0c | 256 | { |
b1b942b7 AW |
257 | SCM_VALIDATE_VM_FRAME (1, frame); |
258 | /* fixme: munge fp if holder is a continuation */ | |
259 | return scm_from_ulong | |
260 | ((unsigned long) | |
261 | RELOC (frame, | |
262 | SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)))); | |
ac99cb0c KN |
263 | } |
264 | #undef FUNC_NAME | |
265 | ||
b1b942b7 AW |
266 | extern SCM |
267 | scm_c_vm_frame_prev (SCM frame) | |
268 | { | |
269 | SCM *this_fp, *new_fp, *new_sp; | |
270 | this_fp = SCM_VM_FRAME_FP (frame); | |
271 | new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp); | |
272 | if (new_fp) | |
273 | { new_fp = RELOC (frame, new_fp); | |
274 | new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1; | |
275 | return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame), | |
276 | new_fp, new_sp, | |
277 | SCM_FRAME_RETURN_ADDRESS (this_fp), | |
278 | SCM_VM_FRAME_OFFSET (frame)); | |
279 | } | |
280 | else | |
281 | return SCM_BOOL_F; | |
282 | } | |
283 | ||
ac99cb0c KN |
284 | \f |
285 | void | |
07e56b27 | 286 | scm_bootstrap_frames (void) |
ac99cb0c | 287 | { |
b1b942b7 | 288 | scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0); |
2f9769b6 | 289 | scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print); |
60ae5ca2 AW |
290 | scm_c_register_extension ("libguile", "scm_init_frames", |
291 | (scm_t_extension_init_func)scm_init_frames, NULL); | |
07e56b27 AW |
292 | } |
293 | ||
294 | void | |
295 | scm_init_frames (void) | |
296 | { | |
297 | scm_bootstrap_vm (); | |
ac99cb0c KN |
298 | |
299 | #ifndef SCM_MAGIC_SNARFER | |
aeeff258 | 300 | #include "libguile/frames.x" |
ac99cb0c KN |
301 | #endif |
302 | } | |
303 | ||
304 | /* | |
305 | Local Variables: | |
306 | c-file-style: "gnu" | |
307 | End: | |
308 | */ |