libguile/generalized-vectors.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/__scm.h"
  28
  29 #include "libguile/array-handle.h"
  30 #include "libguile/generalized-arrays.h"
  31 #include "libguile/generalized-vectors.h"
  32
  33
  34 struct scm_t_vector_ctor
  35 {
  36   SCM tag;
  37   SCM (*ctor)(SCM, SCM);
  38 };
  39
  40 #define VECTOR_CTORS_N_STATIC_ALLOC 20
  41 static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC];
  42 static int num_vector_ctors_registered = 0;
  43
  44 void
  45 scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM))
  46 {
  47   if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC)
  48     /* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */
  49     abort ();
  50   else
  51     {
  52       vector_ctors[num_vector_ctors_registered].tag = type;
  53       vector_ctors[num_vector_ctors_registered].ctor = ctor;
  54       num_vector_ctors_registered++;
  55     }
  56 }
  57
  58 SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
  59             (SCM type, SCM len, SCM fill),
  60             "Make a generalized vector")
  61 #define FUNC_NAME s_scm_make_generalized_vector
  62 {
  63   int i;
  64   for (i = 0; i < num_vector_ctors_registered; i++)
  65     if (scm_is_eq (vector_ctors[i].tag, type))
  66       return vector_ctors[i].ctor(len, fill);
  67   scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
  68 }
  69 #undef FUNC_NAME
  70
  71 int
  72 scm_is_generalized_vector (SCM obj)
  73 {
  74   int ret = 0;
  75   if (scm_is_array (obj))
  76     {
  77       scm_t_array_handle h;
  78       scm_array_get_handle (obj, &h);
  79       ret = scm_array_handle_rank (&h) == 1;
  80       scm_array_handle_release (&h);
  81     }
  82   return ret;
  83 }
  84
  85 SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
  86             (SCM obj),
  87             "Return @code{#t} if @var{obj} is a vector, string,\n"
  88             "bitvector, or uniform numeric vector.")
  89 #define FUNC_NAME s_scm_generalized_vector_p
  90 {
  91   return scm_from_bool (scm_is_generalized_vector (obj));
  92 }
  93 #undef FUNC_NAME
  94
  95 #define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle)   \
  96   scm_generalized_vector_get_handle (val, handle)
  97
  98
  99 void
 100 scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
 101 {
 102   scm_array_get_handle (vec, h);
 103   if (scm_array_handle_rank (h) != 1)
 104     {
 105       scm_array_handle_release (h);
 106       scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
 107     }
 108 }
 109
 110 size_t
 111 scm_c_generalized_vector_length (SCM v)
 112 {
 113   scm_t_array_handle h;
 114   size_t ret;
 115   scm_generalized_vector_get_handle (v, &h);
 116   ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
 117   scm_array_handle_release (&h);
 118   return ret;
 119 }
 120
 121 SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
 122             (SCM v),
 123             "Return the length of the generalized vector @var{v}.")
 124 #define FUNC_NAME s_scm_generalized_vector_length
 125 {
 126   return scm_from_size_t (scm_c_generalized_vector_length (v));
 127 }
 128 #undef FUNC_NAME
 129
 130 SCM
 131 scm_c_generalized_vector_ref (SCM v, size_t idx)
 132 {
 133   scm_t_array_handle h;
 134   size_t pos;
 135   SCM ret;
 136   scm_generalized_vector_get_handle (v, &h);
 137   pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
 138   ret = h.impl->vref (&h, pos);
 139   scm_array_handle_release (&h);
 140   return ret;
 141 }
 142
 143 SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
 144             (SCM v, SCM idx),
 145             "Return the element at index @var{idx} of the\n"
 146             "generalized vector @var{v}.")
 147 #define FUNC_NAME s_scm_generalized_vector_ref
 148 {
 149   return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
 150 }
 151 #undef FUNC_NAME
 152
 153 void
 154 scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
 155 {
 156   scm_t_array_handle h;
 157   size_t pos;
 158   scm_generalized_vector_get_handle (v, &h);
 159   pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
 160   h.impl->vset (&h, pos, val);
 161   scm_array_handle_release (&h);
 162 }
 163
 164 SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
 165             (SCM v, SCM idx, SCM val),
 166             "Set the element at index @var{idx} of the\n"
 167             "generalized vector @var{v} to @var{val}.")
 168 #define FUNC_NAME s_scm_generalized_vector_set_x
 169 {
 170   scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
 171   return SCM_UNSPECIFIED;
 172 }
 173 #undef FUNC_NAME
 174
 175 SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
 176             (SCM v),
 177             "Return a new list whose elements are the elements of the\n"
 178             "generalized vector @var{v}.")
 179 #define FUNC_NAME s_scm_generalized_vector_to_list
 180 {
 181   SCM ret = SCM_EOL;
 182   ssize_t pos, i = 0;
 183   scm_t_array_handle h;
 184   scm_generalized_vector_get_handle (v, &h);
 185   for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd);
 186        i >= 0;
 187        pos -= h.dims[0].inc, i--)
 188     ret = scm_cons (h.impl->vref (&h, pos), ret);
 189   scm_array_handle_release (&h);
 190   return ret;
 191 }
 192 #undef FUNC_NAME
 193
 194 void
 195 scm_init_generalized_vectors ()
 196 {
 197 #include "libguile/generalized-vectors.x"
 198 }
 199
 200 /*
 201   Local Variables:
 202   c-file-style: "gnu"
 203   End:
 204 */