static int
scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<memoized ", port);
scm_write (scm_unmemoize_expression (memoized), port);
scm_puts_unlocked (">", port);
return 1;
}
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts_unlocked (">", port);
}
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<hash-table ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
scm_puts_unlocked (">", port);
}
static SCM
print_values (SCM obj, SCM pwps)
{
SCM values = scm_struct_ref (obj, SCM_INUM0);
SCM port = SCM_PORT_WITH_PS_PORT (pwps);
scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
scm_puts_unlocked ("#<values ", port);
scm_iprin1 (values, port, ps);
scm_puts_unlocked (">", port);
return SCM_UNSPECIFIED;
}
void
scm_stack_report ()
{
SCM port = scm_current_error_port ();
SCM_STACKITEM stack;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_uintprint ((scm_stack_size (thread->continuation_base)
* sizeof (SCM_STACKITEM)),
16, port);
scm_puts_unlocked (" of stack: 0x", port);
scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
scm_puts_unlocked (" - 0x", port);
scm_uintprint ((scm_t_bits) &stack, 16, port);
scm_puts_unlocked ("\n", port);
}
int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{
size_t bit_len = BITVECTOR_LENGTH (vec);
size_t word_len = (bit_len+31)/32;
scm_t_uint32 *bits = BITVECTOR_BITS (vec);
size_t i, j;
scm_puts_unlocked ("#*", port);
for (i = 0; i < word_len; i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port);
}
return 1;
}
void
scm_c_issue_deprecation_warning (const char *msg)
{
if (!SCM_WARN_DEPRECATED)
print_summary = 1;
else
{
struct issued_warning *iw;
scm_i_pthread_mutex_lock (&warn_lock);
for (iw = issued_warnings; iw; iw = iw->prev)
if (!strcmp (iw->message, msg))
{
msg = NULL;
break;
}
if (msg)
{
msg = strdup (msg);
iw = malloc (sizeof (struct issued_warning));
if (msg == NULL || iw == NULL)
/* Nothing sensible to do if you can't allocate this small
amount of memory. */
abort ();
iw->message = msg;
iw->prev = issued_warnings;
issued_warnings = iw;
}
scm_i_pthread_mutex_unlock (&warn_lock);
/* All this dance is to avoid printing to a port inside a mutex,
which could recurse and deadlock. */
if (msg)
{
if (scm_gc_running_p)
fprintf (stderr, "%s\n", msg);
else
{
scm_puts_unlocked (msg, scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
}
}
}
}
