summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/bytevectors.c110
-rw-r--r--test-suite/tests/srfi-4.test43
2 files changed, 104 insertions, 49 deletions
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index b8af53ad3..7ac1fa34e 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -2092,36 +2092,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
/* 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);
-static SCM
-bytevector_ref_c32 (SCM bv, SCM idx)
-{ /* FIXME add some checks */
- float real, imag;
- const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
-
- memcpy (&real, &contents[i], sizeof (float));
- memcpy (&imag, &contents[i + sizeof (float)], sizeof (float));
+/* 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;
- return scm_c_make_rectangular (real, imag);
+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 idx)
-{ /* FIXME add some checks */
- double real, imag;
- const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
-
- memcpy (&real, &contents[i], sizeof (double));
- memcpy (&imag, &contents[i + sizeof (double)], sizeof (double));
-
- return scm_c_make_rectangular (real, imag);
+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);
-const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
+static const scm_t_bytevector_ref_fn
+bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
{
NULL, /* SCM */
NULL, /* CHAR */
@@ -2153,38 +2173,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
return ref_fn (h->array, byte_index);
}
-/* FIXME add checks!!! */
+/* 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 idx, SCM val)
+bytevector_set_c32 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c32"
{
- float imag, real;
- char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
-
- real = scm_c_real_part (val);
- imag = scm_c_imag_part (val);
-
- memcpy (&contents[i], &real, sizeof (float));
- memcpy (&contents[i + sizeof (float)], &imag, sizeof (float));
-
- return SCM_UNSPECIFIED;
+ COMPLEX_NATIVE_SET (float);
}
+#undef FUNC_NAME
static SCM
-bytevector_set_c64 (SCM bv, SCM idx, SCM val)
+bytevector_set_c64 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c64"
{
- double imag, real;
- char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
-
- real = scm_c_real_part (val);
- imag = scm_c_imag_part (val);
-
- memcpy (&contents[i], &real, sizeof (double));
- memcpy (&contents[i + sizeof (double)], &imag, sizeof (double));
-
- return SCM_UNSPECIFIED;
+ COMPLEX_NATIVE_SET (double);
}
+#undef FUNC_NAME
typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index fca065d55..2e7f0d5f5 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -436,7 +436,26 @@
(make-c32vector 4 7)))
(pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
- (c32vector? #c32(+inf.0 -inf.0 +nan.0))))
+ (c32vector? #c32(+inf.0 -inf.0 +nan.0)))
+
+ (pass-if "generalized-vector-ref"
+ (let ((v (c32vector 1+1i)))
+ (= (c32vector-ref v 0)
+ (generalized-vector-ref v 0))))
+
+ (pass-if "generalized-vector-set!"
+ (let ((x 1+1i)
+ (v (c32vector 0)))
+ (generalized-vector-set! v 0 x)
+ (= x (generalized-vector-ref v 0))))
+
+ (pass-if-exception "generalized-vector-ref, out-of-range"
+ exception:out-of-range
+ (generalized-vector-ref (c32vector 1.0) 1))
+
+ (pass-if-exception "generalized-vector-set!, out-of-range"
+ exception:out-of-range
+ (generalized-vector-set! (c32vector 1.0) 1 2.0)))
(with-test-prefix "c64 vectors"
@@ -476,5 +495,23 @@
(make-c64vector 4 7)))
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
- (c64vector? #c64(+inf.0 -inf.0 +nan.0))))
-
+ (c64vector? #c64(+inf.0 -inf.0 +nan.0)))
+
+ (pass-if "generalized-vector-ref"
+ (let ((v (c64vector 1+1i)))
+ (= (c64vector-ref v 0)
+ (generalized-vector-ref v 0))))
+
+ (pass-if "generalized-vector-set!"
+ (let ((x 1+1i)
+ (v (c64vector 0)))
+ (generalized-vector-set! v 0 x)
+ (= x (generalized-vector-ref v 0))))
+
+ (pass-if-exception "generalized-vector-ref, out-of-range"
+ exception:out-of-range
+ (generalized-vector-ref (c64vector 1.0) 1))
+
+ (pass-if-exception "generalized-vector-set!, out-of-range"
+ exception:out-of-range
+ (generalized-vector-set! (c64vector 1.0) 1 2.0)))