/* create FPORT buffer with specified sizes (or -1 to use default size or
0 for no buffer. */
static void
scm_fport_buffer_add (SCM port, long read_size, int write_size)
#define FUNC_NAME "scm_fport_buffer_add"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (read_size == -1 || write_size == -1)
{
size_t default_size;
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
struct stat st;
scm_t_fport *fp = SCM_FSTREAM (port);
default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
: st.st_blksize;
#else
default_size = default_buffer_size;
#endif
if (read_size == -1)
read_size = default_size;
if (write_size == -1)
write_size = default_size;
}
if (SCM_INPUT_PORT_P (port) && read_size > 0)
{
pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer");
pt->read_pos = pt->read_end = pt->read_buf;
pt->read_buf_size = read_size;
}
else
{
pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
pt->read_buf_size = 1;
}
if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
{
pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer");
pt->write_pos = pt->write_buf;
pt->write_buf_size = write_size;
}
else
{
pt->write_buf = pt->write_pos = &pt->shortbuf;
pt->write_buf_size = 1;
}
pt->write_end = pt->write_buf + pt->write_buf_size;
if (read_size > 0 || write_size > 0)
SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
else
SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
}
static void
sysdep_dynl_init ()
{
char *env;
lt_dlinit ();
/* Initialize 'system_extensions_path' from
$GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set:
<SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>.
'lt_dladdsearchdir' can't be used because it is searched before
the system-dependent search path, which is the one 'libtool
--mode=execute -dlopen' fiddles with (info "(libtool) Libltdl
Interface"). See
<http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>.
The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH
can't be used because they would be propagated to subprocesses
which may cause problems for other programs. See
<http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */
env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
if (env)
system_extensions_path = env;
else
{
system_extensions_path
= scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR)
+ strlen (SCM_EXTENSIONS_DIR) + 2,
"system_extensions_path");
sprintf (system_extensions_path, "%s%c%s",
SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR);
}
}
static SCM
make_image (SCM name, SCM s_width, SCM s_height)
{
SCM smob;
struct image *image;
int width = scm_to_int (s_width);
int height = scm_to_int (s_height);
/* Step 1: Allocate the memory block.
*/
image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
/* Step 2: Initialize it with straight code.
*/
image->width = width;
image->height = height;
image->pixels = NULL;
image->name = SCM_BOOL_F;
image->update_func = SCM_BOOL_F;
/* Step 3: Create the smob.
*/
SCM_NEWSMOB (smob, image_tag, image);
/* Step 4: Finish the initialization.
*/
image->name = name;
image->pixels = scm_gc_malloc_pointerless (width * height, "image pixels");
return smob;
}
static SCM
load_thunk_from_fd_using_read (int fd)
#define FUNC_NAME "load-thunk-from-disk"
{
char *data;
size_t len;
struct stat st;
int ret;
ret = fstat (fd, &st);
if (ret < 0)
SCM_SYSERROR;
len = st.st_size;
data = scm_gc_malloc_pointerless (len, "objcode");
if (full_read (fd, data, len) != len)
{
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);
}
(void) close (fd);
return load_thunk_from_memory (data, len);
}
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;
}
static scm_t_weak_entry *
allocate_entries (unsigned long size, scm_t_weak_table_kind kind)
{
scm_t_weak_entry *ret;
size_t bytes = size * sizeof (*ret);
switch (kind)
{
case SCM_WEAK_TABLE_KIND_KEY:
ret = GC_generic_malloc (bytes, weak_key_gc_kind);
break;
case SCM_WEAK_TABLE_KIND_VALUE:
ret = GC_generic_malloc (bytes, weak_value_gc_kind);
break;
case SCM_WEAK_TABLE_KIND_BOTH:
ret = scm_gc_malloc_pointerless (bytes, "weak-table");
break;
default:
abort ();
}
memset (ret, 0, bytes);
return ret;
}
SCM scm_gunzip_buf(SCM scm_buf, SCM scm_outlen){
//this should typecheck buf for us
size_t buflen = scm_c_bytevector_length(scm_buf);
uint8_t *buf = (uint8_t*)SCM_BYTEVECTOR_CONTENTS(scm_buf);
size_t outlen = scm_to_size_t(scm_outlen);
uint8_t *out = scm_gc_malloc_pointerless(outlen, SCM_GC_BYTEVECTOR);
z_stream stream = {.next_in = buf, .avail_in = buflen,
.next_out = out, .avail_out = outlen,
.zalloc = NULL, .zfree = NULL, .opaque = NULL};
//15 | 16 means use 15 bits for the decompression window, and only accept
//gzip compressed buffers
inflateInit2(&stream, 15 | 16);
int status = inflate(&stream, Z_FINISH);
if(status != Z_STREAM_END){ //the output buffer was too small
//Do something useful here, for now this just makes sure that
//we don't cause any errors
fprintf(stderr, "Return value was %d, expecting %d\n",
status, Z_FINISH);
scm_gc_free(out, outlen, SCM_GC_BYTEVECTOR);
SCM ret = scm_from_utf8_string(stream.msg);
inflateEnd(&stream);
return ret;
}
//I don't know what the tag bits for a bytevector are so I need to
//make an empty one.
SCM bv = scm_c_make_bytevector(0);
SCM_SET_CELL_WORD_1(bv, stream.total_out);
SCM_SET_CELL_WORD_2(bv, out);
inflateEnd(&stream);
return bv;
}
static LLVMTypeRef function_type(SCM scm_return_type, SCM scm_argument_types)
{
int n_arguments = scm_ilength(scm_argument_types);
LLVMTypeRef *parameters = scm_gc_malloc_pointerless(n_arguments * sizeof(LLVMTypeRef), "make-llvm-function");
for (int i=0; i<n_arguments; i++) {
parameters[i] = llvm_type(scm_to_int(scm_car(scm_argument_types)));
scm_argument_types = scm_cdr(scm_argument_types);
};
return LLVMFunctionType(llvm_type(scm_to_int(scm_return_type)), parameters, n_arguments, 0);
}
static void
ioscm_init_stdio_buffers (SCM port, long mode_bits)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
#define GDB_STDIO_BUFFER_DEFAULT_SIZE 1024
int size = mode_bits & SCM_BUF0 ? 0 : GDB_STDIO_BUFFER_DEFAULT_SIZE;
int writing = (mode_bits & SCM_WRTNG) != 0;
/* This is heavily copied from scm_fport_buffer_add. */
if (!writing && size > 0)
{
pt->read_buf
= (unsigned char *) scm_gc_malloc_pointerless (size, "port buffer");
pt->read_pos = pt->read_end = pt->read_buf;
pt->read_buf_size = size;
}
else
{
pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
pt->read_buf_size = 1;
}
if (writing && size > 0)
{
pt->write_buf
= (unsigned char *) scm_gc_malloc_pointerless (size, "port buffer");
pt->write_pos = pt->write_buf;
pt->write_buf_size = size;
}
else
{
pt->write_buf = pt->write_pos = &pt->shortbuf;
pt->write_buf_size = 1;
}
pt->write_end = pt->write_buf + pt->write_buf_size;
}
static void
ioscm_init_memory_port (SCM port, CORE_ADDR start, CORE_ADDR end)
{
scm_t_port *pt;
ioscm_memory_port *iomem;
int buffered = (SCM_CELL_WORD_0 (port) & SCM_BUF0) == 0;
gdb_assert (start <= end);
iomem = (ioscm_memory_port *) scm_gc_malloc_pointerless (sizeof (*iomem),
"memory port");
iomem->start = start;
iomem->end = end;
iomem->size = end - start;
iomem->current = 0;
if (buffered)
{
iomem->read_buf_size = default_read_buf_size;
iomem->write_buf_size = default_write_buf_size;
}
else
{
iomem->read_buf_size = 1;
iomem->write_buf_size = 1;
}
pt = SCM_PTAB_ENTRY (port);
/* Match the expectation of `binary-port?'. */
pt->encoding = NULL;
pt->rw_random = 1;
pt->read_buf_size = iomem->read_buf_size;
pt->write_buf_size = iomem->write_buf_size;
if (buffered)
{
pt->read_buf = (unsigned char *) xmalloc (pt->read_buf_size);
pt->write_buf = (unsigned char *) xmalloc (pt->write_buf_size);
}
else
{
pt->read_buf = &pt->shortbuf;
pt->write_buf = &pt->shortbuf;
}
pt->read_pos = pt->read_end = pt->read_buf;
pt->write_pos = pt->write_buf;
pt->write_end = pt->write_buf + pt->write_buf_size;
SCM_SETSTREAM (port, iomem);
}
SCM make_tensor(SCM scm_type, SCM scm_shape, SCM scm_size, SCM scm_source)
{
SCM retval;
struct tf_tensor_t *self = (struct tf_tensor_t *)scm_gc_calloc(sizeof(struct tf_tensor_t), "make-tensor");
SCM_NEWSMOB(retval, tf_tensor_tag, self);
int type = scm_to_int(scm_type);
int num_dims = scm_to_int(scm_length(scm_shape));
int64_t *dims = scm_gc_malloc_pointerless(sizeof(int64_t) * num_dims, "make-tensor");
int count = 1;
for (int i=0; i<num_dims; i++) {
dims[i] = scm_to_int(scm_car(scm_shape));
count = count * dims[i];
scm_shape = scm_cdr(scm_shape);
};
if (type == TF_STRING) {
SCM* pointer = scm_to_pointer(scm_source);
size_t encoded_size = 0;
for (int i=0; i<count; i++) {
encoded_size += TF_StringEncodedSize(scm_c_string_length(*pointer)) + 8;
pointer++;
};
self->tensor = TF_AllocateTensor(type, dims, num_dims, encoded_size);
int64_t *offsets = TF_TensorData(self->tensor);
int offset = 0;
void *result = offsets + count;
pointer = scm_to_pointer(scm_source);
encoded_size = encoded_size - count * sizeof(int64_t);
for (int i=0; i<count; i++) {
char *str = scm_to_locale_string(*pointer);
int len = TF_StringEncodedSize(scm_c_string_length(*pointer));
*offsets++ = offset;
TF_StringEncode(str, scm_c_string_length(*pointer), result, encoded_size, status());
free(str);
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("make-tensor", TF_Message(_status), SCM_EOL);
offset += len;
encoded_size -= len;
result += len;
pointer++;
};
} else {
self->tensor = TF_AllocateTensor(type, dims, num_dims, scm_to_int(scm_size));
memcpy(TF_TensorData(self->tensor), scm_to_pointer(scm_source), scm_to_int(scm_size));
};
return retval;
}
SCM llvm_build_call(SCM scm_function, SCM scm_llvm, SCM scm_return_type, SCM scm_function_name, SCM scm_argument_types, SCM scm_values)
{
SCM retval;
struct llvm_function_t *function = get_llvm_function(scm_function);
struct llvm_module_t *llvm = get_llvm(scm_llvm);
char *function_name = scm_to_locale_string(scm_function_name);
LLVMValueRef function_pointer = LLVMAddFunction(llvm->module, function_name, function_type(scm_return_type, scm_argument_types));
free(function_name);
// LLVMAddFunctionAttr(function_pointer, LLVMExternalLinkage);
int n_values = scm_ilength(scm_values);
LLVMValueRef *values = scm_gc_malloc_pointerless(n_values * sizeof(LLVMValueRef), "llvm-build-call");
for (int i=0; i<n_values; i++) {
values[i] = get_llvm_value(scm_car(scm_values))->value;
scm_values = scm_cdr(scm_values);
};
struct llvm_value_t *result = (struct llvm_value_t *)scm_gc_calloc(sizeof(struct llvm_value_t), "llvmvalue");
SCM_NEWSMOB(retval, llvm_value_tag, result);
result->value = LLVMBuildCall(function->builder, function_pointer, values, n_values, "x");
return retval;
}
static SCM
make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->min_size_index = t->size_index = i;
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
(scm_t_bits)t, 0);
}
SCM tf_from_tensor(SCM scm_self)
{
struct tf_tensor_t *self = get_tf_tensor(scm_self);
int type = TF_TensorType(self->tensor);
int num_dims = TF_NumDims(self->tensor);
int count = 1;
SCM scm_shape = SCM_EOL;
for (int i=num_dims - 1; i>=0; i--) {
scm_shape = scm_cons(scm_from_int(TF_Dim(self->tensor, i)), scm_shape);
count = count * TF_Dim(self->tensor, i);
};
size_t size = TF_TensorByteSize(self->tensor);
void *data;
if (type == TF_STRING) {
int64_t *offsets = TF_TensorData(self->tensor);
void *pointer = offsets + count;
size_t str_len;
data = scm_gc_malloc(sizeof(SCM) * count, "from-tensor");
SCM *result = data;
for (int i=0; i<count; i++) {
const char *str;
size_t len;
TF_StringDecode(pointer + *offsets, size - *offsets, &str, &len, status());
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("from-tensor", TF_Message(_status), SCM_EOL);
*result++ = scm_from_locale_stringn(str, len);
offsets++;
};
} else {
data = scm_gc_malloc_pointerless(size, "from-tensor");
memcpy(data, TF_TensorData(self->tensor), size);
};
return scm_list_3(scm_from_int(type),
scm_shape,
scm_from_pointer(data, NULL));
}
static void
resize_set (scm_t_weak_set *set)
{
scm_t_weak_entry *old_entries, *new_entries;
int new_size_index;
unsigned long old_size, new_size, old_k;
do
{
new_size_index = compute_size_index (set);
if (new_size_index == set->size_index)
return;
new_size = hashset_size[new_size_index];
new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry),
"weak set");
}
while (!is_acceptable_size_index (set, new_size_index));
old_entries = set->entries;
old_size = set->size;
memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry));
set->size_index = new_size_index;
set->size = new_size;
if (new_size_index <= set->min_size_index)
set->lower = 0;
else
set->lower = new_size / 5;
set->upper = 9 * new_size / 10;
set->n_items = 0;
set->entries = new_entries;
for (old_k = 0; old_k < old_size; old_k++)
{
scm_t_weak_entry copy;
unsigned long new_k, distance;
if (!old_entries[old_k].hash)
continue;
copy_weak_entry (&old_entries[old_k], ©);
if (!copy.key)
continue;
new_k = hash_to_index (copy.hash, new_size);
for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
{
unsigned long other_hash = new_entries[new_k].hash;
if (!other_hash)
/* Found an empty entry. */
break;
/* Displace the entry if our distance is less, otherwise keep
looking. */
if (entry_distance (other_hash, new_k, new_size) < distance)
{
rob_from_rich (set, new_k);
break;
}
}
set->n_items++;
new_entries[new_k].hash = copy.hash;
new_entries[new_k].key = copy.key;
if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
(void *) new_entries[new_k].key);
}
}
static SCM
load_thunk_from_fd_using_mmap (int fd)
#define FUNC_NAME "load-thunk-from-disk"
{
Elf_Ehdr header;
Elf_Phdr *ph;
const char *err_msg = 0;
char *base = 0;
size_t n;
int i;
int start_segment = -1;
int prev_segment = -1;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
if (full_read (fd, &header, sizeof header) != sizeof header)
ABORT ("object file too small");
if ((err_msg = check_elf_header (&header)))
goto cleanup;
if (lseek (fd, header.e_phoff, SEEK_SET) == (off_t) -1)
goto cleanup;
n = header.e_phnum;
ph = scm_gc_malloc_pointerless (n * sizeof (Elf_Phdr), "segment headers");
if (full_read (fd, ph, n * sizeof (Elf_Phdr)) != n * sizeof (Elf_Phdr))
ABORT ("failed to read program headers");
for (i = 0; i < n; i++)
{
if (!ph[i].p_memsz)
continue;
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
if (!ph[i].p_flags)
ABORT ("expected nonzero segment flags");
if (ph[i].p_type == PT_DYNAMIC)
{
if (dynamic_segment >= 0)
ABORT ("expected only one PT_DYNAMIC segment");
dynamic_segment = i;
}
if (start_segment < 0)
{
if (!base && ph[i].p_vaddr)
ABORT ("first loadable vaddr is not 0");
start_segment = prev_segment = i;
continue;
}
if (ph[i].p_flags == ph[start_segment].p_flags)
{
if (ph[i].p_vaddr - ph[prev_segment].p_vaddr
!= ph[i].p_offset - ph[prev_segment].p_offset)
ABORT ("coalesced segments not contiguous");
prev_segment = i;
continue;
}
/* Otherwise we have a new kind of segment. Map previous
segments. */
if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
/* Open a new set of segments. */
start_segment = prev_segment = i;
}
/* Map last segments. */
if (start_segment < 0)
ABORT ("no loadable segments");
if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
&init, &entry)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
/* Finally! Return the thunk. */
return entry;
/* FIXME: munmap on error? */
cleanup:
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
SCM_EOL);
}
}
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
int (*cproc) () = cproc_ptr;
SCM z, va0, lva, *plva;
int k, kmax, kroll;
ssize_t *vi, inc;
size_t len;
/* Prepare reference argument. */
if (SCM_I_ARRAYP (ra0))
{
kmax = SCM_I_ARRAY_NDIM (ra0)-1;
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
/* Find unroll depth */
for (kroll = max(0, kmax); kroll > 0; --kroll)
{
inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
break;
}
}
else
{
kroll = kmax = 0;
va0 = ra0 = make1array (ra0, 1);
}
/* Prepare rest arguments. */
lva = SCM_EOL;
plva = &lva;
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
{
SCM va1, ra1 = SCM_CAR (z);
if (SCM_I_ARRAYP (ra1))
{
if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
/* Check unroll depth. */
for (k = kmax; k > kroll; --k)
{
ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
inc *= (u0 - l0 + 1);
if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
{
kroll = k;
break;
}
}
/* Check matching of not-unrolled axes. */
for (; k>=0; --k)
if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
else
{
if (kmax != 0)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
plva = SCM_CDRLOC (*plva);
}
/* Check emptiness of not-unrolled axes. */
for (k = 0; k < kroll; ++k)
if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
return 1;
/* Set unrolled size. */
for (len = 1; k <= kmax; ++k)
len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
UBND (va0, 0) = len - 1;
for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
UBND (SCM_CAR (z), 0) = len - 1;
/* Set starting indices and go. */
vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
for (k = 0; k < kroll; ++k)
vi[k] = LBND (ra0, k);
do
{
if (k == kroll)
{
SCM y = lra;
SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
return 0;
--k;
}
else if (vi[k] < UBND (ra0, k))
{
++vi[k];
++k;
}
else
{
vi[k] = LBND (ra0, k) - 1;
--k;
}
}
while (k >= 0);
return 1;
}
SCM gc_malloc_pointerless(SCM scm_size)
{
size_t size = scm_to_int(scm_size);
void *ptr = scm_gc_malloc_pointerless(size, "gc-malloc-pointerless");
return scm_from_pointer(ptr, NULL);
}
static void *
sysdep_dynl_link (const char *fname, const char *subr)
{
lt_dlhandle handle;
if (fname == NULL)
/* Return a handle for the program as a whole. */
handle = lt_dlopen (NULL);
else
{
handle = lt_dlopenext (fname);
if (handle == NULL
#ifdef LT_DIRSEP_CHAR
&& strchr (fname, LT_DIRSEP_CHAR) == NULL
#endif
&& strchr (fname, '/') == NULL)
{
/* FNAME contains no directory separators and was not in the
usual library search paths, so now we search for it in
SYSTEM_EXTENSIONS_PATH. */
char *fname_attempt
= scm_gc_malloc_pointerless (strlen (system_extensions_path)
+ strlen (fname) + 2,
"dynl fname_attempt");
char *path; /* remaining path to search */
char *end; /* end of current path component */
char *s;
/* Iterate over the components of SYSTEM_EXTENSIONS_PATH */
for (path = system_extensions_path;
*path != '\0';
path = (*end == '\0') ? end : (end + 1))
{
/* Find end of path component */
end = strchr (path, LT_PATHSEP_CHAR);
if (end == NULL)
end = strchr (path, '\0');
/* Skip empty path components */
if (path == end)
continue;
/* Construct FNAME_ATTEMPT, starting with path component */
s = fname_attempt;
memcpy (s, path, end - path);
s += end - path;
/* Append directory separator, but avoid duplicates */
if (s[-1] != '/'
#ifdef LT_DIRSEP_CHAR
&& s[-1] != LT_DIRSEP_CHAR
#endif
)
*s++ = '/';
/* Finally, append FNAME (including null terminator) */
strcpy (s, fname);
/* Try to load it, and terminate the search if successful */
handle = lt_dlopenext (fname_attempt);
if (handle != NULL)
break;
}
}
}
if (handle == NULL)
{
SCM fn;
SCM msg;
fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
msg = scm_from_locale_string (lt_dlerror ());
scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
}
return (void *) handle;
}
