mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-16 00:30:21 +02:00
reimplement srfi-4 vectors on top of bytevectors
* libguile/srfi-4.h: * libguile/srfi-4.c (scm_make_srfi_4_vector): New function, exported by (srfi srfi-4 gnu). * libguile/srfi-4.i.c: Removed. * module/srfi/srfi-4.scm: * module/srfi/srfi-4/gnu.scm: Reimplement srfi-4 vectors on top of bytevectors. The implementation is mostly in Scheme now. * test-suite/tests/unif.test: Update to use (srfi srfi-4 gnu). * libguile/bytevectors.c (bytevector_ref_c32, bytevector_ref_c64) (bytevector_set_c32, bytevector_set_c64): Fix some embarrassing bugs. Still need to do an upper bounds check. * libguile/deprecated.h: Remove deprecated array functions: scm_i_arrayp, scm_i_array_ndim, scm_i_array_mem, scm_i_array_v, scm_i_array_base, scm_i_array_dims, and the deprecated macros: SCM_ARRAYP, SCM_ARRAY_NDIM, SCM_ARRAY_CONTP, SCM_ARRAY_MEM, SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS. * libguile/deprecated.c (scm_uniform_vector_read_x) (scm_uniform_vector_write, scm_uniform_array_read_x) (scm_uniform_array_write): Newly deprecated functions. * libguile/generalized-arrays.c (scm_array_type): Remove the bytevector hack. * libguile/objcodes.c (scm_bytecode_to_objcode, scm_objcode_to_bytecode): Rework to operate on bytevectors, as scm_make_u8vector now causes a module lookup, which can't be done e.g. when loading the VM boot program for psyntax-pp.go on a fresh bootstrap. * libguile/objcodes.h (SCM_F_OBJCODE_IS_BYTEVECTOR): (SCM_OBJCODE_IS_BYTEVECTOR): s/U8VECTOR/BYTEVECTOR/. * module/ice-9/boot-9.scm (the-scm-module): A terrible hack to pull in (srfi srfi-4), as the bindings are primarily there now. We'll worry about this later.
This commit is contained in:
Andy Wingo
parent
3dc2afe2b8
commit
a268973767
16 changed files with 643 additions and 1322 deletions
|
|
@ -570,150 +570,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM
|
||||
scm_ra2contig (SCM ra, int copy)
|
||||
{
|
||||
SCM ret;
|
||||
long inc = 1;
|
||||
size_t k, len = 1;
|
||||
for (k = SCM_I_ARRAY_NDIM (ra); k--;)
|
||||
len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
|
||||
k = SCM_I_ARRAY_NDIM (ra);
|
||||
if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
|
||||
{
|
||||
if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
|
||||
return ra;
|
||||
if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
|
||||
0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
|
||||
0 == len % SCM_LONG_BIT))
|
||||
return ra;
|
||||
}
|
||||
ret = scm_i_make_array (k);
|
||||
SCM_I_ARRAY_BASE (ret) = 0;
|
||||
while (k--)
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
|
||||
SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
|
||||
SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
|
||||
inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
|
||||
}
|
||||
SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra),
|
||||
scm_from_long (inc),
|
||||
SCM_UNDEFINED);
|
||||
if (copy)
|
||||
scm_array_copy_x (ra, ret);
|
||||
return ret;
|
||||
}
|
||||
|
||||
|
||||
|
||||
SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
|
||||
(SCM ura, SCM port_or_fd, SCM start, SCM end),
|
||||
"@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
|
||||
"Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
|
||||
"binary objects from @var{port-or-fdes}.\n"
|
||||
"If an end of file is encountered,\n"
|
||||
"the objects up to that point are put into @var{ura}\n"
|
||||
"(starting at the beginning) and the remainder of the array is\n"
|
||||
"unchanged.\n\n"
|
||||
"The optional arguments @var{start} and @var{end} allow\n"
|
||||
"a specified region of a vector (or linearized array) to be read,\n"
|
||||
"leaving the remainder of the vector unchanged.\n\n"
|
||||
"@code{uniform-array-read!} returns the number of objects read.\n"
|
||||
"@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
|
||||
"returned by @code{(current-input-port)}.")
|
||||
#define FUNC_NAME s_scm_uniform_array_read_x
|
||||
{
|
||||
if (SCM_UNBNDP (port_or_fd))
|
||||
port_or_fd = scm_current_input_port ();
|
||||
|
||||
if (scm_is_uniform_vector (ura))
|
||||
{
|
||||
return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
|
||||
}
|
||||
else if (SCM_I_ARRAYP (ura))
|
||||
{
|
||||
size_t base, vlen, cstart, cend;
|
||||
SCM cra, ans;
|
||||
|
||||
cra = scm_ra2contig (ura, 0);
|
||||
base = SCM_I_ARRAY_BASE (cra);
|
||||
vlen = SCM_I_ARRAY_DIMS (cra)->inc *
|
||||
(SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
|
||||
|
||||
cstart = 0;
|
||||
cend = vlen;
|
||||
if (!SCM_UNBNDP (start))
|
||||
{
|
||||
cstart = scm_to_unsigned_integer (start, 0, vlen);
|
||||
if (!SCM_UNBNDP (end))
|
||||
cend = scm_to_unsigned_integer (end, cstart, vlen);
|
||||
}
|
||||
|
||||
ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
|
||||
scm_from_size_t (base + cstart),
|
||||
scm_from_size_t (base + cend));
|
||||
|
||||
if (!scm_is_eq (cra, ura))
|
||||
scm_array_copy_x (cra, ura);
|
||||
return ans;
|
||||
}
|
||||
else
|
||||
scm_wrong_type_arg_msg (NULL, 0, ura, "array");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
|
||||
(SCM ura, SCM port_or_fd, SCM start, SCM end),
|
||||
"Writes all elements of @var{ura} as binary objects to\n"
|
||||
"@var{port-or-fdes}.\n\n"
|
||||
"The optional arguments @var{start}\n"
|
||||
"and @var{end} allow\n"
|
||||
"a specified region of a vector (or linearized array) to be written.\n\n"
|
||||
"The number of objects actually written is returned.\n"
|
||||
"@var{port-or-fdes} may be\n"
|
||||
"omitted, in which case it defaults to the value returned by\n"
|
||||
"@code{(current-output-port)}.")
|
||||
#define FUNC_NAME s_scm_uniform_array_write
|
||||
{
|
||||
if (SCM_UNBNDP (port_or_fd))
|
||||
port_or_fd = scm_current_output_port ();
|
||||
|
||||
if (scm_is_uniform_vector (ura))
|
||||
{
|
||||
return scm_uniform_vector_write (ura, port_or_fd, start, end);
|
||||
}
|
||||
else if (SCM_I_ARRAYP (ura))
|
||||
{
|
||||
size_t base, vlen, cstart, cend;
|
||||
SCM cra, ans;
|
||||
|
||||
cra = scm_ra2contig (ura, 1);
|
||||
base = SCM_I_ARRAY_BASE (cra);
|
||||
vlen = SCM_I_ARRAY_DIMS (cra)->inc *
|
||||
(SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
|
||||
|
||||
cstart = 0;
|
||||
cend = vlen;
|
||||
if (!SCM_UNBNDP (start))
|
||||
{
|
||||
cstart = scm_to_unsigned_integer (start, 0, vlen);
|
||||
if (!SCM_UNBNDP (end))
|
||||
cend = scm_to_unsigned_integer (end, cstart, vlen);
|
||||
}
|
||||
|
||||
ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
|
||||
scm_from_size_t (base + cstart),
|
||||
scm_from_size_t (base + cend));
|
||||
|
||||
return ans;
|
||||
}
|
||||
else
|
||||
scm_wrong_type_arg_msg (NULL, 0, ura, "array");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
static void
|
||||
list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
|
||||
{
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue