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 void
call_info_from_context(struct call_info *info, os_context_t *context)
{
unsigned long pc;
info->interrupted = 1;
if (lowtag_of(*os_context_register_addr(context, reg_CODE))
== FUN_POINTER_LOWTAG) {
/* We tried to call a function, but crapped out before $CODE could
* be fixed up. Probably an undefined function. */
info->frame =
(struct call_frame *)(unsigned long)
(*os_context_register_addr(context, reg_OCFP));
info->lra = (lispobj)(*os_context_register_addr(context, reg_LRA));
info->code = code_pointer(info->lra);
pc = (unsigned long)native_pointer(info->lra);
}
else {
info->frame =
(struct call_frame *)(unsigned long)
(*os_context_register_addr(context, reg_CFP));
info->code =
code_pointer(*os_context_register_addr(context, reg_CODE));
info->lra = NIL;
pc = *os_context_pc_addr(context);
}
if (info->code != NULL)
info->pc = pc - (unsigned long) info->code -
#ifndef LISP_FEATURE_ALPHA
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
#else
(HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
#endif
else
struct compiled_debug_fun *
debug_function_from_pc (struct code* code, void *pc)
{
uword_t code_header_len = sizeof(lispobj) * HeaderValue(code->header);
uword_t offset
= (uword_t) pc - (uword_t) code - code_header_len;
struct compiled_debug_fun *df;
struct compiled_debug_info *di;
struct vector *v;
int i, len;
if (lowtag_of(code->debug_info) != INSTANCE_POINTER_LOWTAG)
return 0;
di = (struct compiled_debug_info *) native_pointer(code->debug_info);
v = (struct vector *) native_pointer(di->fun_map);
len = fixnum_value(v->length);
df = (struct compiled_debug_fun *) native_pointer(v->data[0]);
if (len == 1)
return df;
for (i = 1;; i += 2) {
unsigned next_pc;
if (i == len)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
if (offset >= (uword_t)fixnum_value(df->elsewhere_pc)) {
struct compiled_debug_fun *p
= ((struct compiled_debug_fun *) native_pointer(v->data[i + 1]));
next_pc = fixnum_value(p->elsewhere_pc);
} else
next_pc = fixnum_value(v->data[i]);
if (offset < next_pc)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
}
return NULL;
}
