mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
d69ffce3f2
This is taken from the read source of the lambda form itself. Previously it was getting the source of the expanded first expression, which more often than not was the let definition in init-7.scm
2304 lines
81 KiB
C
2304 lines
81 KiB
C
/* vm.c -- stack-based virtual machine backend */
|
|
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
|
/* BSD-style license: http://synthcode.com/license.txt */
|
|
|
|
#if SEXP_USE_NATIVE_X86
|
|
#include "opt/x86.c"
|
|
#else
|
|
/* ... the rest of this file ... */
|
|
|
|
#include "chibi/eval.h"
|
|
|
|
#if SEXP_USE_DEBUG_VM > 1
|
|
static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
|
|
int i;
|
|
if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
|
|
for (i=0; i<top; i++) {
|
|
sexp_write_char(ctx, ((i==fp) ? '*' : ' '), out);
|
|
if (i < 10) sexp_write_char(ctx, '0', out);
|
|
sexp_write(ctx, sexp_make_fixnum(i), out);
|
|
sexp_write_string(ctx, ": ", out);
|
|
sexp_write(ctx, stack[i], out);
|
|
sexp_newline(ctx, out);
|
|
}
|
|
}
|
|
#else
|
|
#define sexp_print_stack(ctx, stack, top, fp, out)
|
|
#endif
|
|
|
|
#if SEXP_USE_FULL_SOURCE_INFO
|
|
static sexp sexp_lookup_source_info (sexp src, int ip) {
|
|
int i;
|
|
if (src && sexp_procedurep(src))
|
|
src = sexp_procedure_source(src);
|
|
if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) {
|
|
for (i=1; i<(int)sexp_vector_length(src); i++)
|
|
if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(i)))) > ip)
|
|
return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1)));
|
|
return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1)));
|
|
}
|
|
return SEXP_FALSE;
|
|
}
|
|
#endif
|
|
|
|
void sexp_stack_trace (sexp ctx, sexp out) {
|
|
int i, fp=sexp_context_last_fp(ctx);
|
|
sexp self, bc, src, *stack=sexp_stack_data(sexp_context_stack(ctx));
|
|
if (! sexp_oportp(out))
|
|
out = sexp_current_error_port(ctx);
|
|
for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
|
|
self = stack[i+2];
|
|
if (self && sexp_procedurep(self)) {
|
|
sexp_write_string(ctx, " called from ", out);
|
|
bc = sexp_procedure_code(self);
|
|
if (sexp_symbolp(sexp_bytecode_name(bc)))
|
|
sexp_write(ctx, sexp_bytecode_name(bc), out);
|
|
else
|
|
sexp_write_string(ctx, "<anonymous>", out);
|
|
src = sexp_bytecode_source(bc);
|
|
#if SEXP_USE_FULL_SOURCE_INFO
|
|
if (src && sexp_vectorp(src))
|
|
src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
|
|
#endif
|
|
if (src && sexp_pairp(src)) {
|
|
if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
|
|
sexp_write_string(ctx, " on line ", out);
|
|
sexp_write(ctx, sexp_cdr(src), out);
|
|
}
|
|
if (sexp_stringp(sexp_car(src))) {
|
|
sexp_write_string(ctx, " of file ", out);
|
|
sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
|
|
}
|
|
}
|
|
sexp_write_char(ctx, '\n', out);
|
|
}
|
|
}
|
|
}
|
|
|
|
sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
|
|
sexp_stack_trace(ctx, out);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
/************************* code generation ****************************/
|
|
|
|
#if SEXP_USE_ALIGNED_BYTECODE
|
|
void sexp_context_align_pos(sexp ctx) {
|
|
sexp_uint_t i, pos = sexp_unbox_fixnum(sexp_context_pos(ctx));
|
|
sexp_uint_t new_pos = sexp_word_align(pos);
|
|
if (new_pos > pos) {
|
|
sexp_expand_bcode(ctx, (sexp_sint_t)new_pos - pos);
|
|
if (pos > 0)
|
|
for (i=pos; i<new_pos; ++i)
|
|
sexp_bytecode_data(sexp_context_bc(ctx))[i] =
|
|
sexp_bytecode_data(sexp_context_bc(ctx))[pos-1];
|
|
sexp_context_pos(ctx) = sexp_make_fixnum(new_pos);
|
|
}
|
|
}
|
|
#endif
|
|
|
|
static void sexp_inc_context_pos(sexp ctx, sexp_sint_t off) {
|
|
sexp_expand_bcode(ctx, off);
|
|
sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), sexp_make_fixnum(off));
|
|
}
|
|
|
|
static void sexp_inc_context_depth(sexp ctx, sexp_sint_t off) {
|
|
sexp_context_depth(ctx) = sexp_fx_add(sexp_context_depth(ctx), sexp_make_fixnum(off));
|
|
if (sexp_unbox_fixnum(sexp_context_depth(ctx))
|
|
> sexp_unbox_fixnum(sexp_context_max_depth(ctx)))
|
|
sexp_context_max_depth(ctx) = sexp_context_depth(ctx);
|
|
}
|
|
|
|
static void bytecode_preserve (sexp ctx, sexp obj) {
|
|
sexp ls = sexp_bytecode_literals(sexp_context_bc(ctx));
|
|
if (sexp_pointerp(obj) && !sexp_symbolp(obj)
|
|
&& sexp_not(sexp_memq(ctx, obj, ls)))
|
|
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj);
|
|
}
|
|
|
|
static void sexp_emit_word (sexp ctx, sexp_uint_t val) {
|
|
unsigned char *data;
|
|
sexp_context_align_pos(ctx);
|
|
sexp_expand_bcode(ctx, sizeof(sexp));
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return;
|
|
data = sexp_bytecode_data(sexp_context_bc(ctx));
|
|
*((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val;
|
|
sexp_inc_context_pos(ctx, sizeof(sexp));
|
|
}
|
|
|
|
static void sexp_emit_push (sexp ctx, sexp obj) {
|
|
sexp_emit(ctx, SEXP_OP_PUSH);
|
|
sexp_emit_word(ctx, (sexp_uint_t)obj);
|
|
sexp_inc_context_depth(ctx, 1);
|
|
bytecode_preserve(ctx, obj);
|
|
}
|
|
|
|
void sexp_emit_return (sexp ctx) {
|
|
sexp_emit(ctx, SEXP_OP_RET);
|
|
}
|
|
|
|
static void sexp_push_source (sexp ctx, sexp source) {
|
|
#if SEXP_USE_FULL_SOURCE_INFO
|
|
sexp src, bc = sexp_context_bc(ctx);
|
|
sexp_gc_var1(tmp);
|
|
if (source && sexp_pairp(source)) {
|
|
src = sexp_bytecode_source(bc);
|
|
if (!src) src = sexp_bytecode_source(bc) = SEXP_NULL;
|
|
if (!sexp_pairp(src)
|
|
|| sexp_unbox_fixnum(sexp_context_pos(ctx)) > sexp_unbox_fixnum(sexp_caar(src))) {
|
|
sexp_gc_preserve1(ctx, tmp);
|
|
tmp = sexp_cons(ctx, sexp_context_pos(ctx), source);
|
|
if (sexp_pairp(tmp)) {
|
|
tmp = sexp_cons(ctx, tmp, src);
|
|
if (sexp_pairp(tmp)) sexp_bytecode_source(bc) = tmp;
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
}
|
|
#endif
|
|
}
|
|
|
|
static sexp_sint_t sexp_context_make_label (sexp ctx) {
|
|
sexp_sint_t label;
|
|
sexp_context_align_pos(ctx);
|
|
label = sexp_unbox_fixnum(sexp_context_pos(ctx));
|
|
sexp_inc_context_pos(ctx, sizeof(sexp_uint_t));
|
|
return label;
|
|
}
|
|
|
|
static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
|
|
sexp bc = sexp_context_bc(ctx);
|
|
unsigned char *data = sexp_bytecode_data(bc)+label;
|
|
if (!sexp_exceptionp(sexp_context_exception(ctx)))
|
|
*((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label;
|
|
}
|
|
|
|
static void generate_lit (sexp ctx, sexp value) {
|
|
sexp_emit_push(ctx, value);
|
|
}
|
|
|
|
static void generate_drop_prev (sexp ctx, sexp prev) {
|
|
#if ! SEXP_USE_ALIGNED_BYTECODE
|
|
if ((sexp_pairp(prev) && sexp_opcodep(sexp_car(prev))
|
|
&& (sexp_opcode_code(sexp_car(prev)) == SEXP_OP_PUSH))
|
|
|| sexp_setp(prev) || sexp_litp(prev) || prev == SEXP_VOID)
|
|
sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
|
|
else
|
|
#endif
|
|
sexp_emit(ctx, SEXP_OP_DROP);
|
|
}
|
|
|
|
static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
|
|
sexp head=app, tail=sexp_cdr(app);
|
|
sexp_uint_t tailp = sexp_context_tailp(ctx);
|
|
sexp_push_source(ctx, sexp_pair_source(app));
|
|
sexp_context_tailp(ctx) = 0;
|
|
for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail))
|
|
if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) {
|
|
sexp_generate(ctx, name, loc, lam, sexp_car(head));
|
|
generate_drop_prev(ctx, sexp_car(head));
|
|
sexp_inc_context_depth(ctx, -1);
|
|
}
|
|
sexp_context_tailp(ctx) = (char)tailp;
|
|
sexp_generate(ctx, name, loc, lam, sexp_car(head));
|
|
}
|
|
|
|
static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) {
|
|
sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx);
|
|
sexp_push_source(ctx, sexp_cnd_source(cnd));
|
|
sexp_context_tailp(ctx) = 0;
|
|
sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd));
|
|
sexp_context_tailp(ctx) = (char)tailp;
|
|
sexp_emit(ctx, SEXP_OP_JUMP_UNLESS);
|
|
sexp_inc_context_depth(ctx, -1);
|
|
label1 = sexp_context_make_label(ctx);
|
|
sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd));
|
|
sexp_context_tailp(ctx) = (char)tailp;
|
|
sexp_emit(ctx, SEXP_OP_JUMP);
|
|
sexp_inc_context_depth(ctx, -1);
|
|
label2 = sexp_context_make_label(ctx);
|
|
sexp_context_patch_label(ctx, label1);
|
|
sexp_generate(ctx, name, loc, lam, sexp_cnd_fail(cnd));
|
|
sexp_context_patch_label(ctx, label2);
|
|
}
|
|
|
|
static void generate_non_global_ref (sexp ctx, sexp name, sexp cell,
|
|
sexp lambda, sexp fv, int unboxp) {
|
|
sexp_uint_t i;
|
|
sexp loc = sexp_cdr(cell);
|
|
if (loc == lambda && sexp_lambdap(lambda)) {
|
|
/* local ref */
|
|
sexp_emit(ctx, SEXP_OP_LOCAL_REF);
|
|
sexp_emit_word(ctx, sexp_param_index(ctx, lambda, name));
|
|
} else {
|
|
/* closure ref */
|
|
for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
|
|
if ((name == sexp_ref_name(sexp_car(fv)))
|
|
&& (loc == sexp_ref_loc(sexp_car(fv))))
|
|
break;
|
|
sexp_emit(ctx, SEXP_OP_CLOSURE_REF);
|
|
sexp_emit_word(ctx, i);
|
|
}
|
|
if (unboxp && (sexp_truep(sexp_memq(ctx, name, sexp_lambda_sv(loc)))))
|
|
sexp_emit(ctx, SEXP_OP_CDR);
|
|
sexp_inc_context_depth(ctx, +1);
|
|
}
|
|
|
|
static void generate_ref (sexp ctx, sexp ref, int unboxp) {
|
|
sexp lam;
|
|
sexp_push_source(ctx, sexp_ref_source(ref));
|
|
if (! sexp_lambdap(sexp_ref_loc(ref))) {
|
|
/* global ref */
|
|
if (unboxp) {
|
|
sexp_emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
|
|
? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
|
|
sexp_emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
|
|
bytecode_preserve(ctx, sexp_ref_cell(ref));
|
|
} else
|
|
sexp_emit_push(ctx, sexp_ref_cell(ref));
|
|
} else {
|
|
lam = sexp_context_lambda(ctx);
|
|
if (!lam || !sexp_lambdap(lam)) {
|
|
sexp_warn(ctx, "variable out of phase: ", sexp_ref_name(ref));
|
|
sexp_emit_push(ctx, SEXP_VOID);
|
|
} else {
|
|
generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
|
|
lam, sexp_lambda_fv(lam), unboxp);
|
|
}
|
|
}
|
|
}
|
|
|
|
static void generate_set (sexp ctx, sexp set) {
|
|
sexp ref = sexp_set_var(set), lambda;
|
|
sexp_push_source(ctx, sexp_set_source(set));
|
|
/* compile the value */
|
|
sexp_context_tailp(ctx) = 0;
|
|
if (sexp_lambdap(sexp_set_value(set))) {
|
|
sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref);
|
|
sexp_generate(ctx, sexp_ref_name(ref), sexp_ref_loc(ref), sexp_set_value(set), sexp_set_value(set));
|
|
} else {
|
|
sexp_generate(ctx, 0, 0, 0, sexp_set_value(set));
|
|
}
|
|
if (! sexp_lambdap(sexp_ref_loc(ref))) {
|
|
/* global vars are set directly */
|
|
if (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) {
|
|
/* force an undefined variable error if still undef at runtime */
|
|
generate_ref(ctx, ref, 1);
|
|
sexp_emit(ctx, SEXP_OP_DROP);
|
|
}
|
|
sexp_emit_push(ctx, sexp_ref_cell(ref));
|
|
sexp_emit(ctx, SEXP_OP_SET_CDR);
|
|
} else {
|
|
lambda = sexp_ref_loc(ref);
|
|
if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) {
|
|
/* stack or closure mutable vars are boxed */
|
|
generate_ref(ctx, ref, 0);
|
|
sexp_emit(ctx, SEXP_OP_SET_CDR);
|
|
} else {
|
|
/* internally defined variable */
|
|
sexp_emit(ctx, SEXP_OP_LOCAL_SET);
|
|
sexp_emit_word(ctx, sexp_param_index(ctx, lambda, sexp_ref_name(ref)));
|
|
}
|
|
}
|
|
sexp_emit_push(ctx, SEXP_VOID);
|
|
sexp_inc_context_depth(ctx, +1);
|
|
}
|
|
|
|
static void generate_opcode_app (sexp ctx, sexp app) {
|
|
sexp op = sexp_car(app);
|
|
sexp_sint_t i, num_args, inv_default=0;
|
|
sexp_gc_var1(ls);
|
|
sexp_gc_preserve1(ctx, ls);
|
|
|
|
if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) {
|
|
sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app);
|
|
generate_lit(ctx, SEXP_VOID);
|
|
return;
|
|
}
|
|
|
|
num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app)));
|
|
sexp_context_tailp(ctx) = 0;
|
|
|
|
if (sexp_opcode_class(op) != SEXP_OPC_PARAMETER) {
|
|
|
|
/* maybe push the default for an optional argument */
|
|
if ((num_args == sexp_opcode_num_args(op))
|
|
&& sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) {
|
|
if (sexp_opcode_inverse(op)) {
|
|
inv_default = 1;
|
|
} else {
|
|
if (sexp_opcode_opt_param_p(op) && sexp_opcodep(sexp_opcode_data(op))) {
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
|
|
sexp_emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
|
|
bytecode_preserve(ctx, sexp_opcode_data(op));
|
|
#else
|
|
sexp_emit_push(ctx, sexp_opcode_data(sexp_opcode_data(op)));
|
|
#endif
|
|
sexp_emit(ctx, SEXP_OP_CDR);
|
|
} else {
|
|
sexp_emit_push(ctx, sexp_opcode_data(op));
|
|
}
|
|
sexp_inc_context_depth(ctx, +1);
|
|
num_args++;
|
|
}
|
|
}
|
|
|
|
/* push the arguments onto the stack in reverse order */
|
|
if (!sexp_opcode_static_param_p(op)) {
|
|
ls = ((sexp_opcode_inverse(op)
|
|
&& (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC))
|
|
? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app)));
|
|
for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) {
|
|
sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
|
|
#if SEXP_USE_AUTO_FORCE
|
|
if (((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
|
|
|| sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR)
|
|
&& !(sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
|
|
&& sexp_unbox_fixnum(sexp_opcode_data(op)) == SEXP_PROMISE))
|
|
sexp_emit(ctx, SEXP_OP_FORCE);
|
|
#endif
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
/* push the default for inverse opcodes */
|
|
if (inv_default) {
|
|
sexp_emit_push(ctx, sexp_opcode_data(op));
|
|
if (sexp_opcode_opt_param_p(op)) sexp_emit(ctx, SEXP_OP_CDR);
|
|
sexp_inc_context_depth(ctx, +1);
|
|
num_args++;
|
|
}
|
|
|
|
/* emit the actual operator call */
|
|
switch (sexp_opcode_class(op)) {
|
|
case SEXP_OPC_ARITHMETIC:
|
|
/* fold variadic arithmetic operators */
|
|
for (i=num_args-1; i>0; i--)
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
break;
|
|
case SEXP_OPC_ARITHMETIC_CMP:
|
|
/* With [<true-value>, x] on the stack, and x boolean, */
|
|
/* AND is equivalent to ROT+DROP. Note one AND for every STACK_REF. */
|
|
if (num_args > 2) {
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 2);
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 2);
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
sexp_emit(ctx, SEXP_OP_AND);
|
|
for (i=num_args-2; i>0; i--) {
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 3);
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 3);
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
sexp_emit(ctx, SEXP_OP_AND);
|
|
sexp_emit(ctx, SEXP_OP_AND);
|
|
}
|
|
sexp_emit(ctx, SEXP_OP_AND);
|
|
} else
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
break;
|
|
case SEXP_OPC_FOREIGN:
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
sexp_emit_word(ctx, (sexp_uint_t)op);
|
|
bytecode_preserve(ctx, op);
|
|
break;
|
|
case SEXP_OPC_TYPE_PREDICATE:
|
|
case SEXP_OPC_GETTER:
|
|
case SEXP_OPC_SETTER:
|
|
case SEXP_OPC_CONSTRUCTOR:
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
|
|
|| sexp_opcode_code(op) == SEXP_OP_MAKE) {
|
|
if (sexp_opcode_data(op))
|
|
sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
|
|
if (sexp_opcode_data2(op))
|
|
sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
|
|
if (sexp_opcode_data(op) || sexp_opcode_data2(op))
|
|
bytecode_preserve(ctx, op);
|
|
}
|
|
break;
|
|
case SEXP_OPC_PARAMETER:
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if (num_args > 0) {
|
|
if (sexp_opcode_data2(op) && sexp_applicablep(sexp_opcode_data2(op))) {
|
|
ls = sexp_list2(ctx, sexp_opcode_data2(op), sexp_cadr(app));
|
|
sexp_generate(ctx, 0, 0, 0, ls);
|
|
} else {
|
|
sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
|
|
}
|
|
}
|
|
sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
|
|
sexp_emit_word(ctx, (sexp_uint_t)op);
|
|
bytecode_preserve(ctx, op);
|
|
#else
|
|
if (num_args > 0) sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
|
|
sexp_emit_push(ctx, sexp_opcode_data(op));
|
|
#endif
|
|
sexp_emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR));
|
|
if (num_args > 0) sexp_emit_push(ctx, SEXP_VOID);
|
|
break;
|
|
default:
|
|
sexp_emit(ctx, sexp_opcode_code(op));
|
|
}
|
|
|
|
if (sexp_opcode_static_param_p(op))
|
|
for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ?
|
|
sexp_lit_value(sexp_car(ls)) :
|
|
sexp_car(ls)));
|
|
|
|
if (sexp_opcode_return_type(op) == SEXP_VOID
|
|
&& sexp_opcode_class(op) != SEXP_OPC_FOREIGN)
|
|
sexp_emit_push(ctx, SEXP_VOID);
|
|
|
|
sexp_inc_context_depth(ctx, -(num_args-1));
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
|
|
static void generate_general_app (sexp ctx, sexp app) {
|
|
sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))),
|
|
tailp = sexp_context_tailp(ctx);
|
|
sexp_gc_var1(ls);
|
|
sexp_gc_preserve1(ctx, ls);
|
|
|
|
/* push the arguments onto the stack */
|
|
sexp_context_tailp(ctx) = 0;
|
|
for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
|
|
|
|
/* push the operator onto the stack */
|
|
sexp_generate(ctx, 0, 0, 0, sexp_car(app));
|
|
|
|
/* maybe overwrite the current frame */
|
|
sexp_emit(ctx, ((tailp && sexp_not(sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P))) ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL));
|
|
sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len));
|
|
|
|
sexp_context_tailp(ctx) = (char)tailp;
|
|
sexp_inc_context_depth(ctx, -len);
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
|
|
#if SEXP_USE_TAIL_JUMPS
|
|
static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
|
|
sexp_gc_var3(ls1, ls2, ls3);
|
|
sexp_gc_preserve3(ctx, ls1, ls2, ls3);
|
|
|
|
/* overwrite the arguments that differ */
|
|
sexp_context_tailp(ctx) = 0;
|
|
for (ls1=sexp_cdr(app), ls2=sexp_lambda_params(lam), ls3=SEXP_NULL;
|
|
sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=sexp_cdr(ls2)) {
|
|
if (!(sexp_refp(sexp_car(ls1))
|
|
&& sexp_ref_name(sexp_car(ls1)) == sexp_car(ls2)
|
|
&& sexp_ref_loc(sexp_car(ls1)) == lam
|
|
&& sexp_not(sexp_memq(ctx, sexp_car(ls2), sexp_lambda_sv(lam))))) {
|
|
sexp_generate(ctx, 0, 0, 0, sexp_car(ls1));
|
|
ls3 = sexp_cons(ctx, sexp_car(ls2), ls3);
|
|
}
|
|
}
|
|
for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
|
|
sexp_emit(ctx, SEXP_OP_LOCAL_SET);
|
|
sexp_emit_word(ctx, sexp_param_index(ctx, lam, sexp_car(ls1)));
|
|
}
|
|
|
|
/* drop the current result and jump */
|
|
sexp_emit(ctx, SEXP_OP_JUMP);
|
|
sexp_context_align_pos(ctx);
|
|
sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) +
|
|
(sexp_pairp(sexp_lambda_locals(lam))
|
|
? 1 + sizeof(sexp) : 0)));
|
|
|
|
sexp_context_tailp(ctx) = 1;
|
|
sexp_gc_release3(ctx);
|
|
}
|
|
#endif
|
|
|
|
static void generate_app (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
|
|
sexp_push_source(ctx, sexp_pair_source(app));
|
|
if (sexp_opcodep(sexp_car(app)))
|
|
generate_opcode_app(ctx, app);
|
|
#if SEXP_USE_TAIL_JUMPS
|
|
else if (sexp_context_tailp(ctx) && sexp_refp(sexp_car(app))
|
|
&& name == sexp_ref_name(sexp_car(app))
|
|
&& loc == sexp_ref_loc(sexp_car(app))
|
|
&& (sexp_length(ctx, sexp_cdr(app))
|
|
== sexp_length(ctx, sexp_lambda_params(lam))))
|
|
generate_tail_jump(ctx, name, loc, lam, app);
|
|
#endif
|
|
else
|
|
generate_general_app(ctx, app);
|
|
}
|
|
|
|
#if SEXP_USE_UNBOXED_LOCALS
|
|
static int sexp_internal_definep(sexp ctx, sexp x) {
|
|
return sexp_lambdap(sexp_ref_loc(x))
|
|
&& sexp_truep(sexp_memq(ctx, sexp_ref_name(x),
|
|
sexp_lambda_locals(sexp_ref_loc(x))));
|
|
}
|
|
|
|
static int sexp_mutual_internal_definep(sexp ctx, sexp x, sexp fv) {
|
|
return sexp_internal_definep(ctx, x)
|
|
&& sexp_ref_loc(x) == sexp_ref_loc(fv) && sexp_internal_definep(ctx, fv)
|
|
&& sexp_not(sexp_memq(ctx, sexp_ref_name(fv),
|
|
sexp_lambda_sv(sexp_ref_loc(fv))));
|
|
}
|
|
|
|
static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
|
|
sexp ls;
|
|
if (sexp_seqp(x)) {
|
|
for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if (!generate_lambda_locals(ctx, name, loc, lam, sexp_car(ls)))
|
|
return 0;
|
|
return 1;
|
|
} else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
|
|
sexp_generate(ctx, name, loc, lam, x);
|
|
sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x, sexp prev_lam) {
|
|
sexp_uint_t k, updatep, tailp;
|
|
sexp ls, ref, fv, prev_fv;
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return 0;
|
|
if (sexp_seqp(x)) {
|
|
tailp = sexp_context_tailp(ctx);
|
|
sexp_context_tailp(ctx) = 0;
|
|
for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
if (sexp_nullp(sexp_cdr(ls))) sexp_context_tailp(ctx) = tailp;
|
|
if (!generate_lambda_body(ctx, name, loc, lam, sexp_car(ls), prev_lam)) {
|
|
if (sexp_pairp(sexp_cdr(ls))) {
|
|
generate_drop_prev(ctx, sexp_car(ls));
|
|
for (ls=sexp_cdr(ls); sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls));
|
|
ls=sexp_cdr(ls)) {
|
|
sexp_generate(ctx, name, loc, lam, sexp_car(ls));
|
|
generate_drop_prev(ctx, sexp_car(ls));
|
|
}
|
|
sexp_context_tailp(ctx) = tailp;
|
|
sexp_generate(ctx, name, loc, lam, sexp_car(ls));
|
|
}
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
} else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
|
|
updatep = 0;
|
|
if (sexp_lambdap(sexp_set_value(x))) {
|
|
/* update potentially changed bindings */
|
|
fv = sexp_lambda_fv(sexp_set_value(x));
|
|
prev_fv = sexp_lambdap(prev_lam) ? sexp_lambda_fv(prev_lam) : SEXP_NULL;
|
|
for (k=0; fv && sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
|
|
ref = sexp_car(fv);
|
|
if (sexp_mutual_internal_definep(ctx, sexp_set_var(x), ref)) {
|
|
if (!updatep) {
|
|
updatep = 1;
|
|
generate_non_global_ref(ctx, sexp_ref_name(sexp_set_var(x)),
|
|
sexp_ref_cell(sexp_set_var(x)),
|
|
lam, sexp_lambda_fv(lam), 1);
|
|
sexp_emit(ctx, SEXP_OP_CLOSURE_VARS);
|
|
}
|
|
generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
|
|
lam, sexp_lambda_fv(lam), 1);
|
|
sexp_emit_push(ctx, sexp_make_fixnum(k));
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 3);
|
|
sexp_emit(ctx, SEXP_OP_VECTOR_SET);
|
|
sexp_inc_context_depth(ctx, -1);
|
|
}
|
|
}
|
|
}
|
|
if (updatep) sexp_emit(ctx, SEXP_OP_DROP);
|
|
return 1;
|
|
}
|
|
sexp_generate(ctx, name, loc, lam, x);
|
|
return 0;
|
|
}
|
|
#endif
|
|
|
|
static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambda) {
|
|
sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
|
|
sexp_sint_t k;
|
|
sexp_gc_var2(tmp, bc);
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return;
|
|
prev_lambda = sexp_context_lambda(ctx);
|
|
prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
|
|
fv = sexp_lambda_fv(lambda);
|
|
ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 0);
|
|
if (sexp_exceptionp(ctx2)) {
|
|
sexp_context_exception(ctx) = ctx2;
|
|
return;
|
|
}
|
|
sexp_context_lambda(ctx2) = lambda;
|
|
sexp_gc_preserve2(ctx, tmp, bc);
|
|
tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
|
|
/* allocate space for local vars */
|
|
k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
|
|
if (k > 0) {
|
|
#if SEXP_USE_RESERVE_OPCODE
|
|
sexp_emit(ctx2, SEXP_OP_RESERVE);
|
|
sexp_emit_word(ctx2, k);
|
|
#else
|
|
while (k--) sexp_emit_push(ctx2, SEXP_UNDEF);
|
|
#endif
|
|
}
|
|
/* box mutable vars */
|
|
for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
k = sexp_param_index(ctx, lambda, sexp_car(ls));
|
|
sexp_emit(ctx2, SEXP_OP_LOCAL_REF);
|
|
sexp_emit_word(ctx2, k);
|
|
sexp_emit_push(ctx2, sexp_car(ls));
|
|
sexp_emit(ctx2, SEXP_OP_CONS);
|
|
sexp_emit(ctx2, SEXP_OP_LOCAL_SET);
|
|
sexp_emit_word(ctx2, k);
|
|
}
|
|
if (lam != lambda) loc = 0;
|
|
#if SEXP_USE_UNBOXED_LOCALS
|
|
sexp_context_tailp(ctx2) = 0;
|
|
generate_lambda_locals(ctx2, name, loc, lambda, sexp_lambda_body(lambda));
|
|
sexp_context_tailp(ctx2) = 1;
|
|
generate_lambda_body(ctx2, name, loc, lambda, sexp_lambda_body(lambda), prev_lambda);
|
|
#else
|
|
sexp_context_tailp(ctx2) = 1;
|
|
sexp_generate(ctx2, name, loc, lam, sexp_lambda_body(lambda));
|
|
#endif
|
|
flags = sexp_make_fixnum(sexp_not(sexp_listp(ctx, sexp_lambda_params(lambda)))
|
|
? (SEXP_PROC_VARIADIC + (sexp_rest_unused_p(lambda)
|
|
? SEXP_PROC_UNUSED_REST: 0))
|
|
: SEXP_PROC_NONE);
|
|
len = sexp_length(ctx2, sexp_lambda_params(lambda));
|
|
bc = sexp_complete_bytecode(ctx2);
|
|
if (sexp_exceptionp(bc)) {
|
|
sexp_context_exception(ctx) = bc;
|
|
} else {
|
|
sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
|
|
sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
|
|
if (sexp_nullp(fv)) {
|
|
/* shortcut, no free vars */
|
|
tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
|
|
tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);
|
|
bytecode_preserve(ctx, tmp);
|
|
generate_lit(ctx, tmp);
|
|
} else {
|
|
/* push the closed vars */
|
|
sexp_emit_push(ctx, SEXP_VOID);
|
|
sexp_emit_push(ctx, sexp_length(ctx, fv));
|
|
sexp_emit(ctx, SEXP_OP_MAKE_VECTOR);
|
|
sexp_inc_context_depth(ctx, -1);
|
|
for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
|
|
ref = sexp_car(fv);
|
|
generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
|
|
prev_lambda, prev_fv, 0);
|
|
sexp_emit_push(ctx, sexp_make_fixnum(k));
|
|
sexp_emit(ctx, SEXP_OP_STACK_REF);
|
|
sexp_emit_word(ctx, 3);
|
|
sexp_emit(ctx, SEXP_OP_VECTOR_SET);
|
|
sexp_inc_context_depth(ctx, -1);
|
|
}
|
|
/* push the additional procedure info and make the closure */
|
|
sexp_emit(ctx, SEXP_OP_MAKE_PROCEDURE);
|
|
sexp_emit_word(ctx, (sexp_uint_t)flags);
|
|
sexp_emit_word(ctx, (sexp_uint_t)len);
|
|
sexp_emit_word(ctx, (sexp_uint_t)bc);
|
|
bytecode_preserve(ctx, bc);
|
|
}
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
}
|
|
|
|
void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return;
|
|
if (sexp_pointerp(x)) {
|
|
switch (sexp_pointer_tag(x)) {
|
|
case SEXP_PAIR: generate_app(ctx, name, loc, lam, x); break;
|
|
case SEXP_LAMBDA: generate_lambda(ctx, name, loc, lam, x); break;
|
|
case SEXP_CND: generate_cnd(ctx, name, loc, lam, x); break;
|
|
case SEXP_REF: generate_ref(ctx, x, 1); break;
|
|
case SEXP_SET: generate_set(ctx, x); break;
|
|
case SEXP_SEQ: generate_seq(ctx, name, loc, lam, sexp_seq_ls(x)); break;
|
|
case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break;
|
|
default: generate_lit(ctx, x);
|
|
}
|
|
} else {
|
|
generate_lit(ctx, x);
|
|
}
|
|
}
|
|
|
|
static sexp make_param_list (sexp ctx, sexp_uint_t i) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = SEXP_NULL;
|
|
for ( ; i>0; i--)
|
|
res = sexp_cons(ctx, sexp_make_fixnum(i), res);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
|
|
sexp ls, res, env;
|
|
sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
|
|
if (i == sexp_opcode_num_args(op)) { /* return before preserving */
|
|
if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
|
|
} else if (i < sexp_opcode_num_args(op)) {
|
|
return sexp_compile_error(ctx, "not enough args for opcode", op);
|
|
} else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
|
|
return sexp_compile_error(ctx, "too many args for opcode", op);
|
|
}
|
|
sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
|
|
params = make_param_list(ctx, i);
|
|
lambda = sexp_make_lambda(ctx, params);
|
|
ctx2 = sexp_make_child_context(ctx, lambda);
|
|
env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
|
|
if (sexp_exceptionp(env)) {
|
|
res = env;
|
|
} else {
|
|
sexp_context_env(ctx2) = env;
|
|
for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(ctx, env, sexp_car(ls), 0));
|
|
if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
|
|
}
|
|
if (!sexp_exceptionp(refs))
|
|
refs = sexp_reverse(ctx2, refs);
|
|
refs = sexp_cons(ctx2, op, refs);
|
|
if (sexp_exceptionp(refs)) {
|
|
res = refs;
|
|
} else {
|
|
generate_opcode_app(ctx2, refs);
|
|
bc = sexp_complete_bytecode(ctx2);
|
|
sexp_bytecode_name(bc) = sexp_opcode_name(op);
|
|
res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
|
|
if (i == sexp_opcode_num_args(op))
|
|
sexp_opcode_proc(op) = res;
|
|
}
|
|
}
|
|
sexp_gc_release6(ctx);
|
|
return res;
|
|
}
|
|
|
|
/*********************** the virtual machine **************************/
|
|
|
|
sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
|
|
return sexp_make_exception(ctx, SEXP_TRAMPOLINE, SEXP_FALSE, args, proc, SEXP_FALSE);
|
|
}
|
|
|
|
#if SEXP_USE_GROW_STACK
|
|
static int sexp_grow_stack (sexp ctx, int min_size) {
|
|
sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
|
|
int i, size = sexp_stack_length(old_stack), new_size;
|
|
new_size = size * 2;
|
|
if (new_size < min_size) new_size = min_size;
|
|
if (new_size > SEXP_MAX_STACK_SIZE) {
|
|
if (size == SEXP_MAX_STACK_SIZE)
|
|
return 0;
|
|
new_size = SEXP_MAX_STACK_SIZE;
|
|
}
|
|
stack = sexp_alloc_tagged(ctx, (sexp_sizeof(stack)+sizeof(sexp)*new_size),
|
|
SEXP_STACK);
|
|
if (!stack || sexp_exceptionp(stack))
|
|
return 0;
|
|
sexp_stack_length(stack) = new_size;
|
|
sexp_stack_top(stack) = sexp_context_top(ctx);
|
|
from = sexp_stack_data(old_stack);
|
|
to = sexp_stack_data(stack);
|
|
for (i=sexp_context_top(ctx)+1; i>=0; i--)
|
|
to[i] = from[i];
|
|
for (; ctx; ctx=sexp_context_parent(ctx))
|
|
if (sexp_context_stack(ctx) == old_stack)
|
|
sexp_context_stack(ctx) = stack;
|
|
return 1;
|
|
}
|
|
#else
|
|
#define sexp_grow_stack(ctx, min_size) 0
|
|
#endif
|
|
|
|
static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) {
|
|
sexp res, *data;
|
|
sexp_uint_t i;
|
|
res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID);
|
|
data = sexp_vector_data(res);
|
|
for (i=0; i<to; i++)
|
|
data[i] = stack[i];
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_restore_stack (sexp ctx, sexp saved) {
|
|
sexp_uint_t len = sexp_vector_length(saved), i;
|
|
sexp *from = sexp_vector_data(saved), *to;
|
|
#if SEXP_USE_CHECK_STACK
|
|
if ((len+64 >= sexp_stack_length(sexp_context_stack(ctx)))
|
|
&& !sexp_grow_stack(ctx, len+64))
|
|
return sexp_global(ctx, SEXP_G_OOS_ERROR);
|
|
#endif
|
|
to = sexp_stack_data(sexp_context_stack(ctx));
|
|
for (i=0; i<len; i++)
|
|
to[i] = from[i];
|
|
sexp_context_top(ctx) = len;
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
#define _ARG1 stack[top-1]
|
|
#define _ARG2 stack[top-2]
|
|
#define _ARG3 stack[top-3]
|
|
#define _ARG4 stack[top-4]
|
|
#define _ARG5 stack[top-5]
|
|
#define _ARG6 stack[top-6]
|
|
#define _PUSH(x) (stack[top++]=(x))
|
|
#define _POP() (stack[--top])
|
|
|
|
#if SEXP_USE_ALIGNED_BYTECODE
|
|
#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip)
|
|
#else
|
|
#define _ALIGN_IP()
|
|
#endif
|
|
|
|
#define _WORD0 ((sexp*)ip)[0]
|
|
#define _UWORD0 ((sexp_uint_t*)ip)[0]
|
|
#define _SWORD0 ((sexp_sint_t*)ip)[0]
|
|
#define _WORD1 ((sexp*)ip)[1]
|
|
#define _UWORD1 ((sexp_uint_t*)ip)[1]
|
|
#define _SWORD1 ((sexp_sint_t*)ip)[1]
|
|
#define _WORD2 ((sexp*)ip)[2]
|
|
|
|
#define sexp_raise(msg, args) \
|
|
do {sexp_context_top(ctx) = top+1; \
|
|
stack[top] = args; \
|
|
stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \
|
|
top++; \
|
|
goto call_error_handler;} \
|
|
while (0)
|
|
|
|
#define sexp_check_exception() \
|
|
do {if (sexp_exceptionp(_ARG1)) { \
|
|
goto call_error_handler;}} \
|
|
while (0)
|
|
|
|
static int sexp_check_type(sexp ctx, sexp a, sexp b) {
|
|
int d;
|
|
sexp t, v;
|
|
if (! sexp_pointerp(a))
|
|
return 0;
|
|
if (sexp_isa(a, b))
|
|
return 1;
|
|
t = sexp_object_type(ctx, a);
|
|
v = sexp_type_cpl(t);
|
|
if (! sexp_vectorp(v))
|
|
return 0;
|
|
if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
|
|
return 1;
|
|
d = sexp_type_depth(b);
|
|
return (d < (int)sexp_vector_length(v))
|
|
&& sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
|
|
}
|
|
|
|
#if SEXP_USE_GREEN_THREADS
|
|
#define sexp_fcall_return(x, i) \
|
|
if (sexp_exceptionp(x)) { \
|
|
if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) { \
|
|
fuel = 0; ip--; goto loop; \
|
|
} else if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)) { \
|
|
stack[top-i+1] = SEXP_ZERO; \
|
|
fuel = 0; ip--; goto loop; \
|
|
} else { \
|
|
top -= i; \
|
|
_ARG1 = x; \
|
|
ip += sizeof(sexp); \
|
|
goto call_error_handler; \
|
|
} \
|
|
} else { \
|
|
top -= i; \
|
|
_ARG1 = x; \
|
|
ip += sizeof(sexp); \
|
|
}
|
|
#else
|
|
#define sexp_fcall_return(x, i) \
|
|
top -= i; _ARG1 = x; ip += sizeof(sexp); sexp_check_exception();
|
|
#endif
|
|
|
|
#if SEXP_USE_EXTENDED_FCALL
|
|
#include "opt/fcall.c"
|
|
#endif
|
|
|
|
#if SEXP_USE_PROFILE_VM
|
|
sexp_uint_t profile1[SEXP_OP_NUM_OPCODES];
|
|
sexp_uint_t profile2[SEXP_OP_NUM_OPCODES][SEXP_OP_NUM_OPCODES];
|
|
|
|
sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
|
|
int i, j;
|
|
for (i=0; i<SEXP_OP_NUM_OPCODES; i++) {
|
|
profile1[i] = 0;
|
|
for (j=0; j<SEXP_OP_NUM_OPCODES; j++) profile2[i][j] = 0;
|
|
}
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
|
|
int i, j;
|
|
for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
|
|
fprintf(stderr, "%s %lu\n", sexp_opcode_names[i], profile1[i]);
|
|
for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
|
|
for (j=0; j<SEXP_OP_NUM_OPCODES; j++)
|
|
fprintf(stderr, "%s %s %lu\n", sexp_opcode_names[i],
|
|
sexp_opcode_names[j], profile2[i][j]);
|
|
return SEXP_VOID;
|
|
}
|
|
#endif
|
|
|
|
#if SEXP_USE_DEBUG_THREADS
|
|
static const char* sexp_thread_debug_name(sexp ctx) {
|
|
if (sexp_stringp(sexp_context_name(ctx)))
|
|
return sexp_string_data(sexp_context_name(ctx));
|
|
return "?";
|
|
}
|
|
|
|
static char* sexp_thread_debug_event_type(sexp ctx) {
|
|
sexp evt = sexp_context_event(ctx);
|
|
return sexp_portp(evt) ? "p" : sexp_contextp(evt) ? "c" : "?";
|
|
}
|
|
|
|
static void* sexp_thread_debug_event(sexp ctx) {
|
|
return (void*)sexp_context_event(ctx);
|
|
}
|
|
#endif
|
|
|
|
#if SEXP_USE_CHECK_STACK
|
|
#define sexp_ensure_stack(n) \
|
|
if (top+(n) >= sexp_stack_length(sexp_context_stack(ctx))) { \
|
|
sexp_context_top(ctx) = top; \
|
|
if (sexp_grow_stack(ctx, (n))) { \
|
|
stack = sexp_stack_data(sexp_context_stack(ctx)); \
|
|
} else { \
|
|
_ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); \
|
|
goto end_loop; \
|
|
} \
|
|
}
|
|
#else
|
|
#define sexp_ensure_stack(n)
|
|
#endif
|
|
|
|
/* used only when no thread scheduler has been loaded */
|
|
#if SEXP_USE_POLL_PORT
|
|
int sexp_poll_port(sexp ctx, sexp port, int inputp) {
|
|
fd_set fds;
|
|
int fd = sexp_port_fileno(port);
|
|
if (fd < 0) {
|
|
usleep(SEXP_POLL_SLEEP_TIME);
|
|
return -1;
|
|
}
|
|
FD_ZERO(&fds);
|
|
FD_SET(fd, &fds);
|
|
return select(1, (inputp ? &fds : NULL), (inputp ? NULL : &fds), NULL, NULL);
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|
unsigned char *ip;
|
|
sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx)), tmp;
|
|
sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp root_thread = ctx;
|
|
sexp_sint_t fuel = sexp_context_refuel(ctx);
|
|
#endif
|
|
#if SEXP_USE_PROFILE_VM
|
|
unsigned char last_op = SEXP_OP_NOOP;
|
|
#endif
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_lsint_t prod;
|
|
#endif
|
|
sexp_gc_var3(self, tmp1, tmp2);
|
|
sexp_gc_preserve3(ctx, self, tmp1, tmp2);
|
|
fp = top - 4;
|
|
self = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
|
|
bc = sexp_procedure_code(self);
|
|
cp = sexp_procedure_vars(self);
|
|
ip = sexp_bytecode_data(bc) - sizeof(sexp);
|
|
tmp1 = proc, tmp2 = args;
|
|
i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
|
|
sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
|
|
for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
|
|
_ARG1 = sexp_car(tmp2);
|
|
top += i+1;
|
|
goto make_call;
|
|
|
|
loop:
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if (--fuel <= 0) {
|
|
if (sexp_context_interruptp(ctx)) {
|
|
fuel = sexp_context_refuel(ctx);
|
|
sexp_context_interruptp(ctx) = 0;
|
|
_ARG1 = sexp_global(ctx, SEXP_G_INTERRUPT_ERROR);
|
|
goto call_error_handler;
|
|
}
|
|
tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
|
|
if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) {
|
|
/* save thread */
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_ip(ctx) = ip;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
sexp_context_proc(ctx) = self;
|
|
/* run scheduler */
|
|
#if SEXP_USE_DEBUG_THREADS
|
|
tmp2 = ctx;
|
|
#endif
|
|
ctx = sexp_apply1(ctx, tmp1, root_thread);
|
|
/* restore thread */
|
|
stack = sexp_stack_data(sexp_context_stack(ctx));
|
|
top = sexp_context_top(ctx);
|
|
fp = sexp_context_last_fp(ctx);
|
|
ip = sexp_context_ip(ctx);
|
|
self = sexp_context_proc(ctx);
|
|
bc = sexp_procedure_code(self);
|
|
cp = sexp_procedure_vars(self);
|
|
#if SEXP_USE_DEBUG_THREADS
|
|
if (ctx != tmp2) {
|
|
fprintf(stderr, "****** schedule %p: %p (%s) active:",
|
|
root_thread, ctx, sexp_thread_debug_name(ctx));
|
|
for (tmp1=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
|
|
fprintf(stderr, " %p (%s)", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)));
|
|
fprintf(stderr, " paused:");
|
|
for (tmp1=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
|
|
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)));
|
|
fprintf(stderr, " ******\n");
|
|
}
|
|
#endif
|
|
}
|
|
fuel = sexp_context_refuel(ctx);
|
|
if (fuel <= 0) goto end_loop;
|
|
if (sexp_context_waitp(ctx)) {
|
|
fuel = 1;
|
|
goto loop; /* we were still waiting, try again */
|
|
}
|
|
}
|
|
#endif
|
|
#if SEXP_USE_DEBUG_VM
|
|
if (sexp_context_tracep(ctx)) {
|
|
sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
|
|
fprintf(stderr, "****** VM %s %s ip: %p stack: %p top: %ld fp: %ld (%ld)\n",
|
|
(*ip<=SEXP_OP_NUM_OPCODES) ? sexp_opcode_names[*ip] : "UNKNOWN",
|
|
(SEXP_OP_FCALL0 <= *ip && *ip <= SEXP_OP_FCALL4
|
|
? sexp_string_data(sexp_opcode_name(((sexp*)(ip+1))[0])) : ""),
|
|
ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1));
|
|
}
|
|
#endif
|
|
#if SEXP_USE_PROFILE_VM
|
|
profile1[*ip]++;
|
|
profile2[last_op][*ip]++;
|
|
last_op = *ip;
|
|
#endif
|
|
switch (*ip++) {
|
|
case SEXP_OP_NOOP:
|
|
break;
|
|
call_error_handler:
|
|
if (! sexp_exception_procedure(_ARG1))
|
|
sexp_exception_procedure(_ARG1) = self;
|
|
#if SEXP_USE_FULL_SOURCE_INFO
|
|
if (sexp_not(sexp_exception_source(_ARG1))
|
|
&& sexp_procedurep(sexp_exception_procedure(_ARG1))
|
|
&& sexp_procedure_source(sexp_exception_procedure(_ARG1)))
|
|
sexp_exception_source(_ARG1) = sexp_lookup_source_info(sexp_exception_procedure(_ARG1), (ip-sexp_bytecode_data(bc)));
|
|
#endif
|
|
case SEXP_OP_RAISE:
|
|
sexp_context_top(ctx) = top;
|
|
if (sexp_trampolinep(_ARG1)) {
|
|
tmp1 = sexp_trampoline_procedure(_ARG1);
|
|
tmp2 = sexp_trampoline_args(_ARG1);
|
|
if (sexp_trampoline_abortp(_ARG1)) { /* abort - do not catch */
|
|
_ARG1 = tmp2;
|
|
goto end_loop;
|
|
}
|
|
top--;
|
|
if (sexp_not(tmp1) && sexp_pairp(tmp2)) { /* noop trampoline is */
|
|
_PUSH(sexp_car(tmp2)); /* a wrapped exception */
|
|
goto loop;
|
|
}
|
|
goto apply1;
|
|
}
|
|
tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER));
|
|
sexp_context_last_fp(ctx) = fp;
|
|
if (! sexp_procedurep(tmp1)) {
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_context_errorp(ctx) = 1;
|
|
#endif
|
|
if (!sexp_exceptionp(_ARG1)) {
|
|
_ARG1 = sexp_make_exception(ctx, SEXP_UNCAUGHT, SEXP_FALSE, _ARG1, self, SEXP_FALSE);
|
|
}
|
|
goto end_loop;
|
|
}
|
|
stack[top] = SEXP_ONE;
|
|
stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
|
|
stack[top+2] = self;
|
|
stack[top+3] = sexp_make_fixnum(fp);
|
|
top += 4;
|
|
self = tmp1;
|
|
bc = sexp_procedure_code(self);
|
|
ip = sexp_bytecode_data(bc);
|
|
cp = sexp_procedure_vars(self);
|
|
fp = top-4;
|
|
break;
|
|
case SEXP_OP_RESUMECC:
|
|
sexp_context_top(ctx) = top;
|
|
tmp1 = stack[fp-1];
|
|
tmp2 = sexp_restore_stack(ctx, sexp_vector_ref(cp, 0));
|
|
if (sexp_exceptionp(tmp2)) {_ARG1 = tmp2; goto call_error_handler;}
|
|
top = sexp_context_top(ctx);
|
|
fp = sexp_unbox_fixnum(_ARG1);
|
|
self = _ARG2;
|
|
bc = sexp_procedure_code(self);
|
|
cp = sexp_procedure_vars(self);
|
|
ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3);
|
|
top -= 4;
|
|
_ARG1 = tmp1;
|
|
break;
|
|
case SEXP_OP_CALLCC:
|
|
stack[top] = SEXP_ONE;
|
|
stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
|
|
stack[top+2] = self;
|
|
stack[top+3] = sexp_make_fixnum(fp);
|
|
tmp1 = _ARG1;
|
|
i = 1;
|
|
sexp_context_top(ctx) = top;
|
|
tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF);
|
|
sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4));
|
|
_ARG1 = sexp_make_procedure(ctx,
|
|
SEXP_ZERO,
|
|
SEXP_ONE,
|
|
sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE),
|
|
tmp2);
|
|
top++;
|
|
ip -= sizeof(sexp);
|
|
goto make_call;
|
|
case SEXP_OP_APPLY1:
|
|
tmp1 = _ARG1;
|
|
tmp2 = _ARG2;
|
|
apply1:
|
|
tmp = sexp_length(ctx, tmp2);
|
|
if (sexp_not(tmp))
|
|
sexp_raise("apply: circular list", sexp_list1(ctx, tmp2));
|
|
i = sexp_unbox_fixnum(tmp); /* number of params */
|
|
sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
|
|
k = sexp_unbox_fixnum(stack[fp+3]); /* previous fp */
|
|
j = sexp_unbox_fixnum(stack[fp]); /* previous num params */
|
|
self = stack[fp+2];
|
|
bc = sexp_procedure_code(self);
|
|
cp = sexp_procedure_vars(self);
|
|
ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
|
|
{
|
|
int prev_top = top;
|
|
for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
|
|
stack[top] = sexp_car(tmp2);
|
|
top = fp+i-j+1;
|
|
fp = k;
|
|
/* if final cdr of tmp2 isn't null, then args list was improper */
|
|
if (! sexp_nullp(tmp2)) {
|
|
top = prev_top;
|
|
sexp_raise("apply: improper args list", sexp_list1(ctx, stack[prev_top-2]));
|
|
}
|
|
}
|
|
goto make_call;
|
|
case SEXP_OP_TAIL_CALL:
|
|
_ALIGN_IP();
|
|
i = sexp_unbox_fixnum(_WORD0); /* number of params */
|
|
tmp1 = _ARG1; /* procedure to call */
|
|
/* save frame info */
|
|
tmp2 = stack[fp+3]; /* previous fp */
|
|
j = sexp_unbox_fixnum(stack[fp]); /* previous num params */
|
|
self = stack[fp+2];
|
|
bc = sexp_procedure_code(self);
|
|
cp = sexp_procedure_vars(self);
|
|
ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
|
|
/* copy new args into place */
|
|
for (k=0; k<i; k++)
|
|
stack[fp-j+k] = stack[top-1-i+k];
|
|
top = fp+i-j+1;
|
|
fp = sexp_unbox_fixnum(tmp2);
|
|
goto make_call;
|
|
case SEXP_OP_CALL:
|
|
_ALIGN_IP();
|
|
i = sexp_unbox_fixnum(_WORD0);
|
|
tmp1 = _ARG1;
|
|
make_call:
|
|
sexp_context_top(ctx) = top;
|
|
if (sexp_opcodep(tmp1)) {
|
|
/* compile non-inlined opcode applications on the fly */
|
|
tmp1 = make_opcode_procedure(ctx, tmp1, i);
|
|
if (sexp_exceptionp(tmp1)) {
|
|
_ARG1 = tmp1;
|
|
goto call_error_handler;
|
|
}
|
|
}
|
|
if (! sexp_procedurep(tmp1))
|
|
sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
|
|
j = i - sexp_procedure_num_args(tmp1);
|
|
if (j < 0)
|
|
sexp_raise("not enough args",
|
|
sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
|
|
/* ensure there's sufficient stack space before pushing args */
|
|
sexp_ensure_stack(sexp_bytecode_max_depth(sexp_procedure_code(tmp1))+64);
|
|
if (j > 0) {
|
|
if (sexp_procedure_variadic_p(tmp1)) {
|
|
if (!sexp_procedure_unused_rest_p(tmp1)) {
|
|
stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL);
|
|
for (k=top-i; k<top-(i-j)-1; k++)
|
|
stack[top-i-1] = sexp_cons(ctx, stack[k], stack[top-i-1]);
|
|
for ( ; k<top; k++)
|
|
stack[k-j+1] = stack[k];
|
|
top -= (j-1);
|
|
i -= (j-1);
|
|
}
|
|
} else {
|
|
sexp_raise("too many args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
|
|
}
|
|
} else if (sexp_procedure_variadic_p(tmp1) &&
|
|
!sexp_procedure_unused_rest_p(tmp1)) {
|
|
/* shift stack, set extra arg to null */
|
|
for (k=top; k>=top-i; k--)
|
|
stack[k] = stack[k-1];
|
|
stack[top-i-1] = SEXP_NULL;
|
|
top++;
|
|
i++;
|
|
}
|
|
_ARG1 = sexp_make_fixnum(i);
|
|
stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc));
|
|
stack[top+1] = self;
|
|
stack[top+2] = sexp_make_fixnum(fp);
|
|
top += 3;
|
|
self = tmp1;
|
|
bc = sexp_procedure_code(self);
|
|
ip = sexp_bytecode_data(bc);
|
|
cp = sexp_procedure_vars(self);
|
|
fp = top-4;
|
|
break;
|
|
case SEXP_OP_FCALL0:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
tmp1 = ((sexp_proc1)sexp_opcode_func(_WORD0))(ctx, _WORD0, 0);
|
|
sexp_fcall_return(tmp1, -1)
|
|
break;
|
|
case SEXP_OP_FCALL1:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
tmp1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _WORD0, 1, _ARG1);
|
|
sexp_fcall_return(tmp1, 0)
|
|
break;
|
|
case SEXP_OP_FCALL2:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
tmp1 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _WORD0, 2, _ARG1, _ARG2);
|
|
sexp_fcall_return(tmp1, 1)
|
|
break;
|
|
case SEXP_OP_FCALL3:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
tmp1 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _WORD0, 3, _ARG1, _ARG2, _ARG3);
|
|
sexp_fcall_return(tmp1, 2)
|
|
break;
|
|
case SEXP_OP_FCALL4:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
tmp1 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _WORD0, 4, _ARG1, _ARG2, _ARG3, _ARG4);
|
|
sexp_fcall_return(tmp1, 3)
|
|
break;
|
|
#if SEXP_USE_EXTENDED_FCALL
|
|
case SEXP_OP_FCALLN:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = fp;
|
|
i = sexp_opcode_num_args(_WORD0) + sexp_opcode_variadic_p(_WORD0);
|
|
tmp1 = sexp_fcall(ctx, self, i, _WORD0);
|
|
sexp_fcall_return(tmp1, i-1)
|
|
break;
|
|
#endif
|
|
case SEXP_OP_JUMP_UNLESS:
|
|
_ALIGN_IP();
|
|
if (stack[--top] == SEXP_FALSE)
|
|
ip += _SWORD0;
|
|
else
|
|
ip += sizeof(sexp_sint_t);
|
|
break;
|
|
case SEXP_OP_JUMP:
|
|
_ALIGN_IP();
|
|
ip += _SWORD0;
|
|
break;
|
|
case SEXP_OP_PUSH:
|
|
_ALIGN_IP();
|
|
_PUSH(_WORD0);
|
|
ip += sizeof(sexp);
|
|
break;
|
|
#if SEXP_USE_RESERVE_OPCODE
|
|
case SEXP_OP_RESERVE:
|
|
_ALIGN_IP();
|
|
for (i=_SWORD0; i > 0; i--)
|
|
stack[top++] = SEXP_VOID;
|
|
ip += sizeof(sexp);
|
|
break;
|
|
#endif
|
|
case SEXP_OP_DROP:
|
|
top--;
|
|
break;
|
|
case SEXP_OP_GLOBAL_REF:
|
|
_ALIGN_IP();
|
|
if (sexp_cdr(_WORD0) == SEXP_UNDEF) {
|
|
/* handle renamed forward references by doing a final delayed */
|
|
/* lookup before throwing an undefined variable error */
|
|
if (sexp_synclop(sexp_car(_WORD0))) {
|
|
tmp1 = sexp_env_cell(ctx, sexp_synclo_env(sexp_car(_WORD0)), sexp_synclo_expr(sexp_car(_WORD0)), 0);
|
|
if (tmp1 != NULL) _WORD0 = tmp1;
|
|
}
|
|
if (sexp_cdr(_WORD0) == SEXP_UNDEF)
|
|
sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0)));
|
|
}
|
|
/* ... FALLTHROUGH ... */
|
|
case SEXP_OP_GLOBAL_KNOWN_REF:
|
|
_ALIGN_IP();
|
|
_PUSH(sexp_cdr(_WORD0));
|
|
ip += sizeof(sexp);
|
|
break;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
case SEXP_OP_PARAMETER_REF:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
tmp2 = _WORD0;
|
|
ip += sizeof(sexp);
|
|
for (tmp1=sexp_context_params(ctx); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
|
|
if (sexp_caar(tmp1) == tmp2) {
|
|
_PUSH(sexp_car(tmp1));
|
|
goto loop;
|
|
}
|
|
_PUSH(sexp_opcode_data(tmp2));
|
|
break;
|
|
#endif
|
|
case SEXP_OP_STACK_REF:
|
|
_ALIGN_IP();
|
|
stack[top] = stack[top - _SWORD0];
|
|
ip += sizeof(sexp);
|
|
top++;
|
|
break;
|
|
case SEXP_OP_LOCAL_REF:
|
|
_ALIGN_IP();
|
|
stack[top] = stack[fp - 1 - _SWORD0];
|
|
ip += sizeof(sexp);
|
|
top++;
|
|
break;
|
|
case SEXP_OP_LOCAL_SET:
|
|
_ALIGN_IP();
|
|
stack[fp - 1 - _SWORD0] = _POP();
|
|
ip += sizeof(sexp);
|
|
break;
|
|
case SEXP_OP_CLOSURE_REF:
|
|
_ALIGN_IP();
|
|
_PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_SWORD0)));
|
|
ip += sizeof(sexp);
|
|
break;
|
|
case SEXP_OP_CLOSURE_VARS:
|
|
_ARG1 = sexp_procedure_vars(_ARG1);
|
|
break;
|
|
case SEXP_OP_VECTOR_REF:
|
|
if (! sexp_vectorp(_ARG1))
|
|
sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_fixnump(_ARG2))
|
|
sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
|
|
i = sexp_unbox_fixnum(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
|
|
sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
_ARG2 = sexp_vector_ref(_ARG1, _ARG2);
|
|
top--;
|
|
break;
|
|
case SEXP_OP_VECTOR_SET:
|
|
if (! sexp_vectorp(_ARG1))
|
|
sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_fixnump(_ARG2))
|
|
sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
|
|
i = sexp_unbox_fixnum(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
|
|
sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
sexp_vector_set(_ARG1, _ARG2, _ARG3);
|
|
top-=3;
|
|
break;
|
|
case SEXP_OP_VECTOR_LENGTH:
|
|
if (! sexp_vectorp(_ARG1))
|
|
sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1));
|
|
break;
|
|
case SEXP_OP_BYTES_REF:
|
|
if (! sexp_bytesp(_ARG1))
|
|
sexp_raise("byte-vector-ref: not a byte-vector", sexp_list1(ctx, _ARG1));
|
|
if (! sexp_fixnump(_ARG2))
|
|
sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2));
|
|
i = sexp_unbox_fixnum(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
|
|
sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
_ARG2 = sexp_bytes_ref(_ARG1, _ARG2);
|
|
top--;
|
|
break;
|
|
case SEXP_OP_STRING_REF:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-cursor-ref: not a string", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_string_cursorp(_ARG2))
|
|
sexp_raise("string-cursor-ref: not a string-cursor", sexp_list1(ctx, _ARG2));
|
|
i = sexp_unbox_string_cursor(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
|
|
sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
_ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2);
|
|
top--;
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_BYTES_SET:
|
|
if (! sexp_bytesp(_ARG1))
|
|
sexp_raise("byte-vector-set!: not a byte-vector", sexp_list1(ctx, _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("byte-vector-set!: immutable byte-vector", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_fixnump(_ARG2))
|
|
sexp_raise("byte-vector-set!: not an integer", sexp_list1(ctx, _ARG2));
|
|
else if (!(sexp_fixnump(_ARG3) && sexp_unbox_fixnum(_ARG3)>=0
|
|
&& sexp_unbox_fixnum(_ARG3)<0x100))
|
|
sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3));
|
|
i = sexp_unbox_fixnum(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
|
|
sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
sexp_bytes_set(_ARG1, _ARG2, _ARG3);
|
|
top-=3;
|
|
break;
|
|
#if SEXP_USE_MUTABLE_STRINGS
|
|
case SEXP_OP_STRING_SET:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-cursor-set!: not a string", sexp_list1(ctx, _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("string-cursor-set!: immutable string", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_string_cursorp(_ARG2))
|
|
sexp_raise("string-cursor-set!: not a string-cursor", sexp_list1(ctx, _ARG2));
|
|
else if (! sexp_charp(_ARG3))
|
|
sexp_raise("string-cursor-set!: not a char", sexp_list1(ctx, _ARG3));
|
|
i = sexp_unbox_string_cursor(_ARG2);
|
|
if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
|
|
sexp_raise("string-cursor-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
|
|
sexp_context_top(ctx) = top;
|
|
sexp_string_set(ctx, _ARG1, _ARG2, _ARG3);
|
|
top-=3;
|
|
break;
|
|
#endif
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
case SEXP_OP_STRING_CURSOR_NEXT:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-cursor-next: not a string", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_string_cursorp(_ARG2))
|
|
sexp_raise("string-cursor-next: not a string-cursor", sexp_list1(ctx, _ARG2));
|
|
_ARG2 = sexp_string_cursor_next(_ARG1, _ARG2);
|
|
top--;
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_STRING_CURSOR_PREV:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-cursor-prev: not a string", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_string_cursorp(_ARG2))
|
|
sexp_raise("string-cursor-prev: not a string-cursor", sexp_list1(ctx, _ARG2));
|
|
_ARG2 = sexp_string_cursor_prev(_ARG1, _ARG2);
|
|
top--;
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_STRING_CURSOR_END:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-cursor-end: not a string", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_string_cursor(sexp_string_size(_ARG1));
|
|
break;
|
|
#endif
|
|
case SEXP_OP_BYTES_LENGTH:
|
|
if (! sexp_bytesp(_ARG1))
|
|
sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1));
|
|
break;
|
|
case SEXP_OP_STRING_LENGTH:
|
|
if (! sexp_stringp(_ARG1))
|
|
sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1));
|
|
break;
|
|
case SEXP_OP_MAKE_PROCEDURE:
|
|
sexp_context_top(ctx) = top;
|
|
_ALIGN_IP();
|
|
_ARG1 = sexp_make_procedure(ctx, _WORD0, _WORD1, _WORD2, _ARG1);
|
|
ip += (3 * sizeof(sexp));
|
|
break;
|
|
case SEXP_OP_MAKE_VECTOR:
|
|
sexp_context_top(ctx) = top;
|
|
if (! sexp_fixnump(_ARG1))
|
|
sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1));
|
|
if (sexp_unbox_fixnum(_ARG1) < 0)
|
|
sexp_raise("make-vector: length must be non-negative", sexp_list1(ctx, _ARG1));
|
|
_ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
|
|
top--;
|
|
break;
|
|
case SEXP_OP_MAKE_EXCEPTION:
|
|
sexp_context_top(ctx) = top;
|
|
_ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5);
|
|
top -= 4;
|
|
break;
|
|
case SEXP_OP_AND:
|
|
_ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE));
|
|
top--;
|
|
break;
|
|
case SEXP_OP_EOFP:
|
|
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
|
|
case SEXP_OP_NULLP:
|
|
_ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
|
|
case SEXP_OP_FIXNUMP:
|
|
_ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break;
|
|
case SEXP_OP_SYMBOLP:
|
|
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
|
|
case SEXP_OP_CHARP:
|
|
_ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
|
|
case SEXP_OP_ISA:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2);
|
|
top--;
|
|
goto do_check_type;
|
|
case SEXP_OP_TYPEP:
|
|
_ALIGN_IP();
|
|
tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0);
|
|
ip += sizeof(sexp);
|
|
do_check_type:
|
|
_ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2));
|
|
break;
|
|
case SEXP_OP_MAKE:
|
|
_ALIGN_IP();
|
|
sexp_context_top(ctx) = top;
|
|
_PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0));
|
|
/* initialize fields to void */
|
|
for (i=(_UWORD1-sexp_sizeof_header)/sizeof(sexp_uint_t) - 1; i>=0; i--)
|
|
sexp_slot_set(_ARG1, i, SEXP_VOID);
|
|
ip += sizeof(sexp)*2;
|
|
break;
|
|
case SEXP_OP_SLOT_REF:
|
|
_ALIGN_IP();
|
|
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
|
|
sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
|
|
_ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
|
|
ip += sizeof(sexp)*2;
|
|
break;
|
|
case SEXP_OP_SLOT_SET:
|
|
_ALIGN_IP();
|
|
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
|
|
sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
|
|
sexp_slot_set(_ARG1, _UWORD1, _ARG2);
|
|
ip += sizeof(sexp)*2;
|
|
top-=2;
|
|
break;
|
|
case SEXP_OP_SLOTN_REF:
|
|
if (! sexp_typep(_ARG1))
|
|
sexp_raise("slotn-ref: not a record type", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_check_type(ctx, _ARG2, _ARG1))
|
|
sexp_raise("slotn-ref: bad type", sexp_list1(ctx, _ARG2));
|
|
if (! sexp_fixnump(_ARG3))
|
|
for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
|
|
if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
|
|
if (! sexp_fixnump(_ARG3))
|
|
sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
|
|
if (sexp_vectorp(sexp_type_getters(_ARG1))) {
|
|
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_getters(_ARG1)))
|
|
sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
|
|
tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
|
|
if (sexp_opcodep(tmp1))
|
|
_ARG3 = ((sexp_proc2)sexp_opcode_func(tmp1))(ctx, tmp1, 1, _ARG2);
|
|
else
|
|
sexp_raise("slotn-ref: no getter defined", sexp_list1(ctx, _ARG3));
|
|
} else {
|
|
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
|
|
sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
|
|
_ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
|
|
}
|
|
top-=2;
|
|
if (!_ARG1) _ARG1 = SEXP_VOID;
|
|
else sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_SLOTN_SET:
|
|
if (! sexp_typep(_ARG1))
|
|
sexp_raise("slotn-set!: not a record type", sexp_list1(ctx, _ARG1));
|
|
else if (! sexp_check_type(ctx, _ARG2, _ARG1))
|
|
sexp_raise("slotn-set!: bad type", sexp_list1(ctx, _ARG2));
|
|
else if (sexp_immutablep(_ARG2))
|
|
sexp_raise("slotn-set!: immutable object", sexp_list1(ctx, _ARG2));
|
|
if (! sexp_fixnump(_ARG3))
|
|
for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
|
|
if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
|
|
if (! sexp_fixnump(_ARG3))
|
|
sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
|
|
if (sexp_vectorp(sexp_type_setters(_ARG1))) {
|
|
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_setters(_ARG1)))
|
|
sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
|
|
tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
|
|
if (sexp_opcodep(tmp1))
|
|
_ARG4 = ((sexp_proc3)sexp_opcode_func(tmp1))(ctx, tmp1, 2, _ARG2, _ARG4);
|
|
else
|
|
sexp_raise("slotn-set!: no setter defined", sexp_list1(ctx, _ARG3));
|
|
} else {
|
|
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
|
|
sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
|
|
sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
|
|
}
|
|
top-=4;
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_CAR:
|
|
if (! sexp_pairp(_ARG1))
|
|
sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_car(_ARG1); break;
|
|
case SEXP_OP_CDR:
|
|
if (! sexp_pairp(_ARG1))
|
|
sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_cdr(_ARG1); break;
|
|
case SEXP_OP_SET_CAR:
|
|
if (! sexp_pairp(_ARG1))
|
|
sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1));
|
|
sexp_car(_ARG1) = _ARG2;
|
|
top-=2;
|
|
break;
|
|
case SEXP_OP_SET_CDR:
|
|
if (! sexp_pairp(_ARG1))
|
|
sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1));
|
|
else if (sexp_immutablep(_ARG1))
|
|
sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1));
|
|
sexp_cdr(_ARG1) = _ARG2;
|
|
top-=2;
|
|
break;
|
|
case SEXP_OP_CONS:
|
|
sexp_context_top(ctx) = top;
|
|
_ARG2 = sexp_cons(ctx, _ARG1, _ARG2);
|
|
top--;
|
|
break;
|
|
case SEXP_OP_ADD:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2);
|
|
if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
|
|
_ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
|
|
else
|
|
_ARG1 = sexp_make_fixnum(j);
|
|
}
|
|
else {
|
|
_ARG1 = sexp_add(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_fx_add(tmp1, tmp2);
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_fp_add(ctx, tmp1, tmp2);
|
|
else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2));
|
|
else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2));
|
|
#endif
|
|
else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_SUB:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2);
|
|
if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
|
|
_ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
|
|
else
|
|
_ARG1 = sexp_make_fixnum(j);
|
|
}
|
|
else {
|
|
_ARG1 = sexp_sub(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_fx_sub(tmp1, tmp2);
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_fp_sub(ctx, tmp1, tmp2);
|
|
else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - sexp_fixnum_to_double(tmp2));
|
|
else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, tmp1==SEXP_ZERO ? -sexp_flonum_value(tmp2) : sexp_fixnum_to_double(tmp1)-sexp_flonum_value(tmp2));
|
|
#endif
|
|
else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_MUL:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(tmp1)), sexp_unbox_fixnum(tmp2));
|
|
if (!lsint_is_fixnum(prod))
|
|
_ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
|
|
else
|
|
_ARG1 = sexp_make_fixnum(lsint_to_sint(prod));
|
|
}
|
|
else {
|
|
_ARG1 = sexp_mul(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_fx_mul(tmp1, tmp2);
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_fp_mul(ctx, tmp1, tmp2);
|
|
else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2));
|
|
else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2));
|
|
#endif
|
|
else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_DIV:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (tmp2 == SEXP_ZERO) {
|
|
#if SEXP_USE_FLONUMS
|
|
if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0)
|
|
_ARG1 = sexp_make_flonum(ctx, 0.0);
|
|
else
|
|
#endif
|
|
sexp_raise("divide by zero", SEXP_NULL);
|
|
} else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
#if SEXP_USE_RATIOS
|
|
_ARG1 = sexp_make_ratio(ctx, tmp1, tmp2);
|
|
_ARG1 = sexp_ratio_normalize(ctx, _ARG1, SEXP_FALSE);
|
|
#else
|
|
#if SEXP_USE_FLONUMS
|
|
tmp1 = sexp_fixnum_to_flonum(ctx, tmp1);
|
|
tmp2 = sexp_fixnum_to_flonum(ctx, tmp2);
|
|
_ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
|
|
if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
|
|
_ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
|
|
#else
|
|
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
|
#endif
|
|
#endif
|
|
}
|
|
#if SEXP_USE_BIGNUMS
|
|
else {
|
|
_ARG1 = sexp_div(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
|
|
else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2));
|
|
else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
|
|
_ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2));
|
|
#endif
|
|
else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_QUOTIENT:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
if (tmp2 == SEXP_ZERO)
|
|
sexp_raise("divide by zero", SEXP_NULL);
|
|
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
|
}
|
|
#if SEXP_USE_BIGNUMS
|
|
else {
|
|
_ARG1 = sexp_quotient(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_REMAINDER:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
if (tmp2 == SEXP_ZERO)
|
|
sexp_raise("divide by zero", SEXP_NULL);
|
|
_ARG1 = sexp_fx_rem(tmp1, tmp2);
|
|
}
|
|
#if SEXP_USE_BIGNUMS
|
|
else {
|
|
_ARG1 = sexp_remainder(ctx, tmp1, tmp2);
|
|
sexp_check_exception();
|
|
}
|
|
#else
|
|
else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2));
|
|
#endif
|
|
break;
|
|
case SEXP_OP_LT:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2;
|
|
#if SEXP_USE_BIGNUMS
|
|
_ARG1 = sexp_make_boolean(i);
|
|
} else {
|
|
_ARG1 = sexp_compare(ctx, tmp1, tmp2);
|
|
if (sexp_exceptionp(_ARG1)) {
|
|
if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
|
|
_ARG1 = SEXP_FALSE;
|
|
else
|
|
goto call_error_handler;
|
|
} else {
|
|
_ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0);
|
|
}
|
|
}
|
|
#else
|
|
#if SEXP_USE_FLONUMS
|
|
} else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2);
|
|
} else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2);
|
|
} else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2);
|
|
#endif
|
|
} else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
_ARG1 = sexp_make_boolean(i);
|
|
#endif
|
|
break;
|
|
case SEXP_OP_LE:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2;
|
|
#if SEXP_USE_BIGNUMS
|
|
_ARG1 = sexp_make_boolean(i);
|
|
} else {
|
|
_ARG1 = sexp_compare(ctx, tmp1, tmp2);
|
|
if (sexp_exceptionp(_ARG1)) {
|
|
if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
|
|
_ARG1 = SEXP_FALSE;
|
|
else
|
|
goto call_error_handler;
|
|
} else {
|
|
_ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0);
|
|
}
|
|
}
|
|
#else
|
|
#if SEXP_USE_FLONUMS
|
|
} else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2);
|
|
} else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2);
|
|
} else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2);
|
|
#endif
|
|
} else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
_ARG1 = sexp_make_boolean(i);
|
|
#endif
|
|
break;
|
|
case SEXP_OP_EQN:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = tmp1 == tmp2;
|
|
#if SEXP_USE_BIGNUMS
|
|
_ARG1 = sexp_make_boolean(i);
|
|
} else {
|
|
#if SEXP_USE_COMPLEX
|
|
if (sexp_complexp(tmp1)) {
|
|
if (sexp_flonump(sexp_complex_imag(tmp1))
|
|
&& sexp_flonum_value(sexp_complex_imag(tmp1)) == 0.0) {
|
|
tmp1 = sexp_complex_real(tmp1);
|
|
} else if (sexp_complexp(tmp2)) { /* both complex */
|
|
_ARG1 = sexp_make_boolean(
|
|
(sexp_compare(ctx, sexp_complex_real(tmp1), sexp_complex_real(tmp2))
|
|
== SEXP_ZERO)
|
|
&& (sexp_compare(ctx, sexp_complex_imag(tmp1), sexp_complex_imag(tmp2))
|
|
== SEXP_ZERO));
|
|
break;
|
|
} else if (sexp_numberp(tmp2)) {
|
|
_ARG1 = SEXP_FALSE;
|
|
break;
|
|
}
|
|
}
|
|
if (sexp_complexp(tmp2)) {
|
|
if (sexp_flonump(sexp_complex_imag(tmp2))
|
|
&& sexp_flonum_value(sexp_complex_imag(tmp2)) == 0.0) {
|
|
tmp2 = sexp_complex_real(tmp2);
|
|
} else if (sexp_numberp(tmp1)) {
|
|
_ARG1 = SEXP_FALSE;
|
|
break;
|
|
}
|
|
}
|
|
#endif
|
|
/* neither is complex */
|
|
_ARG1 = sexp_compare(ctx, tmp1, tmp2);
|
|
if (sexp_exceptionp(_ARG1)) {
|
|
if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
|
|
_ARG1 = SEXP_FALSE;
|
|
else
|
|
goto call_error_handler;
|
|
} else {
|
|
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_ZERO);
|
|
}
|
|
}
|
|
#else
|
|
#if SEXP_USE_FLONUMS
|
|
} else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2);
|
|
} else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
|
|
i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2);
|
|
} else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
|
|
i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2);
|
|
#endif
|
|
} else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2));
|
|
_ARG1 = sexp_make_boolean(i);
|
|
#endif
|
|
break;
|
|
case SEXP_OP_EQ:
|
|
_ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
|
|
top--;
|
|
break;
|
|
case SEXP_OP_SCP:
|
|
_ARG1 = sexp_make_boolean(sexp_string_cursorp(_ARG1));
|
|
break;
|
|
case SEXP_OP_SC_LT:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
_ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 < (sexp_sint_t)tmp2);
|
|
break;
|
|
case SEXP_OP_SC_LE:
|
|
tmp1 = _ARG1, tmp2 = _ARG2;
|
|
sexp_context_top(ctx) = --top;
|
|
_ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2);
|
|
break;
|
|
case SEXP_OP_CHAR2INT:
|
|
if (! sexp_charp(_ARG1))
|
|
sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1));
|
|
break;
|
|
case SEXP_OP_INT2CHAR:
|
|
if (! sexp_fixnump(_ARG1))
|
|
sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1));
|
|
break;
|
|
case SEXP_OP_CHAR_UPCASE:
|
|
if (! sexp_charp(_ARG1))
|
|
sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_character(sexp_toupper(sexp_unbox_character(_ARG1)));
|
|
break;
|
|
case SEXP_OP_CHAR_DOWNCASE:
|
|
if (! sexp_charp(_ARG1))
|
|
sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1));
|
|
_ARG1 = sexp_make_character(sexp_tolower(sexp_unbox_character(_ARG1)));
|
|
break;
|
|
case SEXP_OP_WRITE_CHAR:
|
|
if (! sexp_charp(_ARG1))
|
|
sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1));
|
|
if (! sexp_oportp(_ARG2))
|
|
sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2));
|
|
sexp_context_top(ctx) = top;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
errno = 0;
|
|
#endif
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
if (sexp_unbox_character(_ARG1) >= 0x80)
|
|
i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
|
|
else
|
|
#endif
|
|
i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
|
|
if (i == EOF) {
|
|
if (!sexp_port_openp(_ARG2))
|
|
sexp_raise("write-char: port is closed", _ARG2);
|
|
else
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if ((sexp_port_stream(_ARG2) ? ferror(sexp_port_stream(_ARG2)) : 1)
|
|
&& (errno == EAGAIN)) {
|
|
if (sexp_port_stream(_ARG2)) clearerr(sexp_port_stream(_ARG2));
|
|
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
|
|
sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2, SEXP_FALSE);
|
|
else
|
|
sexp_poll_output(ctx, _ARG2);
|
|
fuel = 0;
|
|
ip--; /* try again */
|
|
goto loop;
|
|
} else
|
|
#endif
|
|
sexp_raise("failed to write char to port", _ARG2);
|
|
}
|
|
top--;
|
|
_ARG1 = SEXP_VOID;
|
|
break;
|
|
case SEXP_OP_WRITE_STRING:
|
|
if (sexp_stringp(_ARG1))
|
|
#if SEXP_USE_PACKED_STRINGS
|
|
tmp1 = _ARG1;
|
|
#else
|
|
tmp1 = sexp_string_bytes(_ARG1);
|
|
#endif
|
|
else if (sexp_bytesp(_ARG1))
|
|
tmp1 = _ARG1;
|
|
else
|
|
sexp_raise("write-string: not a string or bytes", sexp_list1(ctx, _ARG1));
|
|
if (_ARG2 == SEXP_TRUE)
|
|
_ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1));
|
|
else if (! sexp_fixnump(_ARG2))
|
|
sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
|
|
if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > (sexp_sint_t)sexp_bytes_length(tmp1))
|
|
sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2));
|
|
if (! sexp_oportp(_ARG3))
|
|
sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
|
|
if (!sexp_port_openp(_ARG3))
|
|
sexp_raise("write-string: port is closed", _ARG3);
|
|
sexp_context_top(ctx) = top;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
errno = 0;
|
|
#endif
|
|
i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3);
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if (i < sexp_unbox_fixnum(_ARG2) && errno == EAGAIN) {
|
|
if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3));
|
|
/* modify stack in-place so we continue where we left off next time */
|
|
if (i > 0) {
|
|
_ARG1 = sexp_subbytes(ctx, tmp1, sexp_make_fixnum(i), SEXP_FALSE);
|
|
_ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i);
|
|
}
|
|
/* yield if threads are enabled (otherwise busy loop) */
|
|
/* TODO: the wait seems necessary on OS X to stop a print loop to ptys */
|
|
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
|
|
sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3, SEXP_FALSE);
|
|
else
|
|
sexp_poll_output(ctx, _ARG3);
|
|
fuel = 0;
|
|
ip--; /* try again */
|
|
goto loop;
|
|
}
|
|
#endif
|
|
tmp1 = sexp_make_fixnum(i); /* return the number of bytes written */
|
|
top-=2;
|
|
_ARG1 = tmp1;
|
|
break;
|
|
case SEXP_OP_READ_CHAR:
|
|
if (! sexp_iportp(_ARG1))
|
|
sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
|
|
sexp_context_top(ctx) = top;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
errno = 0;
|
|
#endif
|
|
i = sexp_read_char(ctx, _ARG1);
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
if (i >= 0x80)
|
|
_ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
|
|
else
|
|
#endif
|
|
if (i == EOF) {
|
|
if (!sexp_port_openp(_ARG1))
|
|
sexp_raise("read-char: port is closed", _ARG1);
|
|
else
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
|
|
&& (errno == EAGAIN)) {
|
|
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
|
|
/* TODO: block and unblock */
|
|
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
|
|
sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
|
|
else
|
|
sexp_poll_input(ctx, _ARG1);
|
|
fuel = 0;
|
|
ip--; /* try again */
|
|
} else
|
|
#endif
|
|
_ARG1 = SEXP_EOF;
|
|
} else {
|
|
if (i == '\n') sexp_port_line(_ARG1)++;
|
|
_ARG1 = sexp_make_character(i);
|
|
}
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_PEEK_CHAR:
|
|
if (! sexp_iportp(_ARG1))
|
|
sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
|
|
sexp_context_top(ctx) = top;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
errno = 0;
|
|
#endif
|
|
i = sexp_read_char(ctx, _ARG1);
|
|
if (i == EOF) {
|
|
if (!sexp_port_openp(_ARG1))
|
|
sexp_raise("peek-char: port is closed", _ARG1);
|
|
else
|
|
#if SEXP_USE_GREEN_THREADS
|
|
if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
|
|
&& (errno == EAGAIN)) {
|
|
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
|
|
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
|
|
sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
|
|
else
|
|
sexp_poll_input(ctx, _ARG1);
|
|
fuel = 0;
|
|
ip--; /* try again */
|
|
} else
|
|
#endif
|
|
_ARG1 = SEXP_EOF;
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
} else if (i >= 0x80) {
|
|
tmp1 = sexp_read_utf8_char(ctx, _ARG1, i);
|
|
sexp_push_utf8_char(ctx, sexp_unbox_character(tmp1), _ARG1);
|
|
_ARG1 = tmp1;
|
|
#endif
|
|
} else {
|
|
sexp_push_char(ctx, i, _ARG1);
|
|
_ARG1 = sexp_make_character(i);
|
|
}
|
|
sexp_check_exception();
|
|
break;
|
|
case SEXP_OP_YIELD:
|
|
#if SEXP_USE_GREEN_THREADS
|
|
fuel = 0;
|
|
#endif
|
|
break;
|
|
case SEXP_OP_FORCE:
|
|
#if SEXP_USE_AUTO_FORCE
|
|
sexp_context_top(ctx) = top;
|
|
while (sexp_promisep(_ARG1)) {
|
|
if (sexp_promise_donep(_ARG1)) {
|
|
_ARG1 = sexp_promise_value(_ARG1);
|
|
} else {
|
|
sexp_context_top(ctx) = top;
|
|
tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
|
|
if (!sexp_promise_donep(_ARG1)) {
|
|
sexp_promise_value(_ARG1) = tmp1;
|
|
sexp_promise_donep(_ARG1) = 1;
|
|
}
|
|
_ARG1 = tmp1;
|
|
}
|
|
}
|
|
#endif
|
|
break;
|
|
case SEXP_OP_RET:
|
|
i = sexp_unbox_fixnum(stack[fp]);
|
|
stack[fp-i] = _ARG1;
|
|
top = fp-i+1;
|
|
self = stack[fp+2];
|
|
bc = sexp_procedure_code(self);
|
|
ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]);
|
|
cp = sexp_procedure_vars(self);
|
|
fp = sexp_unbox_fixnum(stack[fp+3]);
|
|
break;
|
|
case SEXP_OP_DONE:
|
|
sexp_context_last_fp(ctx) = fp;
|
|
goto end_loop;
|
|
default:
|
|
sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1))));
|
|
}
|
|
#if SEXP_USE_DEBUG_VM
|
|
if (sexp_context_tracep(ctx))
|
|
fprintf(stderr, "****** VM => %p (%d)\n", _ARG1,
|
|
sexp_pointerp(_ARG1) && sexp_in_heap_p(ctx, _ARG1)
|
|
? sexp_pointer_tag(_ARG1) : -1);
|
|
#endif
|
|
goto loop;
|
|
|
|
end_loop:
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_context_result(ctx) = _ARG1;
|
|
if (ctx != root_thread) {
|
|
if (sexp_context_refuel(root_thread) <= 0) {
|
|
/* the root already terminated */
|
|
_ARG1 = sexp_context_result(root_thread);
|
|
} else {
|
|
/* don't return from child threads */
|
|
if (sexp_exceptionp(_ARG1)) {
|
|
tmp1 = sexp_current_error_port(ctx);
|
|
sexp_write_string(ctx, "ERROR in child thread: ", tmp1);
|
|
sexp_write(ctx, ctx, tmp1);
|
|
sexp_newline(ctx, tmp1);
|
|
sexp_print_exception(ctx, _ARG1, tmp1);
|
|
}
|
|
#if SEXP_USE_DEBUG_THREADS
|
|
fprintf(stderr, "****** schedule %p: terminating %p (%s)\n",
|
|
root_thread, ctx, sexp_thread_debug_name(ctx));
|
|
#endif
|
|
sexp_context_refuel(ctx) = fuel = 0;
|
|
goto loop;
|
|
}
|
|
}
|
|
#endif
|
|
sexp_gc_release3(ctx);
|
|
tmp1 = _ARG1;
|
|
sexp_context_top(ctx) = --top;
|
|
return tmp1;
|
|
}
|
|
|
|
sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
|
|
sexp res;
|
|
sexp_gc_var1(args);
|
|
if (sexp_opcodep(f) && sexp_opcode_func(f)) {
|
|
res = ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, x);
|
|
} else {
|
|
sexp_gc_preserve1(ctx, args);
|
|
res = sexp_apply(ctx, f, args=sexp_list1(ctx, x));
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y) {
|
|
sexp res;
|
|
sexp_gc_var1(args);
|
|
if (sexp_opcodep(f) && sexp_opcode_func(f)) {
|
|
res = ((sexp_proc3)sexp_opcode_func(f))(ctx, f, 2, x, y);
|
|
} else {
|
|
sexp_gc_preserve1(ctx, args);
|
|
res = sexp_apply(ctx, f, args=sexp_list2(ctx, x, y));
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z) {
|
|
sexp res;
|
|
sexp_gc_var1(args);
|
|
if (sexp_opcodep(f) && sexp_opcode_func(f)) {
|
|
res = ((sexp_proc4)sexp_opcode_func(f))(ctx, f, 3, x, y, z);
|
|
} else {
|
|
sexp_gc_preserve1(ctx, args);
|
|
res = sexp_apply(ctx, f, args=sexp_list3(ctx, x, y, z));
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args) {
|
|
sexp res, err_cell;
|
|
sexp_gc_var2(handler, params);
|
|
sexp_gc_preserve2(ctx, handler, params);
|
|
#if SEXP_USE_GREEN_THREADS
|
|
params = sexp_context_params(ctx);
|
|
sexp_context_params(ctx) = SEXP_NULL;
|
|
++sexp_context_refuel(ctx);
|
|
#endif
|
|
err_cell = sexp_global(ctx, SEXP_G_ERR_HANDLER);
|
|
err_cell = sexp_opcodep(err_cell) ? sexp_opcode_data(err_cell) : SEXP_FALSE;
|
|
handler = sexp_pairp(err_cell) ? sexp_cdr(err_cell) : SEXP_FALSE;
|
|
if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = SEXP_FALSE;
|
|
res = sexp_apply(ctx, proc, args);
|
|
if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = handler;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_context_params(ctx) = params;
|
|
#endif
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
#endif
|