1 /* vm.c -- stack-based virtual machine backend */
2 /* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
3 /* BSD-style license: http://synthcode.com/license.txt */
4
5 #if SEXP_USE_NATIVE_X86
6 #include "opt/x86.c"
7 #else
8 /* ... the rest of this file ... */
9
10 #include "chibi/eval.h"
11
12 #if SEXP_USE_DEBUG_VM > 1
sexp_print_stack(sexp ctx,sexp * stack,int top,int fp,sexp out)13 static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
14 int i;
15 if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
16 for (i=0; i<top; i++) {
17 sexp_write_char(ctx, ((i==fp) ? '*' : ' '), out);
18 if (i < 10) sexp_write_char(ctx, '0', out);
19 sexp_write(ctx, sexp_make_fixnum(i), out);
20 sexp_write_string(ctx, ": ", out);
21 sexp_write(ctx, stack[i], out);
22 sexp_newline(ctx, out);
23 }
24 }
25 #else
26 #define sexp_print_stack(ctx, stack, top, fp, out)
27 #endif
28
29 #if SEXP_USE_FULL_SOURCE_INFO
sexp_lookup_source_info(sexp src,int ip)30 static sexp sexp_lookup_source_info (sexp src, int ip) {
31 int i;
32 if (src && sexp_procedurep(src))
33 src = sexp_procedure_source(src);
34 if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) {
35 for (i=1; i<(int)sexp_vector_length(src); i++)
36 if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(i)))) > ip)
37 return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1)));
38 return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1)));
39 }
40 return SEXP_FALSE;
41 }
42 #endif
43
sexp_get_stack_trace(sexp ctx)44 sexp sexp_get_stack_trace (sexp ctx) {
45 sexp_sint_t i, fp=sexp_context_last_fp(ctx);
46 sexp self, bc, src, *stack = sexp_stack_data(sexp_context_stack(ctx));
47 sexp_gc_var2(res, cell);
48 sexp_gc_preserve2(ctx, res, cell);
49 res = SEXP_NULL;
50 for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
51 self = stack[i+2];
52 if (self && sexp_procedurep(self)) {
53 bc = sexp_procedure_code(self);
54 src = sexp_bytecode_source(bc);
55 #if SEXP_USE_FULL_SOURCE_INFO
56 if (src && sexp_vectorp(src))
57 src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
58 #endif
59 cell = sexp_cons(ctx, self, src ? src : SEXP_FALSE);
60 res = sexp_cons(ctx, cell, res);
61 }
62 }
63 res = sexp_nreverse(ctx, res);
64 sexp_gc_release2(ctx);
65 return res;
66 }
67
sexp_print_extracted_stack_trace(sexp ctx,sexp trace,sexp out)68 void sexp_print_extracted_stack_trace (sexp ctx, sexp trace, sexp out) {
69 sexp self, bc, src, ls;
70 if (! sexp_oportp(out))
71 out = sexp_current_error_port(ctx);
72 for (ls = trace; sexp_pairp(ls); ls = sexp_cdr(ls)) {
73 self = sexp_caar(ls);
74 bc = sexp_procedure_code(self);
75 src = sexp_cdar(ls);
76 sexp_write_string(ctx, " called from ", out);
77 if (sexp_symbolp(sexp_bytecode_name(bc)))
78 sexp_write(ctx, sexp_bytecode_name(bc), out);
79 else
80 sexp_write_string(ctx, "<anonymous>", out);
81 if (sexp_pairp(src)) {
82 if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
83 sexp_write_string(ctx, " on line ", out);
84 sexp_write(ctx, sexp_cdr(src), out);
85 } else {
86 sexp_write_string(ctx, " bad source line: ", out);
87 sexp_write(ctx, src, out);
88 }
89 if (sexp_stringp(sexp_car(src))) {
90 sexp_write_string(ctx, " of file ", out);
91 sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
92 } else {
93 sexp_write_string(ctx, " bad source file: ", out);
94 sexp_write(ctx, src, out);
95 }
96 }
97 sexp_write_char(ctx, '\n', out);
98 }
99 }
100
sexp_print_exception_stack_trace_op(sexp ctx,sexp self,sexp_sint_t n,sexp exn,sexp out)101 sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out) {
102 sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn);
103 sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
104 if (sexp_pairp(sexp_exception_stack_trace(exn))) {
105 sexp_print_extracted_stack_trace(ctx, sexp_exception_stack_trace(exn), out);
106 }
107 return SEXP_VOID;
108 }
109
sexp_stack_trace(sexp ctx,sexp out)110 void sexp_stack_trace (sexp ctx, sexp out) {
111 sexp_gc_var1(trace);
112 sexp_gc_preserve1(ctx, trace);
113 trace = sexp_get_stack_trace(ctx);
114 sexp_print_extracted_stack_trace(ctx, trace, out);
115 sexp_gc_release1(ctx);
116 }
117
sexp_stack_trace_op(sexp ctx,sexp self,sexp_sint_t n,sexp out)118 sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
119 sexp_stack_trace(ctx, out);
120 return SEXP_VOID;
121 }
122
123 /************************* code generation ****************************/
124
125 #if SEXP_USE_ALIGNED_BYTECODE
sexp_context_align_pos(sexp ctx)126 void sexp_context_align_pos(sexp ctx) {
127 sexp_uint_t i, pos = sexp_unbox_fixnum(sexp_context_pos(ctx));
128 sexp_uint_t new_pos = sexp_word_align(pos);
129 if (new_pos > pos) {
130 sexp_expand_bcode(ctx, (sexp_sint_t)new_pos - pos);
131 if (pos > 0)
132 for (i=pos; i<new_pos; ++i)
133 sexp_bytecode_data(sexp_context_bc(ctx))[i] =
134 sexp_bytecode_data(sexp_context_bc(ctx))[pos-1];
135 sexp_context_pos(ctx) = sexp_make_fixnum(new_pos);
136 }
137 }
138 #endif
139
sexp_inc_context_pos(sexp ctx,sexp_sint_t off)140 static void sexp_inc_context_pos(sexp ctx, sexp_sint_t off) {
141 sexp_expand_bcode(ctx, off);
142 sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), sexp_make_fixnum(off));
143 }
144
sexp_inc_context_depth(sexp ctx,sexp_sint_t off)145 static void sexp_inc_context_depth(sexp ctx, sexp_sint_t off) {
146 sexp_context_depth(ctx) = sexp_fx_add(sexp_context_depth(ctx), sexp_make_fixnum(off));
147 if (sexp_unbox_fixnum(sexp_context_depth(ctx))
148 > sexp_unbox_fixnum(sexp_context_max_depth(ctx)))
149 sexp_context_max_depth(ctx) = sexp_context_depth(ctx);
150 }
151
bytecode_preserve(sexp ctx,sexp obj)152 static void bytecode_preserve (sexp ctx, sexp obj) {
153 sexp ls = sexp_bytecode_literals(sexp_context_bc(ctx));
154 if (sexp_pointerp(obj) && !sexp_symbolp(obj)
155 && sexp_not(sexp_memq(ctx, obj, ls)))
156 sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj);
157 }
158
sexp_emit_word(sexp ctx,sexp_uint_t val)159 static void sexp_emit_word (sexp ctx, sexp_uint_t val) {
160 unsigned char *data;
161 sexp_context_align_pos(ctx);
162 sexp_expand_bcode(ctx, sizeof(sexp));
163 if (sexp_exceptionp(sexp_context_exception(ctx)))
164 return;
165 data = sexp_bytecode_data(sexp_context_bc(ctx));
166 *((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val;
167 sexp_inc_context_pos(ctx, sizeof(sexp));
168 }
169
sexp_emit_push(sexp ctx,sexp obj)170 static void sexp_emit_push (sexp ctx, sexp obj) {
171 sexp_emit(ctx, SEXP_OP_PUSH);
172 sexp_emit_word(ctx, (sexp_uint_t)obj);
173 sexp_inc_context_depth(ctx, 1);
174 bytecode_preserve(ctx, obj);
175 }
176
sexp_emit_return(sexp ctx)177 void sexp_emit_return (sexp ctx) {
178 sexp_emit(ctx, SEXP_OP_RET);
179 }
180
sexp_push_source(sexp ctx,sexp source)181 static void sexp_push_source (sexp ctx, sexp source) {
182 #if SEXP_USE_FULL_SOURCE_INFO
183 sexp src, bc = sexp_context_bc(ctx);
184 sexp_gc_var1(tmp);
185 if (source && sexp_pairp(source)) {
186 src = sexp_bytecode_source(bc);
187 if (!src) src = sexp_bytecode_source(bc) = SEXP_NULL;
188 if (!sexp_pairp(src)
189 || sexp_unbox_fixnum(sexp_context_pos(ctx)) > sexp_unbox_fixnum(sexp_caar(src))) {
190 sexp_gc_preserve1(ctx, tmp);
191 tmp = sexp_cons(ctx, sexp_context_pos(ctx), source);
192 if (sexp_pairp(tmp)) {
193 tmp = sexp_cons(ctx, tmp, src);
194 if (sexp_pairp(tmp)) sexp_bytecode_source(bc) = tmp;
195 }
196 sexp_gc_release1(ctx);
197 }
198 }
199 #endif
200 }
201
sexp_context_make_label(sexp ctx)202 static sexp_sint_t sexp_context_make_label (sexp ctx) {
203 sexp_sint_t label;
204 sexp_context_align_pos(ctx);
205 label = sexp_unbox_fixnum(sexp_context_pos(ctx));
206 sexp_inc_context_pos(ctx, sizeof(sexp_uint_t));
207 return label;
208 }
209
sexp_context_patch_label(sexp ctx,sexp_sint_t label)210 static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
211 sexp bc = sexp_context_bc(ctx);
212 unsigned char *data = sexp_bytecode_data(bc)+label;
213 if (!sexp_exceptionp(sexp_context_exception(ctx)))
214 *((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label;
215 }
216
generate_lit(sexp ctx,sexp value)217 static void generate_lit (sexp ctx, sexp value) {
218 sexp_emit_push(ctx, value);
219 }
220
generate_drop_prev(sexp ctx,sexp prev)221 static void generate_drop_prev (sexp ctx, sexp prev) {
222 #if ! SEXP_USE_ALIGNED_BYTECODE
223 if ((sexp_pairp(prev) && sexp_opcodep(sexp_car(prev))
224 && (sexp_opcode_code(sexp_car(prev)) == SEXP_OP_PUSH))
225 || sexp_setp(prev) || sexp_litp(prev) || prev == SEXP_VOID)
226 sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
227 else
228 #endif
229 sexp_emit(ctx, SEXP_OP_DROP);
230 }
231
generate_seq(sexp ctx,sexp name,sexp loc,sexp lam,sexp app)232 static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
233 sexp head=app, tail=sexp_cdr(app);
234 sexp_uint_t tailp = sexp_context_tailp(ctx);
235 sexp_push_source(ctx, sexp_pair_source(app));
236 sexp_context_tailp(ctx) = 0;
237 for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail))
238 if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) {
239 sexp_generate(ctx, name, loc, lam, sexp_car(head));
240 generate_drop_prev(ctx, sexp_car(head));
241 sexp_inc_context_depth(ctx, -1);
242 }
243 sexp_context_tailp(ctx) = (char)tailp;
244 sexp_generate(ctx, name, loc, lam, sexp_car(head));
245 }
246
generate_cnd(sexp ctx,sexp name,sexp loc,sexp lam,sexp cnd)247 static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) {
248 sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx);
249 sexp_push_source(ctx, sexp_cnd_source(cnd));
250 sexp_context_tailp(ctx) = 0;
251 sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd));
252 sexp_context_tailp(ctx) = (char)tailp;
253 sexp_emit(ctx, SEXP_OP_JUMP_UNLESS);
254 sexp_inc_context_depth(ctx, -1);
255 label1 = sexp_context_make_label(ctx);
256 sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd));
257 sexp_context_tailp(ctx) = (char)tailp;
258 sexp_emit(ctx, SEXP_OP_JUMP);
259 sexp_inc_context_depth(ctx, -1);
260 label2 = sexp_context_make_label(ctx);
261 sexp_context_patch_label(ctx, label1);
262 sexp_generate(ctx, name, loc, lam, sexp_cnd_fail(cnd));
263 sexp_context_patch_label(ctx, label2);
264 }
265
generate_non_global_ref(sexp ctx,sexp name,sexp cell,sexp lambda,sexp fv,int unboxp)266 static void generate_non_global_ref (sexp ctx, sexp name, sexp cell,
267 sexp lambda, sexp fv, int unboxp) {
268 sexp_uint_t i;
269 sexp loc = sexp_cdr(cell);
270 if (loc == lambda && sexp_lambdap(lambda)) {
271 /* local ref */
272 sexp_emit(ctx, SEXP_OP_LOCAL_REF);
273 sexp_emit_word(ctx, sexp_param_index(ctx, lambda, name));
274 } else {
275 /* closure ref */
276 for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
277 if ((name == sexp_ref_name(sexp_car(fv)))
278 && (loc == sexp_ref_loc(sexp_car(fv))))
279 break;
280 sexp_emit(ctx, SEXP_OP_CLOSURE_REF);
281 sexp_emit_word(ctx, i);
282 }
283 if (unboxp && (sexp_truep(sexp_memq(ctx, name, sexp_lambda_sv(loc)))))
284 sexp_emit(ctx, SEXP_OP_CDR);
285 sexp_inc_context_depth(ctx, +1);
286 }
287
generate_ref(sexp ctx,sexp ref,int unboxp)288 static void generate_ref (sexp ctx, sexp ref, int unboxp) {
289 sexp lam;
290 sexp_push_source(ctx, sexp_ref_source(ref));
291 if (! sexp_lambdap(sexp_ref_loc(ref))) {
292 /* global ref */
293 if (unboxp) {
294 sexp_emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
295 ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
296 sexp_emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
297 bytecode_preserve(ctx, sexp_ref_cell(ref));
298 } else
299 sexp_emit_push(ctx, sexp_ref_cell(ref));
300 } else {
301 lam = sexp_context_lambda(ctx);
302 if (!lam || !sexp_lambdap(lam)) {
303 sexp_warn(ctx, "variable out of phase: ", sexp_ref_name(ref));
304 sexp_emit_push(ctx, SEXP_VOID);
305 } else {
306 generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
307 lam, sexp_lambda_fv(lam), unboxp);
308 }
309 }
310 }
311
generate_set(sexp ctx,sexp set)312 static void generate_set (sexp ctx, sexp set) {
313 sexp ref = sexp_set_var(set), lambda;
314 sexp_push_source(ctx, sexp_set_source(set));
315 /* compile the value */
316 sexp_context_tailp(ctx) = 0;
317 if (sexp_lambdap(sexp_set_value(set))) {
318 sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref);
319 sexp_generate(ctx, sexp_ref_name(ref), sexp_ref_loc(ref), sexp_set_value(set), sexp_set_value(set));
320 } else {
321 sexp_generate(ctx, 0, 0, 0, sexp_set_value(set));
322 }
323 if (! sexp_lambdap(sexp_ref_loc(ref))) {
324 /* global vars are set directly */
325 if (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) {
326 /* force an undefined variable error if still undef at runtime */
327 generate_ref(ctx, ref, 1);
328 sexp_emit(ctx, SEXP_OP_DROP);
329 }
330 sexp_emit_push(ctx, sexp_ref_cell(ref));
331 sexp_emit(ctx, SEXP_OP_SET_CDR);
332 } else {
333 lambda = sexp_ref_loc(ref);
334 if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) {
335 /* stack or closure mutable vars are boxed */
336 generate_ref(ctx, ref, 0);
337 sexp_emit(ctx, SEXP_OP_SET_CDR);
338 } else {
339 /* internally defined variable */
340 sexp_emit(ctx, SEXP_OP_LOCAL_SET);
341 sexp_emit_word(ctx, sexp_param_index(ctx, lambda, sexp_ref_name(ref)));
342 }
343 }
344 sexp_emit_push(ctx, SEXP_VOID);
345 sexp_inc_context_depth(ctx, +1);
346 }
347
generate_opcode_app(sexp ctx,sexp app)348 static void generate_opcode_app (sexp ctx, sexp app) {
349 sexp op = sexp_car(app);
350 sexp_sint_t i, num_args, inv_default=0;
351 sexp_gc_var1(ls);
352 sexp_gc_preserve1(ctx, ls);
353
354 if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) {
355 sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app);
356 generate_lit(ctx, SEXP_VOID);
357 return;
358 }
359
360 num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app)));
361 sexp_context_tailp(ctx) = 0;
362
363 if (sexp_opcode_class(op) != SEXP_OPC_PARAMETER) {
364
365 /* maybe push the default for an optional argument */
366 if ((num_args == sexp_opcode_num_args(op))
367 && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) {
368 if (sexp_opcode_inverse(op)) {
369 inv_default = 1;
370 } else {
371 if (sexp_opcode_opt_param_p(op) && sexp_opcodep(sexp_opcode_data(op))) {
372 #if SEXP_USE_GREEN_THREADS
373 sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
374 sexp_emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
375 bytecode_preserve(ctx, sexp_opcode_data(op));
376 #else
377 sexp_emit_push(ctx, sexp_opcode_data(sexp_opcode_data(op)));
378 #endif
379 sexp_emit(ctx, SEXP_OP_CDR);
380 } else {
381 sexp_emit_push(ctx, sexp_opcode_data(op));
382 }
383 sexp_inc_context_depth(ctx, +1);
384 num_args++;
385 }
386 }
387
388 /* push the arguments onto the stack in reverse order */
389 if (!sexp_opcode_static_param_p(op)) {
390 ls = ((sexp_opcode_inverse(op)
391 && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC))
392 ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app)));
393 for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) {
394 sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
395 #if SEXP_USE_AUTO_FORCE
396 if (((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
397 || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR)
398 && !(sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
399 && sexp_unbox_fixnum(sexp_opcode_data(op)) == SEXP_PROMISE))
400 sexp_emit(ctx, SEXP_OP_FORCE);
401 #endif
402 }
403 }
404
405 }
406
407 /* push the default for inverse opcodes */
408 if (inv_default) {
409 sexp_emit_push(ctx, sexp_opcode_data(op));
410 if (sexp_opcode_opt_param_p(op)) sexp_emit(ctx, SEXP_OP_CDR);
411 sexp_inc_context_depth(ctx, +1);
412 num_args++;
413 }
414
415 /* emit the actual operator call */
416 switch (sexp_opcode_class(op)) {
417 case SEXP_OPC_ARITHMETIC:
418 /* fold variadic arithmetic operators */
419 for (i=num_args-1; i>0; i--)
420 sexp_emit(ctx, sexp_opcode_code(op));
421 break;
422 case SEXP_OPC_ARITHMETIC_CMP:
423 /* With [<true-value>, x] on the stack, and x boolean, */
424 /* AND is equivalent to ROT+DROP. Note one AND for every STACK_REF. */
425 if (num_args > 2) {
426 sexp_emit(ctx, SEXP_OP_STACK_REF);
427 sexp_emit_word(ctx, 2);
428 sexp_emit(ctx, SEXP_OP_STACK_REF);
429 sexp_emit_word(ctx, 2);
430 sexp_emit(ctx, sexp_opcode_code(op));
431 sexp_emit(ctx, SEXP_OP_AND);
432 for (i=num_args-2; i>0; i--) {
433 sexp_emit(ctx, SEXP_OP_STACK_REF);
434 sexp_emit_word(ctx, 3);
435 sexp_emit(ctx, SEXP_OP_STACK_REF);
436 sexp_emit_word(ctx, 3);
437 sexp_emit(ctx, sexp_opcode_code(op));
438 sexp_emit(ctx, SEXP_OP_AND);
439 sexp_emit(ctx, SEXP_OP_AND);
440 }
441 sexp_emit(ctx, SEXP_OP_AND);
442 } else
443 sexp_emit(ctx, sexp_opcode_code(op));
444 break;
445 case SEXP_OPC_FOREIGN:
446 sexp_emit(ctx, sexp_opcode_code(op));
447 sexp_emit_word(ctx, (sexp_uint_t)op);
448 bytecode_preserve(ctx, op);
449 break;
450 case SEXP_OPC_TYPE_PREDICATE:
451 case SEXP_OPC_GETTER:
452 case SEXP_OPC_SETTER:
453 case SEXP_OPC_CONSTRUCTOR:
454 sexp_emit(ctx, sexp_opcode_code(op));
455 if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
456 || sexp_opcode_code(op) == SEXP_OP_MAKE) {
457 if (sexp_opcode_data(op))
458 sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
459 if (sexp_opcode_data2(op))
460 sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
461 if (sexp_opcode_data(op) || sexp_opcode_data2(op))
462 bytecode_preserve(ctx, op);
463 }
464 break;
465 case SEXP_OPC_PARAMETER:
466 #if SEXP_USE_GREEN_THREADS
467 if (num_args > 0) {
468 if (sexp_opcode_data2(op) && sexp_applicablep(sexp_opcode_data2(op))) {
469 ls = sexp_list2(ctx, sexp_opcode_data2(op), sexp_cadr(app));
470 sexp_generate(ctx, 0, 0, 0, ls);
471 } else {
472 sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
473 }
474 }
475 sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
476 sexp_emit_word(ctx, (sexp_uint_t)op);
477 bytecode_preserve(ctx, op);
478 #else
479 if (num_args > 0) sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
480 sexp_emit_push(ctx, sexp_opcode_data(op));
481 #endif
482 sexp_emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR));
483 if (num_args > 0) sexp_emit_push(ctx, SEXP_VOID);
484 break;
485 default:
486 sexp_emit(ctx, sexp_opcode_code(op));
487 }
488
489 if (sexp_opcode_static_param_p(op))
490 for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls))
491 sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ?
492 sexp_lit_value(sexp_car(ls)) :
493 sexp_car(ls)));
494
495 if (sexp_opcode_return_type(op) == SEXP_VOID
496 && sexp_opcode_class(op) != SEXP_OPC_FOREIGN)
497 sexp_emit_push(ctx, SEXP_VOID);
498
499 sexp_inc_context_depth(ctx, -(num_args-1));
500 sexp_gc_release1(ctx);
501 }
502
generate_general_app(sexp ctx,sexp app)503 static void generate_general_app (sexp ctx, sexp app) {
504 sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))),
505 tailp = sexp_context_tailp(ctx);
506 sexp_gc_var1(ls);
507 sexp_gc_preserve1(ctx, ls);
508
509 /* push the arguments onto the stack */
510 sexp_context_tailp(ctx) = 0;
511 for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls))
512 sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
513
514 /* push the operator onto the stack */
515 sexp_generate(ctx, 0, 0, 0, sexp_car(app));
516
517 /* maybe overwrite the current frame */
518 sexp_emit(ctx, ((tailp && sexp_not(sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P))) ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL));
519 sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len));
520
521 sexp_context_tailp(ctx) = (char)tailp;
522 sexp_inc_context_depth(ctx, -len);
523 sexp_gc_release1(ctx);
524 }
525
526 #if SEXP_USE_TAIL_JUMPS
generate_tail_jump(sexp ctx,sexp name,sexp loc,sexp lam,sexp app)527 static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
528 sexp_gc_var3(ls1, ls2, ls3);
529 sexp_gc_preserve3(ctx, ls1, ls2, ls3);
530
531 /* overwrite the arguments that differ */
532 sexp_context_tailp(ctx) = 0;
533 for (ls1=sexp_cdr(app), ls2=sexp_lambda_params(lam), ls3=SEXP_NULL;
534 sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=sexp_cdr(ls2)) {
535 if (!(sexp_refp(sexp_car(ls1))
536 && sexp_ref_name(sexp_car(ls1)) == sexp_car(ls2)
537 && sexp_ref_loc(sexp_car(ls1)) == lam
538 && sexp_not(sexp_memq(ctx, sexp_car(ls2), sexp_lambda_sv(lam))))) {
539 sexp_generate(ctx, 0, 0, 0, sexp_car(ls1));
540 ls3 = sexp_cons(ctx, sexp_car(ls2), ls3);
541 }
542 }
543 for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
544 sexp_emit(ctx, SEXP_OP_LOCAL_SET);
545 sexp_emit_word(ctx, sexp_param_index(ctx, lam, sexp_car(ls1)));
546 }
547
548 /* drop the current result and jump */
549 sexp_emit(ctx, SEXP_OP_JUMP);
550 sexp_context_align_pos(ctx);
551 sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) +
552 (sexp_pairp(sexp_lambda_locals(lam))
553 ? 1 + sizeof(sexp) : 0)));
554
555 sexp_context_tailp(ctx) = 1;
556 sexp_gc_release3(ctx);
557 }
558 #endif
559
generate_app(sexp ctx,sexp name,sexp loc,sexp lam,sexp app)560 static void generate_app (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
561 sexp_push_source(ctx, sexp_pair_source(app));
562 if (sexp_opcodep(sexp_car(app)))
563 generate_opcode_app(ctx, app);
564 #if SEXP_USE_TAIL_JUMPS
565 else if (sexp_context_tailp(ctx) && sexp_refp(sexp_car(app))
566 && name == sexp_ref_name(sexp_car(app))
567 && loc == sexp_ref_loc(sexp_car(app))
568 && (sexp_length(ctx, sexp_cdr(app))
569 == sexp_length(ctx, sexp_lambda_params(lam))))
570 generate_tail_jump(ctx, name, loc, lam, app);
571 #endif
572 else
573 generate_general_app(ctx, app);
574 }
575
576 #if SEXP_USE_UNBOXED_LOCALS
sexp_internal_definep(sexp ctx,sexp x)577 static int sexp_internal_definep(sexp ctx, sexp x) {
578 return sexp_lambdap(sexp_ref_loc(x))
579 && sexp_truep(sexp_memq(ctx, sexp_ref_name(x),
580 sexp_lambda_locals(sexp_ref_loc(x))));
581 }
582
sexp_mutual_internal_definep(sexp ctx,sexp x,sexp fv)583 static int sexp_mutual_internal_definep(sexp ctx, sexp x, sexp fv) {
584 return sexp_internal_definep(ctx, x)
585 && sexp_ref_loc(x) == sexp_ref_loc(fv) && sexp_internal_definep(ctx, fv)
586 && sexp_not(sexp_memq(ctx, sexp_ref_name(fv),
587 sexp_lambda_sv(sexp_ref_loc(fv))));
588 }
589
generate_lambda_locals(sexp ctx,sexp name,sexp loc,sexp lam,sexp x)590 static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
591 sexp ls;
592 if (sexp_seqp(x)) {
593 for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
594 if (!generate_lambda_locals(ctx, name, loc, lam, sexp_car(ls)))
595 return 0;
596 return 1;
597 } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
598 sexp_generate(ctx, name, loc, lam, x);
599 sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
600 return 1;
601 }
602 return 0;
603 }
604
generate_lambda_body(sexp ctx,sexp name,sexp loc,sexp lam,sexp x,sexp prev_lam)605 static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x, sexp prev_lam) {
606 sexp_uint_t k, updatep, tailp;
607 sexp ls, ref, fv, prev_fv;
608 if (sexp_exceptionp(sexp_context_exception(ctx)))
609 return 0;
610 if (sexp_seqp(x)) {
611 tailp = sexp_context_tailp(ctx);
612 sexp_context_tailp(ctx) = 0;
613 for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls)) {
614 if (sexp_nullp(sexp_cdr(ls))) sexp_context_tailp(ctx) = tailp;
615 if (!generate_lambda_body(ctx, name, loc, lam, sexp_car(ls), prev_lam)) {
616 if (sexp_pairp(sexp_cdr(ls))) {
617 generate_drop_prev(ctx, sexp_car(ls));
618 for (ls=sexp_cdr(ls); sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls));
619 ls=sexp_cdr(ls)) {
620 sexp_generate(ctx, name, loc, lam, sexp_car(ls));
621 generate_drop_prev(ctx, sexp_car(ls));
622 }
623 sexp_context_tailp(ctx) = tailp;
624 sexp_generate(ctx, name, loc, lam, sexp_car(ls));
625 }
626 return 0;
627 }
628 }
629 return 1;
630 } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
631 updatep = 0;
632 if (sexp_lambdap(sexp_set_value(x))) {
633 /* update potentially changed bindings */
634 fv = sexp_lambda_fv(sexp_set_value(x));
635 prev_fv = sexp_lambdap(prev_lam) ? sexp_lambda_fv(prev_lam) : SEXP_NULL;
636 for (k=0; fv && sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
637 ref = sexp_car(fv);
638 if (sexp_mutual_internal_definep(ctx, sexp_set_var(x), ref)) {
639 if (!updatep) {
640 updatep = 1;
641 generate_non_global_ref(ctx, sexp_ref_name(sexp_set_var(x)),
642 sexp_ref_cell(sexp_set_var(x)),
643 lam, sexp_lambda_fv(lam), 1);
644 sexp_emit(ctx, SEXP_OP_CLOSURE_VARS);
645 }
646 generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
647 lam, sexp_lambda_fv(lam), 1);
648 sexp_emit_push(ctx, sexp_make_fixnum(k));
649 sexp_emit(ctx, SEXP_OP_STACK_REF);
650 sexp_emit_word(ctx, 3);
651 sexp_emit(ctx, SEXP_OP_VECTOR_SET);
652 sexp_inc_context_depth(ctx, -1);
653 }
654 }
655 }
656 if (updatep) sexp_emit(ctx, SEXP_OP_DROP);
657 return 1;
658 }
659 sexp_generate(ctx, name, loc, lam, x);
660 return 0;
661 }
662 #endif
663
generate_lambda(sexp ctx,sexp name,sexp loc,sexp lam,sexp lambda)664 static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambda) {
665 sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
666 sexp_sint_t k;
667 sexp_gc_var2(tmp, bc);
668 if (sexp_exceptionp(sexp_context_exception(ctx)))
669 return;
670 prev_lambda = sexp_context_lambda(ctx);
671 prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
672 fv = sexp_lambda_fv(lambda);
673 ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 0);
674 if (sexp_exceptionp(ctx2)) {
675 sexp_context_exception(ctx) = ctx2;
676 return;
677 }
678 sexp_context_lambda(ctx2) = lambda;
679 sexp_gc_preserve2(ctx, tmp, bc);
680 #if SEXP_USE_FULL_SOURCE_INFO
681 tmp = sexp_cons(ctx, SEXP_NEG_ONE, sexp_lambda_source(lambda));
682 tmp = sexp_cons(ctx, tmp, SEXP_NULL);
683 #else
684 tmp = sexp_lambda_source(lambda);
685 #endif
686 sexp_bytecode_source(sexp_context_bc(ctx2)) = tmp;
687 tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
688 /* allocate space for local vars */
689 k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
690 if (k > 0) {
691 #if SEXP_USE_RESERVE_OPCODE
692 sexp_emit(ctx2, SEXP_OP_RESERVE);
693 sexp_emit_word(ctx2, k);
694 #else
695 while (k--) sexp_emit_push(ctx2, SEXP_UNDEF);
696 #endif
697 }
698 /* box mutable vars */
699 for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
700 k = sexp_param_index(ctx, lambda, sexp_car(ls));
701 sexp_emit(ctx2, SEXP_OP_LOCAL_REF);
702 sexp_emit_word(ctx2, k);
703 sexp_emit_push(ctx2, sexp_car(ls));
704 sexp_emit(ctx2, SEXP_OP_CONS);
705 sexp_emit(ctx2, SEXP_OP_LOCAL_SET);
706 sexp_emit_word(ctx2, k);
707 }
708 if (lam != lambda) loc = 0;
709 #if SEXP_USE_UNBOXED_LOCALS
710 sexp_context_tailp(ctx2) = 0;
711 generate_lambda_locals(ctx2, name, loc, lambda, sexp_lambda_body(lambda));
712 sexp_context_tailp(ctx2) = 1;
713 generate_lambda_body(ctx2, name, loc, lambda, sexp_lambda_body(lambda), prev_lambda);
714 #else
715 sexp_context_tailp(ctx2) = 1;
716 sexp_generate(ctx2, name, loc, lam, sexp_lambda_body(lambda));
717 #endif
718 flags = sexp_make_fixnum(sexp_not(sexp_listp(ctx, sexp_lambda_params(lambda)))
719 ? (SEXP_PROC_VARIADIC + (sexp_rest_unused_p(lambda)
720 ? SEXP_PROC_UNUSED_REST: 0))
721 : SEXP_PROC_NONE);
722 len = sexp_length(ctx2, sexp_lambda_params(lambda));
723 bc = sexp_complete_bytecode(ctx2);
724 if (sexp_exceptionp(bc)) {
725 sexp_context_exception(ctx) = bc;
726 } else {
727 sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
728 if (sexp_nullp(fv)) {
729 /* shortcut, no free vars */
730 tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
731 tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);
732 bytecode_preserve(ctx, tmp);
733 generate_lit(ctx, tmp);
734 } else {
735 /* push the closed vars */
736 sexp_emit_push(ctx, SEXP_VOID);
737 sexp_emit_push(ctx, sexp_length(ctx, fv));
738 sexp_emit(ctx, SEXP_OP_MAKE_VECTOR);
739 sexp_inc_context_depth(ctx, -1);
740 for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
741 ref = sexp_car(fv);
742 generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
743 prev_lambda, prev_fv, 0);
744 sexp_emit_push(ctx, sexp_make_fixnum(k));
745 sexp_emit(ctx, SEXP_OP_STACK_REF);
746 sexp_emit_word(ctx, 3);
747 sexp_emit(ctx, SEXP_OP_VECTOR_SET);
748 sexp_inc_context_depth(ctx, -1);
749 }
750 /* push the additional procedure info and make the closure */
751 sexp_emit(ctx, SEXP_OP_MAKE_PROCEDURE);
752 sexp_emit_word(ctx, (sexp_uint_t)flags);
753 sexp_emit_word(ctx, (sexp_uint_t)len);
754 sexp_emit_word(ctx, (sexp_uint_t)bc);
755 bytecode_preserve(ctx, bc);
756 }
757 }
758 sexp_gc_release2(ctx);
759 }
760
sexp_generate(sexp ctx,sexp name,sexp loc,sexp lam,sexp x)761 void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
762 if (sexp_exceptionp(sexp_context_exception(ctx)))
763 return;
764 if (sexp_pointerp(x)) {
765 switch (sexp_pointer_tag(x)) {
766 case SEXP_PAIR: generate_app(ctx, name, loc, lam, x); break;
767 case SEXP_LAMBDA: generate_lambda(ctx, name, loc, lam, x); break;
768 case SEXP_CND: generate_cnd(ctx, name, loc, lam, x); break;
769 case SEXP_REF: generate_ref(ctx, x, 1); break;
770 case SEXP_SET: generate_set(ctx, x); break;
771 case SEXP_SEQ: generate_seq(ctx, name, loc, lam, sexp_seq_ls(x)); break;
772 case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break;
773 default: generate_lit(ctx, x);
774 }
775 } else {
776 generate_lit(ctx, x);
777 }
778 }
779
make_param_list(sexp ctx,sexp_uint_t i)780 static sexp make_param_list (sexp ctx, sexp_uint_t i) {
781 sexp_gc_var1(res);
782 sexp_gc_preserve1(ctx, res);
783 res = SEXP_NULL;
784 for ( ; i>0; i--)
785 res = sexp_cons(ctx, sexp_make_fixnum(i), res);
786 sexp_gc_release1(ctx);
787 return res;
788 }
789
make_opcode_procedure(sexp ctx,sexp op,sexp_uint_t i)790 static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
791 sexp ls, res, env;
792 sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
793 if (i == sexp_opcode_num_args(op)) { /* return before preserving */
794 if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
795 } else if (i < sexp_opcode_num_args(op)) {
796 return sexp_compile_error(ctx, "not enough args for opcode", op);
797 } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
798 return sexp_compile_error(ctx, "too many args for opcode", op);
799 }
800 sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
801 params = make_param_list(ctx, i);
802 lambda = sexp_make_lambda(ctx, params);
803 ctx2 = sexp_make_child_context(ctx, lambda);
804 env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
805 if (sexp_exceptionp(env)) {
806 res = env;
807 } else {
808 sexp_context_env(ctx2) = env;
809 for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
810 ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(ctx, env, sexp_car(ls), 0));
811 if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
812 }
813 if (!sexp_exceptionp(refs))
814 refs = sexp_reverse(ctx2, refs);
815 refs = sexp_cons(ctx2, op, refs);
816 if (sexp_exceptionp(refs)) {
817 res = refs;
818 } else {
819 generate_opcode_app(ctx2, refs);
820 bc = sexp_complete_bytecode(ctx2);
821 sexp_bytecode_name(bc) = sexp_opcode_name(op);
822 res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
823 if (i == sexp_opcode_num_args(op))
824 sexp_opcode_proc(op) = res;
825 }
826 }
827 sexp_gc_release6(ctx);
828 return res;
829 }
830
831 /*********************** the virtual machine **************************/
832
sexp_make_trampoline(sexp ctx,sexp proc,sexp args)833 sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
834 return sexp_make_exception(ctx, SEXP_TRAMPOLINE, SEXP_FALSE, args, proc, SEXP_FALSE);
835 }
836
837 #if SEXP_USE_GROW_STACK
sexp_grow_stack(sexp ctx,int min_size)838 static int sexp_grow_stack (sexp ctx, int min_size) {
839 sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
840 int i, size = sexp_stack_length(old_stack), new_size;
841 new_size = size * 2;
842 if (new_size < min_size) new_size = min_size;
843 if (new_size > SEXP_MAX_STACK_SIZE) {
844 if (size == SEXP_MAX_STACK_SIZE)
845 return 0;
846 new_size = SEXP_MAX_STACK_SIZE;
847 }
848 stack = sexp_alloc_tagged(ctx, (sexp_sizeof(stack)+sizeof(sexp)*new_size),
849 SEXP_STACK);
850 if (!stack || sexp_exceptionp(stack))
851 return 0;
852 sexp_stack_length(stack) = new_size;
853 sexp_stack_top(stack) = sexp_context_top(ctx);
854 from = sexp_stack_data(old_stack);
855 to = sexp_stack_data(stack);
856 for (i=sexp_context_top(ctx)+1; i>=0; i--)
857 to[i] = from[i];
858 for (; ctx; ctx=sexp_context_parent(ctx))
859 if (sexp_context_stack(ctx) == old_stack)
860 sexp_context_stack(ctx) = stack;
861 return 1;
862 }
863 #else
864 #define sexp_grow_stack(ctx, min_size) 0
865 #endif
866
sexp_save_stack(sexp ctx,sexp * stack,sexp_uint_t to)867 static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) {
868 sexp res, *data;
869 sexp_uint_t i;
870 res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID);
871 data = sexp_vector_data(res);
872 for (i=0; i<to; i++)
873 data[i] = stack[i];
874 return res;
875 }
876
sexp_restore_stack(sexp ctx,sexp saved)877 static sexp sexp_restore_stack (sexp ctx, sexp saved) {
878 sexp_uint_t len = sexp_vector_length(saved), i;
879 sexp *from = sexp_vector_data(saved), *to;
880 #if SEXP_USE_CHECK_STACK
881 if ((len+64 >= sexp_stack_length(sexp_context_stack(ctx)))
882 && !sexp_grow_stack(ctx, len+64))
883 return sexp_global(ctx, SEXP_G_OOS_ERROR);
884 #endif
885 to = sexp_stack_data(sexp_context_stack(ctx));
886 for (i=0; i<len; i++)
887 to[i] = from[i];
888 sexp_context_top(ctx) = len;
889 return SEXP_VOID;
890 }
891
892 #define _ARG1 stack[top-1]
893 #define _ARG2 stack[top-2]
894 #define _ARG3 stack[top-3]
895 #define _ARG4 stack[top-4]
896 #define _ARG5 stack[top-5]
897 #define _ARG6 stack[top-6]
898 #define _PUSH(x) (stack[top++]=(x))
899 #define _POP() (stack[--top])
900
901 #if SEXP_USE_ALIGNED_BYTECODE
902 #define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip)
903 #else
904 #define _ALIGN_IP()
905 #endif
906
907 #define _WORD0 ((sexp*)ip)[0]
908 #define _UWORD0 ((sexp_uint_t*)ip)[0]
909 #define _SWORD0 ((sexp_sint_t*)ip)[0]
910 #define _WORD1 ((sexp*)ip)[1]
911 #define _UWORD1 ((sexp_uint_t*)ip)[1]
912 #define _SWORD1 ((sexp_sint_t*)ip)[1]
913 #define _WORD2 ((sexp*)ip)[2]
914
915 #define sexp_raise(msg, args) \
916 do {sexp_context_top(ctx) = top+1; \
917 stack[top] = args; \
918 stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \
919 top++; \
920 goto call_error_handler;} \
921 while (0)
922
923 #define sexp_check_exception() \
924 do {if (sexp_exceptionp(_ARG1)) { \
925 goto call_error_handler;}} \
926 while (0)
927
sexp_check_type(sexp ctx,sexp a,sexp b)928 static int sexp_check_type(sexp ctx, sexp a, sexp b) {
929 int d;
930 sexp t, v;
931 if (! sexp_pointerp(a))
932 return 0;
933 if (sexp_isa(a, b))
934 return 1;
935 t = sexp_object_type(ctx, a);
936 v = sexp_type_cpl(t);
937 if (! sexp_vectorp(v))
938 return 0;
939 if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
940 return 1;
941 d = sexp_type_depth(b);
942 return (d < (int)sexp_vector_length(v))
943 && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
944 }
945
946 #if SEXP_USE_GREEN_THREADS
947 #define sexp_fcall_return(x, i) \
948 if (sexp_exceptionp(x)) { \
949 if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) { \
950 fuel = 0; ip--; goto loop; \
951 } else if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)) { \
952 stack[top-i+1] = SEXP_ZERO; \
953 fuel = 0; ip--; goto loop; \
954 } else { \
955 top -= i; \
956 _ARG1 = x; \
957 ip += sizeof(sexp); \
958 goto call_error_handler; \
959 } \
960 } else { \
961 top -= i; \
962 _ARG1 = x; \
963 ip += sizeof(sexp); \
964 }
965 #else
966 #define sexp_fcall_return(x, i) \
967 top -= i; _ARG1 = x; ip += sizeof(sexp); sexp_check_exception();
968 #endif
969
970 #if SEXP_USE_EXTENDED_FCALL
971 #include "opt/fcall.c"
972 #endif
973
974 #if SEXP_USE_PROFILE_VM
975 sexp_uint_t profile1[SEXP_OP_NUM_OPCODES];
976 sexp_uint_t profile2[SEXP_OP_NUM_OPCODES][SEXP_OP_NUM_OPCODES];
977
sexp_reset_vm_profile(sexp ctx,sexp self,sexp_sint_t n)978 sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
979 int i, j;
980 for (i=0; i<SEXP_OP_NUM_OPCODES; i++) {
981 profile1[i] = 0;
982 for (j=0; j<SEXP_OP_NUM_OPCODES; j++) profile2[i][j] = 0;
983 }
984 return SEXP_VOID;
985 }
986
sexp_print_vm_profile(sexp ctx,sexp self,sexp_sint_t n)987 sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
988 int i, j;
989 for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
990 fprintf(stderr, "%s %lu\n", sexp_opcode_names[i], profile1[i]);
991 for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
992 for (j=0; j<SEXP_OP_NUM_OPCODES; j++)
993 fprintf(stderr, "%s %s %lu\n", sexp_opcode_names[i],
994 sexp_opcode_names[j], profile2[i][j]);
995 return SEXP_VOID;
996 }
997 #endif
998
999 #if SEXP_USE_DEBUG_THREADS
sexp_thread_debug_name(sexp ctx)1000 static const char* sexp_thread_debug_name(sexp ctx) {
1001 if (sexp_stringp(sexp_context_name(ctx)))
1002 return sexp_string_data(sexp_context_name(ctx));
1003 return "?";
1004 }
1005
sexp_thread_debug_event_type(sexp ctx)1006 static char* sexp_thread_debug_event_type(sexp ctx) {
1007 sexp evt = sexp_context_event(ctx);
1008 return sexp_portp(evt) ? "p" : sexp_contextp(evt) ? "c" : "?";
1009 }
1010
sexp_thread_debug_event(sexp ctx)1011 static void* sexp_thread_debug_event(sexp ctx) {
1012 return (void*)sexp_context_event(ctx);
1013 }
1014 #endif
1015
1016 #if SEXP_USE_CHECK_STACK
1017 #define sexp_ensure_stack(n) \
1018 if (top+(n) >= sexp_stack_length(sexp_context_stack(ctx))) { \
1019 sexp_context_top(ctx) = top; \
1020 if (sexp_grow_stack(ctx, (n))) { \
1021 stack = sexp_stack_data(sexp_context_stack(ctx)); \
1022 } else { \
1023 _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); \
1024 goto end_loop; \
1025 } \
1026 }
1027 #else
1028 #define sexp_ensure_stack(n)
1029 #endif
1030
1031 /* used only when no thread scheduler has been loaded */
1032 #if SEXP_USE_POLL_PORT
sexp_poll_port(sexp ctx,sexp port,int inputp)1033 int sexp_poll_port(sexp ctx, sexp port, int inputp) {
1034 fd_set fds;
1035 int fd = sexp_port_fileno(port);
1036 if (fd < 0) {
1037 usleep(SEXP_POLL_SLEEP_TIME);
1038 return -1;
1039 }
1040 FD_ZERO(&fds);
1041 FD_SET(fd, &fds);
1042 return select(1, (inputp ? &fds : NULL), (inputp ? NULL : &fds), NULL, NULL);
1043 }
1044 #endif
1045
sexp_apply(sexp ctx,sexp proc,sexp args)1046 sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
1047 unsigned char *ip;
1048 sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx)), tmp;
1049 sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
1050 #if SEXP_USE_GREEN_THREADS
1051 sexp root_thread = ctx;
1052 sexp_sint_t fuel = sexp_context_refuel(ctx);
1053 #endif
1054 #if SEXP_USE_PROFILE_VM
1055 unsigned char last_op = SEXP_OP_NOOP;
1056 #endif
1057 #if SEXP_USE_BIGNUMS
1058 sexp_lsint_t prod;
1059 #endif
1060 sexp_gc_var3(self, tmp1, tmp2);
1061 sexp_gc_preserve3(ctx, self, tmp1, tmp2);
1062 fp = top - 4;
1063 self = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
1064 bc = sexp_procedure_code(self);
1065 cp = sexp_procedure_vars(self);
1066 ip = sexp_bytecode_data(bc) - sizeof(sexp);
1067 tmp1 = proc, tmp2 = args;
1068 i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
1069 sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
1070 for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
1071 _ARG1 = sexp_car(tmp2);
1072 top += i+1;
1073 goto make_call;
1074
1075 loop:
1076 #if SEXP_USE_GREEN_THREADS
1077 if (--fuel <= 0) {
1078 if (sexp_context_interruptp(ctx)) {
1079 fuel = sexp_context_refuel(ctx);
1080 sexp_context_interruptp(ctx) = 0;
1081 _ARG1 = sexp_global(ctx, SEXP_G_INTERRUPT_ERROR);
1082 goto call_error_handler;
1083 }
1084 tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
1085 if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) {
1086 /* save thread */
1087 sexp_context_top(ctx) = top;
1088 sexp_context_ip(ctx) = ip;
1089 sexp_context_last_fp(ctx) = fp;
1090 sexp_context_proc(ctx) = self;
1091 /* run scheduler */
1092 #if SEXP_USE_DEBUG_THREADS
1093 tmp2 = ctx;
1094 #endif
1095 ctx = sexp_apply1(ctx, tmp1, root_thread);
1096 /* restore thread */
1097 stack = sexp_stack_data(sexp_context_stack(ctx));
1098 top = sexp_context_top(ctx);
1099 fp = sexp_context_last_fp(ctx);
1100 ip = sexp_context_ip(ctx);
1101 self = sexp_context_proc(ctx);
1102 bc = sexp_procedure_code(self);
1103 cp = sexp_procedure_vars(self);
1104 #if SEXP_USE_DEBUG_THREADS
1105 if (ctx != tmp2) {
1106 fprintf(stderr, "****** schedule %p: %p (%s) active:",
1107 root_thread, ctx, sexp_thread_debug_name(ctx));
1108 for (tmp1=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
1109 fprintf(stderr, " %p (%s)", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)));
1110 fprintf(stderr, " paused:");
1111 for (tmp1=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
1112 fprintf(stderr, " %p (%s) [%s %p]", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)), sexp_thread_debug_event_type(sexp_car(tmp1)), sexp_thread_debug_event(sexp_car(tmp1)));
1113 fprintf(stderr, " ******\n");
1114 }
1115 #endif
1116 }
1117 fuel = sexp_context_refuel(ctx);
1118 if (fuel <= 0) goto end_loop;
1119 if (sexp_context_waitp(ctx)) {
1120 fuel = 1;
1121 goto loop; /* we were still waiting, try again */
1122 }
1123 }
1124 #endif
1125 #if SEXP_USE_DEBUG_VM
1126 if (sexp_context_tracep(ctx)) {
1127 sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
1128 fprintf(stderr, "****** VM %s %s ip: %p stack: %p top: %ld fp: %ld (%ld)\n",
1129 (*ip<=SEXP_OP_NUM_OPCODES) ? sexp_opcode_names[*ip] : "UNKNOWN",
1130 (SEXP_OP_FCALL0 <= *ip && *ip <= SEXP_OP_FCALL4
1131 ? sexp_string_data(sexp_opcode_name(((sexp*)(ip+1))[0])) : ""),
1132 ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1));
1133 }
1134 #endif
1135 #if SEXP_USE_PROFILE_VM
1136 profile1[*ip]++;
1137 profile2[last_op][*ip]++;
1138 last_op = *ip;
1139 #endif
1140 switch (*ip++) {
1141 case SEXP_OP_NOOP:
1142 break;
1143 call_error_handler:
1144 if (! sexp_exception_procedure(_ARG1))
1145 sexp_exception_procedure(_ARG1) = self;
1146 #if SEXP_USE_FULL_SOURCE_INFO
1147 if (sexp_not(sexp_exception_source(_ARG1))
1148 && sexp_procedurep(sexp_exception_procedure(_ARG1))
1149 && sexp_procedure_source(sexp_exception_procedure(_ARG1)))
1150 sexp_exception_source(_ARG1) = sexp_lookup_source_info(sexp_exception_procedure(_ARG1), (ip-sexp_bytecode_data(bc)));
1151 #endif
1152 case SEXP_OP_RAISE:
1153 sexp_context_top(ctx) = top;
1154 if (sexp_trampolinep(_ARG1)) {
1155 tmp1 = sexp_trampoline_procedure(_ARG1);
1156 tmp2 = sexp_trampoline_args(_ARG1);
1157 if (sexp_trampoline_abortp(_ARG1)) { /* abort - do not catch */
1158 _ARG1 = tmp2;
1159 goto end_loop;
1160 }
1161 top--;
1162 if (sexp_not(tmp1) && sexp_pairp(tmp2)) { /* noop trampoline is */
1163 _PUSH(sexp_car(tmp2)); /* a wrapped exception */
1164 goto loop;
1165 }
1166 goto apply1;
1167 }
1168 tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER));
1169 sexp_context_last_fp(ctx) = fp;
1170 if (! sexp_procedurep(tmp1)) {
1171 #if SEXP_USE_GREEN_THREADS
1172 sexp_context_errorp(ctx) = 1;
1173 #endif
1174 if (!sexp_exceptionp(_ARG1)) {
1175 _ARG1 = sexp_make_exception(ctx, SEXP_UNCAUGHT, SEXP_FALSE, _ARG1, self, SEXP_FALSE);
1176 }
1177 sexp_context_top(ctx) = top;
1178 sexp_exception_stack_trace(_ARG1) = sexp_get_stack_trace(ctx);
1179 goto end_loop;
1180 }
1181 stack[top] = SEXP_ONE;
1182 stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
1183 stack[top+2] = self;
1184 stack[top+3] = sexp_make_fixnum(fp);
1185 top += 4;
1186 self = tmp1;
1187 bc = sexp_procedure_code(self);
1188 ip = sexp_bytecode_data(bc);
1189 cp = sexp_procedure_vars(self);
1190 fp = top-4;
1191 break;
1192 case SEXP_OP_RESUMECC:
1193 sexp_context_top(ctx) = top;
1194 tmp1 = stack[fp-1];
1195 tmp2 = sexp_restore_stack(ctx, sexp_vector_ref(cp, 0));
1196 if (sexp_exceptionp(tmp2)) {_ARG1 = tmp2; goto call_error_handler;}
1197 top = sexp_context_top(ctx);
1198 fp = sexp_unbox_fixnum(_ARG1);
1199 self = _ARG2;
1200 bc = sexp_procedure_code(self);
1201 cp = sexp_procedure_vars(self);
1202 ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3);
1203 top -= 4;
1204 _ARG1 = tmp1;
1205 break;
1206 case SEXP_OP_CALLCC:
1207 stack[top] = SEXP_ONE;
1208 stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
1209 stack[top+2] = self;
1210 stack[top+3] = sexp_make_fixnum(fp);
1211 tmp1 = _ARG1;
1212 i = 1;
1213 sexp_context_top(ctx) = top;
1214 tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF);
1215 sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4));
1216 _ARG1 = sexp_make_procedure(ctx,
1217 SEXP_ZERO,
1218 SEXP_ONE,
1219 sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE),
1220 tmp2);
1221 top++;
1222 ip -= sizeof(sexp);
1223 goto make_call;
1224 case SEXP_OP_APPLY1:
1225 tmp1 = _ARG1;
1226 tmp2 = _ARG2;
1227 apply1:
1228 tmp = sexp_length(ctx, tmp2);
1229 if (sexp_not(tmp))
1230 sexp_raise("apply: circular list", sexp_list1(ctx, tmp2));
1231 i = sexp_unbox_fixnum(tmp); /* number of params */
1232 sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
1233 k = sexp_unbox_fixnum(stack[fp+3]); /* previous fp */
1234 j = sexp_unbox_fixnum(stack[fp]); /* previous num params */
1235 self = stack[fp+2];
1236 bc = sexp_procedure_code(self);
1237 cp = sexp_procedure_vars(self);
1238 ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
1239 {
1240 int prev_top = top;
1241 for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
1242 stack[top] = sexp_car(tmp2);
1243 top = fp+i-j+1;
1244 fp = k;
1245 /* if final cdr of tmp2 isn't null, then args list was improper */
1246 if (! sexp_nullp(tmp2)) {
1247 top = prev_top;
1248 sexp_raise("apply: improper args list", sexp_list1(ctx, stack[prev_top-2]));
1249 }
1250 }
1251 goto make_call;
1252 case SEXP_OP_TAIL_CALL:
1253 _ALIGN_IP();
1254 i = sexp_unbox_fixnum(_WORD0); /* number of params */
1255 tmp1 = _ARG1; /* procedure to call */
1256 /* save frame info */
1257 tmp2 = stack[fp+3]; /* previous fp */
1258 j = sexp_unbox_fixnum(stack[fp]); /* previous num params */
1259 self = stack[fp+2];
1260 bc = sexp_procedure_code(self);
1261 cp = sexp_procedure_vars(self);
1262 ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
1263 /* copy new args into place */
1264 for (k=0; k<i; k++)
1265 stack[fp-j+k] = stack[top-1-i+k];
1266 top = fp+i-j+1;
1267 fp = sexp_unbox_fixnum(tmp2);
1268 goto make_call;
1269 case SEXP_OP_CALL:
1270 _ALIGN_IP();
1271 i = sexp_unbox_fixnum(_WORD0);
1272 tmp1 = _ARG1;
1273 make_call:
1274 sexp_context_top(ctx) = top;
1275 if (sexp_opcodep(tmp1)) {
1276 /* compile non-inlined opcode applications on the fly */
1277 tmp1 = make_opcode_procedure(ctx, tmp1, i);
1278 if (sexp_exceptionp(tmp1)) {
1279 _ARG1 = tmp1;
1280 goto call_error_handler;
1281 }
1282 }
1283 if (! sexp_procedurep(tmp1))
1284 sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
1285 j = i - sexp_procedure_num_args(tmp1);
1286 if (j < 0)
1287 sexp_raise("not enough args",
1288 sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
1289 /* ensure there's sufficient stack space before pushing args */
1290 sexp_ensure_stack(sexp_bytecode_max_depth(sexp_procedure_code(tmp1))+64);
1291 if (j > 0) {
1292 if (sexp_procedure_variadic_p(tmp1)) {
1293 if (!sexp_procedure_unused_rest_p(tmp1)) {
1294 stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL);
1295 for (k=top-i; k<top-(i-j)-1; k++)
1296 stack[top-i-1] = sexp_cons(ctx, stack[k], stack[top-i-1]);
1297 for ( ; k<top; k++)
1298 stack[k-j+1] = stack[k];
1299 top -= (j-1);
1300 i -= (j-1);
1301 }
1302 } else {
1303 sexp_raise("too many args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
1304 }
1305 } else if (sexp_procedure_variadic_p(tmp1) &&
1306 !sexp_procedure_unused_rest_p(tmp1)) {
1307 /* shift stack, set extra arg to null */
1308 for (k=top; k>=top-i; k--)
1309 stack[k] = stack[k-1];
1310 stack[top-i-1] = SEXP_NULL;
1311 top++;
1312 i++;
1313 }
1314 _ARG1 = sexp_make_fixnum(i);
1315 stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc));
1316 stack[top+1] = self;
1317 stack[top+2] = sexp_make_fixnum(fp);
1318 top += 3;
1319 self = tmp1;
1320 bc = sexp_procedure_code(self);
1321 ip = sexp_bytecode_data(bc);
1322 cp = sexp_procedure_vars(self);
1323 fp = top-4;
1324 break;
1325 case SEXP_OP_FCALL0:
1326 _ALIGN_IP();
1327 sexp_context_top(ctx) = top;
1328 sexp_context_last_fp(ctx) = fp;
1329 tmp1 = ((sexp_proc1)sexp_opcode_func(_WORD0))(ctx, _WORD0, 0);
1330 sexp_fcall_return(tmp1, -1)
1331 break;
1332 case SEXP_OP_FCALL1:
1333 _ALIGN_IP();
1334 sexp_context_top(ctx) = top;
1335 sexp_context_last_fp(ctx) = fp;
1336 tmp1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _WORD0, 1, _ARG1);
1337 sexp_fcall_return(tmp1, 0)
1338 break;
1339 case SEXP_OP_FCALL2:
1340 _ALIGN_IP();
1341 sexp_context_top(ctx) = top;
1342 sexp_context_last_fp(ctx) = fp;
1343 tmp1 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _WORD0, 2, _ARG1, _ARG2);
1344 sexp_fcall_return(tmp1, 1)
1345 break;
1346 case SEXP_OP_FCALL3:
1347 _ALIGN_IP();
1348 sexp_context_top(ctx) = top;
1349 sexp_context_last_fp(ctx) = fp;
1350 tmp1 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _WORD0, 3, _ARG1, _ARG2, _ARG3);
1351 sexp_fcall_return(tmp1, 2)
1352 break;
1353 case SEXP_OP_FCALL4:
1354 _ALIGN_IP();
1355 sexp_context_top(ctx) = top;
1356 sexp_context_last_fp(ctx) = fp;
1357 tmp1 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _WORD0, 4, _ARG1, _ARG2, _ARG3, _ARG4);
1358 sexp_fcall_return(tmp1, 3)
1359 break;
1360 #if SEXP_USE_EXTENDED_FCALL
1361 case SEXP_OP_FCALLN:
1362 _ALIGN_IP();
1363 sexp_context_top(ctx) = top;
1364 sexp_context_last_fp(ctx) = fp;
1365 i = sexp_opcode_num_args(_WORD0) + sexp_opcode_variadic_p(_WORD0);
1366 tmp1 = sexp_fcall(ctx, self, i, _WORD0);
1367 sexp_fcall_return(tmp1, i-1)
1368 break;
1369 #endif
1370 case SEXP_OP_JUMP_UNLESS:
1371 _ALIGN_IP();
1372 if (stack[--top] == SEXP_FALSE)
1373 ip += _SWORD0;
1374 else
1375 ip += sizeof(sexp_sint_t);
1376 break;
1377 case SEXP_OP_JUMP:
1378 _ALIGN_IP();
1379 ip += _SWORD0;
1380 break;
1381 case SEXP_OP_PUSH:
1382 _ALIGN_IP();
1383 _PUSH(_WORD0);
1384 ip += sizeof(sexp);
1385 break;
1386 #if SEXP_USE_RESERVE_OPCODE
1387 case SEXP_OP_RESERVE:
1388 _ALIGN_IP();
1389 for (i=_SWORD0; i > 0; i--)
1390 stack[top++] = SEXP_VOID;
1391 ip += sizeof(sexp);
1392 break;
1393 #endif
1394 case SEXP_OP_DROP:
1395 top--;
1396 break;
1397 case SEXP_OP_GLOBAL_REF:
1398 _ALIGN_IP();
1399 if (sexp_cdr(_WORD0) == SEXP_UNDEF) {
1400 /* handle renamed forward references by doing a final delayed */
1401 /* lookup before throwing an undefined variable error */
1402 if (sexp_synclop(sexp_car(_WORD0))) {
1403 tmp1 = sexp_env_cell(ctx, sexp_synclo_env(sexp_car(_WORD0)), sexp_synclo_expr(sexp_car(_WORD0)), 0);
1404 if (tmp1 != NULL) _WORD0 = tmp1;
1405 }
1406 if (sexp_cdr(_WORD0) == SEXP_UNDEF)
1407 sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0)));
1408 }
1409 /* ... FALLTHROUGH ... */
1410 case SEXP_OP_GLOBAL_KNOWN_REF:
1411 _ALIGN_IP();
1412 _PUSH(sexp_cdr(_WORD0));
1413 ip += sizeof(sexp);
1414 break;
1415 #if SEXP_USE_GREEN_THREADS
1416 case SEXP_OP_PARAMETER_REF:
1417 _ALIGN_IP();
1418 sexp_context_top(ctx) = top;
1419 tmp2 = _WORD0;
1420 ip += sizeof(sexp);
1421 for (tmp1=sexp_context_params(ctx); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
1422 if (sexp_caar(tmp1) == tmp2) {
1423 _PUSH(sexp_car(tmp1));
1424 goto loop;
1425 }
1426 _PUSH(sexp_opcode_data(tmp2));
1427 break;
1428 #endif
1429 case SEXP_OP_STACK_REF:
1430 _ALIGN_IP();
1431 stack[top] = stack[top - _SWORD0];
1432 ip += sizeof(sexp);
1433 top++;
1434 break;
1435 case SEXP_OP_LOCAL_REF:
1436 _ALIGN_IP();
1437 stack[top] = stack[fp - 1 - _SWORD0];
1438 ip += sizeof(sexp);
1439 top++;
1440 break;
1441 case SEXP_OP_LOCAL_SET:
1442 _ALIGN_IP();
1443 stack[fp - 1 - _SWORD0] = _POP();
1444 ip += sizeof(sexp);
1445 break;
1446 case SEXP_OP_CLOSURE_REF:
1447 _ALIGN_IP();
1448 _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_SWORD0)));
1449 ip += sizeof(sexp);
1450 break;
1451 case SEXP_OP_CLOSURE_VARS:
1452 _ARG1 = sexp_procedure_vars(_ARG1);
1453 break;
1454 case SEXP_OP_VECTOR_REF:
1455 if (! sexp_vectorp(_ARG1))
1456 sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
1457 else if (! sexp_fixnump(_ARG2))
1458 sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
1459 i = sexp_unbox_fixnum(_ARG2);
1460 if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
1461 sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1462 _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
1463 top--;
1464 break;
1465 case SEXP_OP_VECTOR_SET:
1466 if (! sexp_vectorp(_ARG1))
1467 sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
1468 else if (sexp_immutablep(_ARG1))
1469 sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1));
1470 else if (! sexp_fixnump(_ARG2))
1471 sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
1472 i = sexp_unbox_fixnum(_ARG2);
1473 if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
1474 sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1475 sexp_vector_set(_ARG1, _ARG2, _ARG3);
1476 top-=3;
1477 break;
1478 case SEXP_OP_VECTOR_LENGTH:
1479 if (! sexp_vectorp(_ARG1))
1480 sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1));
1481 _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1));
1482 break;
1483 case SEXP_OP_BYTES_REF:
1484 if (! sexp_bytesp(_ARG1))
1485 sexp_raise("byte-vector-ref: not a byte-vector", sexp_list1(ctx, _ARG1));
1486 if (! sexp_fixnump(_ARG2))
1487 sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2));
1488 i = sexp_unbox_fixnum(_ARG2);
1489 if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
1490 sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1491 _ARG2 = sexp_bytes_ref(_ARG1, _ARG2);
1492 top--;
1493 break;
1494 case SEXP_OP_STRING_REF:
1495 if (! sexp_stringp(_ARG1))
1496 sexp_raise("string-cursor-ref: not a string", sexp_list1(ctx, _ARG1));
1497 else if (! sexp_string_cursorp(_ARG2))
1498 sexp_raise("string-cursor-ref: not a string-cursor", sexp_list1(ctx, _ARG2));
1499 i = sexp_unbox_string_cursor(_ARG2);
1500 if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
1501 sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1502 _ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2);
1503 top--;
1504 sexp_check_exception();
1505 break;
1506 case SEXP_OP_BYTES_SET:
1507 if (! sexp_bytesp(_ARG1))
1508 sexp_raise("byte-vector-set!: not a byte-vector", sexp_list1(ctx, _ARG1));
1509 else if (sexp_immutablep(_ARG1))
1510 sexp_raise("byte-vector-set!: immutable byte-vector", sexp_list1(ctx, _ARG1));
1511 else if (! sexp_fixnump(_ARG2))
1512 sexp_raise("byte-vector-set!: not an integer", sexp_list1(ctx, _ARG2));
1513 else if (!(sexp_fixnump(_ARG3) && sexp_unbox_fixnum(_ARG3)>=0
1514 && sexp_unbox_fixnum(_ARG3)<0x100))
1515 sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3));
1516 i = sexp_unbox_fixnum(_ARG2);
1517 if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
1518 sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1519 sexp_bytes_set(_ARG1, _ARG2, _ARG3);
1520 top-=3;
1521 break;
1522 #if SEXP_USE_MUTABLE_STRINGS
1523 case SEXP_OP_STRING_SET:
1524 if (! sexp_stringp(_ARG1))
1525 sexp_raise("string-cursor-set!: not a string", sexp_list1(ctx, _ARG1));
1526 else if (sexp_immutablep(_ARG1))
1527 sexp_raise("string-cursor-set!: immutable string", sexp_list1(ctx, _ARG1));
1528 else if (! sexp_string_cursorp(_ARG2))
1529 sexp_raise("string-cursor-set!: not a string-cursor", sexp_list1(ctx, _ARG2));
1530 else if (! sexp_charp(_ARG3))
1531 sexp_raise("string-cursor-set!: not a char", sexp_list1(ctx, _ARG3));
1532 i = sexp_unbox_string_cursor(_ARG2);
1533 if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
1534 sexp_raise("string-cursor-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
1535 sexp_context_top(ctx) = top;
1536 sexp_string_set(ctx, _ARG1, _ARG2, _ARG3);
1537 top-=3;
1538 break;
1539 #endif
1540 #if SEXP_USE_UTF8_STRINGS
1541 case SEXP_OP_STRING_CURSOR_NEXT:
1542 if (! sexp_stringp(_ARG1))
1543 sexp_raise("string-cursor-next: not a string", sexp_list1(ctx, _ARG1));
1544 else if (! sexp_string_cursorp(_ARG2))
1545 sexp_raise("string-cursor-next: not a string-cursor", sexp_list1(ctx, _ARG2));
1546 _ARG2 = sexp_string_cursor_next(_ARG1, _ARG2);
1547 top--;
1548 sexp_check_exception();
1549 break;
1550 case SEXP_OP_STRING_CURSOR_PREV:
1551 if (! sexp_stringp(_ARG1))
1552 sexp_raise("string-cursor-prev: not a string", sexp_list1(ctx, _ARG1));
1553 else if (! sexp_string_cursorp(_ARG2))
1554 sexp_raise("string-cursor-prev: not a string-cursor", sexp_list1(ctx, _ARG2));
1555 _ARG2 = sexp_string_cursor_prev(_ARG1, _ARG2);
1556 top--;
1557 sexp_check_exception();
1558 break;
1559 case SEXP_OP_STRING_CURSOR_END:
1560 if (! sexp_stringp(_ARG1))
1561 sexp_raise("string-cursor-end: not a string", sexp_list1(ctx, _ARG1));
1562 _ARG1 = sexp_make_string_cursor(sexp_string_size(_ARG1));
1563 break;
1564 #endif
1565 case SEXP_OP_BYTES_LENGTH:
1566 if (! sexp_bytesp(_ARG1))
1567 sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1));
1568 _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1));
1569 break;
1570 case SEXP_OP_STRING_LENGTH:
1571 if (! sexp_stringp(_ARG1))
1572 sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1));
1573 _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1));
1574 break;
1575 case SEXP_OP_MAKE_PROCEDURE:
1576 sexp_context_top(ctx) = top;
1577 _ALIGN_IP();
1578 _ARG1 = sexp_make_procedure(ctx, _WORD0, _WORD1, _WORD2, _ARG1);
1579 ip += (3 * sizeof(sexp));
1580 break;
1581 case SEXP_OP_MAKE_VECTOR:
1582 sexp_context_top(ctx) = top;
1583 if (! sexp_fixnump(_ARG1))
1584 sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1));
1585 if (sexp_unbox_fixnum(_ARG1) < 0)
1586 sexp_raise("make-vector: length must be non-negative", sexp_list1(ctx, _ARG1));
1587 _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
1588 top--;
1589 break;
1590 case SEXP_OP_MAKE_EXCEPTION:
1591 sexp_context_top(ctx) = top;
1592 _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5);
1593 top -= 4;
1594 break;
1595 case SEXP_OP_AND:
1596 _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE));
1597 top--;
1598 break;
1599 case SEXP_OP_EOFP:
1600 _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
1601 case SEXP_OP_NULLP:
1602 _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
1603 case SEXP_OP_FIXNUMP:
1604 _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break;
1605 case SEXP_OP_SYMBOLP:
1606 _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
1607 case SEXP_OP_CHARP:
1608 _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
1609 case SEXP_OP_ISA:
1610 tmp1 = _ARG1, tmp2 = _ARG2;
1611 if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2);
1612 top--;
1613 goto do_check_type;
1614 case SEXP_OP_TYPEP:
1615 _ALIGN_IP();
1616 tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0);
1617 ip += sizeof(sexp);
1618 do_check_type:
1619 _ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2));
1620 break;
1621 case SEXP_OP_MAKE:
1622 _ALIGN_IP();
1623 sexp_context_top(ctx) = top;
1624 _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0));
1625 /* initialize fields to void */
1626 for (i=(_UWORD1-sexp_sizeof_header)/sizeof(sexp_uint_t) - 1; i>=0; i--)
1627 sexp_slot_set(_ARG1, i, SEXP_VOID);
1628 ip += sizeof(sexp)*2;
1629 break;
1630 case SEXP_OP_SLOT_REF:
1631 _ALIGN_IP();
1632 if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
1633 sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
1634 _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
1635 ip += sizeof(sexp)*2;
1636 break;
1637 case SEXP_OP_SLOT_SET:
1638 _ALIGN_IP();
1639 if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
1640 sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
1641 else if (sexp_immutablep(_ARG1))
1642 sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
1643 sexp_slot_set(_ARG1, _UWORD1, _ARG2);
1644 ip += sizeof(sexp)*2;
1645 top-=2;
1646 break;
1647 case SEXP_OP_SLOTN_REF:
1648 if (! sexp_typep(_ARG1))
1649 sexp_raise("slotn-ref: not a record type", sexp_list1(ctx, _ARG1));
1650 else if (! sexp_check_type(ctx, _ARG2, _ARG1))
1651 sexp_raise("slotn-ref: bad type", sexp_list1(ctx, _ARG2));
1652 if (! sexp_fixnump(_ARG3))
1653 for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
1654 if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
1655 if (! sexp_fixnump(_ARG3))
1656 sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
1657 if (sexp_vectorp(sexp_type_getters(_ARG1))) {
1658 if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_getters(_ARG1)))
1659 sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
1660 tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
1661 if (sexp_opcodep(tmp1))
1662 _ARG3 = ((sexp_proc2)sexp_opcode_func(tmp1))(ctx, tmp1, 1, _ARG2);
1663 else
1664 sexp_raise("slotn-ref: no getter defined", sexp_list1(ctx, _ARG3));
1665 } else {
1666 if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
1667 sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
1668 _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
1669 }
1670 top-=2;
1671 if (!_ARG1) _ARG1 = SEXP_VOID;
1672 else sexp_check_exception();
1673 break;
1674 case SEXP_OP_SLOTN_SET:
1675 if (! sexp_typep(_ARG1))
1676 sexp_raise("slotn-set!: not a record type", sexp_list1(ctx, _ARG1));
1677 else if (! sexp_check_type(ctx, _ARG2, _ARG1))
1678 sexp_raise("slotn-set!: bad type", sexp_list1(ctx, _ARG2));
1679 else if (sexp_immutablep(_ARG2))
1680 sexp_raise("slotn-set!: immutable object", sexp_list1(ctx, _ARG2));
1681 if (! sexp_fixnump(_ARG3))
1682 for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
1683 if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
1684 if (! sexp_fixnump(_ARG3))
1685 sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
1686 if (sexp_vectorp(sexp_type_setters(_ARG1))) {
1687 if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_setters(_ARG1)))
1688 sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
1689 tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
1690 if (sexp_opcodep(tmp1))
1691 _ARG4 = ((sexp_proc3)sexp_opcode_func(tmp1))(ctx, tmp1, 2, _ARG2, _ARG4);
1692 else
1693 sexp_raise("slotn-set!: no setter defined", sexp_list1(ctx, _ARG3));
1694 } else {
1695 if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
1696 sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
1697 sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
1698 }
1699 top-=4;
1700 sexp_check_exception();
1701 break;
1702 case SEXP_OP_CAR:
1703 if (! sexp_pairp(_ARG1))
1704 sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
1705 _ARG1 = sexp_car(_ARG1); break;
1706 case SEXP_OP_CDR:
1707 if (! sexp_pairp(_ARG1))
1708 sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1));
1709 _ARG1 = sexp_cdr(_ARG1); break;
1710 case SEXP_OP_SET_CAR:
1711 if (! sexp_pairp(_ARG1))
1712 sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1));
1713 else if (sexp_immutablep(_ARG1))
1714 sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1));
1715 sexp_car(_ARG1) = _ARG2;
1716 top-=2;
1717 break;
1718 case SEXP_OP_SET_CDR:
1719 if (! sexp_pairp(_ARG1))
1720 sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1));
1721 else if (sexp_immutablep(_ARG1))
1722 sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1));
1723 sexp_cdr(_ARG1) = _ARG2;
1724 top-=2;
1725 break;
1726 case SEXP_OP_CONS:
1727 sexp_context_top(ctx) = top;
1728 _ARG2 = sexp_cons(ctx, _ARG1, _ARG2);
1729 top--;
1730 break;
1731 case SEXP_OP_ADD:
1732 tmp1 = _ARG1, tmp2 = _ARG2;
1733 sexp_context_top(ctx) = --top;
1734 #if SEXP_USE_BIGNUMS
1735 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1736 j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2);
1737 if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
1738 _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
1739 else
1740 _ARG1 = sexp_make_fixnum(j);
1741 }
1742 else {
1743 _ARG1 = sexp_add(ctx, tmp1, tmp2);
1744 sexp_check_exception();
1745 }
1746 #else
1747 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
1748 _ARG1 = sexp_fx_add(tmp1, tmp2);
1749 #if SEXP_USE_FLONUMS
1750 else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
1751 _ARG1 = sexp_fp_add(ctx, tmp1, tmp2);
1752 else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
1753 _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2));
1754 else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
1755 _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2));
1756 #endif
1757 else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2));
1758 #endif
1759 break;
1760 case SEXP_OP_SUB:
1761 tmp1 = _ARG1, tmp2 = _ARG2;
1762 sexp_context_top(ctx) = --top;
1763 #if SEXP_USE_BIGNUMS
1764 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1765 j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2);
1766 if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
1767 _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
1768 else
1769 _ARG1 = sexp_make_fixnum(j);
1770 }
1771 else {
1772 _ARG1 = sexp_sub(ctx, tmp1, tmp2);
1773 sexp_check_exception();
1774 }
1775 #else
1776 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
1777 _ARG1 = sexp_fx_sub(tmp1, tmp2);
1778 #if SEXP_USE_FLONUMS
1779 else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
1780 _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2);
1781 else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
1782 _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - sexp_fixnum_to_double(tmp2));
1783 else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
1784 _ARG1 = sexp_make_flonum(ctx, tmp1==SEXP_ZERO ? -sexp_flonum_value(tmp2) : sexp_fixnum_to_double(tmp1)-sexp_flonum_value(tmp2));
1785 #endif
1786 else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2));
1787 #endif
1788 break;
1789 case SEXP_OP_MUL:
1790 tmp1 = _ARG1, tmp2 = _ARG2;
1791 sexp_context_top(ctx) = --top;
1792 #if SEXP_USE_BIGNUMS
1793 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1794 prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(tmp1)), sexp_unbox_fixnum(tmp2));
1795 if (!lsint_is_fixnum(prod))
1796 _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
1797 else
1798 _ARG1 = sexp_make_fixnum(lsint_to_sint(prod));
1799 }
1800 else {
1801 _ARG1 = sexp_mul(ctx, tmp1, tmp2);
1802 sexp_check_exception();
1803 }
1804 #else
1805 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
1806 _ARG1 = sexp_fx_mul(tmp1, tmp2);
1807 #if SEXP_USE_FLONUMS
1808 else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
1809 _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2);
1810 else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
1811 _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2));
1812 else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
1813 _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2));
1814 #endif
1815 else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2));
1816 #endif
1817 break;
1818 case SEXP_OP_DIV:
1819 tmp1 = _ARG1, tmp2 = _ARG2;
1820 sexp_context_top(ctx) = --top;
1821 if (tmp2 == SEXP_ZERO) {
1822 #if SEXP_USE_FLONUMS
1823 if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0)
1824 _ARG1 = sexp_make_flonum(ctx, 0.0);
1825 else
1826 #endif
1827 sexp_raise("divide by zero", SEXP_NULL);
1828 } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1829 #if SEXP_USE_RATIOS
1830 _ARG1 = sexp_make_ratio(ctx, tmp1, tmp2);
1831 _ARG1 = sexp_ratio_normalize(ctx, _ARG1, SEXP_FALSE);
1832 #else
1833 #if SEXP_USE_FLONUMS
1834 tmp1 = sexp_fixnum_to_flonum(ctx, tmp1);
1835 tmp2 = sexp_fixnum_to_flonum(ctx, tmp2);
1836 _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
1837 if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
1838 _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
1839 #else
1840 _ARG1 = sexp_fx_div(tmp1, tmp2);
1841 #endif
1842 #endif
1843 }
1844 #if SEXP_USE_BIGNUMS
1845 else {
1846 _ARG1 = sexp_div(ctx, tmp1, tmp2);
1847 sexp_check_exception();
1848 }
1849 #else
1850 #if SEXP_USE_FLONUMS
1851 else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
1852 _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
1853 else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
1854 _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2));
1855 else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
1856 _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2));
1857 #endif
1858 else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2));
1859 #endif
1860 break;
1861 case SEXP_OP_QUOTIENT:
1862 tmp1 = _ARG1, tmp2 = _ARG2;
1863 sexp_context_top(ctx) = --top;
1864 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1865 if (tmp2 == SEXP_ZERO)
1866 sexp_raise("divide by zero", SEXP_NULL);
1867 _ARG1 = sexp_fx_div(tmp1, tmp2);
1868 }
1869 #if SEXP_USE_BIGNUMS
1870 else {
1871 _ARG1 = sexp_quotient(ctx, tmp1, tmp2);
1872 sexp_check_exception();
1873 }
1874 #else
1875 else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2));
1876 #endif
1877 break;
1878 case SEXP_OP_REMAINDER:
1879 tmp1 = _ARG1, tmp2 = _ARG2;
1880 sexp_context_top(ctx) = --top;
1881 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1882 if (tmp2 == SEXP_ZERO)
1883 sexp_raise("divide by zero", SEXP_NULL);
1884 _ARG1 = sexp_fx_rem(tmp1, tmp2);
1885 }
1886 #if SEXP_USE_BIGNUMS
1887 else {
1888 _ARG1 = sexp_remainder(ctx, tmp1, tmp2);
1889 sexp_check_exception();
1890 }
1891 #else
1892 else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2));
1893 #endif
1894 break;
1895 case SEXP_OP_LT:
1896 tmp1 = _ARG1, tmp2 = _ARG2;
1897 sexp_context_top(ctx) = --top;
1898 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1899 i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2;
1900 #if SEXP_USE_BIGNUMS
1901 _ARG1 = sexp_make_boolean(i);
1902 } else {
1903 _ARG1 = sexp_compare(ctx, tmp1, tmp2);
1904 if (sexp_exceptionp(_ARG1)) {
1905 if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
1906 _ARG1 = SEXP_FALSE;
1907 else
1908 goto call_error_handler;
1909 } else {
1910 _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0);
1911 }
1912 }
1913 #else
1914 #if SEXP_USE_FLONUMS
1915 } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
1916 i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2);
1917 } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
1918 i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2);
1919 } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
1920 i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2);
1921 #endif
1922 } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2));
1923 _ARG1 = sexp_make_boolean(i);
1924 #endif
1925 break;
1926 case SEXP_OP_LE:
1927 tmp1 = _ARG1, tmp2 = _ARG2;
1928 sexp_context_top(ctx) = --top;
1929 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1930 i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2;
1931 #if SEXP_USE_BIGNUMS
1932 _ARG1 = sexp_make_boolean(i);
1933 } else {
1934 _ARG1 = sexp_compare(ctx, tmp1, tmp2);
1935 if (sexp_exceptionp(_ARG1)) {
1936 if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
1937 _ARG1 = SEXP_FALSE;
1938 else
1939 goto call_error_handler;
1940 } else {
1941 _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0);
1942 }
1943 }
1944 #else
1945 #if SEXP_USE_FLONUMS
1946 } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
1947 i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2);
1948 } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
1949 i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2);
1950 } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
1951 i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2);
1952 #endif
1953 } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2));
1954 _ARG1 = sexp_make_boolean(i);
1955 #endif
1956 break;
1957 case SEXP_OP_EQN:
1958 tmp1 = _ARG1, tmp2 = _ARG2;
1959 sexp_context_top(ctx) = --top;
1960 if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
1961 i = tmp1 == tmp2;
1962 #if SEXP_USE_BIGNUMS
1963 _ARG1 = sexp_make_boolean(i);
1964 } else {
1965 #if SEXP_USE_COMPLEX
1966 if (sexp_complexp(tmp1)) {
1967 if (sexp_flonump(sexp_complex_imag(tmp1))
1968 && sexp_flonum_value(sexp_complex_imag(tmp1)) == 0.0) {
1969 tmp1 = sexp_complex_real(tmp1);
1970 } else if (sexp_complexp(tmp2)) { /* both complex */
1971 _ARG1 = sexp_make_boolean(
1972 (sexp_compare(ctx, sexp_complex_real(tmp1), sexp_complex_real(tmp2))
1973 == SEXP_ZERO)
1974 && (sexp_compare(ctx, sexp_complex_imag(tmp1), sexp_complex_imag(tmp2))
1975 == SEXP_ZERO));
1976 break;
1977 } else if (sexp_numberp(tmp2)) {
1978 _ARG1 = SEXP_FALSE;
1979 break;
1980 }
1981 }
1982 if (sexp_complexp(tmp2)) {
1983 if (sexp_flonump(sexp_complex_imag(tmp2))
1984 && sexp_flonum_value(sexp_complex_imag(tmp2)) == 0.0) {
1985 tmp2 = sexp_complex_real(tmp2);
1986 } else if (sexp_numberp(tmp1)) {
1987 _ARG1 = SEXP_FALSE;
1988 break;
1989 }
1990 }
1991 #endif
1992 /* neither is complex */
1993 _ARG1 = sexp_compare(ctx, tmp1, tmp2);
1994 if (sexp_exceptionp(_ARG1)) {
1995 if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
1996 _ARG1 = SEXP_FALSE;
1997 else
1998 goto call_error_handler;
1999 } else {
2000 _ARG1 = sexp_make_boolean(_ARG1 == SEXP_ZERO);
2001 }
2002 }
2003 #else
2004 #if SEXP_USE_FLONUMS
2005 } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
2006 i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2);
2007 } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
2008 i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2);
2009 } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
2010 i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2);
2011 #endif
2012 } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2));
2013 _ARG1 = sexp_make_boolean(i);
2014 #endif
2015 break;
2016 case SEXP_OP_EQ:
2017 _ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
2018 top--;
2019 break;
2020 case SEXP_OP_SCP:
2021 _ARG1 = sexp_make_boolean(sexp_string_cursorp(_ARG1));
2022 break;
2023 case SEXP_OP_SC_LT:
2024 tmp1 = _ARG1, tmp2 = _ARG2;
2025 sexp_context_top(ctx) = --top;
2026 _ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 < (sexp_sint_t)tmp2);
2027 break;
2028 case SEXP_OP_SC_LE:
2029 tmp1 = _ARG1, tmp2 = _ARG2;
2030 sexp_context_top(ctx) = --top;
2031 _ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2);
2032 break;
2033 case SEXP_OP_CHAR2INT:
2034 if (! sexp_charp(_ARG1))
2035 sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1));
2036 _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1));
2037 break;
2038 case SEXP_OP_INT2CHAR:
2039 if (! sexp_fixnump(_ARG1))
2040 sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1));
2041 _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1));
2042 break;
2043 case SEXP_OP_CHAR_UPCASE:
2044 if (! sexp_charp(_ARG1))
2045 sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1));
2046 _ARG1 = sexp_make_character(sexp_toupper(sexp_unbox_character(_ARG1)));
2047 break;
2048 case SEXP_OP_CHAR_DOWNCASE:
2049 if (! sexp_charp(_ARG1))
2050 sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1));
2051 _ARG1 = sexp_make_character(sexp_tolower(sexp_unbox_character(_ARG1)));
2052 break;
2053 case SEXP_OP_WRITE_CHAR:
2054 if (! sexp_charp(_ARG1))
2055 sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1));
2056 if (! sexp_oportp(_ARG2))
2057 sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2));
2058 sexp_context_top(ctx) = top;
2059 #if SEXP_USE_GREEN_THREADS
2060 errno = 0;
2061 #endif
2062 #if SEXP_USE_UTF8_STRINGS
2063 if (sexp_unbox_character(_ARG1) >= 0x80)
2064 i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
2065 else
2066 #endif
2067 i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
2068 if (i == EOF) {
2069 if (!sexp_port_openp(_ARG2))
2070 sexp_raise("write-char: port is closed", _ARG2);
2071 else
2072 #if SEXP_USE_GREEN_THREADS
2073 if ((sexp_port_stream(_ARG2) ? ferror(sexp_port_stream(_ARG2)) : 1)
2074 && (errno == EAGAIN)) {
2075 if (sexp_port_stream(_ARG2)) clearerr(sexp_port_stream(_ARG2));
2076 if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
2077 sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2, SEXP_FALSE);
2078 else
2079 sexp_poll_output(ctx, _ARG2);
2080 fuel = 0;
2081 ip--; /* try again */
2082 goto loop;
2083 } else
2084 #endif
2085 sexp_raise("failed to write char to port", _ARG2);
2086 }
2087 top--;
2088 _ARG1 = SEXP_VOID;
2089 break;
2090 case SEXP_OP_WRITE_STRING:
2091 if (sexp_stringp(_ARG1))
2092 #if SEXP_USE_PACKED_STRINGS
2093 tmp1 = _ARG1;
2094 #else
2095 tmp1 = sexp_string_bytes(_ARG1);
2096 #endif
2097 else if (sexp_bytesp(_ARG1))
2098 tmp1 = _ARG1;
2099 else
2100 sexp_raise("write-string: not a string or bytes", sexp_list1(ctx, _ARG1));
2101 if (_ARG2 == SEXP_TRUE)
2102 _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1));
2103 else if (! sexp_fixnump(_ARG2))
2104 sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
2105 if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > (sexp_sint_t)sexp_bytes_length(tmp1))
2106 sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2));
2107 if (! sexp_oportp(_ARG3))
2108 sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
2109 if (!sexp_port_openp(_ARG3))
2110 sexp_raise("write-string: port is closed", _ARG3);
2111 sexp_context_top(ctx) = top;
2112 #if SEXP_USE_GREEN_THREADS
2113 errno = 0;
2114 #endif
2115 i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3);
2116 #if SEXP_USE_GREEN_THREADS
2117 if (i < sexp_unbox_fixnum(_ARG2) && errno == EAGAIN) {
2118 if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3));
2119 /* modify stack in-place so we continue where we left off next time */
2120 if (i > 0) {
2121 _ARG1 = sexp_subbytes(ctx, tmp1, sexp_make_fixnum(i), SEXP_FALSE);
2122 _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i);
2123 }
2124 /* yield if threads are enabled (otherwise busy loop) */
2125 /* TODO: the wait seems necessary on OS X to stop a print loop to ptys */
2126 if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
2127 sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3, SEXP_FALSE);
2128 else
2129 sexp_poll_output(ctx, _ARG3);
2130 fuel = 0;
2131 ip--; /* try again */
2132 goto loop;
2133 }
2134 #endif
2135 tmp1 = sexp_make_fixnum(i); /* return the number of bytes written */
2136 top-=2;
2137 _ARG1 = tmp1;
2138 break;
2139 case SEXP_OP_READ_CHAR:
2140 if (! sexp_iportp(_ARG1))
2141 sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
2142 sexp_context_top(ctx) = top;
2143 #if SEXP_USE_GREEN_THREADS
2144 errno = 0;
2145 #endif
2146 i = sexp_read_char(ctx, _ARG1);
2147 if (i == EOF) {
2148 if (!sexp_port_openp(_ARG1)) {
2149 sexp_raise("read-char: port is closed", _ARG1);
2150 #if SEXP_USE_GREEN_THREADS
2151 } else if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
2152 && (errno == EAGAIN)) {
2153 if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
2154 /* TODO: block and unblock */
2155 if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
2156 sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
2157 else
2158 sexp_poll_input(ctx, _ARG1);
2159 fuel = 0;
2160 ip--; /* try again */
2161 #endif
2162 } else {
2163 _ARG1 = SEXP_EOF;
2164 }
2165 #if SEXP_USE_UTF8_STRINGS
2166 } else if (i >= 0x80) {
2167 _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
2168 #endif
2169 } else {
2170 if (i == '\n') sexp_port_line(_ARG1)++;
2171 _ARG1 = sexp_make_character(i);
2172 }
2173 sexp_check_exception();
2174 break;
2175 case SEXP_OP_PEEK_CHAR:
2176 if (! sexp_iportp(_ARG1))
2177 sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
2178 sexp_context_top(ctx) = top;
2179 #if SEXP_USE_GREEN_THREADS
2180 errno = 0;
2181 #endif
2182 i = sexp_read_char(ctx, _ARG1);
2183 if (i == EOF) {
2184 if (!sexp_port_openp(_ARG1))
2185 sexp_raise("peek-char: port is closed", _ARG1);
2186 else
2187 #if SEXP_USE_GREEN_THREADS
2188 if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
2189 && (errno == EAGAIN)) {
2190 if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
2191 if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
2192 sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
2193 else
2194 sexp_poll_input(ctx, _ARG1);
2195 fuel = 0;
2196 ip--; /* try again */
2197 } else
2198 #endif
2199 _ARG1 = SEXP_EOF;
2200 #if SEXP_USE_UTF8_STRINGS
2201 } else if (i >= 0x80) {
2202 tmp1 = sexp_read_utf8_char(ctx, _ARG1, i);
2203 sexp_push_utf8_char(ctx, sexp_unbox_character(tmp1), _ARG1);
2204 _ARG1 = tmp1;
2205 #endif
2206 } else {
2207 sexp_push_char(ctx, i, _ARG1);
2208 _ARG1 = sexp_make_character(i);
2209 }
2210 sexp_check_exception();
2211 break;
2212 case SEXP_OP_YIELD:
2213 #if SEXP_USE_GREEN_THREADS
2214 fuel = 0;
2215 #endif
2216 break;
2217 case SEXP_OP_FORCE:
2218 #if SEXP_USE_AUTO_FORCE
2219 sexp_context_top(ctx) = top;
2220 while (sexp_promisep(_ARG1)) {
2221 if (sexp_promise_donep(_ARG1)) {
2222 _ARG1 = sexp_promise_value(_ARG1);
2223 } else {
2224 sexp_context_top(ctx) = top;
2225 tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
2226 if (!sexp_promise_donep(_ARG1)) {
2227 sexp_promise_value(_ARG1) = tmp1;
2228 sexp_promise_donep(_ARG1) = 1;
2229 }
2230 _ARG1 = tmp1;
2231 }
2232 }
2233 #endif
2234 break;
2235 case SEXP_OP_RET:
2236 i = sexp_unbox_fixnum(stack[fp]);
2237 stack[fp-i] = _ARG1;
2238 top = fp-i+1;
2239 self = stack[fp+2];
2240 bc = sexp_procedure_code(self);
2241 ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]);
2242 cp = sexp_procedure_vars(self);
2243 fp = sexp_unbox_fixnum(stack[fp+3]);
2244 break;
2245 case SEXP_OP_DONE:
2246 sexp_context_last_fp(ctx) = fp;
2247 goto end_loop;
2248 default:
2249 sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1))));
2250 }
2251 #if SEXP_USE_DEBUG_VM
2252 if (sexp_context_tracep(ctx))
2253 fprintf(stderr, "****** VM => %p (%d)\n", _ARG1,
2254 sexp_pointerp(_ARG1) && sexp_in_heap_p(ctx, _ARG1)
2255 ? sexp_pointer_tag(_ARG1) : -1);
2256 #endif
2257 goto loop;
2258
2259 end_loop:
2260 #if SEXP_USE_GREEN_THREADS
2261 sexp_context_result(ctx) = _ARG1;
2262 if (ctx != root_thread) {
2263 if (sexp_context_refuel(root_thread) <= 0) {
2264 /* the root already terminated */
2265 _ARG1 = sexp_context_result(root_thread);
2266 } else {
2267 /* don't return from child threads */
2268 if (sexp_exceptionp(_ARG1)) {
2269 tmp1 = sexp_current_error_port(ctx);
2270 sexp_write_string(ctx, "ERROR in child thread: ", tmp1);
2271 sexp_write(ctx, ctx, tmp1);
2272 sexp_newline(ctx, tmp1);
2273 sexp_print_exception(ctx, _ARG1, tmp1);
2274 }
2275 #if SEXP_USE_DEBUG_THREADS
2276 fprintf(stderr, "****** schedule %p: terminating %p (%s)\n",
2277 root_thread, ctx, sexp_thread_debug_name(ctx));
2278 #endif
2279 sexp_context_refuel(ctx) = fuel = 0;
2280 goto loop;
2281 }
2282 }
2283 #endif
2284 sexp_gc_release3(ctx);
2285 tmp1 = _ARG1;
2286 sexp_context_top(ctx) = --top;
2287 return tmp1;
2288 }
2289
sexp_apply1(sexp ctx,sexp f,sexp x)2290 sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
2291 sexp res;
2292 sexp_gc_var1(args);
2293 if (sexp_opcodep(f) && sexp_opcode_func(f)) {
2294 res = ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, x);
2295 } else {
2296 sexp_gc_preserve1(ctx, args);
2297 res = sexp_apply(ctx, f, args=sexp_list1(ctx, x));
2298 sexp_gc_release1(ctx);
2299 }
2300 return res;
2301 }
2302
sexp_apply2(sexp ctx,sexp f,sexp x,sexp y)2303 sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y) {
2304 sexp res;
2305 sexp_gc_var1(args);
2306 if (sexp_opcodep(f) && sexp_opcode_func(f)) {
2307 res = ((sexp_proc3)sexp_opcode_func(f))(ctx, f, 2, x, y);
2308 } else {
2309 sexp_gc_preserve1(ctx, args);
2310 res = sexp_apply(ctx, f, args=sexp_list2(ctx, x, y));
2311 sexp_gc_release1(ctx);
2312 }
2313 return res;
2314 }
2315
sexp_apply3(sexp ctx,sexp f,sexp x,sexp y,sexp z)2316 sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z) {
2317 sexp res;
2318 sexp_gc_var1(args);
2319 if (sexp_opcodep(f) && sexp_opcode_func(f)) {
2320 res = ((sexp_proc4)sexp_opcode_func(f))(ctx, f, 3, x, y, z);
2321 } else {
2322 sexp_gc_preserve1(ctx, args);
2323 res = sexp_apply(ctx, f, args=sexp_list3(ctx, x, y, z));
2324 sexp_gc_release1(ctx);
2325 }
2326 return res;
2327 }
2328
sexp_apply_no_err_handler(sexp ctx,sexp proc,sexp args)2329 sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args) {
2330 sexp res, err_cell;
2331 sexp_gc_var2(handler, params);
2332 sexp_gc_preserve2(ctx, handler, params);
2333 #if SEXP_USE_GREEN_THREADS
2334 params = sexp_context_params(ctx);
2335 sexp_context_params(ctx) = SEXP_NULL;
2336 ++sexp_context_refuel(ctx);
2337 #endif
2338 err_cell = sexp_global(ctx, SEXP_G_ERR_HANDLER);
2339 err_cell = sexp_opcodep(err_cell) ? sexp_opcode_data(err_cell) : SEXP_FALSE;
2340 handler = sexp_pairp(err_cell) ? sexp_cdr(err_cell) : SEXP_FALSE;
2341 if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = SEXP_FALSE;
2342 res = sexp_apply(ctx, proc, args);
2343 if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = handler;
2344 #if SEXP_USE_GREEN_THREADS
2345 sexp_context_params(ctx) = params;
2346 #endif
2347 sexp_gc_release2(ctx);
2348 return res;
2349 }
2350
2351 #endif
2352