/*** C I/O functions ***/ int read_char(lref_t port) { assert(TEXT_PORTP(port) && PORT_INPUTP(port)); /* Text port case below. */ int ch = EOF; if (PORT_TEXT_INFO(port)->pbuf_valid) { /* Unread buffer */ PORT_TEXT_INFO(port)->pbuf_valid = false; ch = PORT_TEXT_INFO(port)->pbuf; } else { /* Specific string read handling. */ _TCHAR tch; if (PORT_CLASS(port)->read_chars(port, &tch, 1) > 0) ch = (tch); } /* Update the text position indicators */ if (ch == '\n') { PORT_TEXT_INFO(port)->pline_mcol = PORT_TEXT_INFO(port)->col; PORT_TEXT_INFO(port)->col = 0; PORT_TEXT_INFO(port)->row++; } else PORT_TEXT_INFO(port)->col++; return ch; }
lref_t linput_portp(lref_t obj) { if (PORTP(obj) && PORT_INPUTP(obj)) return obj; return boolcons(false); }
lref_t lwrite_strings(size_t argc, lref_t argv[]) { if (argc < 1) vmerror_unsupported(_T("Must specify port to write-strings")); lref_t port = argv[0]; if (!TEXT_PORTP(port)) vmerror_wrong_type_n(1, port); if (PORT_INPUTP(port)) vmerror_unsupported(_T("cannot write-strings to input ports")); for (size_t ii = 1; ii < argc; ii++) { lref_t str = argv[ii]; if (STRINGP(str)) { write_text(port, str->as.string.data, str->as.string.dim); } else if (CHARP(str)) { _TCHAR ch = CHARV(str); write_text(port, &ch, 1); } else vmerror_wrong_type_n(ii, str); } return port; }
int peek_char(lref_t port) { assert(TEXT_PORTP(port) && PORT_INPUTP(port)); if (PORT_CLASS(port)->peek_char == NULL) vmerror_unsupported(_T("Peek not supported on this port.")); return PORT_CLASS(port)->peek_char(port); }
lref_t lnewline(lref_t port) { if (NULLP(port)) port = CURRENT_OUTPUT_PORT(); if (!TEXT_PORTP(port)) vmerror_wrong_type_n(1, port); if (PORT_INPUTP(port)) vmerror_unsupported(_T("cannot newline to input ports")); write_char(port, _T('\n')); return port; }
lref_t lfresh_line(lref_t port) { if (NULLP(port)) port = CURRENT_OUTPUT_PORT(); if (!TEXT_PORTP(port)) vmerror_wrong_type_n(1, port); if (PORT_INPUTP(port)) vmerror_unsupported(_T("cannot fresh-line to input ports")); if ((PORT_TEXT_INFO(port)->col != 0) && !PORT_TEXT_INFO(port)->needs_lf) { lnewline(port); return boolcons(true); } return boolcons(false); }
lref_t lwrite_char(lref_t ch, lref_t port) { if (NULLP(port)) port = CURRENT_OUTPUT_PORT(); if (!TEXT_PORTP(port)) vmerror_wrong_type_n(2, port); if (PORT_INPUTP(port)) vmerror_unsupported(_T("cannot write-char to input ports")); if (!CHARP(ch)) vmerror_wrong_type_n(1, ch); write_char(port, CHARV(ch)); return port; }
lref_t lrich_write(lref_t obj, lref_t machine_readable, lref_t port) { if (NULLP(port)) port = CURRENT_OUTPUT_PORT(); if (!PORTP(port)) vmerror_wrong_type_n(3, port); if (PORT_INPUTP(port)) vmerror_unsupported(_T("cannot rich-write to input ports")); if (PORT_CLASS(port)->rich_write == NULL) return boolcons(false); if (PORT_CLASS(port)->rich_write(port, obj, TRUEP(machine_readable))) return port; return boolcons(false); }
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; }