Commit | Line | Data |
---|---|---|
a98cef7e KN |
1 | /* Copyright (C) 2000 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 | ||
17e90c5e KN |
42 | #include <string.h> |
43 | #include "instructions.h" | |
44 | #include "programs.h" | |
45 | #include "envs.h" | |
a98cef7e KN |
46 | #include "vm.h" |
47 | ||
a98cef7e KN |
48 | /* I sometimes use this for debugging. */ |
49 | #define vm_puts(OBJ) \ | |
50 | { \ | |
51 | scm_display (OBJ, scm_def_errp); \ | |
52 | scm_newline (scm_def_errp); \ | |
53 | } | |
54 | ||
55 | \f | |
e6db4668 | 56 | /* |
17e90c5e | 57 | * VM Debug frame |
a98cef7e KN |
58 | */ |
59 | ||
17e90c5e | 60 | scm_bits_t scm_tc16_vm_debug_frame; |
a98cef7e KN |
61 | |
62 | static SCM | |
17e90c5e | 63 | make_vm_debug_frame (SCM *fp) |
a98cef7e | 64 | { |
17e90c5e KN |
65 | int i, size; |
66 | struct scm_vm_debug_frame *p; | |
a98cef7e | 67 | |
17e90c5e | 68 | if (!fp) |
a98cef7e | 69 | return SCM_BOOL_F; |
a98cef7e | 70 | |
17e90c5e KN |
71 | p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame"); |
72 | p->program = SCM_VM_FRAME_PROGRAM (fp); | |
73 | p->dynamic_link = make_vm_debug_frame (SCM_VM_FRAME_ADDRESS | |
74 | (SCM_VM_FRAME_DYNAMIC_LINK (fp))); | |
a98cef7e | 75 | |
17e90c5e | 76 | size = SCM_PROGRAM_NARGS (p->program) + SCM_PROGRAM_NLOCS (p->program); |
a98cef7e KN |
77 | p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); |
78 | for (i = 0; i < size; i++) | |
79 | SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i); | |
80 | ||
17e90c5e | 81 | SCM_RETURN_NEWSMOB (scm_tc16_vm_debug_frame, p); |
a98cef7e KN |
82 | } |
83 | ||
84 | static SCM | |
17e90c5e | 85 | vm_debug_frame_mark (SCM obj) |
a98cef7e | 86 | { |
17e90c5e KN |
87 | scm_gc_mark (SCM_VM_DEBUG_FRAME_PROGRAM (obj)); |
88 | scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj)); | |
89 | return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj); | |
a98cef7e KN |
90 | } |
91 | ||
92 | /* Scheme interface */ | |
93 | ||
94 | SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, | |
95 | (SCM obj), | |
17e90c5e | 96 | "") |
a98cef7e KN |
97 | #define FUNC_NAME s_scm_frame_p |
98 | { | |
17e90c5e | 99 | return SCM_BOOL (SCM_VM_DEBUG_FRAME_P (obj)); |
a98cef7e KN |
100 | } |
101 | #undef FUNC_NAME | |
102 | ||
103 | SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, | |
104 | (SCM frame), | |
17e90c5e | 105 | "") |
a98cef7e KN |
106 | #define FUNC_NAME s_scm_frame_program |
107 | { | |
17e90c5e KN |
108 | SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); |
109 | return SCM_VM_DEBUG_FRAME_PROGRAM (frame); | |
a98cef7e KN |
110 | } |
111 | #undef FUNC_NAME | |
112 | ||
113 | SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, | |
114 | (SCM frame), | |
17e90c5e | 115 | "") |
a98cef7e KN |
116 | #define FUNC_NAME s_scm_frame_variables |
117 | { | |
17e90c5e KN |
118 | SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); |
119 | return SCM_VM_DEBUG_FRAME_VARIABLES (frame); | |
a98cef7e KN |
120 | } |
121 | #undef FUNC_NAME | |
122 | ||
123 | SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, | |
124 | (SCM frame), | |
17e90c5e | 125 | "") |
a98cef7e KN |
126 | #define FUNC_NAME s_scm_frame_dynamic_link |
127 | { | |
17e90c5e KN |
128 | SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); |
129 | return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame); | |
a98cef7e KN |
130 | } |
131 | #undef FUNC_NAME | |
132 | ||
133 | \f | |
134 | /* | |
135 | * VM Continuation | |
136 | */ | |
137 | ||
17e90c5e KN |
138 | scm_bits_t scm_tc16_vm_cont; |
139 | ||
140 | ||
141 | #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) | |
3d5ee0cd | 142 | #define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) |
a98cef7e KN |
143 | |
144 | static SCM | |
3d5ee0cd | 145 | capture_vm_cont (struct scm_vm *vp) |
a98cef7e KN |
146 | { |
147 | struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont"); | |
3d5ee0cd | 148 | p->stack_size = vp->stack_limit - vp->sp; |
a98cef7e KN |
149 | p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM), |
150 | "capture_vm_cont"); | |
17e90c5e | 151 | p->stack_limit = p->stack_base + p->stack_size - 2; |
3d5ee0cd KN |
152 | p->ip = vp->ip; |
153 | p->sp = (SCM *) (vp->stack_limit - vp->sp); | |
154 | p->fp = (SCM *) (vp->stack_limit - vp->fp); | |
155 | memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM)); | |
17e90c5e | 156 | SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p); |
a98cef7e KN |
157 | } |
158 | ||
159 | static void | |
3d5ee0cd | 160 | reinstate_vm_cont (struct scm_vm *vp, SCM cont) |
a98cef7e | 161 | { |
3d5ee0cd KN |
162 | struct scm_vm *p = SCM_VM_CONT_VP (cont); |
163 | if (vp->stack_size < p->stack_size) | |
a98cef7e | 164 | { |
17e90c5e | 165 | /* puts ("FIXME: Need to expand"); */ |
a98cef7e KN |
166 | abort (); |
167 | } | |
3d5ee0cd KN |
168 | vp->ip = p->ip; |
169 | vp->sp = vp->stack_limit - (int) p->sp; | |
170 | vp->fp = vp->stack_limit - (int) p->fp; | |
171 | memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); | |
a98cef7e KN |
172 | } |
173 | ||
174 | static SCM | |
17e90c5e | 175 | vm_cont_mark (SCM obj) |
a98cef7e KN |
176 | { |
177 | SCM *p; | |
3d5ee0cd KN |
178 | struct scm_vm *vp = SCM_VM_CONT_VP (obj); |
179 | for (p = vp->stack_base; p <= vp->stack_limit; p++) | |
a98cef7e KN |
180 | if (SCM_NIMP (*p)) |
181 | scm_gc_mark (*p); | |
182 | return SCM_BOOL_F; | |
183 | } | |
184 | ||
185 | static scm_sizet | |
17e90c5e | 186 | vm_cont_free (SCM obj) |
a98cef7e | 187 | { |
3d5ee0cd | 188 | struct scm_vm *p = SCM_VM_CONT_VP (obj); |
a98cef7e KN |
189 | int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM); |
190 | scm_must_free (p->stack_base); | |
191 | scm_must_free (p); | |
192 | return size; | |
193 | } | |
194 | ||
17e90c5e KN |
195 | \f |
196 | /* | |
197 | * VM Internal functions | |
198 | */ | |
199 | ||
200 | SCM_SYMBOL (sym_vm_engine, "vm-engine"); | |
201 | SCM_SYMBOL (sym_vm_error, "vm-error"); | |
202 | ||
203 | static scm_byte_t * | |
204 | vm_fetch_length (scm_byte_t *ip, size_t *lenp) | |
a98cef7e | 205 | { |
17e90c5e KN |
206 | *lenp = *ip++; |
207 | if (*lenp < 254) | |
208 | return ip; | |
209 | else if (*lenp == 254) | |
46cd9a34 KN |
210 | { |
211 | int b1 = *ip++; | |
212 | int b2 = *ip++; | |
213 | *lenp = (b1 << 8) + b2; | |
214 | } | |
17e90c5e | 215 | else |
46cd9a34 KN |
216 | { |
217 | int b1 = *ip++; | |
218 | int b2 = *ip++; | |
219 | int b3 = *ip++; | |
220 | int b4 = *ip++; | |
221 | *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4; | |
222 | } | |
17e90c5e | 223 | return ip; |
a98cef7e KN |
224 | } |
225 | ||
226 | \f | |
227 | /* | |
228 | * VM | |
229 | */ | |
230 | ||
17e90c5e KN |
231 | #define VM_DEFAULT_STACK_SIZE (16 * 1024) |
232 | #define VM_MAXIMUM_STACK_SIZE (128 * 1024) | |
233 | ||
234 | #define VM_REGULAR_ENGINE 0 | |
235 | #define VM_DEBUG_ENGINE 1 | |
236 | ||
237 | #if 0 | |
238 | #define VM_NAME vm_regular_engine | |
239 | #define VM_ENGINE VM_REGULAR_ENGINE | |
240 | #include "vm_engine.c" | |
241 | #undef VM_NAME | |
242 | #undef VM_ENGINE | |
243 | #endif | |
244 | ||
245 | #define VM_NAME vm_debug_engine | |
246 | #define VM_ENGINE VM_DEBUG_ENGINE | |
247 | #include "vm_engine.c" | |
248 | #undef VM_NAME | |
249 | #undef VM_ENGINE | |
250 | ||
251 | scm_bits_t scm_tc16_vm; | |
a98cef7e KN |
252 | |
253 | static SCM | |
17e90c5e KN |
254 | make_vm (void) |
255 | #define FUNC_NAME "make_vm" | |
a98cef7e | 256 | { |
17e90c5e | 257 | int i; |
3d5ee0cd KN |
258 | struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm)); |
259 | vp->stack_size = VM_DEFAULT_STACK_SIZE; | |
260 | vp->stack_base = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM)); | |
261 | vp->stack_limit = vp->stack_base + vp->stack_size - 1; | |
262 | vp->ip = NULL; | |
263 | vp->sp = vp->stack_limit; | |
264 | vp->fp = NULL; | |
265 | vp->cons = 0; | |
266 | vp->time = 0; | |
267 | vp->clock = 0; | |
268 | vp->options = SCM_EOL; | |
17e90c5e | 269 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd KN |
270 | vp->hooks[i] = SCM_BOOL_F; |
271 | SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); | |
a98cef7e | 272 | } |
17e90c5e | 273 | #undef FUNC_NAME |
a98cef7e KN |
274 | |
275 | static SCM | |
17e90c5e | 276 | vm_mark (SCM obj) |
a98cef7e | 277 | { |
17e90c5e KN |
278 | int i; |
279 | SCM *sp, *fp; | |
3d5ee0cd | 280 | struct scm_vm *vp = SCM_VM_DATA (obj); |
17e90c5e KN |
281 | |
282 | /* Mark the stack */ | |
3d5ee0cd KN |
283 | sp = vp->sp; |
284 | fp = vp->fp; | |
17e90c5e KN |
285 | while (fp) |
286 | { | |
287 | SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp); | |
288 | SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp); | |
289 | /* Mark intermediate data */ | |
290 | for (; sp < lower; sp++) | |
291 | if (SCM_NIMP (*sp)) | |
292 | scm_gc_mark (*sp); | |
293 | /* Mark frame data */ | |
294 | scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp)); | |
295 | /* Mark frame variables */ | |
296 | for (sp = fp; sp < upper; sp++) | |
297 | if (SCM_NIMP (*sp)) | |
298 | scm_gc_mark (*sp); | |
299 | fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp)); | |
300 | } | |
a98cef7e | 301 | |
17e90c5e KN |
302 | /* Mark the options */ |
303 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) | |
3d5ee0cd KN |
304 | scm_gc_mark (vp->hooks[i]); |
305 | return vp->options; | |
a98cef7e KN |
306 | } |
307 | ||
17e90c5e KN |
308 | static scm_sizet |
309 | vm_free (SCM obj) | |
310 | { | |
3d5ee0cd KN |
311 | struct scm_vm *vp = SCM_VM_DATA (obj); |
312 | int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM)); | |
313 | scm_must_free (vp->stack_base); | |
314 | scm_must_free (vp); | |
17e90c5e KN |
315 | return size; |
316 | } | |
317 | ||
318 | SCM_SYMBOL (sym_debug, "debug"); | |
319 | ||
320 | SCM | |
321 | scm_vm_apply (SCM vm, SCM program, SCM args) | |
322 | #define FUNC_NAME "scm_vm_apply" | |
a98cef7e | 323 | { |
17e90c5e KN |
324 | SCM_VALIDATE_PROGRAM (1, program); |
325 | return vm_engine (vm, program, args); | |
a98cef7e | 326 | } |
17e90c5e | 327 | #undef FUNC_NAME |
a98cef7e KN |
328 | |
329 | /* Scheme interface */ | |
330 | ||
331 | SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, | |
17e90c5e KN |
332 | (void), |
333 | "") | |
a98cef7e KN |
334 | #define FUNC_NAME s_scm_vm_version |
335 | { | |
336 | return scm_makfrom0str (VERSION); | |
337 | } | |
338 | #undef FUNC_NAME | |
339 | ||
340 | SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, | |
341 | (SCM obj), | |
17e90c5e | 342 | "") |
a98cef7e KN |
343 | #define FUNC_NAME s_scm_vm_p |
344 | { | |
345 | return SCM_BOOL (SCM_VM_P (obj)); | |
346 | } | |
347 | #undef FUNC_NAME | |
348 | ||
349 | SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, | |
17e90c5e KN |
350 | (void), |
351 | "") | |
352 | #define FUNC_NAME s_scm_make_vm, | |
a98cef7e | 353 | { |
17e90c5e | 354 | return make_vm (); |
a98cef7e KN |
355 | } |
356 | #undef FUNC_NAME | |
357 | ||
17e90c5e | 358 | SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, |
a98cef7e | 359 | (SCM vm), |
17e90c5e KN |
360 | "") |
361 | #define FUNC_NAME s_scm_vm_ip | |
a98cef7e KN |
362 | { |
363 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 364 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->ip); |
a98cef7e KN |
365 | } |
366 | #undef FUNC_NAME | |
367 | ||
368 | SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, | |
369 | (SCM vm), | |
17e90c5e | 370 | "") |
a98cef7e KN |
371 | #define FUNC_NAME s_scm_vm_sp |
372 | { | |
373 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 374 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->sp); |
a98cef7e KN |
375 | } |
376 | #undef FUNC_NAME | |
377 | ||
378 | SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, | |
379 | (SCM vm), | |
17e90c5e | 380 | "") |
a98cef7e KN |
381 | #define FUNC_NAME s_scm_vm_fp |
382 | { | |
383 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 384 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp); |
a98cef7e KN |
385 | } |
386 | #undef FUNC_NAME | |
387 | ||
17e90c5e KN |
388 | #define VM_DEFINE_HOOK(n) \ |
389 | { \ | |
3d5ee0cd | 390 | struct scm_vm *vp; \ |
17e90c5e | 391 | SCM_VALIDATE_VM (1, vm); \ |
3d5ee0cd KN |
392 | vp = SCM_VM_DATA (vm); \ |
393 | if (SCM_FALSEP (vp->hooks[n])) \ | |
394 | vp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \ | |
395 | return vp->hooks[n]; \ | |
17e90c5e KN |
396 | } |
397 | ||
398 | SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, | |
a98cef7e | 399 | (SCM vm), |
17e90c5e KN |
400 | "") |
401 | #define FUNC_NAME s_scm_vm_boot_hook | |
a98cef7e | 402 | { |
17e90c5e | 403 | VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); |
a98cef7e KN |
404 | } |
405 | #undef FUNC_NAME | |
406 | ||
17e90c5e KN |
407 | SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, |
408 | (SCM vm), | |
409 | "") | |
410 | #define FUNC_NAME s_scm_vm_halt_hook | |
a98cef7e | 411 | { |
17e90c5e | 412 | VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); |
a98cef7e KN |
413 | } |
414 | #undef FUNC_NAME | |
415 | ||
17e90c5e | 416 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, |
a98cef7e | 417 | (SCM vm), |
17e90c5e KN |
418 | "") |
419 | #define FUNC_NAME s_scm_vm_next_hook | |
a98cef7e | 420 | { |
17e90c5e | 421 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
422 | } |
423 | #undef FUNC_NAME | |
424 | ||
17e90c5e KN |
425 | SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, |
426 | (SCM vm), | |
427 | "") | |
428 | #define FUNC_NAME s_scm_vm_enter_hook | |
a98cef7e | 429 | { |
17e90c5e | 430 | VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); |
a98cef7e KN |
431 | } |
432 | #undef FUNC_NAME | |
433 | ||
17e90c5e KN |
434 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, |
435 | (SCM vm), | |
436 | "") | |
437 | #define FUNC_NAME s_scm_vm_apply_hook | |
a98cef7e | 438 | { |
17e90c5e | 439 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
440 | } |
441 | #undef FUNC_NAME | |
442 | ||
17e90c5e | 443 | SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, |
a98cef7e | 444 | (SCM vm), |
17e90c5e KN |
445 | "") |
446 | #define FUNC_NAME s_scm_vm_exit_hook | |
a98cef7e | 447 | { |
17e90c5e | 448 | VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); |
a98cef7e KN |
449 | } |
450 | #undef FUNC_NAME | |
451 | ||
17e90c5e | 452 | SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, |
a98cef7e | 453 | (SCM vm), |
17e90c5e KN |
454 | "") |
455 | #define FUNC_NAME s_scm_vm_return_hook | |
a98cef7e | 456 | { |
17e90c5e | 457 | VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); |
a98cef7e KN |
458 | } |
459 | #undef FUNC_NAME | |
460 | ||
17e90c5e KN |
461 | SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0, |
462 | (SCM vm, SCM key), | |
463 | "") | |
464 | #define FUNC_NAME s_scm_vm_option | |
a98cef7e KN |
465 | { |
466 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 467 | return scm_assq_ref (SCM_VM_DATA (vm)->options, key); |
a98cef7e KN |
468 | } |
469 | #undef FUNC_NAME | |
470 | ||
17e90c5e KN |
471 | SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, |
472 | (SCM vm, SCM key, SCM val), | |
473 | "") | |
474 | #define FUNC_NAME s_scm_set_vm_option_x | |
a98cef7e KN |
475 | { |
476 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e KN |
477 | SCM_VM_DATA (vm)->options |
478 | = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); | |
479 | return SCM_UNSPECIFIED; | |
a98cef7e KN |
480 | } |
481 | #undef FUNC_NAME | |
482 | ||
17e90c5e | 483 | SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, |
a98cef7e | 484 | (SCM vm), |
17e90c5e KN |
485 | "") |
486 | #define FUNC_NAME s_scm_vm_stats | |
a98cef7e | 487 | { |
17e90c5e KN |
488 | SCM stats; |
489 | ||
a98cef7e | 490 | SCM_VALIDATE_VM (1, vm); |
17e90c5e KN |
491 | |
492 | stats = scm_c_make_vector (3, SCM_MAKINUM (0)); | |
493 | SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->cons); | |
494 | SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->time); | |
495 | SCM_VELTS (stats)[2] = scm_long2num (SCM_VM_DATA (vm)->clock); | |
496 | ||
497 | return stats; | |
a98cef7e KN |
498 | } |
499 | #undef FUNC_NAME | |
500 | ||
17e90c5e KN |
501 | #define VM_CHECK_RUNNING(vm) \ |
502 | if (!SCM_VM_DATA (vm)->ip) \ | |
503 | SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm)) | |
504 | ||
505 | SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, | |
a98cef7e | 506 | (SCM vm), |
17e90c5e KN |
507 | "") |
508 | #define FUNC_NAME s_scm_vm_current_frame | |
a98cef7e KN |
509 | { |
510 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e KN |
511 | VM_CHECK_RUNNING (vm); |
512 | return make_vm_debug_frame (SCM_VM_DATA (vm)->fp); | |
a98cef7e KN |
513 | } |
514 | #undef FUNC_NAME | |
515 | ||
17e90c5e KN |
516 | SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0, |
517 | (SCM vm), | |
518 | "") | |
519 | #define FUNC_NAME s_scm_vm_fetch_code | |
520 | { | |
521 | int i; | |
522 | SCM list; | |
523 | scm_byte_t *ip; | |
524 | struct scm_instruction *p; | |
a98cef7e | 525 | |
17e90c5e KN |
526 | SCM_VALIDATE_VM (1, vm); |
527 | VM_CHECK_RUNNING (vm); | |
a98cef7e | 528 | |
17e90c5e KN |
529 | ip = SCM_VM_DATA (vm)->ip; |
530 | p = SCM_INSTRUCTION (*ip); | |
a98cef7e | 531 | |
17e90c5e KN |
532 | list = SCM_LIST1 (scm_str2symbol (p->name)); |
533 | for (i = 1; i <= p->len; i++) | |
534 | list = scm_cons (SCM_MAKINUM (ip[i]), list); | |
535 | return scm_reverse_x (list, SCM_EOL); | |
536 | } | |
537 | #undef FUNC_NAME | |
538 | ||
539 | SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, | |
540 | (SCM vm), | |
541 | "") | |
542 | #define FUNC_NAME s_scm_vm_fetch_stack | |
a98cef7e | 543 | { |
17e90c5e KN |
544 | SCM *p; |
545 | SCM list = SCM_EOL; | |
a98cef7e KN |
546 | |
547 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 548 | VM_CHECK_RUNNING (vm); |
a98cef7e | 549 | |
17e90c5e KN |
550 | if (SCM_VM_DATA (vm)->fp) |
551 | for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1; | |
552 | p >= SCM_VM_DATA (vm)->sp; | |
553 | p--) | |
554 | list = scm_cons (*p, list); | |
555 | return list; | |
a98cef7e KN |
556 | } |
557 | #undef FUNC_NAME | |
558 | ||
17e90c5e KN |
559 | SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0, |
560 | (SCM vm, SCM bytes), | |
561 | "") | |
562 | #define FUNC_NAME s_scm_vm_load | |
26403690 | 563 | { |
17e90c5e | 564 | SCM prog; |
26403690 KN |
565 | |
566 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 567 | SCM_VALIDATE_STRING (2, bytes); |
26403690 | 568 | |
17e90c5e KN |
569 | prog = scm_c_make_program (SCM_STRING_CHARS (bytes), |
570 | SCM_STRING_LENGTH (bytes), | |
571 | bytes); | |
572 | return scm_vm_apply (vm, prog, SCM_EOL); | |
26403690 KN |
573 | } |
574 | #undef FUNC_NAME | |
575 | ||
a98cef7e KN |
576 | \f |
577 | /* | |
17e90c5e | 578 | * Initialize |
a98cef7e KN |
579 | */ |
580 | ||
17e90c5e KN |
581 | void |
582 | scm_init_vm (void) | |
583 | { | |
17e90c5e KN |
584 | scm_init_instructions (); |
585 | scm_init_programs (); | |
a98cef7e | 586 | |
17e90c5e KN |
587 | scm_tc16_vm_debug_frame = scm_make_smob_type ("vm_frame", 0); |
588 | scm_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark); | |
a98cef7e | 589 | |
17e90c5e KN |
590 | scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); |
591 | scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark); | |
592 | scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free); | |
a98cef7e | 593 | |
17e90c5e KN |
594 | scm_tc16_vm = scm_make_smob_type ("vm", 0); |
595 | scm_set_smob_mark (scm_tc16_vm, vm_mark); | |
596 | scm_set_smob_free (scm_tc16_vm, vm_free); | |
597 | scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); | |
a98cef7e | 598 | |
17e90c5e | 599 | #ifndef SCM_MAGIC_SNARFER |
a98cef7e | 600 | #include "vm.x" |
17e90c5e | 601 | #endif |
a98cef7e | 602 | } |
17e90c5e KN |
603 | |
604 | /* | |
605 | Local Variables: | |
606 | c-file-style: "gnu" | |
607 | End: | |
608 | */ |