lref_t lbinary_portp(lref_t obj) { if (BINARY_PORTP(obj)) return obj; return boolcons(false); }
lref_t lmake_fasl_reader(lref_t port) { if (!BINARY_PORTP(port)) vmerror_wrong_type_n(1, port); return faslreadercons(port); }
lref_t lread_binary_flonum(lref_t port) { if (!BINARY_PORTP(port)) vmerror_wrong_type_n(1, port); flonum_t result = 0; if (read_binary_flonum(port, &result)) return flocons(result); return lmake_eof(); }
bool read_binary_flonum(lref_t port, flonum_t *result) { assert(BINARY_PORTP(port)); uint8_t bytes[sizeof(flonum_t)]; if (read_bytes(port, bytes, sizeof(flonum_t)) != sizeof(flonum_t)) return false; *result = io_decode_flonum(bytes); return true; }
lref_t lopen_text_output_port(lref_t underlying) { if (!PORTP(underlying)) vmerror_wrong_type_n(1, underlying); if (!BINARY_PORTP(underlying)) vmerror_unsupported(_T("cannot open text output on binary port")); return portcons(&text_port_class, lport_name(underlying), PORT_OUTPUT | PORT_TEXT, underlying, NULL); }
lref_t lbinary_write_flonum(lref_t v, lref_t port) { if (!NUMBERP(v)) vmerror_wrong_type_n(1, v); if (!BINARY_PORTP(port)) vmerror_wrong_type_n(2, port); uint8_t bytes[sizeof(flonum_t)]; io_encode_flonum(bytes, get_c_flonum(v)); if (write_bytes(port, bytes, sizeof(flonum_t)) != sizeof(flonum_t)) vmerror_io_error(_T("error writing to port."), port); return port; }
lref_t lwrite_binary_string(lref_t string, lref_t port) { if (!STRINGP(string)) vmerror_wrong_type_n(1, string); if (!BINARY_PORTP(port)) vmerror_wrong_type_n(2, port); size_t sz = (string->as.string.dim * sizeof(_TCHAR)); size_t written = write_bytes(port, string->as.string.data, sz); if (written != sz) vmerror_io_error(_T("error writing to port."), port); return port; }
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 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; }