167 lines
3.0 KiB
C
167 lines
3.0 KiB
C
#include "factor.h"
|
|
|
|
/* Implements some Factor library words in C, to dump a stack in a semi-human-readable
|
|
form without any Factor code executing.. This is not used during normal execution, only
|
|
when the runtime dies. */
|
|
bool equals(CELL obj1, CELL obj2)
|
|
{
|
|
if(type_of(obj1) == STRING_TYPE
|
|
&& type_of(obj2) == STRING_TYPE)
|
|
{
|
|
return string_compare(untag_string(obj1),untag_string(obj2)) == 0;
|
|
}
|
|
else
|
|
return (obj1 == obj2);
|
|
}
|
|
|
|
CELL assoc(CELL alist, CELL key)
|
|
{
|
|
if(alist == F)
|
|
return F;
|
|
|
|
if(TAG(alist) != CONS_TYPE)
|
|
{
|
|
fprintf(stderr,"Not an alist: %ld\n",alist);
|
|
return F;
|
|
}
|
|
|
|
{
|
|
CELL pair = untag_cons(alist)->car;
|
|
if(TAG(pair) != CONS_TYPE)
|
|
{
|
|
fprintf(stderr,"Not a pair: %ld\n",alist);
|
|
return F;
|
|
}
|
|
|
|
if(equals(untag_cons(pair)->car,key))
|
|
return untag_cons(pair)->cdr;
|
|
else
|
|
return assoc(untag_cons(alist)->cdr,key);
|
|
}
|
|
}
|
|
|
|
CELL hash(CELL hash, CELL key)
|
|
{
|
|
if(type_of(hash) != HASHTABLE_TYPE)
|
|
{
|
|
fprintf(stderr,"Not a hash: %ld\n",hash);
|
|
return F;
|
|
}
|
|
|
|
{
|
|
int i;
|
|
|
|
CELL array = ((F_HASHTABLE*)UNTAG(hash))->array;
|
|
F_ARRAY* a;
|
|
|
|
if(type_of(array) != ARRAY_TYPE)
|
|
{
|
|
fprintf(stderr,"Not an array: %ld\n",hash);
|
|
return F;
|
|
}
|
|
|
|
a = untag_array_fast(array);
|
|
|
|
for(i = 0; i < array_capacity(a); i++)
|
|
{
|
|
CELL value = assoc(get(AREF(a,i)),key);
|
|
if(value != F)
|
|
return value;
|
|
}
|
|
|
|
return F;
|
|
}
|
|
}
|
|
void print_cons(CELL cons)
|
|
{
|
|
fprintf(stderr,"[ ");
|
|
|
|
do
|
|
{
|
|
print_obj(untag_cons(cons)->car);
|
|
fprintf(stderr," ");
|
|
cons = untag_cons(cons)->cdr;
|
|
}
|
|
while(TAG(cons) == CONS_TYPE);
|
|
|
|
if(cons != F)
|
|
{
|
|
fprintf(stderr,"| ");
|
|
print_obj(cons);
|
|
fprintf(stderr," ");
|
|
}
|
|
fprintf(stderr,"]");
|
|
}
|
|
|
|
void print_word(F_WORD* word)
|
|
{
|
|
CELL name = hash(word->props,tag_object(from_c_string("name")));
|
|
if(type_of(name) == STRING_TYPE)
|
|
fprintf(stderr,"%s",to_c_string(untag_string(name)));
|
|
else
|
|
{
|
|
fprintf(stderr,"#<not a string: ");
|
|
print_obj(name);
|
|
fprintf(stderr,">");
|
|
}
|
|
|
|
fprintf(stderr," (#%ld)",word->primitive);
|
|
}
|
|
|
|
void print_string(F_STRING* str)
|
|
{
|
|
fprintf(stderr,"\"");
|
|
fprintf(stderr,"%s",to_c_string(str));
|
|
fprintf(stderr,"\"");
|
|
}
|
|
|
|
void print_obj(CELL obj)
|
|
{
|
|
switch(type_of(obj))
|
|
{
|
|
case FIXNUM_TYPE:
|
|
fprintf(stderr,"%ld",untag_fixnum_fast(obj));
|
|
break;
|
|
case CONS_TYPE:
|
|
print_cons(obj);
|
|
break;
|
|
case WORD_TYPE:
|
|
print_word(untag_word(obj));
|
|
break;
|
|
case STRING_TYPE:
|
|
print_string(untag_string(obj));
|
|
break;
|
|
case F_TYPE:
|
|
fprintf(stderr,"f");
|
|
break;
|
|
default:
|
|
fprintf(stderr,"#<type %ld @ %ld>",type_of(obj),obj);
|
|
break;
|
|
}
|
|
}
|
|
|
|
void print_stack(CELL* start, CELL* end)
|
|
{
|
|
while(start < end)
|
|
{
|
|
print_obj(*start);
|
|
fprintf(stderr,"\n");
|
|
start++;
|
|
}
|
|
}
|
|
|
|
void dump_stacks(void)
|
|
{
|
|
fprintf(stderr,"*** Data stack:\n");
|
|
print_stack((CELL*)ds_bot,(CELL*)(ds + CELLS));
|
|
fprintf(stderr,"*** Call stack:\n");
|
|
print_stack((CELL*)cs_bot,(CELL*)(cs + CELLS));
|
|
fprintf(stderr,"*** Call frame:\n");
|
|
print_obj(callframe);
|
|
fprintf(stderr,"\n");
|
|
fprintf(stderr,"*** Executing:\n");
|
|
print_obj(executing);
|
|
fprintf(stderr,"\n");
|
|
fflush(stderr);
|
|
}
|