static void fast_read_structure(lref_t reader, lref_t * st)
{
lref_t st_meta;
fast_read(reader, &st_meta, false);
if (!CONSP(st_meta))
vmerror_fast_read("Expected list for structure metadata", reader, st_meta);
lref_t st_length;
fast_read(reader, &st_length, false);
if (!FIXNUMP(st_length))
vmerror_fast_read("Expected fixnum for structure length", reader, st_length);
*st = lstructurecons(vectorcons(FIXNM(st_length), NIL), st_meta);
for (fixnum_t ii = 0; ii < FIXNM(st_length); ii++)
{
lref_t object;
fast_read(reader, &object, false);
if (EOFP(object))
vmerror_fast_read("incomplete structure definition", reader, *st);
SET_STRUCTURE_ELEM(*st, ii, object);
}
}
static fixnum_t fast_read_table_index(lref_t reader)
{
lref_t index;
fast_read(reader, &index, false);
if (!FIXNUMP(index))
vmerror_fast_read("Expected fixnum for FASL table index", reader, index);
if (FIXNM(index) < 0)
vmerror_fast_read("FASL table indicies must be >=0", reader, index);
fasl_ensure_valid_table_index(reader, (size_t) FIXNM(index));
return FIXNM(index);
}
lref_t lstress_c_heap(lref_t c, lref_t s)
{
if (!FIXNUMP(c))
vmerror_wrong_type_n(1, c);
if (!FIXNUMP(s))
vmerror_wrong_type_n(2, s);
fixnum_t count = FIXNM(c);
fixnum_t size = FIXNM(s);
for (fixnum_t i = 0; i < count; i++)
vectorcons(size, NIL);
return NIL;
}
static void fast_read_fast_op(int fast_op_arity, bool has_next, lref_t reader, lref_t * fop)
{
assert((fast_op_arity >= 0) && (fast_op_arity <= 2));
lref_t opcode_obj;
fast_read(reader, &opcode_obj, false);
if (!FIXNUMP(opcode_obj))
vmerror_fast_read("Expected fixnum for opcode.", reader, opcode_obj);
lref_t op_arg1 = NIL;
lref_t op_arg2 = NIL;
lref_t next = NIL;
if (fast_op_arity > 0)
fast_read(reader, &op_arg1, false);
if (fast_op_arity > 1)
fast_read(reader, &op_arg2, false);
if (has_next)
fast_read(reader, &next, false);
*fop = fast_op((int) FIXNM(opcode_obj), op_arg1, op_arg2, next);
}
static void fast_read_string(lref_t reader, lref_t * retval)
{
lref_t l;
fast_read(reader, &l, false);
if (!FIXNUMP(l))
vmerror_fast_read("strings must have a fixnum length", reader, NIL);
fixnum_t expected_length = FIXNM(l);
_TCHAR *buf = (_TCHAR *) gc_malloc((size_t) (expected_length + 1));
memset(buf, 0, (size_t) (expected_length + 1));
fixnum_t actual_length =
read_bytes(FASL_READER_PORT(reader), buf, (size_t)(expected_length * sizeof(_TCHAR)));
if (actual_length != expected_length) {
gc_free(buf);
vmerror_fast_read("EOF during string data", reader, NIL);
}
*retval = strconsbufn((size_t) actual_length, buf);
gc_free(buf);
}
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 lset_debug_flags(lref_t v)
{
if (!FIXNUMP(v))
vmerror_wrong_type_n(1, v);
fixnum_t old_flags = interp.debug_flags;
interp.debug_flags = (enum debug_flag_t) FIXNM(v);
return fixcons(old_flags);
}
lref_t lstress_lisp_heap(lref_t c)
{
if (!FIXNUMP(c))
vmerror_wrong_type_n(1, c);
fixnum_t count = FIXNM(c);
for (fixnum_t i = 0; i < count; i++)
lcons(NIL, NIL);
return NIL;
}
static void fast_read_vector(lref_t reader, lref_t * vec)
{
lref_t vec_length;
fast_read(reader, &vec_length, false);
if (!FIXNUMP(vec_length))
vmerror_fast_read("Expected fixnum for vector length", reader, vec_length);
*vec = vectorcons(FIXNM(vec_length), NIL);
for (fixnum_t ii = 0; ii < FIXNM(vec_length); ii++)
{
lref_t object;
fast_read(reader, &object, false);
if (EOFP(object))
vmerror_fast_read("incomplete vector definition", reader, *vec);
(*vec)->as.vector.data[ii] = object;
}
}
static void fast_read_loader_application(lref_t reader, enum fasl_opcode_t opcode)
{
assert(FASL_READER_P(reader));
size_t argc = 0;
lref_t argv[FAST_LOAD_STACK_DEPTH];
fast_read(reader, &argv[0], false);
if (!(SUBRP(argv[0]) || CLOSUREP(argv[0])))
vmerror_fast_read(_T("Invalid function to apply"), reader, NIL);
if (opcode == FASL_OP_LOADER_APPLYN)
{
lref_t ac;
fast_read(reader, &ac, false);
if (!FIXNUMP(ac))
vmerror_fast_read("Expected fixnum for loader application argc", reader, ac);
argc = (size_t)FIXNM(ac);
if (argc > FAST_LOAD_STACK_DEPTH) /* Assuming FAST_LOAD_STACK_DEPTH <= ARG_BUF_LEN - 2 */
vmerror_fast_read("Loader application, argc < FAST_LOAD_STACK_DEPTH", reader, ac);
for(size_t ii = 0; ii < argc; ii++)
argv[ii + 1] = fast_loader_stack_pop(reader);
/* Fake a final NIL argument so that we can pass in the argv arguments
* as scalars rather than as a list. */
argc++;
argv[argc] = NIL;
}
else if (opcode != FASL_OP_LOADER_APPLY0)
panic("invalid opcode in fast_read_loader_application");
dscwritef(DF_SHOW_FAST_LOAD_FORMS, (_T("; DEBUG: FASL applying ~s (argc=~cd)\n"), argv[0], argc));
FASL_READER_STREAM(reader)->accum = lapply(argc + 1, argv);
}
static void fast_read_list(lref_t reader, bool read_listd, lref_t * list)
{
*list = NIL;
lref_t list_bud = NIL;
lref_t next_list_cell = NIL;
lref_t list_length;
fast_read(reader, &list_length, false);
if (!FIXNUMP(list_length))
vmerror_fast_read("expected fixnum for list length", reader, list_length);
*list = NIL;
for (fixnum_t ii = 0; ii < FIXNM(list_length); ii++)
{
next_list_cell = lcons(NIL, NIL);
if (NULLP(*list))
*list = next_list_cell;
else
SET_CDR(list_bud, next_list_cell);
list_bud = next_list_cell;
fast_read(reader, &(next_list_cell->as.cons.car), false);
if (EOFP(CAR(next_list_cell)))
vmerror_fast_read("incomplete list definition", reader, NIL);
}
if (read_listd)
{
fast_read(reader, &(list_bud->as.cons.cdr), false);
if (EOFP(CDR(list_bud)))
vmerror_fast_read("incomplete list defintion, missing cdr", reader, NIL);
}
}
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;
}
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable)
{
_TCHAR buf[STACK_STRBUF_LEN];
if (DEBUG_FLAG(DF_PRINT_ADDRESSES))
scwritef("#@~c&=", port, obj);
lref_t tmp;
size_t ii;
lref_t slots;
const _TCHAR *fast_op_name;
switch (TYPE(obj))
{
case TC_NIL:
WRITE_TEXT_CONSTANT(port, _T("()"));
break;
case TC_BOOLEAN:
if (TRUEP(obj))
WRITE_TEXT_CONSTANT(port, _T("#t"));
else
WRITE_TEXT_CONSTANT(port, _T("#f"));
break;
case TC_CONS:
write_char(port, _T('('));
debug_print_object(lcar(obj), port, machine_readable);
for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp))
{
write_char(port, _T(' '));
debug_print_object(lcar(tmp), port, machine_readable);
}
if (!NULLP(tmp))
{
WRITE_TEXT_CONSTANT(port, _T(" . "));
debug_print_object(tmp, port, machine_readable);
}
write_char(port, _T(')'));
break;
case TC_FIXNUM:
_sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj));
write_text(port, buf, _tcslen(buf));
break;
case TC_FLONUM:
debug_print_flonum(obj, port, machine_readable);
break;
case TC_CHARACTER:
if (machine_readable)
{
if (CHARV(obj) < CHARNAMECOUNT)
scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]);
else if (CHARV(obj) >= CHAREXTENDED - 1)
scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj));
else
scwritef(_T("#\\~cc"), port, (int) CHARV(obj));
}
else
scwritef(_T("~cc"), port, (int) CHARV(obj));
break;
case TC_SYMBOL:
if (NULLP(SYMBOL_HOME(obj)))
{
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#:<uninterned-symbol>", port);
else
scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj);
}
else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD])
scwritef(":~a", port, SYMBOL_PNAME(obj));
else
{
/* With only a minimal c-level package implementation, we
* just assume every symbol is private. */
scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj));
}
break;
case TC_VECTOR:
WRITE_TEXT_CONSTANT(port, _T("["));
for (ii = 0; ii < obj->as.vector.dim; ii++)
{
debug_print_object(obj->as.vector.data[ii], port, true);
if (ii + 1 < obj->as.vector.dim)
write_char(port, _T(' '));
}
write_char(port, _T(']'));
break;
case TC_STRUCTURE:
WRITE_TEXT_CONSTANT(port, _T("#S("));
debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true);
for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj)));
ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots))
{
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(CAR(CAR(slots)), port, true);
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(STRUCTURE_ELEM(obj, ii), port, true);
}
WRITE_TEXT_CONSTANT(port, _T(")"));
break;
case TC_STRING:
debug_print_string(obj, port, machine_readable);
break;
case TC_HASH:
debug_print_hash(obj, port, machine_readable);
break;
case TC_PACKAGE:
scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name);
break;
case TC_SUBR:
scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj));
break;
case TC_CLOSURE:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port,
(lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj),
CLOSURE_PROPERTY_LIST(obj));
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_VALUES_TUPLE:
scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values);
break;
case TC_MACRO:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer);
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_END_OF_FILE:
scwritef("~u", port, (lref_t) obj);
break;
case TC_PORT:
scwritef(_T("~u~cs~cs~cs ~cs ~s"), port,
obj,
PORT_INPUTP(obj) ? " (input)" : "",
PORT_OUTPUTP(obj) ? " (output)" : "",
BINARY_PORTP(obj) ? " (binary)" : "",
PORT_CLASS(obj)->name,
PORT_PINFO(obj)->port_name);
break;
case TC_FAST_OP:
fast_op_name = fast_op_opcode_name(obj->header.opcode);
if (fast_op_name)
scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj,
fast_op_name,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
else
scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj,
obj->header.opcode,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
break;
case TC_FASL_READER:
scwritef(_T("~u~s"), port,
obj,
FASL_READER_PORT(obj));
break;
case TC_UNBOUND_MARKER:
scwritef("#<UNBOUND-MARKER>", port);
break;
case TC_FREE_CELL:
scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj);
break;
default:
scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj);
}
return port;
}
