123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/__scm.h"
- #include "libguile/array-handle.h"
- #include "libguile/generalized-arrays.h"
- #include "libguile/generalized-vectors.h"
- struct scm_t_vector_ctor
- {
- SCM tag;
- SCM (*ctor)(SCM, SCM);
- };
- #define VECTOR_CTORS_N_STATIC_ALLOC 20
- static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC];
- static int num_vector_ctors_registered = 0;
- void
- scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM))
- {
- if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC)
-
- abort ();
- else
- {
- vector_ctors[num_vector_ctors_registered].tag = type;
- vector_ctors[num_vector_ctors_registered].ctor = ctor;
- num_vector_ctors_registered++;
- }
- }
- SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
- (SCM type, SCM len, SCM fill),
- "Make a generalized vector")
- #define FUNC_NAME s_scm_make_generalized_vector
- {
- int i;
- for (i = 0; i < num_vector_ctors_registered; i++)
- if (scm_is_eq (vector_ctors[i].tag, type))
- return vector_ctors[i].ctor(len, fill);
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
- }
- #undef FUNC_NAME
- int
- scm_is_generalized_vector (SCM obj)
- {
- int ret = 0;
- if (scm_is_array (obj))
- {
- scm_t_array_handle h;
- scm_array_get_handle (obj, &h);
- ret = scm_array_handle_rank (&h) == 1;
- scm_array_handle_release (&h);
- }
- return ret;
- }
- #define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
- scm_generalized_vector_get_handle (val, handle)
-
- void
- scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
- {
- scm_array_get_handle (vec, h);
- if (scm_array_handle_rank (h) != 1)
- {
- scm_array_handle_release (h);
- scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
- }
- }
- size_t
- scm_c_generalized_vector_length (SCM v)
- {
- return scm_c_array_length (v);
- }
- SCM
- scm_c_generalized_vector_ref (SCM v, ssize_t idx)
- {
- return scm_c_array_ref_1 (v, idx);
- }
- void
- scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
- {
- scm_c_array_set_1_x (v, val, idx);
- }
- void
- scm_init_generalized_vectors ()
- {
- #include "libguile/generalized-vectors.x"
- }
|