mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Add type and range checks to the complex generalized vector accessors.

Browse source 
* libguile/bytevectors.c (COMPLEX_ACCESSOR_PROLOGUE, COMPLEX_NATIVE_REF,
  COMPLEX_NATIVE_SET): New macros.
  (bytevector_ref_c32, bytevector_ref_c64): Defined in terms of
  `COMPLEX_NATIVE_REF'.
  (bytevector_set_c32, bytevector_set_c64): Defined in terms of
  `COMPLEX_NATIVE_SET'.
  (bytevector_ref_fns): Make `static'.

* test-suite/tests/srfi-4.test ("c32 vectors")["generalized-vector-ref",
  "generalized-vector-set!", "generalized-vector-ref, out-of-range",
  "generalized-vector-set!, out-of-range"]: New tests.
  ("c64 vectors")["generalized-vector-ref", "generalized-vector-set!",
  "generalized-vector-ref, out-of-range",
  "generalized-vector-set!, out-of-range"]: New tests.
This commit is contained in:
Ludovic Courtès 2011-07-01 19:09:29 +02:00
parent 1e8f939229
commit 4bc95fccad
2 changed files with 105 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

114
libguile/bytevectors.c
View file

@ -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);
/* 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 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));
return scm_c_make_rectangular (real, imag);
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!!! */
static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
{
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));
/* 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_c64 (SCM bv, SCM idx, SCM val)
bytevector_set_c32 (SCM bv, SCM index, SCM value)
#define FUNC_NAME "bytevector_set_c32"
{
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 (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);

41
test-suite/tests/srfi-4.test
View file

@ -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)))