diff options
author | Andy Wingo <wingo@pobox.com> | 2009-07-19 15:35:33 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-01-07 22:06:56 +0100 |
commit | a2689737679cf2553c118a1d96de7c9ddfec62b0 (patch) | |
tree | 527a55fa0ed77eae66e282f8b87cf7b836edb9e8 | |
parent | 3dc2afe2b85eb5c7ec784b6ed8b19242e45f6e34 (diff) | |
download | guile-a2689737679cf2553c118a1d96de7c9ddfec62b0.tar.gz |
reimplement srfi-4 vectors on top of bytevectors
* libguile/srfi-4.h:
* libguile/srfi-4.c (scm_make_srfi_4_vector): New function, exported by
(srfi srfi-4 gnu).
* libguile/srfi-4.i.c: Removed.
* module/srfi/srfi-4.scm:
* module/srfi/srfi-4/gnu.scm: Reimplement srfi-4 vectors on top of
bytevectors. The implementation is mostly in Scheme now.
* test-suite/tests/unif.test: Update to use (srfi srfi-4 gnu).
* libguile/bytevectors.c (bytevector_ref_c32, bytevector_ref_c64)
(bytevector_set_c32, bytevector_set_c64): Fix some embarrassing bugs.
Still need to do an upper bounds check.
* libguile/deprecated.h: Remove deprecated array functions:
scm_i_arrayp, scm_i_array_ndim, scm_i_array_mem, scm_i_array_v,
scm_i_array_base, scm_i_array_dims, and the deprecated macros:
SCM_ARRAYP, SCM_ARRAY_NDIM, SCM_ARRAY_CONTP, SCM_ARRAY_MEM,
SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS.
* libguile/deprecated.c (scm_uniform_vector_read_x)
(scm_uniform_vector_write, scm_uniform_array_read_x)
(scm_uniform_array_write): Newly deprecated functions.
* libguile/generalized-arrays.c (scm_array_type): Remove the bytevector
hack.
* libguile/objcodes.c (scm_bytecode_to_objcode, scm_objcode_to_bytecode):
Rework to operate on bytevectors, as scm_make_u8vector now causes a
module lookup, which can't be done e.g. when loading the VM boot
program for psyntax-pp.go on a fresh bootstrap.
* libguile/objcodes.h (SCM_F_OBJCODE_IS_BYTEVECTOR):
(SCM_OBJCODE_IS_BYTEVECTOR): s/U8VECTOR/BYTEVECTOR/.
* module/ice-9/boot-9.scm (the-scm-module): A terrible hack to pull in
(srfi srfi-4), as the bindings are primarily there now. We'll worry
about this later.
-rw-r--r-- | libguile/Makefile.am | 1 | ||||
-rw-r--r-- | libguile/arrays.c | 144 | ||||
-rw-r--r-- | libguile/arrays.h | 6 | ||||
-rw-r--r-- | libguile/bytevectors.c | 21 | ||||
-rw-r--r-- | libguile/deprecated.c | 263 | ||||
-rw-r--r-- | libguile/deprecated.h | 11 | ||||
-rw-r--r-- | libguile/generalized-arrays.c | 7 | ||||
-rw-r--r-- | libguile/objcodes.c | 29 | ||||
-rw-r--r-- | libguile/objcodes.h | 10 | ||||
-rw-r--r-- | libguile/srfi-4.c | 1025 | ||||
-rw-r--r-- | libguile/srfi-4.h | 3 | ||||
-rw-r--r-- | libguile/srfi-4.i.c | 207 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 3 | ||||
-rw-r--r-- | module/srfi/srfi-4.scm | 149 | ||||
-rw-r--r-- | module/srfi/srfi-4/gnu.scm | 66 | ||||
-rw-r--r-- | test-suite/tests/unif.test | 6 |
16 files changed, 636 insertions, 1315 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9bef5077b..838946769 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -429,7 +429,6 @@ install-exec-hook: ## 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 \ diff --git a/libguile/arrays.c b/libguile/arrays.c index 39d10670b..db6258512 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -570,150 +570,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, #undef FUNC_NAME -SCM -scm_ra2contig (SCM ra, int copy) -{ - SCM ret; - long inc = 1; - size_t k, len = 1; - for (k = SCM_I_ARRAY_NDIM (ra); k--;) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - k = SCM_I_ARRAY_NDIM (ra); - if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) - { - if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) - return ra; - if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && - 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) - return ra; - } - ret = scm_i_make_array (k); - SCM_I_ARRAY_BASE (ret) = 0; - while (k--) - { - SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; - SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; - SCM_I_ARRAY_DIMS (ret)[k].inc = inc; - inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - } - SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra), - scm_from_long (inc), - SCM_UNDEFINED); - if (copy) - scm_array_copy_x (ra, ret); - return ret; -} - - - -SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" - "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" - "binary objects from @var{port-or-fdes}.\n" - "If an end of file is encountered,\n" - "the objects up to that point are put into @var{ura}\n" - "(starting at the beginning) and the remainder of the array is\n" - "unchanged.\n\n" - "The optional arguments @var{start} and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be read,\n" - "leaving the remainder of the vector unchanged.\n\n" - "@code{uniform-array-read!} returns the number of objects read.\n" - "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" - "returned by @code{(current-input-port)}.") -#define FUNC_NAME s_scm_uniform_array_read_x -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_input_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_read_x (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 0); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - if (!scm_is_eq (cra, ura)) - scm_array_copy_x (cra, ura); - return ans; - } - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "Writes all elements of @var{ura} as binary objects to\n" - "@var{port-or-fdes}.\n\n" - "The optional arguments @var{start}\n" - "and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be written.\n\n" - "The number of objects actually written is returned.\n" - "@var{port-or-fdes} may be\n" - "omitted, in which case it defaults to the value returned by\n" - "@code{(current-output-port)}.") -#define FUNC_NAME s_scm_uniform_array_write -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_output_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_write (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 1); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - return ans; - } - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - - static void list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) { diff --git a/libguile/arrays.h b/libguile/arrays.h index 325bb9cda..964a1faca 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -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_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 diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index ffd2f1286..45dae1cc8 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -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 * 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 */ 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 @@ -2103,7 +2103,7 @@ bytevector_ref_c64 (SCM bv, SCM idx) { /* 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); @@ -2140,23 +2140,22 @@ bv_handle_ref (scm_t_array_handle *h, size_t index) 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; } diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 3a6134234..f428bd4bf 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -28,6 +28,11 @@ #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" @@ -36,7 +41,6 @@ #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" @@ -48,12 +52,14 @@ #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> @@ -1327,65 +1333,222 @@ scm_vector_equal_p (SCM x, SCM y) 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) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5b7c9a2ac..f7b053c55 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -24,7 +24,6 @@ */ #include "libguile/__scm.h" -#include "libguile/arrays.h" #include "libguile/strings.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_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) \ @@ -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_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. */ diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c index ea5388d83..ff05151b3 100644 --- a/libguile/generalized-arrays.c +++ b/libguile/generalized-arrays.c @@ -138,9 +138,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, } #undef FUNC_NAME -/* HACK*/ -#include "libguile/bytevectors.h" - SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, (SCM ra), "") @@ -149,10 +146,6 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, 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); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 87ffaa5d1..f73265727 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -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 * 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 { 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? */ @@ -225,17 +224,17 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0, "") #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 diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 4627cfb89..f28f713e0 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -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 * 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) \ ((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; @@ -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_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); diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 738861928..b807046eb 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -1,6 +1,6 @@ /* srfi-4.c --- Uniform numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc. + * 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 @@ -22,809 +22,199 @@ # 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 +#include "libguile/extensions.h" +#include "libguile/uniform.h" +#include "libguile/generalized-vectors.h" +#include "libguile/validate.h" -#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; +#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); \ } - 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; -} +#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); \ + } -static SCM_C_INLINE_KEYWORD SCM -uvec_p (int type, SCM obj) -{ - return scm_from_bool (is_uvec (type, obj)); -} +#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); \ + } -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]); -} +#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); \ + } -/* 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); -} +#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); \ + } -static SCM -take_uvec (int type, void *base, size_t len) -{ - SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base); -} +#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"); \ -/* 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; + +#define ETYPE(TAG) \ + SCM_ARRAY_ELEMENT_TYPE_##TAG - 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; - } +#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; \ + } \ + } - scm_array_handle_release (&handle); - return scm_from_size_t (ans); -} -#undef FUNC_NAME +#define MOD "srfi srfi-4" -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)); - } +DEFINE_SRFI_4_PROXIES (u8); +DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8); - 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); - } +DEFINE_SRFI_4_PROXIES (s8); +DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8); - amount = (cend - cstart) * sz; - off = cstart * sz; +DEFINE_SRFI_4_PROXIES (u16); +DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16); - 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; - } +DEFINE_SRFI_4_PROXIES (s16); +DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16); - scm_array_handle_release (&handle); +DEFINE_SRFI_4_PROXIES (u32); +DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32); - return scm_from_size_t (ans); -} -#undef FUNC_NAME +DEFINE_SRFI_4_PROXIES (s32); +DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32); -/* ================================================================ */ -/* 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 +DEFINE_SRFI_4_PROXIES (u64); +#if SCM_HAVE_T_INT64 +DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64); #endif -#include "libguile/srfi-4.i.c" -#define TYPE SCM_UVEC_S64 -#define TAG s64 +DEFINE_SRFI_4_PROXIES (s64); #if SCM_HAVE_T_INT64 -#define CTYPE scm_t_int64 +DEFINE_SRFI_4_C_FUNCS (S64, s64, 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_SRFI_4_PROXIES (f32); +DEFINE_SRFI_4_C_FUNCS (F32, f32, float); -#define TYPE SCM_UVEC_C32 -#define TAG c32 -#define CTYPE float -#include "libguile/srfi-4.i.c" +DEFINE_SRFI_4_PROXIES (f64); +DEFINE_SRFI_4_C_FUNCS (F64, f64, double); -#define TYPE SCM_UVEC_C64 -#define TAG c64 -#define CTYPE double -#include "libguile/srfi-4.i.c" +#undef MOD +#define MOD "srfi srfi-4 gnu" -#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_SRFI_4_PROXIES (c32); +DEFINE_SRFI_4_C_FUNCS (C32, c32, float); -#define DEFPROXY100(cname, scmname) \ - DEFINE_SCHEME_PROXY100 (cname, MOD, scmname) +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); @@ -840,68 +230,60 @@ 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) +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 { - 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); + 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 */ + } } - -SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec), - SCM_SMOB_TYPE_MASK, - uvec_handle_ref, uvec_handle_set, - uvec_get_handle) +#undef FUNC_NAME 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], \ @@ -921,7 +303,6 @@ scm_init_srfi_4 (void) REGISTER (c64, C64); #include "libguile/srfi-4.x" - } /* End of srfi-4.c. */ diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 48001abe3..18b1cb184 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -23,6 +23,9 @@ #include "libguile/__scm.h" +SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill); + + /* Specific procedures. */ diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c deleted file mode 100644 index 098752ef2..000000000 --- a/libguile/srfi-4.i.c +++ /dev/null @@ -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 diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 1fe1959c1..bbffda0d4 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3562,6 +3562,9 @@ module '(ice-9 q) '(make-q q-length))}." ;; (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)) diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm index b133f2106..8438ba33a 100644 --- a/module/srfi/srfi-4.scm +++ b/module/srfi/srfi-4.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -26,46 +26,111 @@ ;;; 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 - ) diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm index c5c41ea92..ccb1ab1d8 100644 --- a/module/srfi/srfi-4/gnu.scm +++ b/module/srfi/srfi-4/gnu.scm @@ -23,13 +23,77 @@ ;;; 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) diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 4ac6204a5..a850dba2b 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -1,6 +1,6 @@ ;;;; 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 @@ -18,7 +18,9 @@ (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? |