void pdf_xrefcache_dumppage( PDFCONTEXT *pdfc, int32 page ) { int32 i ; PDFXCONTEXT *pdfxc ; PDF_CHECK_MC( pdfc ) ; PDF_GET_XC( pdfxc ) ; /* Each entry in the cache array is a linked list. */ for ( i = 0 ; i < XREF_CACHE_SIZE ; i++ ) { XREFCACHE **cacheLink = & pdfxc->xrefcache[ i ] ; while ( *cacheLink != NULL ) { XREFCACHE *cache = *cacheLink; if ( cache->lastAccessId == page ) { FILELIST *flptr = theIStderr( workingsave ) ; monitorf(( uint8 * ) "%d %d obj\n" , cache->objnum , cache->objgen ) ; debug_print_object( &cache->pdfobj ) ; if (( *theIMyFlushFile( flptr ))( flptr ) == EOF ) { HQFAIL( "Flush failed" ) ; return ; } monitorf(( uint8 * ) "\n" ) ; } cacheLink = &cache->xrefnxt; } } }
lref_t lidebug_printer(lref_t obj, lref_t port, lref_t machine_readable_p) { if (!PORTP(port)) vmerror_wrong_type_n(2, port); return debug_print_object(obj, port, TRUEP(machine_readable_p)); }
static void debug_print_hash_elements(lref_t obj, lref_t port, bool machine_readable) { assert(HASHP(obj)); fixnum_t count = 0; lref_t key, val; hash_iter_t ii; hash_iter_begin(obj, &ii); while (hash_iter_next(obj, &ii, &key, &val)) { count++; write_char(port, _T(' ')); debug_print_object(key, port, machine_readable); write_char(port, _T(' ')); debug_print_object(val, port, machine_readable); } }
lref_t ldebug_write(lref_t form) { debug_print_object(form, CURRENT_DEBUG_PORT(), true); return lnewline(CURRENT_DEBUG_PORT()); }
/* A C function to do Lisp-style Formatted I/O ****************** * * ~s - write the lisp object * ~a - display the lisp object * REVISIT: remove scvwritef ~u in favor of some kind of print_unreadable_object call * ~u - display the lisp object in unprintable fashion (ie. <type@addr...> * * ~cs - display the C string * ~cS - display the C string/arglist with a recursive call to scvwritef * ~cd - display the C integer * ~cf - display the C flonum * ~c& - display the C pointer * ~cc - display the C character * ~cC - display the C integer as an octal character constant * ~cB - display the C integer as a byte * * Prefixing a format code with a #\! (ie. ~!L) causes the corresponding * value to be returned from the function as a Lisp object. */ lref_t scvwritef(const _TCHAR * format_str, lref_t port, va_list arglist) { char ch; if (NULLP(port)) port = CURRENT_OUTPUT_PORT(); assert(PORTP(port)); _TCHAR buf[STACK_STRBUF_LEN]; lref_t lisp_arg_value = NULL; _TCHAR *str_arg_value = NULL; _TCHAR char_arg_value = _T('\0'); long int long_arg_value = 0; unsigned long int ulong_arg_value = 0; flonum_t flonum_arg_value = 0.0; lref_t unprintable_object = NIL; lref_t return_value = NIL; for (;;) { ch = *format_str; if (ch == '\0') break; bool return_next_value = false; format_str++; if (ch != '~') { write_char(port, ch); continue; } ch = *format_str; format_str++; if (ch == '!') { ch = *format_str; format_str++; return_next_value = true; } switch (ch) { case 's': lisp_arg_value = va_arg(arglist, lref_t); if (return_next_value) return_value = lisp_arg_value; debug_print_object(lisp_arg_value, port, true); break; case 'a': lisp_arg_value = va_arg(arglist, lref_t); if (return_next_value) return_value = lisp_arg_value; debug_print_object(lisp_arg_value, port, false); break; case 'u': unprintable_object = va_arg(arglist, lref_t); if (return_next_value) return_value = unprintable_object; if (DEBUG_FLAG(DF_PRINT_FOR_DIFF)) scwritef("#<~cs@(no-addr)", port, typecode_name(TYPE(unprintable_object))); else scwritef("#<~cs@~c&", port, typecode_name(TYPE(unprintable_object)), unprintable_object); break; case '~': write_char(port, '~'); break; case 'c': /* C object prefix */ ch = *format_str; /* read the next format character */ format_str++; switch (ch) { case 's': str_arg_value = va_arg(arglist, _TCHAR *); if (return_next_value) return_value = strconsbuf(str_arg_value); if (str_arg_value) write_text(port, str_arg_value, _tcslen(str_arg_value)); else WRITE_TEXT_CONSTANT(port, _T("<null>")); break; case 'S': str_arg_value = va_arg(arglist, _TCHAR *); if (return_next_value) return_value = scvwritef(str_arg_value, port, arglist); else scvwritef(str_arg_value, port, arglist); break; case 'd': long_arg_value = va_arg(arglist, long int); if (return_next_value) return_value = fixcons(long_arg_value); _sntprintf(buf, STACK_STRBUF_LEN, _T("%d"), (int) long_arg_value); write_text(port, buf, _tcslen(buf)); break; case 'x': long_arg_value = va_arg(arglist, long int); if (return_next_value) return_value = fixcons(long_arg_value); _sntprintf(buf, STACK_STRBUF_LEN, _T("%08lx"), long_arg_value); write_text(port, buf, _tcslen(buf)); break; case 'f': flonum_arg_value = va_arg(arglist, flonum_t); if (return_next_value) return_value = flocons(flonum_arg_value); _sntprintf(buf, STACK_STRBUF_LEN, _T("%f"), flonum_arg_value); write_text(port, buf, _tcslen(buf)); break; case '&': _sntprintf(buf, STACK_STRBUF_LEN, _T("%p"), (void *) va_arg(arglist, void *)); if (return_next_value) return_value = strconsbuf(buf); write_text(port, buf, _tcslen(buf)); break; case 'c': ulong_arg_value = va_arg(arglist, unsigned long int); if (return_next_value) return_value = fixcons(ulong_arg_value); char_arg_value = (_TCHAR) ulong_arg_value; write_text(port, &char_arg_value, 1); break; case 'C': ulong_arg_value = va_arg(arglist, unsigned long int); if (return_next_value) return_value = fixcons(ulong_arg_value); _sntprintf(buf, STACK_STRBUF_LEN, _T("%03o"), (uint32_t) ulong_arg_value); write_text(port, buf, _tcslen(buf)); break; case 'B': ulong_arg_value = va_arg(arglist, unsigned long int); if (return_next_value) return_value = fixcons(ulong_arg_value); _sntprintf(buf, STACK_STRBUF_LEN, _T("0x%02x"), (uint32_t) ulong_arg_value); write_text(port, buf, _tcslen(buf)); break; default: panic(_T("Invalid C object format character in scwritef")); break; }; break; default: panic(_T("Invalid format character in scwritef")); break; } return_next_value = false; } va_end(arglist); if (!NULLP(unprintable_object)) scwritef(">", port); return return_value; }
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; }