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