static void
print_entry_name (lispobj name)
{
if (lowtag_of (name) == LIST_POINTER_LOWTAG) {
putchar('(');
while (name != NIL) {
struct cons *cons = (struct cons *) native_pointer(name);
print_entry_name(cons->car);
name = cons->cdr;
if (name != NIL)
putchar(' ');
}
putchar(')');
} else if (lowtag_of(name) == OTHER_POINTER_LOWTAG) {
lispobj *object = (lispobj *) native_pointer(name);
if (widetag_of(*object) == SYMBOL_HEADER_WIDETAG) {
struct symbol *symbol = (struct symbol *) object;
if (symbol->package != NIL) {
struct package *pkg
= (struct package *) native_pointer(symbol->package);
lispobj pkg_name = pkg->_name;
if (string_equal(native_pointer(pkg_name), "COMMON-LISP"))
;
else if (string_equal(native_pointer(pkg_name), "COMMON-LISP-USER")) {
fputs("CL-USER::", stdout);
}
else if (string_equal(native_pointer(pkg_name), "KEYWORD")) {
putchar(':');
} else {
print_string(native_pointer(pkg_name));
fputs("::", stdout);
}
}
print_string(native_pointer(symbol->name));
} else if (widetag_of(*object) == SIMPLE_BASE_STRING_WIDETAG
#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
|| widetag_of(*object) == SIMPLE_CHARACTER_STRING_WIDETAG
#endif
) {
putchar('"');
print_string(object);
putchar('"');
} else {
printf("<??? type %d>", (int) widetag_of(*object));
}
} else {
printf("<??? lowtag %d>", (int) lowtag_of(name));
}
}
static lispobj find_code(os_context_t *context)
{
#ifdef reg_CODE
lispobj code = *os_context_register_addr(context, reg_CODE);
lispobj header;
if (lowtag_of(code) != OTHER_POINTER_LOWTAG)
return NIL;
header = *(lispobj *)(code-OTHER_POINTER_LOWTAG);
if (widetag_of(header) == CODE_HEADER_WIDETAG)
return code;
else
return code - HeaderValue(header)*sizeof(lispobj);
#else
lispobj codeptr =
(lispobj)component_ptr_from_pc((lispobj *)(*os_context_pc_addr(context)));
if (codeptr == 0)
return NIL;
else
return codeptr + OTHER_POINTER_LOWTAG;
#endif
}
static struct code *
code_pointer(lispobj object)
{
lispobj *headerp, header;
int type, len;
headerp = (lispobj *) native_pointer(object);
header = *headerp;
type = widetag_of(header);
switch (type) {
case CODE_HEADER_WIDETAG:
break;
case RETURN_PC_HEADER_WIDETAG:
case SIMPLE_FUN_HEADER_WIDETAG:
len = HEADER_LENGTH(header);
if (len == 0)
headerp = NULL;
else
headerp -= len;
break;
default:
headerp = NULL;
}
return (struct code *) headerp;
}
static void
print_string (lispobj *object)
{
int tag = widetag_of(*object);
struct vector *vector = (struct vector *) object;
#define doit(TYPE) \
do { \
int i; \
int n = fixnum_value(vector->length); \
TYPE *data = (TYPE *) vector->data; \
for (i = 0; i < n; i++) { \
wchar_t c = (wchar_t) data[i]; \
if (c == '\\' || c == '"') \
putchar('\\'); \
sbcl_putwc(c, stdout); \
} \
} while (0)
switch (tag) {
case SIMPLE_BASE_STRING_WIDETAG:
doit(unsigned char);
break;
#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
case SIMPLE_CHARACTER_STRING_WIDETAG:
doit(unsigned int);
break;
#endif
default:
printf("<??? type %d>", tag);
}
#undef doit
}
static void
search_cmd(char **ptr)
{
static int lastval = 0, lastcount = 0;
static lispobj *start = 0, *end = 0;
int val, count;
lispobj *addr, obj;
if (more_p(ptr)) {
val = parse_number(ptr);
if (val < 0 || val > 0xff) {
printf("can only search for single bytes\n");
return;
}
if (more_p(ptr)) {
addr = (lispobj *)native_pointer((uword_t)parse_addr(ptr));
if (more_p(ptr)) {
count = parse_number(ptr);
}
else {
/* Specified value and address, but no count. Only one. */
count = -1;
}
}
else {
/* Specified a value, but no address, so search same range. */
addr = start;
count = lastcount;
}
}
else {
/* Specified nothing, search again for val. */
val = lastval;
addr = end;
count = lastcount;
}
lastval = val;
start = end = addr;
lastcount = count;
printf("searching for 0x%x at %p\n", val, (void*)(uword_t)end);
while (search_for_type(val, &end, &count)) {
printf("found 0x%x at %p:\n", val, (void*)(uword_t)end);
obj = *end;
addr = end;
end += 2;
if (widetag_of(obj) == SIMPLE_FUN_HEADER_WIDETAG) {
print((uword_t)addr | FUN_POINTER_LOWTAG);
} else if (other_immediate_lowtag_p(obj)) {
print((lispobj)addr | OTHER_POINTER_LOWTAG);
} else {
print((lispobj)addr);
}
if (count == -1) {
return;
}
}
}
static int string_equal (lispobj *object, char *string)
{
int tag = widetag_of(*object);
struct vector *vector = (struct vector *) object;
if (tag != SIMPLE_BASE_STRING_WIDETAG)
return 0;
return !strcmp((char *) vector->data, string);
}
static void
scan_objects(lispobj *start, long n_words, scan_table table)
{
lispobj *end = start + n_words;
lispobj *object_ptr;
long n_words_scanned;
for (object_ptr = start;
object_ptr < end;
object_ptr += n_words_scanned) {
lispobj obj = *object_ptr;
n_words_scanned = (table[widetag_of(obj)])(object_ptr);
}
}
static long
lutex_scan_action(lispobj *obj)
{
/* note the address of the lutex */
if(n_lutexes >= max_lutexes) {
max_lutexes *= 2;
lutex_addresses = realloc(lutex_addresses, max_lutexes * sizeof(void *));
gc_assert(lutex_addresses);
}
lutex_addresses[n_lutexes++] = obj;
return (*sizetab[widetag_of(*obj)])(obj);
}
static long
default_scan_action(lispobj *obj)
{
return (sizetab[widetag_of(*obj)])(obj);
}
