lref_t lstructure_length(lref_t st) { if (!STRUCTUREP(st)) vmerror_wrong_type_n(1, st); return fixcons(STRUCTURE_DIM(st)); }
bool structure_equal(lref_t sta, lref_t stb) { assert(STRUCTUREP(sta)); assert(STRUCTUREP(stb)); if (STRUCTURE_LAYOUT(sta) != STRUCTURE_LAYOUT(stb)) return false; if (STRUCTURE_DIM(sta) != STRUCTURE_DIM(stb)) return false; for (size_t ii = 0; ii < STRUCTURE_DIM(sta); ii++) if (!equalp(STRUCTURE_ELEM(sta, ii), STRUCTURE_ELEM(stb, ii))) return false; return true; }
lref_t lstructure_ref(lref_t st, lref_t index) { if (!STRUCTUREP(st)) vmerror_wrong_type_n(1, st); if (!FIXNUMP(index)) vmerror_wrong_type_n(2, index); fixnum_t idx = get_c_fixnum(index); if ((idx >= 0) && ((size_t) idx < STRUCTURE_DIM(st))) return STRUCTURE_ELEM(st, idx); vmerror_index_out_of_bounds(index, st); return NIL; // unreached }
lref_t lcopy_structure(lref_t st) { if (!STRUCTUREP(st)) vmerror_wrong_type_n(1, st); lref_t new_st = new_cell(TC_STRUCTURE); size_t len = STRUCTURE_DIM(st);; SET_STRUCTURE_DIM(new_st, len); SET_STRUCTURE_LAYOUT(new_st, STRUCTURE_LAYOUT(st)); SET_STRUCTURE_DATA(new_st, (lref_t *) gc_malloc(len * sizeof(lref_t))); for (size_t ii = 0; ii < len; ii++) SET_STRUCTURE_ELEM(new_st, ii, STRUCTURE_ELEM(st, ii)); return new_st; }
lref_t lstructure_set(lref_t st, lref_t index, lref_t value) { if (!STRUCTUREP(st)) vmerror_wrong_type_n(1, st); if (!FIXNUMP(index)) vmerror_wrong_type_n(2, index); fixnum_t idx = get_c_fixnum(index); if ((idx >= 0) && ((size_t) idx < STRUCTURE_DIM(st))) { SET_STRUCTURE_ELEM(st, idx, value); return st; } vmerror_index_out_of_bounds(index, st); 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; }