guile18/libguile/srfi-4.i.c

   1 /* This file defines the procedures related to one type of uniform
   2    numeric vector.  It is included multiple time in srfi-4.c, once for
   3    each type.
   4
   5    Before inclusion, the following macros must be defined.  They are
   6    undefined at the end of this file to get back to a clean slate for
   7    the next inclusion.
   8
   9    - TYPE
  10
  11    The type tag of the vector, for example SCM_UVEC_U8
  12
  13    - TAG
  14
  15    The tag name of the vector, for example u8.  The tag is used to
  16    form the function names and is included in the docstrings, for
  17    example.
  18
  19    - CTYPE
  20
  21    The C type of the elements, for example scm_t_uint8.  The code
  22    below will never do sizeof (CTYPE), thus you can use just 'float'
  23    for the c32 type, for example.
  24
  25    When CTYPE is not defined, the functions using it are excluded.
  26 */
  27
  28 /* The first level does not expand macros in the arguments. */
  29 #define paste(a1,a2,a3)   a1##a2##a3
  30 #define s_paste(a1,a2,a3) s_##a1##a2##a3
  31 #define stringify(a)      #a
  32
  33 /* But the second level does. */
  34 #define F(pre,T,suf)   paste(pre,T,suf)
  35 #define s_F(pre,T,suf) s_paste(pre,T,suf)
  36 #define S(T)           stringify(T)
  37
  38 SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
  39             (SCM obj),
  40             "Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
  41             "@code{#f} otherwise.")
  42 #define FUNC_NAME s_F(scm_, TAG, vector_p)
  43 {
  44   return uvec_p (TYPE, obj);
  45 }
  46 #undef FUNC_NAME
  47
  48 SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
  49             (SCM len, SCM fill),
  50             "Return a newly allocated uniform numeric vector which can\n"
  51             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
  52             "initialize the elements, otherwise the contents of the vector\n"
  53             "is unspecified.")
  54 #define FUNC_NAME s_S(scm_make_,TAG,vector)
  55 {
  56   return make_uvec (TYPE, len, fill);
  57 }
  58 #undef FUNC_NAME
  59
  60 SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
  61             (SCM l),
  62             "Return a newly allocated uniform numeric vector containing\n"
  63             "all argument values.")
  64 #define FUNC_NAME s_F(scm_,TAG,vector)
  65 {
  66   return list_to_uvec (TYPE, l);
  67 }
  68 #undef FUNC_NAME
  69
  70
  71 SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
  72             (SCM uvec),
  73             "Return the number of elements in the uniform numeric vector\n"
  74             "@var{uvec}.")
  75 #define FUNC_NAME s_F(scm_,TAG,vector_length)
  76 {
  77   return uvec_length (TYPE, uvec);
  78 }
  79 #undef FUNC_NAME
  80
  81
  82 SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
  83             (SCM uvec, SCM index),
  84             "Return the element at @var{index} in the uniform numeric\n"
  85             "vector @var{uvec}.")
  86 #define FUNC_NAME s_F(scm_,TAG,vector_ref)
  87 {
  88   return uvec_ref (TYPE, uvec, index);
  89 }
  90 #undef FUNC_NAME
  91
  92
  93 SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
  94             (SCM uvec, SCM index, SCM value),
  95             "Set the element at @var{index} in the uniform numeric\n"
  96             "vector @var{uvec} to @var{value}.  The return value is not\n"
  97             "specified.")
  98 #define FUNC_NAME s_F(scm_,TAG,vector_set_x)
  99 {
 100   return uvec_set_x (TYPE, uvec, index, value);
 101 }
 102 #undef FUNC_NAME
 103
 104
 105 SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
 106             (SCM uvec),
 107             "Convert the uniform numeric vector @var{uvec} to a list.")
 108 #define FUNC_NAME s_F(scm_,TAG,vector_to_list)
 109 {
 110   return uvec_to_list (TYPE, uvec);
 111 }
 112 #undef FUNC_NAME
 113
 114
 115 SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
 116             (SCM l),
 117             "Convert the list @var{l} to a numeric uniform vector.")
 118 #define FUNC_NAME s_F(scm_list_to_,TAG,vector)
 119 {
 120   return list_to_uvec (TYPE, l);
 121 }
 122 #undef FUNC_NAME
 123
 124 SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
 125             (SCM obj),
 126             "Convert @var{obj}, which can be a list, vector, or\n"
 127             "uniform vector, to a numeric uniform vector of\n"
 128             "type " S(TAG)".")
 129 #define FUNC_NAME s_F(scm_any_to_,TAG,vector)
 130 {
 131   return coerce_to_uvec (TYPE, obj);
 132 }
 133 #undef FUNC_NAME
 134
 135 #ifdef CTYPE
 136
 137 SCM
 138 F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
 139 {
 140   scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE],
 141                                       uvec_names[TYPE]);
 142   return take_uvec (TYPE, data, n);
 143 }
 144
 145 const CTYPE *
 146 F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
 147 {
 148   return F(scm_array_handle_,TAG,_writable_elements) (h);
 149 }
 150
 151 CTYPE *
 152 F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
 153 {
 154   SCM vec = h->array;
 155   if (SCM_I_ARRAYP (vec))
 156     vec = SCM_I_ARRAY_V (vec);
 157   uvec_assert (TYPE, vec);
 158   if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
 159     return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
 160   else
 161     return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
 162 }
 163
 164 const CTYPE *
 165 F(scm_,TAG,vector_elements) (SCM uvec,
 166                              scm_t_array_handle *h,
 167                              size_t *lenp, ssize_t *incp)
 168 {
 169   return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
 170 }
 171
 172 CTYPE *
 173 F(scm_,TAG,vector_writable_elements) (SCM uvec,
 174                                       scm_t_array_handle *h,
 175                                       size_t *lenp, ssize_t *incp)
 176 {
 177   scm_generalized_vector_get_handle (uvec, h);
 178   if (lenp)
 179     {
 180       scm_t_array_dim *dim = scm_array_handle_dims (h);
 181       *lenp = dim->ubnd - dim->lbnd + 1;
 182       *incp = dim->inc;
 183     }
 184   return F(scm_array_handle_,TAG,_writable_elements) (h);
 185 }
 186
 187 #endif
 188
 189 static SCM
 190 F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos)
 191 {
 192   return uvec_fast_ref (TYPE, handle->elements, pos);
 193 }
 194
 195 static void
 196 F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val)
 197 {
 198   uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
 199 }
 200
 201 #undef paste
 202 #undef s_paste
 203 #undef stringify
 204 #undef F
 205 #undef s_F
 206 #undef S
 207
 208 #undef TYPE
 209 #undef TAG
 210 #undef CTYPE