[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-724-gcf64dca
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-724-gcf64dca |
|
Date: |
Sun, 09 Feb 2014 11:52:16 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cf64dca65c4ee4d845a73e7d7c15ab7583aff15b
The branch, master has been updated
via cf64dca65c4ee4d845a73e7d7c15ab7583aff15b (commit)
via 8269f0be18c046d94f01f83dcff80794e97e6c27 (commit)
via b0d9b0744a6bfadbf172a90ed3b5b788555ca11d (commit)
via a0ef1252af3204e9d86087c5752f48790575d372 (commit)
via e6658f527e2decf4b353f14b36b71c6009ebe3d6 (commit)
via 2b5625ad0c93045d181d6c05eb9b94dc21462f22 (commit)
via 7070f12b9dc13f3b204acf2bd68c68b26e764990 (commit)
via d747313100cafb2d2e05c84b146e70df295d0931 (commit)
from a32488ba13e81e51c1fef9fb057bdd805e8b3d72 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cf64dca65c4ee4d845a73e7d7c15ab7583aff15b
Author: Andy Wingo <address@hidden>
Date: Sun Feb 9 12:31:59 2014 +0100
Remove array impl. registry; instead, hard-code array handle creation
* libguile/array-handle.h (scm_t_vector_ref, scm_t_vector_set): Rename
from scm_t_array_ref, scm_t_array_set. These were named
scm_i_t_array_ref and scm_i_t_array_set in 1.8 and 2.0. Change to
take the vector directly, instead of the array handle. In this way,
generic array handles are layered on top of specific implementations
of backing stores.
Remove scm_t_array_implementation, introduced in 2.0 but never
documented. It was a failed attempt to layer the array implementation
that actually introduced too many layers, as it prevented the "vref"
and "vset" members of scm_t_array_handle (called "ref" and "set" in
1.8, not present in 2.0) from specializing on array backing stores.
(scm_i_register_array_implementation)
(scm_i_array_implementation_for_obj):
Remove these internal interfaces.
(scm_t_array_handle): Adapt to scm_t_vector_ref / scm_t_vector_set
change.
(scm_array_handle_ref, scm_array_handle_set): Adapt to change in
vref/vset prototype.
* libguile/array-handle.c (scm_array_get_handle): Inline all the
necessary initializations here for all specific array types.
* libguile/array-map.c (rafill, racp, ramap, rafe, array_index_map_1):
* libguile/arrays.c: Remove array implementation code.
* libguile/bitvectors.h:
* libguile/bitvectors.c: Remove array implementation code.
(scm_i_bitvector_bits): New internal interface.
* libguile/bytevectors.c: Remove array implementation code.
* libguile/srfi-4.h: Remove declarations for internal procedures that
don't exist (!).
* libguile/strings.c: Remove array implementation code.
* libguile/vectors.c: Remove array implementation code.
commit 8269f0be18c046d94f01f83dcff80794e97e6c27
Author: Daniel Llorens <address@hidden>
Date: Fri Apr 19 12:57:13 2013 +0200
Fix array map functions with empty arguments
* libguile/array-map.c
- scm_ra_matchp: look for empty axes and return new case 5 if so. Use
array handles to remove the SCM_I_ARRAYP / not branch.
- scm_ramapc: Heed case 5.
* test-suite/tests/ramap.test
- test empty arguments for array-copy! and array-for-each. Note those
that failed in 2.0.9.
commit b0d9b0744a6bfadbf172a90ed3b5b788555ca11d
Author: Daniel Llorens <address@hidden>
Date: Fri Apr 19 10:42:40 2013 +0200
Fix empty array bug in array-index-map!
* libguile/array-map.c: (scm_array_index_map_x): bail out if any one of the
axes is empty.
* test-suite/tests/ramap.test: add tests for empty array-case of
array-index-map!. The 'f64 case with not-last emtpy axis is broken in
2.0.9.
commit a0ef1252af3204e9d86087c5752f48790575d372
Author: Andy Wingo <address@hidden>
Date: Sat Feb 8 22:11:36 2014 +0100
Add "vector" member to scm_t_array_handle
* libguile/array-handle.h (scm_t_array_handle): Add "vector" member.
* libguile/array-handle.c (scm_array_get_handle): Initialize the vector
member.
commit e6658f527e2decf4b353f14b36b71c6009ebe3d6
Author: Andy Wingo <address@hidden>
Date: Sat Feb 8 21:51:52 2014 +0100
Remove "impl" member of array handles.
* libguile/array-handle.h (scm_t_array_handle): Remove "impl" member.
* libguile/array-handle.c (scm_array_get_handle): Adapt.
commit 2b5625ad0c93045d181d6c05eb9b94dc21462f22
Author: Andy Wingo <address@hidden>
Date: Sat Feb 8 21:42:53 2014 +0100
Inline scm_i_array_implementation_for_obj in scm_i_array
* libguile/generalized-arrays.c (scm_is_array, scm_is_typed_array): In
preparation for removing the registry of array implementations, remove
a couple uss of scm_i_array_implementation_for_obj.
commit 7070f12b9dc13f3b204acf2bd68c68b26e764990
Author: Andy Wingo <address@hidden>
Date: Sat Feb 8 21:02:48 2014 +0100
vref, vset members of scm_t_array_handle
* libguile/array-handle.h (scm_t_array_ref, scm_t_array_set): Rename
from scm_i_t_array_ref, scm_i_t_array_set.
(scm_t_array_handle): Copy vref and vset from impl to handle.
(scm_array_handle_ref, scm_array_handle_set):
* libguile/array-map.c (racp, ramap, rafe, rafill, array_index_map_1):
* libguile/array-handle.c (scm_array_get_handle): Adapt.
commit d747313100cafb2d2e05c84b146e70df295d0931
Author: Daniel Llorens <address@hidden>
Date: Thu Apr 11 18:11:35 2013 +0200
Change uses of scm_is_simple_vector to scm_is_vector
* libguile/filesys.c, libguile/random.c, libguile/stime.c, libguile/trees.c,
libguile/validate.h: use scm_is_vector instead of scm_is_simple_vector.
* libguile/sort.c (scm_sort_x, scm_sort, scm_stable_sort_x)
(scm_stable_sort): Remove scm_is_vector check; scm_is_array is
sufficient.
* test-suite/tests/arrays.test: Fix header.
* test-suite/tests/random.test: New coverage test covering
random:normal-vector!.
* test-suite/Makefile.am: Include random.test in make check.
-----------------------------------------------------------------------
Summary of changes:
libguile/array-handle.c | 233 ++++++++++++++++++++++++++++++++++++-----
libguile/array-handle.h | 44 ++------
libguile/array-map.c | 163 ++++++++++++----------------
libguile/arrays.c | 34 ------
libguile/bitvectors.c | 39 ++------
libguile/bitvectors.h | 3 +-
libguile/bytevectors.c | 178 +-------------------------------
libguile/filesys.c | 10 +-
libguile/generalized-arrays.c | 17 +++-
libguile/random.c | 6 +-
libguile/sort.c | 16 +--
libguile/srfi-4.h | 7 +-
libguile/stime.c | 2 +-
libguile/strings.c | 30 +-----
libguile/trees.c | 4 +-
libguile/validate.h | 7 +-
libguile/vectors.c | 34 ------
test-suite/Makefile.am | 1 +
test-suite/tests/arrays.test | 2 +-
test-suite/tests/ramap.test | 83 +++++++++++++--
test-suite/tests/random.test | 55 ++++++++++
21 files changed, 463 insertions(+), 505 deletions(-)
create mode 100644 test-suite/tests/random.test
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 62d8520..84e9f88 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
- * 2006, 2009, 2011, 2013 Free Software Foundation, Inc.
+ * 2006, 2009, 2011, 2013, 2014 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
@@ -33,48 +33,223 @@
SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
-#define ARRAY_IMPLS_N_STATIC_ALLOC 7
-static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
-static int num_array_impls_registered = 0;
+/* Bytevectors as generalized vectors & arrays. */
+#define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
+ static SCM \
+ bytevector_##tag##_ref (SCM bv, size_t pos) \
+ { \
+ SCM idx = scm_from_size_t (pos * sizeof (type)); \
+ return scm_bytevector_##infix##_ref (bv, idx); \
+ } \
+ static void \
+ bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
+ { \
+ SCM idx = scm_from_size_t (pos * sizeof (type)); \
+ scm_bytevector_##infix##_set_x (bv, idx, val); \
+ }
-void
-scm_i_register_array_implementation (scm_t_array_implementation *impl)
+DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
+DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
+DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
+DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
+DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
+DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
+DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);
+
+/* Since these functions are only called by Guile's C code, we can abort
+ instead of throwing if there is an error. */
+static SCM
+bytevector_c32_ref (SCM bv, size_t pos)
+{
+ char *c_bv;
+ float real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (float);
+ if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ memcpy (&real, &c_bv[pos], sizeof (float));
+ memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
+ return scm_c_make_rectangular (real, imag);
+}
+
+static SCM
+bytevector_c64_ref (SCM bv, size_t pos)
+{
+ char *c_bv;
+ double real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (double);
+ if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ memcpy (&real, &c_bv[pos], sizeof (double));
+ memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
+ return scm_c_make_rectangular (real, imag);
+}
+
+static void
+bytevector_c32_set (SCM bv, size_t pos, SCM val)
+{
+ char *c_bv;
+ float real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (float);
+ if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ real = scm_c_real_part (val);
+ imag = scm_c_imag_part (val);
+ memcpy (&c_bv[pos], &real, sizeof (float));
+ memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
+}
+
+static void
+bytevector_c64_set (SCM bv, size_t pos, SCM val)
{
- if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
- /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
+ char *c_bv;
+ double real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (double);
+ if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
abort ();
- else
- array_impls[num_array_impls_registered++] = *impl;
+
+ real = scm_c_real_part (val);
+ imag = scm_c_imag_part (val);
+ memcpy (&c_bv[pos], &real, sizeof (double));
+ memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
}
-scm_t_array_implementation*
-scm_i_array_implementation_for_obj (SCM obj)
+static void
+initialize_vector_handle (scm_t_array_handle *h, size_t len,
+ scm_t_array_element_type element_type,
+ scm_t_vector_ref vref, scm_t_vector_set vset,
+ void *writable_elements)
{
- int i;
- for (i = 0; i < num_array_impls_registered; i++)
- if (SCM_NIMP (obj)
- && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
- return &array_impls[i];
- return NULL;
+ h->base = 0;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = (ssize_t) (len - 1U);
+ h->dim0.inc = 1;
+ h->element_type = element_type;
+ h->elements = h->writable_elements = writable_elements;
+ h->vector = h->array;
+ h->vref = vref;
+ h->vset = vset;
}
void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
- scm_t_array_implementation *impl = scm_i_array_implementation_for_obj
(array);
- if (!impl)
+ if (!SCM_HEAP_OBJECT_P (array))
scm_wrong_type_arg_msg (NULL, 0, array, "array");
+
h->array = array;
- h->impl = impl;
- h->base = 0;
- h->ndims = 0;
- h->dims = NULL;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
- something... */
- h->elements = NULL;
- h->writable_elements = NULL;
- h->impl->get_handle (array, h);
+
+ switch (SCM_TYP7 (array))
+ {
+ case scm_tc7_string:
+ initialize_vector_handle (h, scm_c_string_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_CHAR,
+ scm_c_string_ref, scm_c_string_set_x,
+ NULL);
+ break;
+ case scm_tc7_vector:
+ initialize_vector_handle (h, scm_c_vector_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_SCM,
+ scm_c_vector_ref, scm_c_vector_set_x,
+ SCM_I_VECTOR_WELTS (array));
+ break;
+ case scm_tc7_bitvector:
+ initialize_vector_handle (h, scm_c_bitvector_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_BIT,
+ scm_c_bitvector_ref, scm_c_bitvector_set_x,
+ scm_i_bitvector_bits (array));
+ break;
+ case scm_tc7_bytevector:
+ {
+ size_t byte_length, length, element_byte_size;
+ scm_t_array_element_type element_type;
+ scm_t_vector_ref vref;
+ scm_t_vector_set vset;
+
+ byte_length = scm_c_bytevector_length (array);
+ element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
+ element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
+ length = byte_length / element_byte_size;
+
+ switch (element_type)
+ {
+#define ACCESSOR_CASE(tag, TAG) \
+ case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
+ vref = bytevector_##tag##_ref; \
+ vset = bytevector_##tag##_set; \
+ break
+
+ case SCM_ARRAY_ELEMENT_TYPE_VU8:
+ ACCESSOR_CASE(u8, U8);
+ ACCESSOR_CASE(s8, S8);
+ ACCESSOR_CASE(u16, U16);
+ ACCESSOR_CASE(s16, S16);
+ ACCESSOR_CASE(u32, U32);
+ ACCESSOR_CASE(s32, S32);
+ ACCESSOR_CASE(u64, U64);
+ ACCESSOR_CASE(s64, S64);
+ ACCESSOR_CASE(f32, F32);
+ ACCESSOR_CASE(f64, F64);
+ ACCESSOR_CASE(c32, C32);
+ ACCESSOR_CASE(c64, C64);
+
+ case SCM_ARRAY_ELEMENT_TYPE_SCM:
+ case SCM_ARRAY_ELEMENT_TYPE_BIT:
+ case SCM_ARRAY_ELEMENT_TYPE_CHAR:
+ default:
+ abort ();
+
+#undef ACCESSOR_CASE
+ }
+
+ initialize_vector_handle (h, length, element_type, vref, vset,
+ SCM_BYTEVECTOR_CONTENTS (array));
+ }
+ break;
+ case scm_tc7_array:
+ h->base = SCM_I_ARRAY_BASE (array);
+ h->ndims = SCM_I_ARRAY_NDIM (array);
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ {
+ scm_t_array_handle vh;
+
+ scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+ h->element_type = vh.element_type;
+ h->elements = vh.elements;
+ h->writable_elements = vh.writable_elements;
+ h->vector = vh.vector;
+ h->vref = vh.vref;
+ h->vset = vh.vset;
+ scm_array_handle_release (&vh);
+ }
+ break;
+ default:
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+ }
}
ssize_t
diff --git a/libguile/array-handle.h b/libguile/array-handle.h
index fa2449d..a623b4e 100644
--- a/libguile/array-handle.h
+++ b/libguile/array-handle.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006,
- * 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
+ * 2008, 2009, 2011, 2013, 2014 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
@@ -30,35 +30,8 @@
-struct scm_t_array_handle;
-
-typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t);
-typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM);
-
-typedef struct
-{
- scm_t_bits tag;
- scm_t_bits mask;
- scm_i_t_array_ref vref;
- scm_i_t_array_set vset;
- void (*get_handle)(SCM, struct scm_t_array_handle*);
-} scm_t_array_implementation;
-
-#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \
- SCM_SNARF_INIT ({ \
- scm_t_array_implementation impl; \
- impl.tag = tag_; impl.mask = mask_; \
- impl.vref = vref_; impl.vset = vset_; \
- impl.get_handle = handle_; \
- scm_i_register_array_implementation (&impl); \
- })
-
-
-SCM_INTERNAL void scm_i_register_array_implementation
(scm_t_array_implementation *impl);
-SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj
(SCM obj);
-
-
-
+typedef SCM (*scm_t_vector_ref) (SCM, size_t);
+typedef void (*scm_t_vector_set) (SCM, size_t, SCM);
typedef struct scm_t_array_dim
{
@@ -93,7 +66,7 @@ SCM_INTERNAL SCM scm_i_array_element_types[];
typedef struct scm_t_array_handle {
SCM array;
- scm_t_array_implementation *impl;
+
/* `Base' is an offset into elements or writable_elements, corresponding to
the first element in the array. It would be nicer just to adjust the
elements/writable_elements pointer, but we can't because that element
might
@@ -107,6 +80,11 @@ typedef struct scm_t_array_handle {
scm_t_array_element_type element_type;
const void *elements;
void *writable_elements;
+
+ /* The backing store for the array, and its accessors. */
+ SCM vector;
+ scm_t_vector_ref vref;
+ scm_t_vector_set vset;
} scm_t_array_handle;
#define scm_array_handle_rank(h) ((h)->ndims)
@@ -135,7 +113,7 @@ scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
- return h->impl->vref (h, h->base + p);
+ return h->vref (h->vector, h->base + p);
}
SCM_INLINE_IMPLEMENTATION void
@@ -145,7 +123,7 @@ scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM
v)
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
- h->impl->vset (h, h->base + p, v);
+ h->vset (h->vector, h->base + p, v);
}
#endif
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 245cc1f..bef539d 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -74,108 +74,80 @@ cind (SCM ra, long *ve)
/* Checker for scm_array mapping functions:
- return values: 4 --> shapes, increments, and bases are the same;
+ return values:
+ 5 --> empty axes;
+ 4 --> shapes, increments, and bases are the same;
3 --> shapes and increments are the same;
2 --> shapes are the same;
1 --> ras are at least as big as ra0;
0 --> no match.
*/
-int
+int
scm_ra_matchp (SCM ra0, SCM ras)
{
- SCM ra1;
- scm_t_array_dim dims;
- scm_t_array_dim *s0 = &dims;
- scm_t_array_dim *s1;
- unsigned long bas0 = 0;
- int i, ndim = 1;
- int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
+ int i, exact = 4, empty = 0;
+ scm_t_array_handle h0;
- if (SCM_I_ARRAYP (ra0))
+ scm_array_get_handle (ra0, &h0);
+ for (i = 0; i < h0.ndims; ++i)
{
- ndim = SCM_I_ARRAY_NDIM (ra0);
- s0 = SCM_I_ARRAY_DIMS (ra0);
- bas0 = SCM_I_ARRAY_BASE (ra0);
+ empty = empty || (h0.dims[i].lbnd > h0.dims[i].ubnd);
}
- else if (scm_is_array (ra0))
- {
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = scm_c_array_length (ra0) - 1;
- }
- else
- return 0;
while (scm_is_pair (ras))
{
- ra1 = SCM_CAR (ras);
-
- if (!SCM_I_ARRAYP (ra1))
- {
- size_t length;
-
- if (1 != ndim)
- return 0;
+ scm_t_array_handle h1;
- length = scm_c_array_length (ra1);
+ scm_array_get_handle (SCM_CAR (ras), &h1);
- switch (exact)
- {
- case 4:
- if (0 != bas0)
- exact = 3;
- case 3:
- if (1 != s0->inc)
- exact = 2;
- case 2:
- if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= length)
- return 0;
- }
- }
- else if (ndim == SCM_I_ARRAY_NDIM (ra1))
- {
- s1 = SCM_I_ARRAY_DIMS (ra1);
- if (bas0 != SCM_I_ARRAY_BASE (ra1))
- exact = 3;
- for (i = 0; i < ndim; i++)
- switch (exact)
- {
- case 4:
- case 3:
- if (s0[i].inc != s1[i].inc)
- exact = 2;
- case 2:
- if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
- break;
- exact = 1;
- default:
- if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
- return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
- }
- }
- else
- return 0;
+ if (h0.ndims != h1.ndims)
+ {
+ scm_array_handle_release (&h0);
+ scm_array_handle_release (&h1);
+ return 0;
+ }
+ if (h0.base != h1.base)
+ exact = min(3, exact);
+ for (i = 0; i < h0.ndims; ++i)
+ {
+ empty = empty || (h1.dims[i].lbnd > h1.dims[i].ubnd);
+ switch (exact)
+ {
+ case 4:
+ case 3:
+ if (h0.dims[i].inc != h1.dims[i].inc)
+ exact = 2;
+ case 2:
+ if (h0.dims[i].lbnd == h1.dims[i].lbnd && h0.dims[i].ubnd ==
h1.dims[i].ubnd)
+ break;
+ exact = 1;
+ default:
+ if (h0.dims[i].lbnd < h1.dims[i].lbnd || h0.dims[i].ubnd >
h1.dims[i].ubnd)
+ {
+ scm_array_handle_release (&h0);
+ scm_array_handle_release (&h1);
+ return 0;
+ }
+ }
+ }
+ scm_array_handle_release (&h1);
ras = SCM_CDR (ras);
}
-
- return exact;
+ scm_array_handle_release (&h0);
+ return empty ? 5 : exact;
}
-/* array mapper: apply cproc to each dimension of the given arrays?.
+/* array mapper: apply cproc to each dimension of the given arrays?.
int (*cproc) (); procedure to call on unrolled arrays?
cproc (dest, source list) or
- cproc (dest, data, source list).
- SCM data; data to give to cproc or unbound.
+ cproc (dest, data, source list).
+ SCM data; data to give to cproc or unbound.
SCM ra0; destination array.
SCM lra; list of source arrays.
const char *what; caller, for error reporting. */
-int
+int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
SCM z;
@@ -320,6 +292,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra,
const char *what)
}
while (k >= 0);
+ case 5:
return 1;
}
}
@@ -336,7 +309,7 @@ rafill (SCM dst, SCM fill)
inc = SCM_I_ARRAY_DIMS (dst)->inc;
for (; n-- > 0; i += inc)
- h.impl->vset (&h, i, fill);
+ h.vset (h.vector, i, fill);
scm_array_handle_release (&h);
return 1;
@@ -372,7 +345,7 @@ racp (SCM src, SCM dst)
inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+ h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s));
scm_array_handle_release (&h_d);
scm_array_handle_release (&h_s);
@@ -674,7 +647,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
- h0.impl->vset (&h0, i0, scm_call_0 (proc));
+ h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
@@ -687,7 +660,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
ras = SCM_CDR (ras);
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0, i1 += inc1)
- h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1,
i1)));
+ h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector,
i1)));
else
{
ras = scm_vector (ras);
@@ -697,7 +670,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1,
i1), args));
+ h0.vset (h0.vector, i0,
+ scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
}
scm_array_handle_release (&h1);
@@ -747,7 +721,7 @@ rafe (SCM ra0, SCM proc, SCM ras)
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
- scm_call_1 (proc, h0.impl->vref (&h0, i0));
+ scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
ras = scm_vector (ras);
@@ -757,7 +731,7 @@ rafe (SCM ra0, SCM proc, SCM ras)
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
+ scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
}
scm_array_handle_release (&h0);
@@ -783,12 +757,10 @@ array_index_map_1 (SCM ra, SCM proc)
scm_t_array_handle h;
ssize_t i, inc;
size_t p;
- SCM v;
scm_array_get_handle (ra, &h);
- v = h.array;
inc = h.dims[0].inc;
for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
- h.impl->vset (&h, p, scm_call_1 (proc, scm_from_ulong (i)));
+ h.vset (h.vector, p, scm_call_1 (proc, scm_from_ulong (i)));
scm_array_handle_release (&h);
}
@@ -806,7 +778,11 @@ array_index_map_n (SCM ra, SCM proc)
indices_gc_hint);
for (k = 0; k <= kmax; k++)
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ {
+ vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ if (vinds[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ return;
+ }
k = kmax;
do
{
@@ -822,16 +798,17 @@ array_index_map_n (SCM ra, SCM proc)
i += SCM_I_ARRAY_DIMS (ra)[k].inc;
}
k--;
- continue;
}
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ else if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
{
vinds[k]++;
k++;
- continue;
}
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
- k--;
+ else
+ {
+ vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
+ k--;
+ }
}
while (k >= 0);
}
diff --git a/libguile/arrays.c b/libguile/arrays.c
index a771739..84d0f71 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -819,40 +819,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-static SCM
-array_handle_ref (scm_t_array_handle *hh, size_t pos)
-{
- return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh->array), pos);
-}
-
-static void
-array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val)
-{
- scm_c_array_set_1_x (SCM_I_ARRAY_V (hh->array), val, pos);
-}
-
-/* FIXME: should be handle for vect? maybe not, because of dims */
-static void
-array_get_handle (SCM array, scm_t_array_handle *h)
-{
- scm_t_array_handle vh;
- scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
- assert (vh.dims[0].inc == 1 && vh.dims[0].lbnd == 0 && vh.base == 0);
- h->element_type = vh.element_type;
- h->elements = vh.elements;
- h->writable_elements = vh.writable_elements;
- scm_array_handle_release (&vh);
-
- h->dims = SCM_I_ARRAY_DIMS (array);
- h->ndims = SCM_I_ARRAY_NDIM (array);
- h->base = SCM_I_ARRAY_BASE (array);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
- 0x7f,
- array_handle_ref, array_handle_set,
- array_get_handle)
-
void
scm_init_arrays ()
{
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 2eef1dc..1611119 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011, 2012, 2013, 2014 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
@@ -42,6 +42,13 @@
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj))
+scm_t_uint32 *scm_i_bitvector_bits (SCM vec)
+{
+ if (!IS_BITVECTOR (vec))
+ abort ();
+ return BITVECTOR_BITS (vec);
+}
+
int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{
@@ -852,36 +859,6 @@ scm_istr2bve (SCM str)
return res;
}
-/* FIXME: h->array should be h->vector */
-static SCM
-bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
-{
- return scm_c_bitvector_ref (h->array, pos);
-}
-
-static void
-bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
-{
- scm_c_bitvector_set_x (h->array, pos, val);
-}
-
-static void
-bitvector_get_handle (SCM bv, scm_t_array_handle *h)
-{
- h->array = bv;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
- h->elements = h->writable_elements = BITVECTOR_BITS (bv);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_bitvector,
- 0x7f,
- bitvector_handle_ref, bitvector_handle_set,
- bitvector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector)
void
diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h
index 6b25327..6b2cb1e 100644
--- a/libguile/bitvectors.h
+++ b/libguile/bitvectors.h
@@ -3,7 +3,7 @@
#ifndef SCM_BITVECTORS_H
#define SCM_BITVECTORS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2014
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
@@ -70,6 +70,7 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM
vec,
size_t *lenp,
ssize_t *incp);
+SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec);
SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state
*pstate);
SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2);
SCM_INTERNAL void scm_init_bitvectors (void);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 064c427..c7908d7 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -2081,168 +2081,6 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
#undef FUNC_NAME
-/* Bytevectors as generalized vectors & arrays. */
-
-#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
- size_t c_len, c_index; \
- char *c_bv; \
- \
- SCM_VALIDATE_BYTEVECTOR (1, bv); \
- c_index = scm_to_size_t (index); \
- \
- c_len = SCM_BYTEVECTOR_LENGTH (bv); \
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
- \
- if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
- scm_out_of_range (FUNC_NAME, index);
-
-/* Template for native access to complex numbers of type TYPE. */
-#define COMPLEX_NATIVE_REF(_type) \
- SCM result; \
- \
- COMPLEX_ACCESSOR_PROLOGUE (_type); \
- \
- { \
- _type real, imag; \
- \
- memcpy (&real, &c_bv[c_index], sizeof (_type)); \
- memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
- \
- result = scm_c_make_rectangular (real, imag); \
- } \
- \
- return result;
-
-static SCM
-bytevector_ref_c32 (SCM bv, SCM index)
-#define FUNC_NAME "bytevector_ref_c32"
-{
- COMPLEX_NATIVE_REF (float);
-}
-#undef FUNC_NAME
-
-static SCM
-bytevector_ref_c64 (SCM bv, SCM index)
-#define FUNC_NAME "bytevector_ref_c64"
-{
- COMPLEX_NATIVE_REF (double);
-}
-#undef FUNC_NAME
-
-typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
-
-static const scm_t_bytevector_ref_fn
-bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
-{
- NULL, /* SCM */
- NULL, /* CHAR */
- NULL, /* BIT */
- scm_bytevector_u8_ref, /* VU8 */
- scm_bytevector_u8_ref, /* U8 */
- scm_bytevector_s8_ref,
- scm_bytevector_u16_native_ref,
- scm_bytevector_s16_native_ref,
- scm_bytevector_u32_native_ref,
- scm_bytevector_s32_native_ref,
- scm_bytevector_u64_native_ref,
- scm_bytevector_s64_native_ref,
- scm_bytevector_ieee_single_native_ref,
- scm_bytevector_ieee_double_native_ref,
- bytevector_ref_c32,
- bytevector_ref_c64
-};
-
-static SCM
-bv_handle_ref (scm_t_array_handle *h, size_t index)
-{
- SCM byte_index;
- scm_t_bytevector_ref_fn ref_fn;
-
- ref_fn = bytevector_ref_fns[h->element_type];
- byte_index =
- scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
- return ref_fn (h->array, byte_index);
-}
-
-/* Template for native modification of complex numbers of type TYPE. */
-#define COMPLEX_NATIVE_SET(_type) \
- COMPLEX_ACCESSOR_PROLOGUE (_type); \
- \
- { \
- _type real, imag; \
- real = scm_c_real_part (value); \
- imag = scm_c_imag_part (value); \
- \
- memcpy (&c_bv[c_index], &real, sizeof (_type)); \
- memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
- } \
- \
- return SCM_UNSPECIFIED;
-
-static SCM
-bytevector_set_c32 (SCM bv, SCM index, SCM value)
-#define FUNC_NAME "bytevector_set_c32"
-{
- COMPLEX_NATIVE_SET (float);
-}
-#undef FUNC_NAME
-
-static SCM
-bytevector_set_c64 (SCM bv, SCM index, SCM value)
-#define FUNC_NAME "bytevector_set_c64"
-{
- COMPLEX_NATIVE_SET (double);
-}
-#undef FUNC_NAME
-
-typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
-
-const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST +
1] =
-{
- NULL, /* SCM */
- NULL, /* CHAR */
- NULL, /* BIT */
- scm_bytevector_u8_set_x, /* VU8 */
- scm_bytevector_u8_set_x, /* U8 */
- scm_bytevector_s8_set_x,
- scm_bytevector_u16_native_set_x,
- scm_bytevector_s16_native_set_x,
- scm_bytevector_u32_native_set_x,
- scm_bytevector_s32_native_set_x,
- scm_bytevector_u64_native_set_x,
- scm_bytevector_s64_native_set_x,
- scm_bytevector_ieee_single_native_set_x,
- scm_bytevector_ieee_double_native_set_x,
- bytevector_set_c32,
- bytevector_set_c64
-};
-
-static void
-bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
-{
- SCM byte_index;
- scm_t_bytevector_set_fn set_fn;
-
- set_fn = bytevector_set_fns[h->element_type];
- byte_index =
- scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
- set_fn (h->array, byte_index, val);
-}
-
-static void
-bytevector_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_BYTEVECTOR_TYPED_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
- h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
-}
-
-
/* Initialization. */
void
@@ -2264,19 +2102,9 @@ scm_bootstrap_bytevectors (void)
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
- {
- scm_t_array_implementation impl;
-
- impl.tag = scm_tc7_bytevector;
- impl.mask = 0x7f;
- impl.vref = bv_handle_ref;
- impl.vset = bv_handle_set_x;
- impl.get_handle = bytevector_get_handle;
- scm_i_register_array_implementation (&impl);
- scm_i_register_vector_constructor
- (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
- scm_make_bytevector);
- }
+ scm_i_register_vector_constructor
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
+ scm_make_bytevector);
}
void
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 8597f90..aa3e671 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -694,7 +694,7 @@ fill_select_type (fd_set *set, SCM *ports_ready, SCM
list_or_vec, int pos)
{
int max_fd = 0;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
@@ -755,7 +755,7 @@ retrieve_select_type (fd_set *set, SCM ports_ready, SCM
list_or_vec)
{
SCM answer_list = ports_ready;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
@@ -824,7 +824,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
SCM write_ports_ready = SCM_EOL;
int max_fd;
- if (scm_is_simple_vector (reads))
+ if (scm_is_vector (reads))
{
read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
}
@@ -833,7 +833,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
read_count = scm_ilength (reads);
SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
}
- if (scm_is_simple_vector (writes))
+ if (scm_is_vector (writes))
{
write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
}
@@ -842,7 +842,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
write_count = scm_ilength (writes);
SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
}
- if (scm_is_simple_vector (excepts))
+ if (scm_is_vector (excepts))
{
except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
}
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 88c1cde..9a001eb 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -42,7 +42,20 @@ SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
int
scm_is_array (SCM obj)
{
- return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
+ if (!SCM_HEAP_OBJECT_P (obj))
+ return 0;
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_string:
+ case scm_tc7_vector:
+ case scm_tc7_bitvector:
+ case scm_tc7_bytevector:
+ case scm_tc7_array:
+ return 1;
+ default:
+ return 0;
+ }
}
SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
@@ -69,7 +82,7 @@ int
scm_is_typed_array (SCM obj, SCM type)
{
int ret = 0;
- if (scm_i_array_implementation_for_obj (obj))
+ if (scm_is_array (obj))
{
scm_t_array_handle h;
diff --git a/libguile/random.c b/libguile/random.c
index 6df2cd9..915f17f 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -504,7 +504,7 @@ static void
vector_scale_x (SCM v, double c)
{
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
@@ -532,7 +532,7 @@ vector_sum_squares (SCM v)
{
double x, sum = 0.0;
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
@@ -626,7 +626,7 @@ SCM_DEFINE (scm_random_normal_vector_x,
"random:normal-vector!", 1, 1, 0,
scm_generalized_vector_get_handle (v, &handle);
dim = scm_array_handle_dims (&handle);
- if (scm_is_vector (v))
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
{
SCM *elts = scm_array_handle_writable_elements (&handle);
for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
diff --git a/libguile/sort.c b/libguile/sort.c
index 998be89..9373fb8 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -377,8 +377,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
{
scm_restricted_vector_sort_x (items,
less,
@@ -404,8 +403,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
return scm_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
@@ -491,8 +489,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
{
scm_t_array_handle temp_handle, vec_handle;
SCM temp, *temp_elts, *vec_elts;
@@ -535,16 +532,13 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less);
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
- return scm_stable_sort_x (scm_vector_copy (items), less);
else
- SCM_WRONG_TYPE_ARG (1, items);
+ return scm_stable_sort_x (scm_vector_copy (items), less);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
+SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. The sorting is destructive, that means that the\n"
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 0e5afc3..f56c3f3 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -2,7 +2,7 @@
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software
Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010, 2011, 2014 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
@@ -274,11 +274,6 @@ SCM_API double *scm_c64vector_writable_elements (SCM uvec,
size_t *lenp,
ssize_t *incp);
-SCM_INTERNAL SCM scm_i_generalized_vector_type (SCM vec);
-SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec);
-SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
-SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);
-
SCM_INTERNAL void scm_init_srfi_4 (void);
#endif /* SCM_SRFI_4_H */
diff --git a/libguile/stime.c b/libguile/stime.c
index 78539d9..c876925 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -506,7 +506,7 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
- SCM_ASSERT (scm_is_simple_vector (sbd_time)
+ SCM_ASSERT (scm_is_vector (sbd_time)
&& SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
sbd_time, pos, subr);
diff --git a/libguile/strings.c b/libguile/strings.c
index e8eb91c..90dc83a 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011,
2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011,
2012, 2013, 2014 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
@@ -2465,34 +2465,6 @@ scm_i_get_substring_spec (size_t len,
*cend = scm_to_unsigned_integer (end, *cstart, len);
}
-static SCM
-string_handle_ref (scm_t_array_handle *h, size_t index)
-{
- return scm_c_string_ref (h->array, index);
-}
-
-static void
-string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
-{
- scm_c_string_set_x (h->array, index, val);
-}
-
-static void
-string_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_c_string_length (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
- h->elements = h->writable_elements = NULL;
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f,
- string_handle_ref, string_handle_set,
- string_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
void
diff --git a/libguile/trees.c b/libguile/trees.c
index 76bb686..88adf88 100644
--- a/libguile/trees.c
+++ b/libguile/trees.c
@@ -99,7 +99,7 @@ copy_tree (struct t_trace *const hare,
unsigned int tortoise_delay)
#define FUNC_NAME s_scm_copy_tree
{
- if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+ if (!scm_is_pair (hare->obj) && !scm_is_vector (hare->obj))
{
return hare->obj;
}
@@ -128,7 +128,7 @@ copy_tree (struct t_trace *const hare,
--tortoise_delay;
}
- if (scm_is_simple_vector (hare->obj))
+ if (scm_is_vector (hare->obj))
{
size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
diff --git a/libguile/validate.h b/libguile/validate.h
index 68ff374..6d57b9e 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -4,7 +4,7 @@
#define SCM_VALIDATE_H
/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2009,
- * 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 2011, 2012, 2013, 2014 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
@@ -358,13 +358,12 @@
#define SCM_VALIDATE_VECTOR(pos, v) \
do { \
- SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
+ SCM_ASSERT (scm_is_vector (v), v, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
do { \
- SCM_ASSERT ((scm_is_simple_vector (v) \
- || (scm_is_true (scm_f64vector_p (v)))), \
+ SCM_ASSERT (scm_is_vector (v) || scm_is_true (scm_f64vector_p (v)), \
v, pos, FUNC_NAME); \
} while (0)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index bb42e00..5dab545 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -432,40 +432,6 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!",
5, 0, 0,
#undef FUNC_NAME
-static SCM
-vector_handle_ref (scm_t_array_handle *h, size_t idx)
-{
- if (idx > h->dims[0].ubnd)
- scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
- return ((SCM*)h->elements)[idx];
-}
-
-static void
-vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
-{
- if (idx > h->dims[0].ubnd)
- scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
- ((SCM*)h->writable_elements)[idx] = val;
-}
-
-static void
-vector_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_I_VECTOR_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
- h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
-}
-
-/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
- tags.h. */
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
- vector_handle_ref, vector_handle_set,
- vector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 6df9826..4d08d06 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -111,6 +111,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
tests/ramap.test \
+ tests/random.test \
tests/rdelim.test \
tests/reader.test \
tests/receive.test \
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 015470c..090338f 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,4 +1,4 @@
-;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
+;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
;;;;
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 00de626..299df9f 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -19,6 +19,9 @@
(define-module (test-suite test-ramap)
#:use-module (test-suite lib))
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
(define (array-row a i)
(make-shared-array a (lambda (j) (list i j))
(cadr (array-dimensions a))))
@@ -33,11 +36,33 @@
(with-test-prefix "array-index-map!"
- (pass-if (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1)))))
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t)))
;;;
;;; array-copy!
@@ -45,11 +70,23 @@
(with-test-prefix "array-copy!"
- (pass-if "empty arrays"
- (let* ((b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2:0:2() c))))
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add type 'b cases.
+
+ ))
;;;
;;; array-map!
@@ -300,4 +337,28 @@
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l))))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
diff --git a/test-suite/tests/random.test b/test-suite/tests/random.test
new file mode 100644
index 0000000..ab20b58
--- /dev/null
+++ b/test-suite/tests/random.test
@@ -0,0 +1,55 @@
+;;;; random.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2013 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
+
+(define-module (test-suite test-random)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
+
+; see strings.test, arrays.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+;;;
+;;; random:normal-vector!
+;;;
+
+(with-test-prefix "random:normal-vector!"
+
+ ;; FIXME need proper function test.
+
+ (pass-if "non uniform"
+ (let ((a (make-vector 4 0))
+ (b (make-vector 4 0))
+ (c (make-shared-array (make-vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c))))))
+
+ (pass-if "uniform (f64)"
+ (let ((a (make-f64vector 4 0))
+ (b (make-f64vector 4 0))
+ (c (make-shared-array (make-f64vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-724-gcf64dca,
Andy Wingo <=