static void fast_read(lref_t reader, lref_t * retval, bool allow_loader_ops /* = false */ )
{
lref_t *fasl_table_entry = NULL;
*retval = NIL;
if (!FASL_READER_P(reader))
vmerror_wrong_type_n(1, reader);
assert(NULLP(FASL_READER_STREAM(reader)->table) || VECTORP(FASL_READER_STREAM(reader)->table));
/* The core of this function is wrapped in a giant while loop to remove
* tail recursive calls. Some opcodes don't directly return anything:
* they just tail recursively read the next opcode after performing their
* action via side effect. */
bool current_read_complete = false;
while (!current_read_complete)
{
/* Assume we're going to complete the read unless we find out otherwise.. */
current_read_complete = true;
size_t opcode_location = PORT_BYTES_READ(FASL_READER_PORT(reader));
enum fasl_opcode_t opcode = fast_read_opcode(reader);
fixnum_t index = 0;
lref_t name;
if (DEBUG_FLAG(DF_FASL_SHOW_OPCODES))
{
const _TCHAR *opcode_name = fasl_opcode_name(opcode);
dscwritef(DF_FASL_SHOW_OPCODES,
(_T("; DEBUG: fasl-opcode@~cx :~cS\n"),
opcode_location, opcode_name ? opcode_name : _T("<INVALID>")));
}
switch (opcode)
{
case FASL_OP_NIL:
*retval = NIL;
break;
case FASL_OP_TRUE:
*retval = boolcons(true);
break;
case FASL_OP_FALSE:
*retval = boolcons(false);
break;
case FASL_OP_CHARACTER:
fast_read_character(reader, retval);
break;
case FASL_OP_LIST:
fast_read_list(reader, false, retval);
break;
case FASL_OP_LISTD:
fast_read_list(reader, true, retval);
break;
case FASL_OP_FIX8:
fast_read_fixnum_int8(reader, retval);
break;
case FASL_OP_FIX16:
fast_read_fixnum_int16(reader, retval);
break;
case FASL_OP_FIX32:
fast_read_fixnum_int32(reader, retval);
break;
case FASL_OP_FIX64:
fast_read_fixnum_int64(reader, retval);
break;
case FASL_OP_FLOAT:
fast_read_flonum(reader, false, retval);
break;
case FASL_OP_COMPLEX:
fast_read_flonum(reader, true, retval);
break;
case FASL_OP_STRING:
fast_read_string(reader, retval);
break;
case FASL_OP_PACKAGE:
fast_read_package(reader, retval);
break;
case FASL_OP_VECTOR:
fast_read_vector(reader, retval);
break;
case FASL_OP_HASH:
fast_read_hash(reader, retval);
break;
case FASL_OP_CLOSURE:
fast_read_closure(reader, retval);
break;
case FASL_OP_MACRO:
fast_read_macro(reader, retval);
break;
case FASL_OP_SYMBOL:
fast_read_symbol(reader, retval);
break;
case FASL_OP_SUBR:
fast_read_subr(reader, retval);
break;
case FASL_OP_STRUCTURE:
fast_read_structure(reader, retval);
break;
case FASL_OP_STRUCTURE_LAYOUT:
fast_read_structure_layout(reader, retval);
break;
case FASL_OP_FAST_OP_0:
fast_read_fast_op(0, false, reader, retval);
break;
case FASL_OP_FAST_OP_1:
fast_read_fast_op(1, false, reader, retval);
break;
case FASL_OP_FAST_OP_2:
fast_read_fast_op(2, false, reader, retval);
break;
case FASL_OP_FAST_OP_0N:
fast_read_fast_op(0, true, reader, retval);
break;
case FASL_OP_FAST_OP_1N:
fast_read_fast_op(1, true, reader, retval);
break;
case FASL_OP_FAST_OP_2N:
fast_read_fast_op(2, true, reader, retval);
break;
case FASL_OP_NOP_1:
case FASL_OP_NOP_2:
case FASL_OP_NOP_3:
current_read_complete = false;
break;
case FASL_OP_COMMENT_1:
case FASL_OP_COMMENT_2:
fast_read_to_newline(reader);
current_read_complete = false;
break;
case FASL_OP_RESET_READER_DEFS:
FASL_READER_STREAM(reader)->table = NIL;
current_read_complete = false;
break;
case FASL_OP_READER_DEFINITION:
index = fast_read_table_index(reader);
fasl_table_entry = &(FASL_READER_STREAM(reader)->table->as.vector.data[index]);
fast_read(reader, fasl_table_entry, allow_loader_ops);
/* This should throw if the FASL table was resized
* during the call to read. */
assert(fasl_table_entry == &(FASL_READER_STREAM(reader)->table->as.vector.data[index]));
*retval = *fasl_table_entry;
break;
case FASL_OP_READER_REFERENCE:
index = fast_read_table_index(reader);
*retval = FASL_READER_STREAM(reader)->table->as.vector.data[index];
break;
case FASL_OP_EOF:
*retval = lmake_eof();
break;
case FASL_OP_LOADER_DEFINEQ:
case FASL_OP_LOADER_DEFINEA0:
if (!allow_loader_ops)
vmerror_fast_read(_T("loader definitions not allowed outside loader"), reader, NIL);
fast_read_loader_definition(reader, opcode);
current_read_complete = false;
break;
case FASL_OP_LOADER_APPLY0:
case FASL_OP_LOADER_APPLYN:
if (!allow_loader_ops)
vmerror_fast_read(_T("loader function applications not allowed outside loader"), reader, NIL);
fast_read_loader_application(reader, opcode);
break;
case FASL_OP_BEGIN_LOAD_UNIT:
if (!allow_loader_ops)
vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);
fast_read(reader, &name, allow_loader_ops);
dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL entering unit ~s\n", name));
break;
case FASL_OP_END_LOAD_UNIT:
if (!allow_loader_ops)
vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);
fast_read(reader, &name, allow_loader_ops);
dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL leaving unit ~s\n", name));
break;
case FASL_OP_LOADER_PUSH:
fast_loader_stack_push(reader, FASL_READER_STREAM(reader)->accum);
break;
case FASL_OP_LOADER_DROP:
fast_loader_stack_pop(reader);
break;
default:
vmerror_fast_read("invalid opcode", reader, fixcons(opcode));
}
}
}
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;
}