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