obj basic_num_to_string_obj( obj a, unsigned radix )
{
char buf[100];
if (FIXNUM_P(a)) {
return make_string( fixnum_to_string( &buf[100], a, radix ) );
} else if (LONGFLOAT_P(a)) {
snprintf( buf, 100, "%g", extract_float(a) );
if (!strchr( buf,'.') && !strchr(buf,'e')) {
strcat( buf, "." );
}
return make_string( buf );
} else if (OBJ_ISA_PTR_OF_CLASS(a,bignum_class)) {
return bignum_to_string_obj( a, radix );
} else if (OBJ_ISA_PTR_OF_CLASS(a,mp_rational_class)) {
return rational_to_string_obj( a, radix );
} else if (OBJ_ISA_PTR_OF_CLASS(a,rect_complex_class)) {
obj r;
char *str;
obj re = basic_num_to_string_obj( gvec_ref( a, SLOT(0) ), radix );
obj im = basic_num_to_string_obj( gvec_ref( a, SLOT(1) ), radix );
unsigned len = string_length(re) + string_length(im) + 1;
if (string_text(im)[0] != '-') {
len++;
}
r = bvec_alloc( len+1, string_class );
str = string_text( r );
memcpy( str, string_text( re ), string_length( re ) );
str += string_length( re );
if (string_text(im)[0] != '-') {
*str++ = '+';
}
memcpy( str, string_text( im ), string_length( im ) );
str += string_length( im );
*str++ = 'i';
*str = 0;
return r;
} else {
return FALSE_OBJ;
}
}
static void rs_vmd_envts( FILE *f, int pass, obj envt )
{
unsigned i = 0;
char tmp[20];
fprintf( f, "\n" );
while (OBJ_ISA_PTR_OF_CLASS( envt, binding_envt_class ) && (i < 20)) {
unsigned k;
fprintf( f, " --: %08lx :-- (binding frame %u.)\n", VAL( envt ), i );
sprintf( tmp, "%u.next", i );
rs_vmd_prn( f, pass, tmp, gvec_ref( envt, SLOT(0) ) );
for (k=SLOT(1); k<SIZEOF_PTR( envt ); k+=SLOT(1)) {
sprintf( tmp, "%u.%u", i, k / SLOT(1) );
rs_vmd_prn( f, pass, tmp, gvec_ref( envt, k ) );
}
envt = gvec_ref( envt, SLOT(0) );
i++;
}
}
static void rs_vmd_pass( FILE *f, int pass )
{
obj saved_cr;
unsigned i;
obj envts[20];
unsigned num_envts = 0;
fprintf( f, "--------- VM State ----------\n" );
fprintf( f, "Registers:\n" );
rs_vmd_prn( f, pass, "envt_reg", envt_reg );
if (OBJ_ISA_PTR_OF_CLASS( envt_reg, binding_envt_class )) {
envts[num_envts++] = envt_reg;
}
rs_vmd_prn( f, pass, "literals_reg", literals_reg );
rs_vmd_prn( f, pass, "dynamic_state_reg", dynamic_state_reg );
rs_vmd_prn( f, pass, "thread_state_reg", thread_state_reg );
fprintf( f, " arg_count_reg: %8u\n", arg_count_reg );
fprintf( f, " continuation_reg: %08lx\n", VAL(continuation_reg) );
for (i=0; i<arg_count_reg; i++) {
char tmp[20];
sprintf( tmp, "REG(%d)", i );
rs_vmd_prn( f, pass, tmp, reg_ref(i) );
}
fflush( f ); /* get all of that out of the process boundary */
/* now, try to dive into some more detail... */
fprintf( f, "Continuation Chain:\n" );
saved_cr = continuation_reg;
for (i=0; i<10; i++) {
unsigned n, j;
obj x;
fprintf( f, " (%u) will continue in #[FRAME %08lx]", i, VAL(continuation_reg) );
fflush( f );
/* 'n' is the number of slots above and beyond CONT_FIXED */
n = get_partcont_size( continuation_reg );
fprintf( f, " (%u slots)\n", n );
x = gvec_ref( continuation_reg, SLOT(0) );
rs_vmd_prn( f, pass, ".envt", x );
if (OBJ_ISA_PTR_OF_CLASS( x, binding_envt_class ) && (num_envts < 20)) {
envts[num_envts++] = x;
}
rs_vmd_prn( f, pass, ".literals", gvec_ref( continuation_reg, SLOT(1) ) );
rs_vmd_prn( f, pass, ".label", gvec_ref( continuation_reg, SLOT(2) ) );
rs_vmd_prn( f, pass, ".contn", gvec_ref( continuation_reg, SLOT(3) ) );
for (j=0; j<n; j++) {
char tmp[20];
sprintf( tmp, "slot[%u]", j );
rs_vmd_prn( f, pass, tmp, gvec_ref( continuation_reg, SLOT(j + CONT_FIXED) ) );
}
RESTORE_CONT_REG();
if (!OBJ_ISA_PTR( continuation_reg )) {
break;
}
}
fprintf( f, "Binding Environments:\n" );
for (i=0; i<num_envts; i++) {
rs_vmd_envts( f, pass, envts[i] );
}
continuation_reg = saved_cr;
}
