SCM
scm_make_foreign_object_n (SCM type, size_t n, void *vals[])
#define FUNC_NAME "make-foreign-object"
{
SCM obj;
SCM layout;
size_t i;
const char *layout_chars;
SCM_VALIDATE_VTABLE (SCM_ARG1, type);
layout = SCM_VTABLE_LAYOUT (type);
if (scm_i_symbol_length (layout) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
layout_chars = scm_i_symbol_chars (layout);
for (i = 0; i < n; i++)
if (layout_chars[i * 2] != 'u')
scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
obj = scm_c_make_structv (type, 0, 0, NULL);
for (i = 0; i < n; i++)
SCM_STRUCT_DATA_SET (obj, i, (scm_t_bits) vals[i]);
return obj;
}
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);
}
/* Accept character strings from the curses terminal keyboard */
SCM
gucu_wgetnstr (SCM win, SCM n)
{
SCM s_str;
int ret;
int c_n;
c_n = scm_to_int (n);
if (c_n <= 0)
scm_out_of_range ("%wgetnstr", n);
#ifdef HAVE_NCURSESW
{
wint_t *c_wstr = (wint_t *) scm_malloc (sizeof (wint_t) * (c_n + 1));
ret = wgetn_wstr (_scm_to_window (win), c_wstr, c_n);
c_wstr[c_n] = 0;
if (ret == OK)
{
s_str = _scm_sstring_from_wint_string (c_wstr);
free (c_wstr);
}
else if (ret == KEY_RESIZE)
{
s_str = scm_from_int (KEY_RESIZE);
}
else
abort ();
}
#else
{
char *c_str = (char *) scm_malloc (sizeof (char) * (c_n + 1));
ret = wgetnstr (_scm_to_window (win), c_str, c_n);
c_str[c_n] = '\0';
if (ret == OK)
{
s_str = scm_from_locale_string (c_str);
free (c_str);
}
else if (ret == KEY_RESIZE)
{
s_str = scm_from_int (KEY_RESIZE);
}
else
abort ();
}
#endif
return (s_str);
}
void
scm_foreign_object_unsigned_set_x (SCM obj, size_t n, scm_t_bits val)
#define FUNC_NAME "foreign-object-set!"
{
SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
if (SCM_STRUCT_SIZE (obj) <= n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n))
scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field");
SCM_STRUCT_DATA_SET (obj, n, val);
}
scm_t_bits
scm_foreign_object_unsigned_ref (SCM obj, size_t n)
#define FUNC_NAME "foreign-object-ref"
{
SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
if (SCM_STRUCT_SIZE (obj) <= n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n))
scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field");
return SCM_STRUCT_DATA_REF (obj, n);
}
void
scm_foreign_object_unsigned_set_x (SCM obj, size_t n, scm_t_bits val)
#define FUNC_NAME "foreign-object-set!"
{
SCM layout;
SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
layout = SCM_STRUCT_LAYOUT (obj);
if (scm_i_symbol_length (layout) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
if (scm_i_symbol_ref (layout, n * 2) != 'u')
scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
SCM_STRUCT_DATA_SET (obj, n, val);
}
/* Create a new plotter whose output and error are Guile ports */
SCM
gupl_newpl (SCM type, SCM outp, SCM errp, SCM param)
{
char *c_type;
FILE *c_outp, *c_errp;
plPlotter *ret;
plPlotterParams *c_param;
SCM_ASSERT (scm_is_string (type), type, SCM_ARG1, "newpl");
SCM_ASSERT (scm_is_true (scm_output_port_p (outp)), outp, SCM_ARG2,
"newpl");
SCM_ASSERT (scm_is_true (scm_output_port_p (errp)), errp, SCM_ARG3, "newpl");
SCM_ASSERT (_scm_is_plparams (param), param, SCM_ARG4, "newpl");
/* Convert the output port to a special stream */
c_outp = fopencookie (SCM2PTR (outp), "wb", port_funcs);
/* Don't buffer port here, since the underlying Guile port also has
port buffering. Double buffering causes problems. */
setvbuf (c_outp, NULL, _IONBF, 0);
if (c_outp == NULL)
scm_syserror ("newpl");
/* Convert the err port to a special stream */
c_errp = fopencookie (SCM2PTR (errp), "wb", port_funcs);
if (c_errp == NULL)
scm_out_of_range ("newpl", errp);
setvbuf (c_errp, NULL, _IONBF, 0);
c_type = scm_to_locale_string (type);
c_param = _scm_to_plparams (param);
ret = pl_newpl_r (c_type, NULL, c_outp, c_errp, c_param);
free (c_type);
if (ret == NULL)
return SCM_BOOL_F;
return _scm_from_plotter (ret);
}
SCM
scm_make_foreign_object_n (SCM type, size_t n, void *vals[])
#define FUNC_NAME "make-foreign-object"
{
SCM obj;
size_t i;
SCM_VALIDATE_VTABLE (SCM_ARG1, type);
if (SCM_VTABLE_SIZE (type) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
for (i = 0; i < n; i++)
if (!SCM_VTABLE_FIELD_IS_UNBOXED (type, i))
scm_wrong_type_arg_msg (FUNC_NAME, 0, type, "foreign object type");
obj = scm_c_make_structv (type, 0, 0, NULL);
for (i = 0; i < n; i++)
SCM_STRUCT_DATA_SET (obj, i, (scm_t_bits) vals[i]);
return obj;
}
void
scm_i_rehash (SCM table,
scm_t_hash_fn hash_fn,
void *closure,
const char* func_name)
{
SCM buckets, new_buckets;
int i;
unsigned long old_size;
unsigned long new_size;
if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
{
/* rehashing is not triggered when i <= min_size */
i = SCM_HASHTABLE (table)->size_index;
do
--i;
while (i > SCM_HASHTABLE (table)->min_size_index
&& SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
}
else
{
i = SCM_HASHTABLE (table)->size_index + 1;
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
}
SCM_HASHTABLE (table)->size_index = i;
new_size = hashtable_size[i];
if (i <= SCM_HASHTABLE (table)->min_size_index)
SCM_HASHTABLE (table)->lower = 0;
else
SCM_HASHTABLE (table)->lower = new_size / 4;
SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
buckets = SCM_HASHTABLE_VECTOR (table);
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < old_size; ++i)
{
SCM ls, cell, handle;
ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
while (scm_is_pair (ls))
{
unsigned long h;
cell = ls;
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
SCM_HASHTABLE_INCREMENT (table);
}
}
}
SCM
guile_sock_connect (SCM host, SCM proto, SCM port)
{
svz_socket_t *sock;
uint32_t xhost;
uint16_t xport = 0;
uint16_t p;
int xproto;
char *str;
struct sockaddr_in addr;
SCM ret = SCM_BOOL_F;
SCM_ASSERT (scm_is_integer (host) || scm_is_string (host), host, SCM_ARG1,
FUNC_NAME);
SCM_ASSERT (scm_is_integer (proto), proto, SCM_ARG2, FUNC_NAME);
/* Extract host to connect to. */
if (scm_is_integer (host))
xhost = htonl (scm_to_uint32 (host));
else
{
str = guile_to_string (host);
if (svz_inet_aton (str, &addr) == -1)
{
if (guile_resolve (str, &xhost) == -1)
{
guile_error ("%s: IP in dotted decimals or hostname expected",
FUNC_NAME);
free (str);
return ret;
}
}
else
xhost = addr.sin_addr.s_addr;
free (str);
}
/* Extract protocol to use. */
xproto = scm_to_int (proto);
/* Find out about given port. */
if (!SCM_UNBNDP (port))
{
SCM_ASSERT (scm_is_integer (port), port, SCM_ARG3, FUNC_NAME);
p = scm_to_uint16 (port);
xport = htons (p);
}
/* Depending on the requested protocol; create different kinds of
socket structures. */
switch (xproto)
{
case PROTO_TCP:
sock = svz_tcp_connect (xhost, xport);
break;
case PROTO_UDP:
sock = svz_udp_connect (xhost, xport);
break;
case PROTO_ICMP:
sock = svz_icmp_connect (xhost, xport, ICMP_SERVEEZ);
break;
default:
scm_out_of_range (FUNC_NAME, proto);
}
if (sock == NULL)
return ret;
sock->disconnected_socket = guile_func_disconnected_socket;
SCM_RETURN_NEWSMOB (guile_svz_socket_tag, sock);
}