/* 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; }