EVAL_INLINE lref_t subr_apply(lref_t function, size_t argc, lref_t argv[], lref_t * env, lref_t * retval) { lref_t arg1; lref_t args; size_t ii; UNREFERENCED(env); fstack_enter_frame(FRAME_SUBR); fstack_push((lref_t)function); switch (SUBR_TYPE(function)) { case SUBR_0: *retval = (SUBR_F0(function) ()); break; case SUBR_1: *retval = (SUBR_F1(function) (_ARGV(0))); break; case SUBR_2: *retval = (SUBR_F2(function) (_ARGV(0), _ARGV(1))); break; case SUBR_3: *retval = (SUBR_F3(function) (_ARGV(0), _ARGV(1), _ARGV(2))); break; case SUBR_4: *retval = (SUBR_F4(function) (_ARGV(0), _ARGV(1), _ARGV(2), _ARGV(3))); break; case SUBR_2N: arg1 = _ARGV(0); arg1 = SUBR_F2(function) (arg1, _ARGV(1)); for (ii = 2; ii < argc; ii++) arg1 = SUBR_F2(function) (arg1, _ARGV(ii)); *retval = arg1; break; case SUBR_ARGC: *retval = (SUBR_FARGC(function) (argc, argv)); break; case SUBR_N: args = arg_list_from_buffer(argc, argv); *retval = (SUBR_F1(function) (args)); break; } fstack_leave_frame(); return NIL; }
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; }