## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
ieee-754.h \
- srfi-4.i.c \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
#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)
{
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_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_typed_array (SCM type, SCM ndim, SCM lst);
-SCM_API SCM scm_ra2contig (SCM ra, int copy);
-
/* internal. */
typedef struct scm_i_t_array
-/* 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
* modify it under the terms of the GNU Lesser General Public License
{ /* FIXME add some checks */
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
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
{ /* FIXME add some checks */
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
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);
return ref_fn (h->array, byte_index);
}
+/* FIXME add checks!!! */
static SCM
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);
- contents[i/8] = scm_c_real_part (val);
- contents[i/8 + 1] = scm_c_imag_part (val);
+ contents[i/4] = scm_c_real_part (val);
+ contents[i/4 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
static SCM
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);
- contents[i/16] = scm_c_real_part (val);
- contents[i/16 + 1] = scm_c_imag_part (val);
+ contents[i/8] = scm_c_real_part (val);
+ contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
#include "libguile/_scm.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/discouraged.h"
#include "libguile/deprecation.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/modules.h"
-#include "libguile/generalized-arrays.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
#include "libguile/ports.h"
#include "libguile/eq.h"
#include "libguile/read.h"
+#include "libguile/r6rs-ports.h"
#include "libguile/strports.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
#include "libguile/socket.h"
#include "libguile/feature.h"
+#include "libguile/uniform.h"
#include <math.h>
#include <stdio.h>
return scm_equal_p (x, y);
}
-int
-scm_i_arrayp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
- return SCM_I_ARRAYP(a);
-}
+SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
+ (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
+{
+ size_t width;
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-size_t
-scm_i_array_ndim (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_NDIM is deprecated. "
- "Use scm_c_array_rank or scm_array_handle_rank instead.");
- return scm_c_array_rank (a);
-}
+ scm_c_issue_deprecation_warning
+ ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
+ "`(rnrs io ports)' instead.");
-int
-scm_i_array_contp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
- return SCM_I_ARRAY_CONTP (a);
-}
+ width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-scm_t_array *
-scm_i_array_mem (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_MEM is deprecated. Do not use it.");
- return (scm_t_array *)SCM_I_ARRAY_MEM (a);
+ 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
-scm_i_array_v (SCM a)
-{
- /* 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);
+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
-size_t
-scm_i_array_base (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_BASE is deprecated. Do not use it.");
- return SCM_I_ARRAY_BASE (a);
+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;
+}
+
+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_t_array_dim *
-scm_i_array_dims (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
- return SCM_I_ARRAY_DIMS (a);
+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
SCM
scm_i_cur_inp (void)
*/
#include "libguile/__scm.h"
-#include "libguile/arrays.h"
#include "libguile/strings.h"
#include "libguile/eval.h"
#define scm_srcprops_chunk scm_t_srcprops_chunk
#define scm_array scm_t_array
#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_WTA(pos, scm) \
#define SCM_ARRAY_BASE(a) scm_i_array_base(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
use the official interfaces.
*/
}
#undef FUNC_NAME
-/* HACK*/
-#include "libguile/bytevectors.h"
-
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
(SCM ra),
"")
scm_t_array_handle h;
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);
type = scm_array_handle_element_type (&h);
scm_array_handle_release (&h);
-/* 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
* modify it under the terms of the GNU Lesser General Public License
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
- ssize_t increment;
- scm_t_array_handle handle;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
SCM objcode;
- if (scm_is_false (scm_u8vector_p (bytecode)))
+ if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ size = SCM_BYTEVECTOR_LENGTH (bytecode);
+ c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
- SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
- scm_array_handle_release (&handle);
- SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
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_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
will be of the same length; perhaps a bad assumption? */
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_uint8 *u8vector;
+ scm_t_int8 *s8vector;
scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- u8vector = scm_malloc (len);
- memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+ s8vector = scm_malloc (len);
+ memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, len);
+ return scm_c_take_bytevector (s8vector, len);
}
#undef FUNC_NAME
-/* 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
* modify it under the terms of the GNU Lesser General Public License
#define SCM_C_OBJCODE_BASE(obj) \
((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
-#define SCM_F_OBJCODE_IS_MMAP (1<<0)
-#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
-#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_MMAP (1<<0)
+#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE (1<<2)
SCM_API scm_t_bits scm_tc16_objcode;
#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_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)
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
-/* srfi-4.c --- Uniform numeric vector datatypes.
- *
- * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <string.h>
-#include <errno.h>
-#include <stdio.h>
-
-#include "libguile/_scm.h"
-#include "libguile/__scm.h"
-#include "libguile/bdw-gc.h"
-#include "libguile/srfi-4.h"
-#include "libguile/bitvectors.h"
-#include "libguile/bytevectors.h"
-#include "libguile/generalized-vectors.h"
-#include "libguile/uniform.h"
-#include "libguile/error.h"
-#include "libguile/eval.h"
-#include "libguile/read.h"
-#include "libguile/ports.h"
-#include "libguile/chars.h"
-#include "libguile/vectors.h"
-#include "libguile/arrays.h"
-#include "libguile/strings.h"
-#include "libguile/strports.h"
-#include "libguile/dynwind.h"
-#include "libguile/deprecation.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_IO_H
-#include <io.h>
-#endif
-
-/* Smob type code for uniform numeric vectors. */
-int scm_tc16_uvec = 0;
-
-#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
-
-/* Accessor macros for the three components of a uniform numeric
- vector:
- - The type tag (one of the symbolic constants below).
- - The vector's length (counted in elements).
- - The address of the data area (holding the elements of the
- vector). */
-#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
-
-
-/* Symbolic constants encoding the various types of uniform
- numeric vectors. */
-#define SCM_UVEC_U8 0
-#define SCM_UVEC_S8 1
-#define SCM_UVEC_U16 2
-#define SCM_UVEC_S16 3
-#define SCM_UVEC_U32 4
-#define SCM_UVEC_S32 5
-#define SCM_UVEC_U64 6
-#define SCM_UVEC_S64 7
-#define SCM_UVEC_F32 8
-#define SCM_UVEC_F64 9
-#define SCM_UVEC_C32 10
-#define SCM_UVEC_C64 11
-
-
-/* This array maps type tags to the size of the elements. */
-static const int uvec_sizes[12] = {
- 1, 1,
- 2, 2,
- 4, 4,
-#if SCM_HAVE_T_INT64
- 8, 8,
-#else
- sizeof (SCM), sizeof (SCM),
-#endif
- sizeof(float), sizeof(double),
- 2*sizeof(float), 2*sizeof(double)
-};
-
-static const char *uvec_tags[12] = {
- "u8", "s8",
- "u16", "s16",
- "u32", "s32",
- "u64", "s64",
- "f32", "f64",
- "c32", "c64",
-};
-
-static const char *uvec_names[12] = {
- "u8vector", "s8vector",
- "u16vector", "s16vector",
- "u32vector", "s32vector",
- "u64vector", "s64vector",
- "f32vector", "f64vector",
- "c32vector", "c64vector"
-};
-
-/* ================================================================ */
-/* SMOB procedures. */
-/* ================================================================ */
-
-
-/* Smob print hook for uniform vectors. */
-static int
-uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
-{
- union {
- scm_t_uint8 *u8;
- scm_t_int8 *s8;
- scm_t_uint16 *u16;
- scm_t_int16 *s16;
- scm_t_uint32 *u32;
- scm_t_int32 *s32;
-#if SCM_HAVE_T_INT64
- scm_t_uint64 *u64;
- scm_t_int64 *s64;
-#endif
- float *f32;
- double *f64;
- SCM *fake_64;
- } np;
-
- size_t i = 0;
- const size_t uvlen = SCM_UVEC_LENGTH (uvec);
- void *uptr = SCM_UVEC_BASE (uvec);
-
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
- case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
- case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
- case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
- case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
- case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
- case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break;
-#endif
- case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
- case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
- default:
- abort (); /* Sanity check. */
- break;
- }
-
- scm_putc ('#', port);
- scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
- scm_putc ('(', port);
-
- while (i < uvlen)
- {
- if (i != 0) scm_puts (" ", port);
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
- case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
- case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
- case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
- case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
- case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
- case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate);
- np.fake_64++; break;
-#endif
- case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
- case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
- case SCM_UVEC_C32:
- scm_i_print_complex (np.f32[0], np.f32[1], port);
- np.f32 += 2;
- break;
- case SCM_UVEC_C64:
- scm_i_print_complex (np.f64[0], np.f64[1], port);
- np.f64 += 2;
- break;
- default:
- abort (); /* Sanity check. */
- break;
- }
- i++;
- }
- scm_remember_upto_here_1 (uvec);
- scm_puts (")", port);
- return 1;
-}
-
-const char *
-scm_i_uniform_vector_tag (SCM uvec)
-{
- return uvec_tags[SCM_UVEC_TYPE (uvec)];
-}
-
-static SCM
-uvec_equalp (SCM a, SCM b)
-{
- SCM result = SCM_BOOL_T;
- if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
- result = SCM_BOOL_F;
- else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
- result = SCM_BOOL_F;
-#if SCM_HAVE_T_INT64 == 0
- else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64
- || SCM_UVEC_TYPE (a) == SCM_UVEC_S64)
- {
- SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b);
- size_t len = SCM_UVEC_LENGTH (a), i;
- for (i = 0; i < len; i++)
- if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++)))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
-#endif
- else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
- SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
- result = SCM_BOOL_F;
-
- scm_remember_upto_here_2 (a, b);
- return result;
-}
-
-
-/* ================================================================ */
-/* Utility procedures. */
-/* ================================================================ */
-
-static SCM_C_INLINE_KEYWORD int
-is_uvec (int type, SCM obj)
-{
- if (SCM_IS_UVEC (obj))
- return SCM_UVEC_TYPE (obj) == type;
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
- }
- return 0;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_p (int type, SCM obj)
-{
- return scm_from_bool (is_uvec (type, obj));
-}
-
-static SCM_C_INLINE_KEYWORD void
-uvec_assert (int type, SCM obj)
-{
- if (!is_uvec (type, obj))
- scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
-}
-
-/* Invoke free(3) on DATA, a user-provided buffer passed to one of the
- `scm_take_' functions. */
-static void
-free_user_data (GC_PTR data, GC_PTR unused)
-{
- free (data);
-}
-
-static SCM
-take_uvec (int type, void *base, size_t len)
-{
- SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
-}
-
-/* Create a new, uninitialized uniform numeric vector of type TYPE
- with space for LEN elements. */
-static SCM
-alloc_uvec (int type, size_t len)
-{
- void *base;
- if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
- scm_out_of_range (NULL, scm_from_size_t (len));
- base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
-#if SCM_HAVE_T_INT64 == 0
- if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64)
- {
- SCM *ptr = (SCM *)base;
- size_t i;
- for (i = 0; i < len; i++)
- *ptr++ = SCM_UNSPECIFIED;
- }
-#endif
- return take_uvec (type, base, len);
-}
-
-/* GCC doesn't seem to want to optimize unused switch clauses away,
- so we use a big 'if' in the next two functions.
-*/
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_fast_ref (int type, const void *base, size_t c_idx)
-{
- if (type == SCM_UVEC_U8)
- return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
- else if (type == SCM_UVEC_S8)
- return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
- else if (type == SCM_UVEC_U16)
- return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
- else if (type == SCM_UVEC_S16)
- return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
- else if (type == SCM_UVEC_U32)
- return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
- else if (type == SCM_UVEC_S32)
- return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
- else if (type == SCM_UVEC_S64)
- return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
-#else
- else if (type == SCM_UVEC_U64)
- return ((SCM *)base)[c_idx];
- else if (type == SCM_UVEC_S64)
- return ((SCM *)base)[c_idx];
-#endif
- else if (type == SCM_UVEC_F32)
- return scm_from_double (((float*)base)[c_idx]);
- else if (type == SCM_UVEC_F64)
- return scm_from_double (((double*)base)[c_idx]);
- else if (type == SCM_UVEC_C32)
- return scm_c_make_rectangular (((float*)base)[2*c_idx],
- ((float*)base)[2*c_idx+1]);
- else if (type == SCM_UVEC_C64)
- return scm_c_make_rectangular (((double*)base)[2*c_idx],
- ((double*)base)[2*c_idx+1]);
- else
- return SCM_BOOL_F;
-}
-
-#if SCM_HAVE_T_INT64 == 0
-static SCM scm_uint64_min, scm_uint64_max;
-static SCM scm_int64_min, scm_int64_max;
-
-static void
-assert_exact_integer_range (SCM val, SCM min, SCM max)
-{
- if (!scm_is_integer (val)
- || scm_is_false (scm_exact_p (val)))
- scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
- if (scm_is_true (scm_less_p (val, min))
- || scm_is_true (scm_gr_p (val, max)))
- scm_out_of_range (NULL, val);
-}
-#endif
-
-static SCM_C_INLINE_KEYWORD void
-uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
-{
- if (type == SCM_UVEC_U8)
- (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
- else if (type == SCM_UVEC_S8)
- (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
- else if (type == SCM_UVEC_U16)
- (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
- else if (type == SCM_UVEC_S16)
- (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
- else if (type == SCM_UVEC_U32)
- (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
- else if (type == SCM_UVEC_S32)
- (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
- else if (type == SCM_UVEC_S64)
- (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
-#else
- else if (type == SCM_UVEC_U64)
- {
- assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max);
- ((SCM *)base)[c_idx] = val;
- }
- else if (type == SCM_UVEC_S64)
- {
- assert_exact_integer_range (val, scm_int64_min, scm_int64_max);
- ((SCM *)base)[c_idx] = val;
- }
-#endif
- else if (type == SCM_UVEC_F32)
- (((float*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_F64)
- (((double*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_C32)
- {
- (((float*)base)[2*c_idx]) = scm_c_real_part (val);
- (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
- else if (type == SCM_UVEC_C64)
- {
- (((double*)base)[2*c_idx]) = scm_c_real_part (val);
- (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-make_uvec (int type, SCM len, SCM fill)
-{
- size_t c_len = scm_to_size_t (len);
- SCM uvec = alloc_uvec (type, c_len);
- if (!SCM_UNBNDP (fill))
- {
- size_t idx;
- void *base = SCM_UVEC_BASE (uvec);
- for (idx = 0; idx < c_len; idx++)
- uvec_fast_set_x (type, base, idx, fill);
- }
- return uvec;
-}
-
-static SCM_C_INLINE_KEYWORD void *
-uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- if (type >= 0)
- {
- SCM v = uvec;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- uvec_assert (type, v);
- }
-
- return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
-}
-
-static SCM_C_INLINE_KEYWORD const void *
-uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- return uvec_writable_elements (type, uvec, handle, lenp, incp);
-}
-
-static int
-uvec_type (scm_t_array_handle *h)
-{
- SCM v = h->array;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- return SCM_UVEC_TYPE (v);
-}
-
-static SCM
-uvec_to_list (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t i, inc;
- const void *elts;
- SCM res = SCM_EOL;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- for (i = len - 1; i >= 0; i--)
- res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
- scm_array_handle_release (&handle);
- return res;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_length (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
- uvec_elements (type, uvec, &handle, &len, &inc);
- scm_array_handle_release (&handle);
- return scm_from_size_t (len);
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_ref (int type, SCM uvec, SCM idx)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const void *elts;
- SCM res;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- res = uvec_fast_ref (type, elts, i*inc);
- scm_array_handle_release (&handle);
- return res;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- void *elts;
-
- elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- uvec_fast_set_x (type, elts, i*inc, val);
- scm_array_handle_release (&handle);
- return SCM_UNSPECIFIED;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-list_to_uvec (int type, SCM list)
-{
- SCM uvec;
- void *base;
- long idx;
- long len = scm_ilength (list);
- if (len < 0)
- scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
-
- uvec = alloc_uvec (type, len);
- base = SCM_UVEC_BASE (uvec);
- idx = 0;
- while (scm_is_pair (list) && idx < len)
- {
- uvec_fast_set_x (type, base, idx, SCM_CAR (list));
- list = SCM_CDR (list);
- idx++;
- }
- return uvec;
-}
-
-SCM_SYMBOL (scm_sym_a, "a");
-SCM_SYMBOL (scm_sym_b, "b");
-
-SCM
-scm_i_generalized_vector_type (SCM v)
-{
- if (scm_is_vector (v))
- return SCM_BOOL_T;
- else if (scm_is_string (v))
- return scm_sym_a;
- else if (scm_is_bitvector (v))
- return scm_sym_b;
- else if (scm_is_uniform_vector (v))
- return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
- else if (scm_is_bytevector (v))
- return scm_from_locale_symbol ("vu8");
- else
- return SCM_BOOL_F;
-}
-
-SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
- (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_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t remaining, off;
- char *base;
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPINPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-
- base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
-
- 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);
- }
-
- remaining = (cend - cstart) * sz;
- off = cstart * sz;
-
- if (SCM_NIMP (port_or_fd))
- {
- ans = cend - cstart;
- remaining -= scm_c_read (port_or_fd, base + off, remaining);
- if (remaining % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans -= remaining / sz;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd);
- int n;
-
- SCM_SYSCALL (n = read (fd, base + off, remaining));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans = n / sz;
- }
-
- scm_array_handle_release (&handle);
-
- return scm_from_size_t (ans);
-}
-#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
-{
- scm_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t amount, off;
- const char *base;
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPOUTPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
-
- 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);
- }
-
- amount = (cend - cstart) * sz;
- off = cstart * sz;
-
- if (SCM_NIMP (port_or_fd))
- {
- scm_lfwrite (base + off, amount, port_or_fd);
- ans = cend - cstart;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd), n;
- SCM_SYSCALL (n = write (fd, base + off, amount));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
- ans = n / sz;
- }
-
- scm_array_handle_release (&handle);
-
- return scm_from_size_t (ans);
-}
-#undef FUNC_NAME
-
-/* ================================================================ */
-/* Exported procedures. */
-/* ================================================================ */
-
-#define TYPE SCM_UVEC_U8
-#define TAG u8
-#define CTYPE scm_t_uint8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S8
-#define TAG s8
-#define CTYPE scm_t_int8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U16
-#define TAG u16
-#define CTYPE scm_t_uint16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S16
-#define TAG s16
-#define CTYPE scm_t_int16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U32
-#define TAG u32
-#define CTYPE scm_t_uint32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S32
-#define TAG s32
-#define CTYPE scm_t_int32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U64
-#define TAG u64
-#if SCM_HAVE_T_UINT64
-#define CTYPE scm_t_uint64
-#endif
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S64
-#define TAG s64
-#if SCM_HAVE_T_INT64
-#define CTYPE scm_t_int64
-#endif
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_F32
-#define TAG f32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_F64
-#define TAG f64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_C32
-#define TAG c32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_C64
-#define TAG c64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
-
-#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
- SCM cname (SCM arg1) \
- { \
- static SCM var = SCM_BOOL_F; \
- if (scm_is_false (var)) \
- var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
- return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
- }
-
-#define DEFPROXY100(cname, scmname) \
- DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
-
-#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
- DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
-
-#define MOD "srfi srfi-4 gnu"
-DEFINE_SRFI_4_GNU_PROXIES (u8);
-DEFINE_SRFI_4_GNU_PROXIES (s8);
-DEFINE_SRFI_4_GNU_PROXIES (u16);
-DEFINE_SRFI_4_GNU_PROXIES (s16);
-DEFINE_SRFI_4_GNU_PROXIES (u32);
-DEFINE_SRFI_4_GNU_PROXIES (s32);
-DEFINE_SRFI_4_GNU_PROXIES (u64);
-DEFINE_SRFI_4_GNU_PROXIES (s64);
-DEFINE_SRFI_4_GNU_PROXIES (f32);
-DEFINE_SRFI_4_GNU_PROXIES (f64);
-DEFINE_SRFI_4_GNU_PROXIES (c32);
-DEFINE_SRFI_4_GNU_PROXIES (c64);
-
-
-static scm_i_t_array_ref uvec_reffers[12] = {
- u8ref, s8ref,
- u16ref, s16ref,
- u32ref, s32ref,
- u64ref, s64ref,
- f32ref, f64ref,
- c32ref, c64ref
-};
-
-static scm_i_t_array_set uvec_setters[12] = {
- u8set, s8set,
- u16set, s16set,
- u32set, s32set,
- u64set, s64set,
- f32set, f64set,
- c32set, c64set
-};
-
-static SCM
-uvec_handle_ref (scm_t_array_handle *h, size_t index)
-{
- return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index);
-}
-
-static void
-uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
-{
- uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
-}
-
-static void
-uvec_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
- h->elements = h->writable_elements = SCM_UVEC_BASE (v);
-}
-
-SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
- SCM_SMOB_TYPE_MASK,
- uvec_handle_ref, uvec_handle_set,
- uvec_get_handle)
-
-void
-scm_init_srfi_4 (void)
-{
- scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
- scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
- scm_set_smob_print (scm_tc16_uvec, uvec_print);
-
-#if SCM_HAVE_T_INT64 == 0
- scm_uint64_min = scm_from_int (0);
- scm_uint64_max = scm_c_read_string ("18446744073709551615");
- scm_int64_min = scm_c_read_string ("-9223372036854775808");
- scm_int64_max = scm_c_read_string ("9223372036854775807");
-#endif
-
-#define REGISTER(tag, TAG) \
- scm_i_register_vector_constructor \
- (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
- scm_make_##tag##vector)
-
- REGISTER (u8, U8);
- REGISTER (s8, S8);
- REGISTER (u16, U16);
- REGISTER (s16, S16);
- REGISTER (u32, U32);
- REGISTER (s32, S32);
- REGISTER (u64, U64);
- REGISTER (s64, S64);
- REGISTER (f32, F32);
- REGISTER (f64, F64);
- REGISTER (c32, C32);
- REGISTER (c64, C64);
-
-#include "libguile/srfi-4.x"
-
-}
-
-/* End of srfi-4.c. */
+/* srfi-4.c --- Uniform numeric vector datatypes.
+ *
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/bdw-gc.h"
+#include "libguile/srfi-4.h"
+#include "libguile/bytevectors.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/extensions.h"
+#include "libguile/uniform.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/validate.h"
+
+
+#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
+ SCM cname (SCM arg1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ }
+
+#define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \
+ SCM cname (SCM args) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_apply_0 (SCM_VARIABLE_REF (var), args); \
+ }
+
+#define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM opt1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ if (SCM_UNBNDP (opt1)) \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ else \
+ return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \
+ }
+
+#define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2); \
+ }
+
+#define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2, SCM arg3) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \
+ }
+
+#define DEFPROXY100(cname, scmname) \
+ DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+#define DEFPROXY110(cname, scmname) \
+ DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
+#define DEFPROXY001(cname, scmname) \
+ DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
+#define DEFPROXY200(cname, scmname) \
+ DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
+#define DEFPROXY300(cname, scmname) \
+ DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)
+
+#define DEFVECT(sym, str, func)\
+
+#define DEFINE_SRFI_4_PROXIES(tag) \
+ DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \
+ DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \
+ DEFPROXY001 (scm_##tag##vector, #tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \
+ DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \
+ DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \
+ DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \
+
+
+#define ETYPE(TAG) \
+ SCM_ARRAY_ELEMENT_TYPE_##TAG
+
+#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype) \
+ SCM scm_take_##tag##vector (ctype *data, size_t n) \
+ { \
+ return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
+ } \
+ const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return h->elements; \
+ } \
+ ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return h->writable_elements; \
+ } \
+ const ctype *scm_##tag##vector_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
+ } \
+ ctype *scm_##tag##vector_writable_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ scm_uniform_vector_elements (uvec, h, lenp, incp); \
+ if (h->element_type == ETYPE (TAG)) \
+ return ((ctype*)h->writable_elements) + h->base; \
+ /* otherwise... */ \
+ else \
+ { \
+ size_t sfrom, sto, lfrom, lto; \
+ if (h->dims != &h->dim0) \
+ { \
+ h->dim0 = h->dims[0]; \
+ h->dims = &h->dim0; \
+ } \
+ sfrom = scm_i_array_element_type_sizes [h->element_type]; \
+ sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \
+ lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \
+ lto = lfrom * sfrom / sto; \
+ if (lto * sto != lfrom * sfrom) \
+ { \
+ scm_array_handle_release (h); \
+ scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
+ } \
+ h->dim0.ubnd = h->dim0.lbnd + lto; \
+ h->base = h->base * sto / sfrom; \
+ h->element_type = ETYPE (TAG); \
+ return ((ctype*)h->writable_elements) + h->base; \
+ } \
+ }
+
+
+#define MOD "srfi srfi-4"
+
+DEFINE_SRFI_4_PROXIES (u8);
+DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8);
+
+DEFINE_SRFI_4_PROXIES (s8);
+DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8);
+
+DEFINE_SRFI_4_PROXIES (u16);
+DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16);
+
+DEFINE_SRFI_4_PROXIES (s16);
+DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16);
+
+DEFINE_SRFI_4_PROXIES (u32);
+DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32);
+
+DEFINE_SRFI_4_PROXIES (s32);
+DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32);
+
+DEFINE_SRFI_4_PROXIES (u64);
+#if SCM_HAVE_T_INT64
+DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64);
+#endif
+
+DEFINE_SRFI_4_PROXIES (s64);
+#if SCM_HAVE_T_INT64
+DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64);
+#endif
+
+DEFINE_SRFI_4_PROXIES (f32);
+DEFINE_SRFI_4_C_FUNCS (F32, f32, float);
+
+DEFINE_SRFI_4_PROXIES (f64);
+DEFINE_SRFI_4_C_FUNCS (F64, f64, double);
+
+#undef MOD
+#define MOD "srfi srfi-4 gnu"
+
+DEFINE_SRFI_4_PROXIES (c32);
+DEFINE_SRFI_4_C_FUNCS (C32, c32, float);
+
+DEFINE_SRFI_4_PROXIES (c64);
+DEFINE_SRFI_4_C_FUNCS (C64, c64, double);
+
+#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
+ DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+
+#undef MOD
+#define MOD "srfi srfi-4 gnu"
+DEFINE_SRFI_4_GNU_PROXIES (u8);
+DEFINE_SRFI_4_GNU_PROXIES (s8);
+DEFINE_SRFI_4_GNU_PROXIES (u16);
+DEFINE_SRFI_4_GNU_PROXIES (s16);
+DEFINE_SRFI_4_GNU_PROXIES (u32);
+DEFINE_SRFI_4_GNU_PROXIES (s32);
+DEFINE_SRFI_4_GNU_PROXIES (u64);
+DEFINE_SRFI_4_GNU_PROXIES (s64);
+DEFINE_SRFI_4_GNU_PROXIES (f32);
+DEFINE_SRFI_4_GNU_PROXIES (f64);
+DEFINE_SRFI_4_GNU_PROXIES (c32);
+DEFINE_SRFI_4_GNU_PROXIES (c64);
+
+
+SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
+ (SCM type, SCM len, SCM fill),
+ "Make a srfi-4 vector")
+#define FUNC_NAME s_scm_make_srfi_4_vector
+{
+ int i;
+ for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
+ if (scm_is_eq (type, scm_i_array_element_types[i]))
+ break;
+ if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
+ switch (i)
+ {
+ case SCM_ARRAY_ELEMENT_TYPE_U8:
+ case SCM_ARRAY_ELEMENT_TYPE_S8:
+ case SCM_ARRAY_ELEMENT_TYPE_U16:
+ case SCM_ARRAY_ELEMENT_TYPE_S16:
+ case SCM_ARRAY_ELEMENT_TYPE_U32:
+ case SCM_ARRAY_ELEMENT_TYPE_S32:
+ case SCM_ARRAY_ELEMENT_TYPE_U64:
+ case SCM_ARRAY_ELEMENT_TYPE_S64:
+ case SCM_ARRAY_ELEMENT_TYPE_F32:
+ case SCM_ARRAY_ELEMENT_TYPE_F64:
+ case SCM_ARRAY_ELEMENT_TYPE_C32:
+ case SCM_ARRAY_ELEMENT_TYPE_C64:
+ {
+ SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);
+ if (SCM_UNBNDP (fill))
+ ; /* pass */
+ else if (scm_is_true (scm_zero_p (fill)))
+ memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
+ SCM_BYTEVECTOR_LENGTH (ret));
+ else
+ {
+ scm_t_array_handle h;
+ size_t len;
+ ssize_t pos, inc;
+ scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
+ for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
+ scm_array_handle_set (&h, pos, fill);
+ scm_array_handle_release (&h);
+ }
+ return ret;
+ }
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type");
+ return SCM_BOOL_F; /* not reached */
+ }
+}
+#undef FUNC_NAME
+
+void
+scm_init_srfi_4 (void)
+{
+#define REGISTER(tag, TAG) \
+ scm_i_register_vector_constructor \
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
+ scm_make_##tag##vector)
+
+ REGISTER (u8, U8);
+ REGISTER (s8, S8);
+ REGISTER (u16, U16);
+ REGISTER (s16, S16);
+ REGISTER (u32, U32);
+ REGISTER (s32, S32);
+ REGISTER (u64, U64);
+ REGISTER (s64, S64);
+ REGISTER (f32, F32);
+ REGISTER (f64, F64);
+ REGISTER (c32, C32);
+ REGISTER (c64, C64);
+
+#include "libguile/srfi-4.x"
+}
+
+/* End of srfi-4.c. */
#include "libguile/__scm.h"
+SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill);
+
+
/* Specific procedures.
*/
+++ /dev/null
-/* 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
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
+;; FIXME:
+(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
+
(define-module (guile-user)
#:autoload (system base compile) (compile))
;;; 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
;; modify it under the terms of the GNU Lesser General Public
;;; 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
+
+ ;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+ ;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+ ;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+ ;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+ ;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+ ;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+ ;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+ ;; 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))
+
+
+;; 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)
-(re-export
-;;; Unsigned 8-bit vectors.
- u8vector? make-u8vector u8vector u8vector-length u8vector-ref
- u8vector-set! u8vector->list list->u8vector
-;;; Signed 8-bit vectors.
- s8vector? make-s8vector s8vector s8vector-length s8vector-ref
- s8vector-set! s8vector->list list->s8vector
-
-;;; Unsigned 16-bit vectors.
- u16vector? make-u16vector u16vector u16vector-length u16vector-ref
- u16vector-set! u16vector->list list->u16vector
-
-;;; Signed 16-bit vectors.
- s16vector? make-s16vector s16vector s16vector-length s16vector-ref
- s16vector-set! s16vector->list list->s16vector
-
-;;; Unsigned 32-bit vectors.
- u32vector? make-u32vector u32vector u32vector-length u32vector-ref
- u32vector-set! u32vector->list list->u32vector
-
-;;; Signed 32-bit vectors.
- s32vector? make-s32vector s32vector s32vector-length s32vector-ref
- s32vector-set! s32vector->list list->s32vector
-
-;;; Unsigned 64-bit vectors.
- u64vector? make-u64vector u64vector u64vector-length u64vector-ref
- u64vector-set! u64vector->list list->u64vector
-
-;;; Signed 64-bit vectors.
- s64vector? make-s64vector s64vector s64vector-length s64vector-ref
- s64vector-set! s64vector->list list->s64vector
-
-;;; 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
- )
;;; Code:
(define-module (srfi srfi-4 gnu)
+ #:use-module (rnrs bytevector)
#: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->u32vector any->s32vector any->u64vector any->s64vector
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)
`(begin
,@(map (lambda (tag)
;;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
(define-module (test-suite test-unif)
#: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?
HCoop / bpt / guile.git / commitdiff