static void validate_structure_layout(size_t slots, lref_t layout)
{
if (!CONSP(layout))
vmerror_wrong_type_n(2, layout);
size_t len = (size_t) get_c_long(llength(layout));
if (len != 2)
vmerror_arg_out_of_range(layout, _T("bad structure layout, length<>2"));
lref_t slot_layout = CAR(CDR(layout));
if (get_c_long(llength(slot_layout)) != (long) slots)
vmerror_arg_out_of_range(lcons(slot_layout, fixcons(slots)),
_T("bad structure layout, wrong number of slots"));
for (; CONSP(slot_layout); slot_layout = CDR(slot_layout))
{
if (!CONSP(CAR(slot_layout)))
vmerror_arg_out_of_range(lcons(slot_layout, layout),
_T("bad structure layout, bad slot layout"));
if (!SYMBOLP(CAR(CAR(slot_layout))))
vmerror_arg_out_of_range(layout,
_T("bad structure layout, missing slot name"));
}
}
lref_t lenvlookup(lref_t var, lref_t env)
{
lref_t frame;
for (frame = env; CONSP(frame); frame = CDR(frame))
{
lref_t tmp = CAR(frame);
if (!CONSP(tmp))
panic("damaged frame");
lref_t al, fl;
for (fl = CAR(tmp), al = CDR(tmp);
CONSP(fl);
fl = CDR(fl), al = CDR(al))
{
if (!CONSP(al))
vmerror_arg_out_of_range(NIL, _T("too few arguments"));
if (EQ(CAR(fl), var))
return al;
}
if (SYMBOLP(fl) && EQ(fl, var))
return lcons(al, NIL);
}
if (!NULLP(frame))
panic("damaged env");
return NIL;
}
void lenvlookup_set_by_index(fixnum_t frame_index, fixnum_t var_index, lref_t env, lref_t val)
{
lref_t binding_cell = binding_cell_by_index(frame_index, var_index, env);
if (NULLP(binding_cell)) {
vmerror_arg_out_of_range(NIL, _T("too few arguments (no binding cell)"));
}
SET_CAR(binding_cell, val);
}
lref_t lenvlookup_by_index(fixnum_t frame_index, fixnum_t var_index, lref_t env)
{
lref_t binding_cell = binding_cell_by_index(frame_index, var_index, env);
if (NULLP(binding_cell)) {
vmerror_arg_out_of_range(NIL, _T("too few arguments"));
}
return CAR(binding_cell);
}
static size_t get_trap_id(lref_t trap_id)
{
if (!FIXNUMP(trap_id))
vmerror_wrong_type_n(1, trap_id);
size_t id = (size_t)FIXNM(trap_id);
if (id > TRAP_LAST)
vmerror_arg_out_of_range(trap_id, _T("[0,TRAP_LAST]"));
return id;
}
lref_t lread_binary_string(lref_t l, lref_t port)
{
_TCHAR buf[STACK_STRBUF_LEN];
if (!BINARY_PORTP(port))
vmerror_wrong_type_n(2, port);
if (!NUMBERP(l))
vmerror_wrong_type_n(1, l);
fixnum_t remaining_length = get_c_fixnum(l);
if (remaining_length <= 0)
vmerror_arg_out_of_range(l, _T(">0"));
lref_t new_str = strcons();
size_t total_read = 0;
while (remaining_length > 0)
{
fixnum_t to_read = remaining_length;
if (to_read > STACK_STRBUF_LEN)
to_read = STACK_STRBUF_LEN;
size_t actual_read = read_bytes(port, buf, (size_t)(remaining_length * sizeof(_TCHAR)));
if (actual_read <= 0)
break;
string_appendd(new_str, buf, actual_read);
remaining_length -= actual_read;
total_read += actual_read;
}
if (total_read == 0)
return lmake_eof();
return new_str;
}
lref_t lapply(size_t argc, lref_t argv[])
{
size_t fn_argc = 0;
lref_t fn_argv[ARG_BUF_LEN];
lref_t fn = (argc > 0) ? argv[0] : NIL;
if (!PROCEDUREP(fn))
vmerror_wrong_type_n(1, fn);
for (size_t ii = 1; ii < argc - 1; ii++)
{
if (fn_argc >= ARG_BUF_LEN)
break;
fn_argv[fn_argc] = argv[ii];
fn_argc++;
}
lref_t args = (argc > 1) ? argv[argc - 1] : NIL;
while (CONSP(args))
{
if (fn_argc >= ARG_BUF_LEN)
break;
fn_argv[fn_argc] = CAR(args);
fn_argc++;
args = CDR(args);
}
if (fn_argc >= ARG_BUF_LEN)
vmerror_unsupported(_T("too many actual arguments in call to apply"));
if (!NULLP(args))
vmerror_arg_out_of_range(args, _T("bad formal argument list"));
return apply1(fn, fn_argc, fn_argv);
}
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
lref_t retval = NIL;
lref_t sym;
lref_t binding;
lref_t fn;
lref_t args;
size_t argc;
lref_t argv[ARG_BUF_LEN];
lref_t after;
lref_t tag;
lref_t cell;
lref_t escape_retval;
jmp_buf *jmpbuf;
STACK_CHECK(&fop);
_process_interrupts();
fstack_enter_eval_frame(&fop, fop, env);
while(!NULLP(fop)) {
switch(fop->header.opcode)
{
case FOP_LITERAL:
retval = fop->as.fast_op.arg1;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_REF:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
retval = binding;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_SET:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, retval);
fop = fop->as.fast_op.next;
break;
case FOP_APPLY_GLOBAL:
sym = fop->as.fast_op.arg1;
fn = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(fn))
vmerror_unbound(sym);
argc = 0;
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_APPLY:
argc = 0;
fn = execute_fast_op(fop->as.fast_op.arg1, env);
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_IF_TRUE:
if (TRUEP(retval))
fop = fop->as.fast_op.arg1;
else
fop = fop->as.fast_op.arg2;
break;
case FOP_RETVAL:
fop = fop->as.fast_op.next;
break;
case FOP_SEQUENCE:
retval = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.arg2;
break;
case FOP_THROW:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));
CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
CURRENT_TIB()->escape_value = escape_retval;
if (CURRENT_TIB()->escape_frame == NULL) {
/* If we don't find a matching catch for the throw, we have a
* problem and need to invoke a trap. */
vmtrap(TRAP_UNCAUGHT_THROW,
(enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
2, tag, escape_retval);
}
unwind_stack_for_throw();
fop = fop->as.fast_op.next;
break;
case FOP_CATCH:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));
if (setjmp(*jmpbuf) == 0) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
} else {
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));
retval = CURRENT_TIB()->escape_value;
CURRENT_TIB()->escape_value = NIL;
}
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_WITH_UNWIND_FN:
fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];
fstack_leave_frame();
apply1(after, 0, NULL);
fop = fop->as.fast_op.next;
break;
case FOP_CLOSURE:
retval = lclosurecons(env,
lcons(lcar(fop->as.fast_op.arg1),
fop->as.fast_op.arg2),
lcdr(fop->as.fast_op.arg1));
fop = fop->as.fast_op.next;
break;
case FOP_CAR:
retval = lcar(retval);
fop = fop->as.fast_op.next;
break;
case FOP_CDR:
retval = lcdr(retval);
fop = fop->as.fast_op.next;
break;
case FOP_NOT:
retval = boolcons(!TRUEP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_NULLP:
retval = boolcons(NULLP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_EQP:
retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
execute_fast_op(fop->as.fast_op.arg2, env)));
fop = fop->as.fast_op.next;
break;
case FOP_GET_ENV:
retval = env;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FSP:
retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FRAME:
retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
fop = fop->as.fast_op.next;
break;
case FOP_GET_HFRAMES:
retval = CURRENT_TIB()->handler_frames;
fop = fop->as.fast_op.next;
break;
case FOP_SET_HFRAMES:
CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_PRESERVE_FRAME:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fop = fop->as.fast_op.next;
break;
case FOP_STACK_BOUNDARY:
sym = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_boundary_frame(sym);
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_FAST_ENQUEUE_CELL:
retval = execute_fast_op(fop->as.fast_op.arg2, env);
cell = execute_fast_op(fop->as.fast_op.arg1, env);
SET_CDR(CAR(retval), cell);
SET_CAR(retval, cell);
fop = fop->as.fast_op.next;
break;
case FOP_WHILE_TRUE:
while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
}
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_BY_INDEX:
retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_RESTARG:
retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_SET_BY_INDEX:
lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env,
retval);
fop = fop->as.fast_op.next;
break;
default:
panic("Unsupported fast-op");
}
}
fstack_leave_frame();
return retval;
}
