mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

reimplement srfi-4 vectors on top of bytevectors

Browse source 
* 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 2009-07-19 15:35:33 +02:00
parent 3dc2afe2b8
commit a268973767
16 changed files with 643 additions and 1322 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/Makefile.am
View file

@ -429,7 +429,6 @@ install-exec-hook:
## working. ## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
ieee-754.h \ ieee-754.h \
srfi-4.i.c \
srfi-14.i.c \ srfi-14.i.c \
quicksort.i.c \ quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \ win32-uname.h win32-dirent.h win32-socket.h \

144
libguile/arrays.c
View file

@ -570,150 +570,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
#undef FUNC_NAME #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 static void
list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
{ {

6
libguile/arrays.h
View file

@ -46,15 +46,9 @@ SCM_API SCM scm_shared_array_increments (SCM ra);
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args); SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
SCM_API SCM scm_ra2contig (SCM ra, int copy);
/* internal. */ /* internal. */
typedef struct scm_i_t_array typedef struct scm_i_t_array

21
libguile/bytevectors.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2009 Free Software Foundation, Inc. /* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -2095,7 +2095,7 @@ bytevector_ref_c32 (SCM bv, SCM idx)
{ /* FIXME add some checks */ { /* FIXME add some checks */
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv); const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx); size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]); return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
} }
static SCM static SCM
@ -2103,7 +2103,7 @@ bytevector_ref_c64 (SCM bv, SCM idx)
{ /* FIXME add some checks */ { /* FIXME add some checks */
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv); const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx); size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/16], contents[i/16 + 1]); return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
} }
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
@ -2140,23 +2140,22 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
return ref_fn (h->array, byte_index); return ref_fn (h->array, byte_index);
} }
/* FIXME add checks!!! */
static SCM static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val) bytevector_set_c32 (SCM bv, SCM idx, SCM val)
{ /* checks are unnecessary here */ { float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx); size_t i = scm_to_size_t (idx);
contents[i/8] = scm_c_real_part (val); contents[i/4] = scm_c_real_part (val);
contents[i/8 + 1] = scm_c_imag_part (val); contents[i/4 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
static SCM static SCM
bytevector_set_c64 (SCM bv, SCM idx, SCM val) bytevector_set_c64 (SCM bv, SCM idx, SCM val)
{ /* checks are unnecessary here */ { double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx); size_t i = scm_to_size_t (idx);
contents[i/16] = scm_c_real_part (val); contents[i/8] = scm_c_real_part (val);
contents[i/16 + 1] = scm_c_imag_part (val); contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

259
libguile/deprecated.c
View file

@ -28,6 +28,11 @@
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/async.h" #include "libguile/async.h"
#include "libguile/arrays.h"
#include "libguile/array-map.h"
#include "libguile/generalized-arrays.h"
#include "libguile/bytevectors.h"
#include "libguile/bitvectors.h"
#include "libguile/deprecated.h" #include "libguile/deprecated.h"
#include "libguile/discouraged.h" #include "libguile/discouraged.h"
#include "libguile/deprecation.h" #include "libguile/deprecation.h"
@ -36,7 +41,6 @@
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/srfi-13.h" #include "libguile/srfi-13.h"
#include "libguile/modules.h" #include "libguile/modules.h"
#include "libguile/generalized-arrays.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/smob.h" #include "libguile/smob.h"
#include "libguile/procprop.h" #include "libguile/procprop.h"
@ -48,12 +52,14 @@
#include "libguile/ports.h" #include "libguile/ports.h"
#include "libguile/eq.h" #include "libguile/eq.h"
#include "libguile/read.h" #include "libguile/read.h"
#include "libguile/r6rs-ports.h"
#include "libguile/strports.h" #include "libguile/strports.h"
#include "libguile/smob.h" #include "libguile/smob.h"
#include "libguile/alist.h" #include "libguile/alist.h"
#include "libguile/keywords.h" #include "libguile/keywords.h"
#include "libguile/socket.h" #include "libguile/socket.h"
#include "libguile/feature.h" #include "libguile/feature.h"
#include "libguile/uniform.h"
#include <math.h> #include <math.h>
#include <stdio.h> #include <stdio.h>
@ -1327,65 +1333,222 @@ scm_vector_equal_p (SCM x, SCM y)
return scm_equal_p (x, y); return scm_equal_p (x, y);
} }
int SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
scm_i_arrayp (SCM a) (SCM uvec, SCM port_or_fd, SCM start, SCM end),
"Fill the elements of @var{uvec} by reading\n"
"raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
"The optional arguments @var{start} (inclusive) and @var{end}\n"
"(exclusive) allow a specified region to be read,\n"
"leaving the remainder of the vector unchanged.\n\n"
"When @var{port-or-fdes} is a port, all specified elements\n"
"of @var{uvec} are attempted to be read, potentially blocking\n"
"while waiting formore input or end-of-file.\n"
"When @var{port-or-fd} is an integer, a single call to\n"
"read(2) is made.\n\n"
"An error is signalled when the last element has only\n"
"been partially filled before reaching end-of-file or in\n"
"the single call to read(2).\n\n"
"@code{uniform-vector-read!} returns the number of elements\n"
"read.\n\n"
"@var{port-or-fdes} may be omitted, in which case it defaults\n"
"to the value returned by @code{(current-input-port)}.")
#define FUNC_NAME s_scm_uniform_vector_read_x
{ {
scm_c_issue_deprecation_warning size_t width;
("SCM_ARRAYP is deprecated. Use scm_is_array instead."); SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
return SCM_I_ARRAYP(a);
scm_c_issue_deprecation_warning
("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
"`(rnrs io ports)' instead.");
width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
return scm_get_bytevector_n_x (port_or_fd, uvec,
scm_from_size_t (scm_to_size_t (start)*width),
scm_from_size_t ((scm_to_size_t (end)
- scm_to_size_t (start))
* width));
}
#undef FUNC_NAME
SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
(SCM uvec, SCM port_or_fd, SCM start, SCM end),
"Write the elements of @var{uvec} as raw bytes to\n"
"@var{port-or-fdes}, in the host byte order.\n\n"
"The optional arguments @var{start} (inclusive)\n"
"and @var{end} (exclusive) allow\n"
"a specified region to be written.\n\n"
"When @var{port-or-fdes} is a port, all specified elements\n"
"of @var{uvec} are attempted to be written, potentially blocking\n"
"while waiting for more room.\n"
"When @var{port-or-fd} is an integer, a single call to\n"
"write(2) is made.\n\n"
"An error is signalled when the last element has only\n"
"been partially written in the single call to write(2).\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_vector_write
{
size_t width;
SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
scm_c_issue_deprecation_warning
("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
"`(rnrs io ports)' instead.");
width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
return scm_put_bytevector (port_or_fd, uvec,
scm_from_size_t (scm_to_size_t (start)*width),
scm_from_size_t ((scm_to_size_t (end)
- scm_to_size_t (start))
* width));
}
#undef FUNC_NAME
static 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_size_t (inc),
SCM_UNDEFINED);
if (copy)
scm_array_copy_x (ra, ret);
return ret;
} }
size_t SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
scm_i_array_ndim (SCM a) (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
{ {
scm_c_issue_deprecation_warning if (SCM_UNBNDP (port_or_fd))
("SCM_ARRAY_NDIM is deprecated. " port_or_fd = scm_current_input_port ();
"Use scm_c_array_rank or scm_array_handle_rank instead.");
return scm_c_array_rank (a);
}
int if (scm_is_uniform_vector (ura))
scm_i_array_contp (SCM a) {
{ return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
scm_c_issue_deprecation_warning }
("SCM_ARRAY_CONTP is deprecated. Do not use it."); else if (SCM_I_ARRAYP (ura))
return SCM_I_ARRAY_CONTP (a); {
} 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);
scm_t_array * cstart = 0;
scm_i_array_mem (SCM a) cend = vlen;
{ if (!SCM_UNBNDP (start))
scm_c_issue_deprecation_warning {
("SCM_ARRAY_MEM is deprecated. Do not use it."); cstart = scm_to_unsigned_integer (start, 0, vlen);
return (scm_t_array *)SCM_I_ARRAY_MEM (a); if (!SCM_UNBNDP (end))
} cend = scm_to_unsigned_integer (end, cstart, vlen);
}
SCM ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
scm_i_array_v (SCM a) scm_from_size_t (base + cstart),
{ scm_from_size_t (base + cend));
/* We could use scm_shared_array_root here, but it is better to move
them away from expecting vectors as the basic storage for arrays.
*/
scm_c_issue_deprecation_warning
("SCM_ARRAY_V is deprecated. Do not use it.");
return SCM_I_ARRAY_V (a);
}
size_t if (!scm_is_eq (cra, ura))
scm_i_array_base (SCM a) scm_array_copy_x (cra, ura);
{ return ans;
scm_c_issue_deprecation_warning }
("SCM_ARRAY_BASE is deprecated. Do not use it."); else
return SCM_I_ARRAY_BASE (a); scm_wrong_type_arg_msg (NULL, 0, ura, "array");
} }
#undef FUNC_NAME
scm_t_array_dim * SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
scm_i_array_dims (SCM a) (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
{ {
scm_c_issue_deprecation_warning if (SCM_UNBNDP (port_or_fd))
("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead."); port_or_fd = scm_current_output_port ();
return SCM_I_ARRAY_DIMS (a);
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
SCM SCM
scm_i_cur_inp (void) scm_i_cur_inp (void)

11
libguile/deprecated.h
View file

@ -24,7 +24,6 @@
*/ */
#include "libguile/__scm.h" #include "libguile/__scm.h"
#include "libguile/arrays.h"
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/eval.h" #include "libguile/eval.h"
@ -232,7 +231,6 @@ SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define scm_srcprops_chunk scm_t_srcprops_chunk #define scm_srcprops_chunk scm_t_srcprops_chunk
#define scm_array scm_t_array #define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim #define scm_array_dim scm_t_array_dim
#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME)) #define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
#define SCM_WTA(pos, scm) \ #define SCM_WTA(pos, scm) \
@ -485,6 +483,15 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAY_BASE(a) scm_i_array_base(a) #define SCM_ARRAY_BASE(a) scm_i_array_base(a)
#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a) #define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
SCM start, SCM end);
/* Deprecated because they should not be lvalues and we want people to /* Deprecated because they should not be lvalues and we want people to
use the official interfaces. use the official interfaces.
*/ */

7
libguile/generalized-arrays.c
View file

@ -138,9 +138,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
/* HACK*/
#include "libguile/bytevectors.h"
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
(SCM ra), (SCM ra),
"") "")
@ -149,10 +146,6 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
scm_t_array_handle h; scm_t_array_handle h;
SCM type; SCM type;
/* a hack, until srfi-4 and bytevectors are reunited */
if (scm_is_bytevector (ra))
return scm_from_locale_symbol ("vu8");
scm_array_get_handle (ra, &h); scm_array_get_handle (ra, &h);
type = scm_array_handle_element_type (&h); type = scm_array_handle_element_type (&h);
scm_array_handle_release (&h); scm_array_handle_release (&h);

31
libguile/objcodes.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. /* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -172,27 +172,26 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
#define FUNC_NAME s_scm_bytecode_to_objcode #define FUNC_NAME s_scm_bytecode_to_objcode
{ {
size_t size; size_t size;
ssize_t increment;
scm_t_array_handle handle;
const scm_t_uint8 *c_bytecode; const scm_t_uint8 *c_bytecode;
struct scm_objcode *data; struct scm_objcode *data;
SCM objcode; SCM objcode;
if (scm_is_false (scm_u8vector_p (bytecode))) if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode); scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); size = SCM_BYTEVECTOR_LENGTH (bytecode);
data = (struct scm_objcode*)c_bytecode; c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
scm_array_handle_release (&handle);
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
if (data->len + data->metalen != (size - sizeof (*data))) if (data->len + data->metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)", scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size), scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
assert (increment == 1);
SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR); SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_BYTEVECTOR);
/* foolishly, we assume that as long as bytecode is around, that c_bytecode /* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */ will be of the same length; perhaps a bad assumption? */
@ -225,17 +224,17 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
"") "")
#define FUNC_NAME s_scm_objcode_to_bytecode #define FUNC_NAME s_scm_objcode_to_bytecode
{ {
scm_t_uint8 *u8vector; scm_t_int8 *s8vector;
scm_t_uint32 len; scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode); SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
u8vector = scm_malloc (len); s8vector = scm_malloc (len);
memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len); memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
return scm_take_u8vector (u8vector, len); return scm_c_take_bytevector (s8vector, len);
} }
#undef FUNC_NAME #undef FUNC_NAME

10
libguile/objcodes.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. /* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -35,9 +35,9 @@ struct scm_objcode
#define SCM_C_OBJCODE_BASE(obj) \ #define SCM_C_OBJCODE_BASE(obj) \
((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode)) ((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
#define SCM_F_OBJCODE_IS_MMAP (1<<0) #define SCM_F_OBJCODE_IS_MMAP (1<<0)
#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) #define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2) #define SCM_F_OBJCODE_IS_SLICE (1<<2)
SCM_API scm_t_bits scm_tc16_objcode; SCM_API scm_t_bits scm_tc16_objcode;
@ -51,7 +51,7 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x))) #define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP) #define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR) #define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_BYTEVECTOR)
#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr); SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);

1057
libguile/srfi-4.c
View file

File diff suppressed because it is too large Load diff

3
libguile/srfi-4.h
View file

@ -23,6 +23,9 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill);
/* Specific procedures. /* Specific procedures.
*/ */

207
libguile/srfi-4.i.c
View file

@ -1,207 +0,0 @@
/* This file defines the procedures related to one type of uniform
numeric vector. It is included multiple time in srfi-4.c, once for
each type.
Before inclusion, the following macros must be defined. They are
undefined at the end of this file to get back to a clean slate for
the next inclusion.
- TYPE
The type tag of the vector, for example SCM_UVEC_U8
- TAG
The tag name of the vector, for example u8. The tag is used to
form the function names and is included in the docstrings, for
example.
- CTYPE
The C type of the elements, for example scm_t_uint8. The code
below will never do sizeof (CTYPE), thus you can use just 'float'
for the c32 type, for example.
When CTYPE is not defined, the functions using it are excluded.
*/
/* The first level does not expand macros in the arguments. */
#define paste(a1,a2,a3) a1##a2##a3
#define s_paste(a1,a2,a3) s_##a1##a2##a3
#define stringify(a) #a
/* But the second level does. */
#define F(pre,T,suf) paste(pre,T,suf)
#define s_F(pre,T,suf) s_paste(pre,T,suf)
#define S(T) stringify(T)
SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
"@code{#f} otherwise.")
#define FUNC_NAME s_F(scm_, TAG, vector_p)
{
return uvec_p (TYPE, obj);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
(SCM len, SCM fill),
"Return a newly allocated uniform numeric vector which can\n"
"hold @var{len} elements. If @var{fill} is given, it is used to\n"
"initialize the elements, otherwise the contents of the vector\n"
"is unspecified.")
#define FUNC_NAME s_S(scm_make_,TAG,vector)
{
return make_uvec (TYPE, len, fill);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
(SCM l),
"Return a newly allocated uniform numeric vector containing\n"
"all argument values.")
#define FUNC_NAME s_F(scm_,TAG,vector)
{
return list_to_uvec (TYPE, l);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
(SCM uvec),
"Return the number of elements in the uniform numeric vector\n"
"@var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_length)
{
return uvec_length (TYPE, uvec);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
(SCM uvec, SCM index),
"Return the element at @var{index} in the uniform numeric\n"
"vector @var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_ref)
{
return uvec_ref (TYPE, uvec, index);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
(SCM uvec, SCM index, SCM value),
"Set the element at @var{index} in the uniform numeric\n"
"vector @var{uvec} to @var{value}. The return value is not\n"
"specified.")
#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
{
return uvec_set_x (TYPE, uvec, index, value);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
(SCM uvec),
"Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
{
return uvec_to_list (TYPE, uvec);
}
#undef FUNC_NAME
SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
(SCM l),
"Convert the list @var{l} to a numeric uniform vector.")
#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
{
return list_to_uvec (TYPE, l);
}
#undef FUNC_NAME
#ifdef CTYPE
SCM
F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
{
/* The manual says "Return a new uniform numeric vector [...] that uses the
memory pointed to by DATA". We *have* to use DATA as the underlying
storage; thus we must register a finalizer to eventually free(3) it. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalization_data;
GC_REGISTER_FINALIZER_NO_ORDER (data, free_user_data, 0,
&prev_finalizer,
&prev_finalization_data);
return take_uvec (TYPE, data, n);
}
const CTYPE *
F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
{
return F(scm_array_handle_,TAG,_writable_elements) (h);
}
CTYPE *
F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
{
SCM vec = h->array;
if (SCM_I_ARRAYP (vec))
vec = SCM_I_ARRAY_V (vec);
uvec_assert (TYPE, vec);
if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
else
return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
}
const CTYPE *
F(scm_,TAG,vector_elements) (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
}
CTYPE *
F(scm_,TAG,vector_writable_elements) (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
scm_generalized_vector_get_handle (uvec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return F(scm_array_handle_,TAG,_writable_elements) (h);
}
#endif
static SCM
F(,TAG,ref) (scm_t_array_handle *handle, size_t pos)
{
return uvec_fast_ref (TYPE, handle->elements, pos);
}
static void
F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val)
{
uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
}
#undef paste
#undef s_paste
#undef stringify
#undef F
#undef s_F
#undef S
#undef TYPE
#undef TAG
#undef CTYPE

3
module/ice-9/boot-9.scm
View file

@ -3562,6 +3562,9 @@ module '(ice-9 q) '(make-q q-length))}."
;; (module-eval-closure (current-module)))) ;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp))))) ;; (deannotate/source-properties (sc-expand (annotate exp)))))
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
(define-module (guile-user) (define-module (guile-user)
#:autoload (system base compile) (compile)) #:autoload (system base compile) (compile))

133
module/srfi/srfi-4.scm
View file

@ -1,6 +1,6 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc. ;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;; ;;
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -26,46 +26,111 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-4)) (define-module (srfi srfi-4)
#:use-module (rnrs bytevector)
#:export (;; Unsigned 8-bit vectors.
u8vector? make-u8vector u8vector u8vector-length u8vector-ref
u8vector-set! u8vector->list list->u8vector
(re-export ;; Signed 8-bit vectors.
;;; Unsigned 8-bit vectors. s8vector? make-s8vector s8vector s8vector-length s8vector-ref
u8vector? make-u8vector u8vector u8vector-length u8vector-ref s8vector-set! s8vector->list list->s8vector
u8vector-set! u8vector->list list->u8vector
;;; Signed 8-bit vectors. ;; Unsigned 16-bit vectors.
s8vector? make-s8vector s8vector s8vector-length s8vector-ref u16vector? make-u16vector u16vector u16vector-length u16vector-ref
s8vector-set! s8vector->list list->s8vector u16vector-set! u16vector->list list->u16vector
;;; Unsigned 16-bit vectors. ;; Signed 16-bit vectors.
u16vector? make-u16vector u16vector u16vector-length u16vector-ref s16vector? make-s16vector s16vector s16vector-length s16vector-ref
u16vector-set! u16vector->list list->u16vector s16vector-set! s16vector->list list->s16vector
;;; Signed 16-bit vectors. ;; Unsigned 32-bit vectors.
s16vector? make-s16vector s16vector s16vector-length s16vector-ref u32vector? make-u32vector u32vector u32vector-length u32vector-ref
s16vector-set! s16vector->list list->s16vector u32vector-set! u32vector->list list->u32vector
;;; Unsigned 32-bit vectors. ;; Signed 32-bit vectors.
u32vector? make-u32vector u32vector u32vector-length u32vector-ref s32vector? make-s32vector s32vector s32vector-length s32vector-ref
u32vector-set! u32vector->list list->u32vector s32vector-set! s32vector->list list->s32vector
;;; Signed 32-bit vectors. ;; Unsigned 64-bit vectors.
s32vector? make-s32vector s32vector s32vector-length s32vector-ref u64vector? make-u64vector u64vector u64vector-length u64vector-ref
s32vector-set! s32vector->list list->s32vector u64vector-set! u64vector->list list->u64vector
;;; Unsigned 64-bit vectors. ;; Signed 64-bit vectors.
u64vector? make-u64vector u64vector u64vector-length u64vector-ref s64vector? make-s64vector s64vector s64vector-length s64vector-ref
u64vector-set! u64vector->list list->u64vector s64vector-set! s64vector->list list->s64vector
;;; Signed 64-bit vectors. ;; 32-bit floating point vectors.
s64vector? make-s64vector s64vector s64vector-length s64vector-ref f32vector? make-f32vector f32vector f32vector-length f32vector-ref
s64vector-set! s64vector->list list->s64vector f32vector-set! f32vector->list list->f32vector
;; 64-bit floating point vectors.
f64vector? make-f64vector f64vector f64vector-length f64vector-ref
f64vector-set! f64vector->list list->f64vector))
;; Need quasisyntax to do this effectively using syntax-case
(define-macro (define-bytevector-type tag infix size)
`(begin
(define (,(symbol-append tag 'vector?) obj)
(and (uniform-vector? obj)
(eq? (uniform-vector-element-type obj) ',tag)))
(define (,(symbol-append 'make- tag 'vector) len . fill)
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v)))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
(define (,(symbol-append tag 'vector) . elts)
(,(symbol-append 'list-> tag 'vector) elts))
(define (,(symbol-append 'list-> tag 'vector) elts)
(let* ((len (length elts))
(v (,(symbol-append 'make- tag 'vector) len)))
(let lp ((i 0) (elts elts))
(if (and (< i len) (pair? elts))
(begin
(,(symbol-append tag 'vector-set!) v i (car elts))
(lp (1+ i) (cdr elts)))
v))))
(define (,(symbol-append tag 'vector->list) v)
(let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
(if (< i 0)
elts
(lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
(define (,(symbol-append tag 'vector-ref) v i)
(,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
(define (,(symbol-append tag 'vector-set!) v i x)
(,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
(define (,(symbol-append tag 'vector-set!) v i x)
(,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
(define-bytevector-type u8 u8 1)
(define-bytevector-type s8 s8 1)
(define-bytevector-type u16 u16-native 2)
(define-bytevector-type s16 s16-native 2)
(define-bytevector-type u32 u32-native 4)
(define-bytevector-type s32 s32-native 4)
(define-bytevector-type u64 u64-native 8)
(define-bytevector-type s64 s64-native 8)
(define-bytevector-type f32 ieee-single-native 4)
(define-bytevector-type f64 ieee-double-native 8)
(define (bytevector-c32-ref v i)
(make-rectangular (bytevector-ieee-single-native-ref v i)
(bytevector-ieee-single-native-ref v (+ i 4))))
(define (bytevector-c32-set! v i x)
(bytevector-ieee-single-native-set! v i x)
(bytevector-ieee-single-native-set! v (+ i 4) x))
(define-bytevector-type c32 c32 8)
(define (bytevector-c64-ref v i)
(make-rectangular (bytevector-ieee-double-native-ref v i)
(bytevector-ieee-double-native-ref v (+ i 8))))
(define (bytevector-c64-set! v i x)
(bytevector-ieee-double-native-set! v i x)
(bytevector-ieee-double-native-set! v (+ i 8) x))
(define-bytevector-type c64 c64 16)
;;; 32-bit floating point vectors.
f32vector? make-f32vector f32vector f32vector-length f32vector-ref
f32vector-set! f32vector->list list->f32vector
;;; 64-bit floating point vectors.
f64vector? make-f64vector f64vector f64vector-length f64vector-ref
f64vector-set! f64vector->list list->f64vector
)

66
module/srfi/srfi-4/gnu.scm
View file

@ -23,13 +23,77 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-4 gnu) (define-module (srfi srfi-4 gnu)
#:use-module (rnrs bytevector)
#:use-module (srfi srfi-4) #:use-module (srfi srfi-4)
#:export (;; Somewhat polymorphic conversions. #:export (;; Complex numbers with 32- and 64-bit components.
c32vector? make-c32vector c32vector c32vector-length c32vector-ref
c32vector-set! c32vector->list list->c32vector
c64vector? make-c64vector c64vector c64vector-length c64vector-ref
c64vector-set! c64vector->list list->c64vector
make-srfi-4-vector
;; Somewhat polymorphic conversions.
any->u8vector any->s8vector any->u16vector any->s16vector any->u8vector any->s8vector any->u16vector any->s16vector
any->u32vector any->s32vector any->u64vector any->s64vector any->u32vector any->s32vector any->u64vector any->s64vector
any->f32vector any->f64vector any->c32vector any->c64vector)) any->f32vector any->f64vector any->c32vector any->c64vector))
(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
;; Need quasisyntax to do this effectively using syntax-case
(define-macro (define-bytevector-type tag infix size)
`(begin
(define (,(symbol-append tag 'vector?) obj)
(and (uniform-vector? obj)
(eq? (uniform-vector-element-type obj) ',tag)))
(define (,(symbol-append 'make- tag 'vector) len . fill)
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v)))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
(define (,(symbol-append tag 'vector) . elts)
(,(symbol-append 'list-> tag 'vector) elts))
(define (,(symbol-append 'list-> tag 'vector) elts)
(let* ((len (length elts))
(v (,(symbol-append 'make- tag 'vector) len)))
(let lp ((i 0) (elts elts))
(if (and (< i len) (pair? elts))
(begin
(,(symbol-append tag 'vector-set!) v i (car elts))
(lp (1+ i) (cdr elts)))
v))))
(define (,(symbol-append tag 'vector->list) v)
(let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
(if (< i 0)
elts
(lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
(define (,(symbol-append tag 'vector-ref) v i)
(,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
(define (,(symbol-append tag 'vector-set!) v i x)
(,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
(define (,(symbol-append tag 'vector-set!) v i x)
(,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
(define (bytevector-c32-native-ref v i)
(make-rectangular (bytevector-ieee-single-native-ref v i)
(bytevector-ieee-single-native-ref v (+ i 4))))
(define (bytevector-c32-native-set! v i x)
(bytevector-ieee-single-native-set! v i x)
(bytevector-ieee-single-native-set! v (+ i 4) x))
(define (bytevector-c64-native-ref v i)
(make-rectangular (bytevector-ieee-double-native-ref v i)
(bytevector-ieee-double-native-ref v (+ i 8))))
(define (bytevector-c64-native-set! v i x)
(bytevector-ieee-double-native-set! v i x)
(bytevector-ieee-double-native-set! v (+ i 8) x))
(define-bytevector-type c32 c32-native 8)
(define-bytevector-type c64 c64-native 16)
(define-macro (define-any->vector . tags) (define-macro (define-any->vector . tags)
`(begin `(begin
,@(map (lambda (tag) ,@(map (lambda (tag)

6
test-suite/tests/unif.test
View file

@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
;;;; ;;;;
;;;; Copyright 2004, 2006, 2009 Free Software Foundation, Inc. ;;;; Copyright 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -18,7 +18,9 @@
(define-module (test-suite test-unif) (define-module (test-suite test-unif)
#:use-module ((system base compile) #:select (compile)) #:use-module ((system base compile) #:select (compile))
#:use-module (test-suite lib)) #:use-module (test-suite lib)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
;;; ;;;
;;; array? ;;; array?