diff options
-rw-r--r-- | libguile/bytevectors.c | 110 | ||||
-rw-r--r-- | test-suite/tests/srfi-4.test | 43 |
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))) |