LispObj
find_symbol_in_range(LispObj *start, LispObj *end, char *name)
{
LispObj header;
int n = strlen(name);
char *s = name, *p;
while (start < end) {
header = *start;
if (header_subtag(header) == subtag_symbol) {
LispObj
pname = deref(start, 1),
pname_header = header_of(pname);
if ((header_subtag(pname_header) == subtag_simple_base_string) &&
(header_element_count(pname_header) == n)) {
p = (char *) (pname + misc_data_offset);
if (strncmp(p, s, n) == 0) {
return ((LispObj)start)+fulltag_misc;
}
}
}
if (fulltag_of(header) == fulltag_nodeheader) {
start += (~1 & (2 + header_element_count(header)));
} else if (fulltag_of(header) == fulltag_immheader) {
start = (LispObj *) skip_over_ivector((unsigned)start, header);
} else {
start += 2;
}
}
return (LispObj)NULL;
}
LispObj
find_symbol_in_range(LispObj *start, LispObj *end, char *name)
{
LispObj header, tag;
int n = strlen(name);
char *s = name;
lisp_char_code *p;
while (start < end) {
header = *start;
tag = fulltag_of(header);
if (header_subtag(header) == subtag_symbol) {
LispObj
pname = deref(ptr_to_lispobj(start), 1),
pname_header = header_of(pname);
if ((header_subtag(pname_header) == subtag_simple_base_string) &&
(header_element_count(pname_header) == n)) {
p = (lisp_char_code *) ptr_from_lispobj(pname + misc_data_offset);
if (compare_lisp_string_to_c_string(p, s, n) == 0) {
return (ptr_to_lispobj(start))+fulltag_misc;
}
}
}
if (nodeheader_tag_p(tag)) {
start += (~1 & (2 + header_element_count(header)));
} else if (immheader_tag_p(tag)) {
start = (LispObj *) skip_over_ivector((natural)start, header);
} else {
start += 2;
}
}
return (LispObj)NULL;
}
void
sprint_lisp_object(LispObj o, int depth)
{
if (--depth < 0) {
add_char('#');
} else {
switch (fulltag_of(o)) {
case fulltag_even_fixnum:
case fulltag_odd_fixnum:
sprint_signed_decimal(unbox_fixnum(o));
break;
#ifdef PPC64
case fulltag_immheader_0:
case fulltag_immheader_1:
case fulltag_immheader_2:
case fulltag_immheader_3:
case fulltag_nodeheader_0:
case fulltag_nodeheader_1:
case fulltag_nodeheader_2:
case fulltag_nodeheader_3:
#else
case fulltag_immheader:
case fulltag_nodeheader:
#endif
add_c_string("#<header ? ");
sprint_unsigned_hex(o);
add_c_string(">");
break;
#ifdef PPC64
case fulltag_imm_0:
case fulltag_imm_1:
case fulltag_imm_2:
case fulltag_imm_3:
#else
case fulltag_imm:
#endif
if (o == unbound) {
add_c_string("#<Unbound>");
} else {
if (header_subtag(o) == subtag_character) {
unsigned c = (o >> charcode_shift);
add_c_string("#\\");
if ((c >= ' ') && (c < 0x7f)) {
add_char(c);
} else {
sprintf(numbuf, "%o", c);
add_c_string(numbuf);
}
#ifdef PPC64
} else if (header_subtag(o) == subtag_single_float) {
sprintf(numbuf, "%f", o>>32);
add_c_string(numbuf);
#endif
} else {
void
sprint_specializers_list(LispObj o, int depth)
{
LispObj the_cdr, the_car;
add_char('(');
while(1) {
if (o != lisp_nil) {
the_car = car(o);
if (fulltag_of(the_car) == fulltag_misc) {
LispObj header = header_of(the_car);
unsigned subtag = header_subtag(header);
if (subtag == subtag_instance) {
if (unbox_fixnum(deref(the_car,1)) < (1<<20)) {
sprint_lisp_object(deref(deref(the_car,3), 4), depth);
} else {
/* An EQL specializer */
add_c_string("(EQL ");
sprint_lisp_object(deref(deref(the_car,3), 3), depth);
add_char(')');
}
} else if (subtag == subtag_macptr) {
char *class_name = foreign_class_name(deref(the_car,1));
if (class_name) {
add_c_string(class_name);
} else {
sprint_lisp_object(the_car, depth);
}
} else {
sprint_lisp_object(the_car, depth);
}
} else {
sprint_lisp_object(the_car, depth);
}
the_cdr = cdr(o);
if (the_cdr != lisp_nil) {
add_char(' ');
if (fulltag_of(the_cdr) == fulltag_cons) {
o = the_cdr;
continue;
}
add_c_string(". ");
sprint_lisp_object(the_cdr, depth);
break;
}
}
break;
}
add_char(')');
}
void
sprint_function(LispObj o, int depth)
{
LispObj lfbits, header, name = lisp_nil;
natural elements;
header = header_of(o);
elements = header_element_count(header);
lfbits = deref(o, elements);
if ((lfbits & lfbits_noname_mask) == 0) {
name = deref(o, elements-1);
}
add_c_string("#<");
if (name == lisp_nil) {
add_c_string("Anonymous Function ");
} else {
if (lfbits & lfbits_method_mask) {
if (header_subtag(header_of(name)) == subtag_instance) {
LispObj
slot_vector = deref(name,3),
method_name = deref(slot_vector, 6),
method_qualifiers = deref(slot_vector, 2),
method_specializers = deref(slot_vector, 3);
add_c_string("Method-Function ");
sprint_lisp_object(method_name, depth);
add_char(' ');
if (method_qualifiers != lisp_nil) {
if (cdr(method_qualifiers) == lisp_nil) {
sprint_lisp_object(car(method_qualifiers), depth);
} else {
sprint_lisp_object(method_qualifiers, depth);
}
add_char(' ');
}
sprint_specializers_list(method_specializers, depth);
} else {
sprint_lisp_object(name, depth);
}
add_char(' ');
} else {
add_c_string("Function ");
sprint_lisp_object(name, depth);
add_char(' ');
}
}
sprint_unsigned_hex(o);
add_char('>');
}
void
print_lisp_frame(lisp_frame *frame)
{
LispObj fun = frame->savefn, pc = frame->savelr;
int delta = 0;
Dl_info info;
char *spname;
if ((fun == 0) || (fun == fulltag_misc)) {
spname = "unknown ?";
#ifndef STATIC
if (dladdr((void *)ptr_from_lispobj(pc), &info)) {
spname = (char *)(info.dli_sname);
#ifdef DARWIN
if (spname[-1] != '_') {
--spname;
}
#endif
}
#endif
#ifdef PPC64
Dprintf("(#x%016lX) #x%016lX : (subprimitive %s)", frame, pc, spname);
#else
Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, pc, spname);
#endif
} else {
if ((fulltag_of(fun) != fulltag_misc) ||
(header_subtag(header_of(fun)) != subtag_function)) {
#ifdef PPC64
Dprintf("(#x%016lX) #x%016lX : (not a function!)", frame, pc);
#else
Dprintf("(#x%08X) #x%08X : (not a function!)", frame, pc);
#endif
} else {
LispObj code_vector = deref(fun, 1);
if ((pc >= (code_vector+misc_data_offset)) &&
(pc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) {
delta = (pc - (code_vector+misc_data_offset));
}
#ifdef PPC64
Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta);
#else
Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta);
#endif
}
}
}
void
sprint_gvector(LispObj o, int depth)
{
LispObj header = header_of(o);
unsigned
elements = header_element_count(header),
subtag = header_subtag(header);
switch(subtag) {
case subtag_function:
sprint_function(o, depth);
break;
case subtag_symbol:
sprint_symbol(o);
break;
case subtag_struct:
case subtag_istruct:
add_c_string("#<");
sprint_lisp_object(deref(o,1), depth);
add_c_string(" @");
sprint_unsigned_hex(o);
add_c_string(">");
break;
case subtag_simple_vector:
{
int i;
add_c_string("#(");
for(i = 1; i <= elements; i++) {
if (i > 1) {
add_char(' ');
}
sprint_lisp_object(deref(o, i), depth);
}
add_char(')');
break;
}
default:
sprint_random_vector(o, subtag, elements);
break;
}
}
void
sprint_tra(LispObj o, int depth)
{
#ifdef X8664
signed sdisp;
unsigned disp = 0;
LispObj f = 0;
if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) &&
(*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
sdisp = (*(int *) (o+3));
f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp;
disp = o-f;
}
if (fulltag_of(f) == fulltag_function) {
add_c_string("tagged return address: ");
sprint_function(f, depth);
add_c_string(" + ");
sprint_unsigned_decimal(disp);
} else {
add_c_string("(tra ?) : ");
sprint_unsigned_hex(o);
}
#else
LispObj f = 0;
unsigned disp = 0;
if (*(unsigned char *)o == RECOVER_FN_OPCODE) {
f = (LispObj)(*((natural *)(o + 1)));
disp = o - f;
}
if (f && header_subtag(header_of(f)) == subtag_function) {
add_c_string("tagged return address: ");
sprint_function(f, depth);
add_c_string(" + ");
sprint_unsigned_decimal(disp);
} else {
add_c_string("(tra ?) : ");
sprint_unsigned_hex(o);
}
#endif
}
void
plsym(ExceptionInformation *xp, char *pname)
{
long address = 0;
address = find_symbol(pname);
if (address == 0) {
Dprintf("Can't find symbol.");
return;
}
if ((fulltag_of(address) == fulltag_misc) &&
(header_subtag(header_of(address)) == subtag_symbol)){
describe_symbol(address);
} else {
fprintf(stderr, "Not a symbol.\n");
}
return;
}
void
sprint_ivector(LispObj o)
{
LispObj header = header_of(o);
unsigned
elements = header_element_count(header),
subtag = header_subtag(header);
switch(subtag) {
case subtag_simple_base_string:
add_char('"');
add_lisp_base_string(o);
add_char('"');
return;
case subtag_bignum:
if (elements == 1) {
sprint_signed_decimal((signed_natural)(deref(o, 1)));
return;
}
if ((elements == 2) && (deref(o, 2) == 0)) {
sprint_unsigned_decimal(deref(o, 1));
return;
}
break;
case subtag_double_float:
break;
case subtag_macptr:
add_c_string("#<MACPTR ");
sprint_unsigned_hex(deref(o,1));
add_c_string(">");
break;
default:
sprint_random_vector(o, subtag, elements);
}
}
void
sprint_lisp_object(LispObj o, int depth)
{
if (--depth < 0) {
add_char('#');
} else {
switch (fulltag_of(o)) {
case fulltag_even_fixnum:
case fulltag_odd_fixnum:
sprint_signed_decimal(unbox_fixnum(o));
break;
#ifdef X8664
case fulltag_immheader_0:
case fulltag_immheader_1:
case fulltag_immheader_2:
case fulltag_nodeheader_0:
case fulltag_nodeheader_1:
#else
case fulltag_immheader:
case fulltag_nodeheader:
#endif
add_c_string("#<header ? ");
sprint_unsigned_hex(o);
add_c_string(">");
break;
#ifdef X8664
case fulltag_imm_0:
case fulltag_imm_1:
#else
case fulltag_imm:
#endif
if (o == unbound) {
add_c_string("#<Unbound>");
} else {
if (header_subtag(o) == subtag_character) {
unsigned c = (o >> charcode_shift);
add_c_string("#\\");
if ((c >= ' ') && (c < 0x7f)) {
add_char(c);
} else {
sprintf(numbuf, "%#o", c);
add_c_string(numbuf);
}
#ifdef X8664
} else if (header_subtag(o) == subtag_single_float) {
LispObj xx = o;
float f = ((float *)&xx)[1];
sprintf(numbuf, "%f", f);
add_c_string(numbuf);
#endif
} else {
add_c_string("#<imm ");
sprint_unsigned_hex(o);
add_c_string(">");
}
}
break;
#ifdef X8664
case fulltag_nil:
#endif
case fulltag_cons:
sprint_list(o, depth);
break;
case fulltag_misc:
sprint_vector(o, depth);
break;
#ifdef X8664
case fulltag_symbol:
sprint_symbol(o);
break;
case fulltag_function:
sprint_function(o, depth);
break;
#endif
#ifdef X8664
case fulltag_tra_0:
case fulltag_tra_1:
#else
case fulltag_tra:
#endif
sprint_tra(o,depth);
break;
}