Ejemplo n.º 1
0
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;
}
Ejemplo n.º 2
0
Archivo: plsym.c Proyecto: 8l/clozure
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;
}
Ejemplo n.º 3
0
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 {
Ejemplo n.º 4
0
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(')');
}
Ejemplo n.º 5
0
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('>');
}
Ejemplo n.º 6
0
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
    }
  }
}
Ejemplo n.º 7
0
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;
  }
}
Ejemplo n.º 8
0
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
}
Ejemplo n.º 9
0
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;
}
Ejemplo n.º 10
0
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);
  }
}
Ejemplo n.º 11
0
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;
    }