size_t
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
size_t ret = scm_i_array_element_type_sizes[h->element_type];
if (ret && ret % 8 == 0)
return ret / 8;
else if (ret)
scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
else
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
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;
}
size_t
scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
{
size_t ret = scm_i_array_element_type_sizes[h->element_type];
if (ret)
return ret;
else
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
const SCM *ret = scm_vector_elements (vec, h, lenp, incp);
if (h->writable_elements != h->elements)
scm_wrong_type_arg_msg (NULL, 0, vec, "mutable vector");
return (SCM *) ret;
}
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);
}
const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
/* it's unsafe to access the memory of a weak vector */
if (SCM_I_WVECTP (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_array_get_handle (vec, h);
if (1 != scm_array_handle_rank (h))
{
scm_array_handle_release (h);
scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array of Scheme values");
}
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_elements (h);
}
/* OBJ must be a values object containing exactly two values.
scm_i_extract_values_2 puts those two values into *p1 and *p2. */
void
scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
{
SCM values;
SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
"scm_i_extract_values_2", "values");
values = scm_struct_ref (obj, SCM_INUM0);
if (scm_ilength (values) != 2)
scm_wrong_type_arg_msg
("scm_i_extract_values_2", SCM_ARG1, obj,
"a values object containing exactly two values");
*p1 = SCM_CAR (values);
*p2 = SCM_CADR (values);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
if (SCM_I_WVECTP (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_writable_elements (h);
}
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);
}
SCM
scm_apply_0 (SCM proc, SCM args)
{
SCM *argv;
int i, nargs;
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
scm_wrong_type_arg_msg ("apply", 2, args, "list");
/* FIXME: Use vm_builtin_apply instead of alloca. */
argv = alloca (nargs * sizeof(SCM));
for (i = 0; i < nargs; i++)
{
argv[i] = SCM_CAR (args);
args = SCM_CDR (args);
}
return scm_call_n (proc, argv, nargs);
}
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;
}
TYPE
SCM_TO_TYPE_PROTO (SCM val)
{
if (SCM_I_INUMP (val))
{
scm_t_signed_bits n = SCM_I_INUM (val);
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SIZEOF_SCM_T_BITS
return n;
#else
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
else
{
goto out_of_range;
}
#endif
}
else if (SCM_BIGP (val))
{
if (TYPE_MIN >= SCM_MOST_NEGATIVE_FIXNUM
&& TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM)
goto out_of_range;
else if (TYPE_MIN >= LONG_MIN && TYPE_MAX <= LONG_MAX)
{
if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
{
long n = mpz_get_si (SCM_I_BIG_MPZ (val));
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
return n;
#else
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
else
goto out_of_range;
#endif
}
else
goto out_of_range;
}
else
{
scm_t_intmax n;
size_t count;
if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
> CHAR_BIT*sizeof (scm_t_uintmax))
goto out_of_range;
mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
SCM_I_BIG_MPZ (val));
if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
{
if (n < 0)
goto out_of_range;
}
else
{
n = -n;
if (n >= 0)
goto out_of_range;
}
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
else
{
out_of_range:
scm_i_range_error (val,
scm_from_signed_integer (TYPE_MIN),
scm_from_signed_integer (TYPE_MAX));
return 0;
}
}
}
else
{
scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
return 0;
}
}
void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
if (!SCM_SMOB_PREDICATE (tag, val))
scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
}
