SCM
gfec_apply(SCM proc, SCM arglist, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:apply-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error;
call_result = scm_call_2 (func, proc, arglist);
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
SCM
gfec_eval_string(const char *str, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:eval-string-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error = SCM_UNDEFINED;
call_result = scm_call_1 (func, scm_from_utf8_string (str));
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
static const scm_t_uint32*
get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
{
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
return SUBR_STUB_CODE (nreq, nopt, rest);
}
static SCM
gdbscm_memory_port_write_buffer_size (SCM port)
{
ioscm_memory_port *iomem;
SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
memory_port_desc_name);
iomem = (ioscm_memory_port *) SCM_STREAM (port);
return scm_from_uint (iomem->write_buf_size);
}
SCM
gfec_eval_string(const char *str, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:eval-string-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error = SCM_UNDEFINED;
/* Deal with the possibility that scm_from_utf8_string will
* throw, falling back to scm_from_locale_string. If that fails, log a
* warning and punt.
*/
SCM scm_string = scm_internal_catch(SCM_BOOL_T,
gfec_string_from_utf8, (void*)str,
gfec_string_inner_handler,
(void*)str);
if (!scm_string)
{
error_handler("Contents could not be interpreted as UTF-8 or the current locale/codepage.");
return result;
}
call_result = scm_call_1 (func, scm_string);
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
SCM scm_from_ip_addr_number(struct ip_addr const *ip)
{
if (ip->family == AF_INET) {
return scm_from_uint32(ntohl(ip->u.v4.s_addr));
} else {
uint32_t w4, w3, w2, w1;
memcpy(&w4, ((char *)ip->u.v6.s6_addr)+0*sizeof(w4), sizeof(w4));
memcpy(&w3, ((char *)ip->u.v6.s6_addr)+1*sizeof(w4), sizeof(w3));
memcpy(&w2, ((char *)ip->u.v6.s6_addr)+2*sizeof(w4), sizeof(w2));
memcpy(&w1, ((char *)ip->u.v6.s6_addr)+3*sizeof(w4), sizeof(w1));
uint64_t hi = ((uint64_t)ntohl(w4) << 32ULL) | ntohl(w3);
uint64_t lo = ((uint64_t)ntohl(w2) << 32ULL) | ntohl(w1);
return scm_logior(scm_ash(scm_from_uint64(hi), scm_from_uint(64)), scm_from_uint64(lo));
}
}
static SCM g_get_duplicogram(void)
{
SCM lst = SCM_EOL;
uint64_t const nb_pkts = nb_nodups + nb_dups;
scm_dynwind_begin(0);
mutex_lock(&dup_lock);
scm_dynwind_unwind_handler(pthread_mutex_unlock_, &dup_lock.mutex, SCM_F_WIND_EXPLICITLY);
unsigned dt = bucket_width/2;
for (unsigned x = 0; x < nb_buckets; x++, dt += bucket_width) {
lst = scm_cons(
scm_cons(scm_from_uint(dt),
scm_from_double(nb_pkts > 0 ? (double)dups[x] / nb_pkts : 0.)),
lst);
}
dup_reset_locked();
scm_dynwind_end();
return lst;
}
static SCM
pascm_param_value (enum var_types type, void *var,
int arg_pos, const char *func_name)
{
/* Note: We *could* support var_integer here in case someone is trying to get
the value of a Python-created parameter (which is the only place that
still supports var_integer). To further discourage its use we do not. */
switch (type)
{
case var_string:
case var_string_noescape:
case var_optional_filename:
case var_filename:
case var_enum:
{
const char *str = *(char **) var;
if (str == NULL)
str = "";
return gdbscm_scm_from_host_string (str, strlen (str));
}
case var_boolean:
{
if (* (int *) var)
return SCM_BOOL_T;
else
return SCM_BOOL_F;
}
case var_auto_boolean:
{
enum auto_boolean ab = * (enum auto_boolean *) var;
if (ab == AUTO_BOOLEAN_TRUE)
return SCM_BOOL_T;
else if (ab == AUTO_BOOLEAN_FALSE)
return SCM_BOOL_F;
else
return auto_keyword;
}
case var_zuinteger_unlimited:
if (* (int *) var == -1)
return unlimited_keyword;
gdb_assert (* (int *) var >= 0);
/* Fall through. */
case var_zinteger:
return scm_from_int (* (int *) var);
case var_uinteger:
if (* (unsigned int *) var == UINT_MAX)
return unlimited_keyword;
/* Fall through. */
case var_zuinteger:
return scm_from_uint (* (unsigned int *) var);
default:
break;
}
return gdbscm_make_out_of_range_error (func_name, arg_pos,
scm_from_int (type),
_("program error: unhandled type"));
}