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);
}
static SCM
make_weak_vector (size_t len, SCM fill)
#define FUNC_NAME "make-weak-vector"
{
SCM wv;
size_t j;
SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
if (SCM_UNBNDP (fill))
fill = SCM_UNSPECIFIED;
wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
"weak vector"));
SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
if (SCM_HEAP_OBJECT_P (fill))
{
memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
for (j = 0; j < len; j++)
scm_c_weak_vector_set_x (wv, j, fill);
}
else
for (j = 0; j < len; j++)
SCM_SIMPLE_VECTOR_SET (wv, j, fill);
return wv;
}
VISIBLE SCM
scm_rexp_number_of_subexpressions (SCM match)
{
return (scm_is_true (match)) ?
scm_from_size_t (rexp_num_subexpr (scm_to_rexp_match_t (match))) :
scm_from_int (0);
}
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 char*
map_file_contents (int fd, size_t len, int *is_read_only)
#define FUNC_NAME "load-thunk-from-file"
{
char *data;
#ifdef HAVE_SYS_MMAN_H
data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
if (data == MAP_FAILED)
SCM_SYSERROR;
*is_read_only = 1;
#else
if (lseek (fd, 0, SEEK_START) < 0)
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
SCM_SYSERROR;
}
/* Given that we are using the read fallback, optimistically assume
that the .go files were made with 8-byte alignment.
alignment. */
data = malloc (end);
if (!data)
{
(void) close (fd);
scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes",
scm_list_1 (scm_from_size_t (end)));
}
if (full_read (fd, data, end) != end)
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, "short read while loading objcode",
SCM_EOL);
}
/* If our optimism failed, fall back. */
{
unsigned alignment = sniff_elf_alignment (data, end);
if (alignment != 8)
{
char *copy = copy_and_align_elf_data (data, end, alignment);
free (data);
data = copy;
}
}
*is_read_only = 0;
#endif
return data;
}
static SCM api_rwrite(SCM s_, SCM buffer_)
{
servlet *s = scm_to_pointer(s_);
size_t length;
char *str = scm_to_utf8_stringn(buffer_, &length);
size_t ret = rwrite(s, str, length);
free(str);
return scm_from_size_t(ret);
}
/* returns a (sec . usec) pair. It throws an 'a-sync-exception guile
exception if the library has been configured for monotonic time at
configuration time but it is not in fact supported, but this is not
worth testing for by user code as it should never happen - the
library configuration macros should always give the correct
answer */
static SCM get_time(void) {
#ifdef HAVE_MONOTONIC_CLOCK
struct timespec ts;
if (clock_gettime(CLOCK_MONOTONIC, &ts) == -1) {
scm_throw(scm_from_latin1_symbol("a-sync-exception"),
scm_list_4(scm_from_latin1_string("get-time"),
scm_from_latin1_string("guile-a-sync2: ~A"),
scm_list_1(scm_from_latin1_string("monotonic time not supported "
"by underlying implementation")),
scm_from_int(errno)));
}
return scm_cons(scm_from_size_t(ts.tv_sec), scm_from_long(ts.tv_nsec/1000L));
#else
return scm_gettimeofday();
#endif
}
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);
}
static SCM
scm_elev_scm_spline (const char *who,
void elev_scm_spline (size_t new_degree,
size_t degree,
ssize_t stride,
const SCM *spline,
ssize_t result_stride,
SCM *result),
SCM new_degree, SCM spline)
{
scm_t_array_handle handle;
scm_t_array_handle handle2;
scm_dynwind_begin (0);
const size_t _new_degree = scm_to_size_t (new_degree);
scm_array_get_handle (spline, &handle);
scm_dynwind_array_handle_release (&handle);
assert_c_rank_1_or_2_array (who, spline, &handle);
size_t dim;
ssize_t stride;
scm_array_handle_get_vector_dim_and_stride (who, spline, &handle,
&dim, &stride);
const SCM *_spline = scm_array_handle_elements (&handle);
if (_new_degree < dim - 1)
the_new_degree_is_not_an_elevation (who, new_degree,
scm_from_size_t (dim - 1), spline);
SCM result = scm_make_array (SCM_UNSPECIFIED,
scm_list_1 (scm_oneplus (new_degree)));
scm_array_get_handle (result, &handle2);
scm_dynwind_array_handle_release (&handle2);
SCM *_result = scm_array_handle_writable_elements (&handle2);
elev_scm_spline (_new_degree, dim - 1, stride, _spline, 1, _result);
scm_dynwind_end ();
return result;
}
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;
}
