static void
test_query (QofQuery *q)
{
SCM scm_q;
QofQuery *q2;
scm_q = gnc_query2scm (q);
q2 = gnc_scm2query (scm_q);
if (!qof_query_equal (q, q2))
{
failure ("queries don't match");
scm_display (scm_q, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
scm_q = gnc_query2scm (q2);
scm_display (scm_q, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
exit (1);
}
else
{
success ("queries match");
}
qof_query_destroy (q2);
}
static void
test_newline__specify_closed_port__return_ERROR(ScmObj port, int type)
{
SCM_REFSTK_INIT_REG(&port);
scm_close_port(port);
TEST_ASSERT_EQUAL_INT(-1, scm_newline(port));
}
static void
cmdscm_bad_completion_result (const char *msg, SCM completion)
{
SCM port = scm_current_error_port ();
scm_puts (msg, port);
scm_display (completion, port);
scm_newline (port);
}
static void
test_query (Query *q, SCM val2str)
{
SCM scm_q;
SCM str_q;
SCM args = SCM_EOL;
scm_q = gnc_query2scm (q);
args = scm_cons (scm_q, SCM_EOL);
str_q = scm_apply (val2str, args, SCM_EOL);
args = scm_cons (scm_makfrom0str ("'"), scm_cons (str_q, SCM_EOL));
str_q = scm_string_append (args);
scm_display (str_q, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
}
void
gdbscm_debug_display (SCM obj)
{
SCM port = scm_current_output_port ();
scm_display (obj, port);
scm_newline (port);
scm_force_output (port);
}
static void
test_newline(ScmObj port, int type)
{
const char *expected = "\n";
SCM_REFSTK_INIT_REG(&port);
TEST_ASSERT_EQUAL_INT(0, scm_newline(port));
scm_close_port(port);
if (type == FILEPORT)
chk_file_contents(expected);
else if (type == STRINGPORT)
chk_string_port_contents(port, expected);
}
static void *
scscm_eval_scheme_string (void *datap)
{
struct eval_scheme_string_data *data = datap;
SCM result = scm_c_eval_string (data->string);
if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED))
{
SCM port = scm_current_output_port ();
scm_write (result, port);
scm_newline (port);
}
/* If we get here the eval succeeded. */
return NULL;
}
static void
test_query (Query *q, SCM val2str)
{
SCM scm_q;
SCM str_q;
SCM res_q;
SCM args = SCM_EOL;
Query *q2;
gchar *str2 = NULL;
scm_q = gnc_query2scm (q);
args = scm_cons (scm_q, SCM_EOL);
str_q = scm_apply (val2str, args, SCM_EOL);
args = scm_cons (scm_from_utf8_string ("'"), scm_cons (str_q, SCM_EOL));
str_q = scm_string_append (args);
str2 = gnc_scm_to_utf8_string (str_q);
if (str2)
{
res_q = scm_c_eval_string (str2);
}
else
{
res_q = SCM_BOOL_F;
}
q2 = gnc_scm2query (res_q);
if (!qof_query_equal (q, q2))
{
failure ("queries don't match");
fprintf (stderr, "%s\n\n", str2 ? str2 : "(null)");
scm_q = gnc_query2scm (q2);
scm_display (scm_q, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
g_free(str2);
exit (1);
}
else
{
success ("queries match");
}
g_free(str2);
if (q2) qof_query_destroy (q2);
}
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 ());
}
}
}
}
static void
gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
gdb_assert (!scm_is_eq (key, with_stack_error_symbol));
/* This does not use scm_print_exception because we tweak the output a bit.
Compare Guile's print-exception with our %print-exception-message for
details. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
percent_print_exception_message_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_message_name);
/* If we can't find %print-exception-message, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_message_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_message_var);
status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
void
gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
percent_print_exception_with_stack_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_with_stack_name);
/* If we can't find %print-exception-with-stack, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_with_stack_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_with_stack_var);
status = gdbscm_safe_call_4 (printer, port, stack, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
