libguile/weak-vector.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011, 2012 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 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include <stdio.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/vectors.h"
  29
  30 #include "libguile/validate.h"
  31
  32 \f
  33
  34 /* {Weak Vectors}
  35  */
  36
  37 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
  38
  39 static SCM
  40 make_weak_vector (size_t len, SCM fill)
  41 #define FUNC_NAME "make-weak-vector"
  42 {
  43   SCM wv;
  44   size_t j;
  45
  46   SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
  47
  48   if (SCM_UNBNDP (fill))
  49     fill = SCM_UNSPECIFIED;
  50
  51   wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
  52                                            "weak vector"));
  53
  54   SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
  55
  56   if (SCM_HEAP_OBJECT_P (fill))
  57     {
  58       memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
  59       for (j = 0; j < len; j++)
  60         scm_c_weak_vector_set_x (wv, j, fill);
  61     }
  62   else
  63     for (j = 0; j < len; j++)
  64       SCM_SIMPLE_VECTOR_SET (wv, j, fill);
  65
  66   return wv;
  67 }
  68 #undef FUNC_NAME
  69
  70 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
  71             (SCM size, SCM fill),
  72             "Return a weak vector with @var{size} elements. If the optional\n"
  73             "argument @var{fill} is given, all entries in the vector will be\n"
  74             "set to @var{fill}. The default value for @var{fill} is the\n"
  75             "empty list.")
  76 #define FUNC_NAME s_scm_make_weak_vector
  77 {
  78   return make_weak_vector (scm_to_size_t (size), fill);
  79 }
  80 #undef FUNC_NAME
  81
  82
  83 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
  84
  85 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
  86            (SCM lst),
  87             "@deffnx {Scheme Procedure} list->weak-vector lst\n"
  88             "Construct a weak vector from a list: @code{weak-vector} uses\n"
  89             "the list of its arguments while @code{list->weak-vector} uses\n"
  90             "its only argument @var{l} (a list) to construct a weak vector\n"
  91             "the same way @code{list->vector} would.")
  92 #define FUNC_NAME s_scm_weak_vector
  93 {
  94   SCM wv;
  95   size_t i;
  96   long c_size;
  97
  98   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size);
  99
 100   wv = make_weak_vector ((size_t) c_size, SCM_BOOL_F);
 101
 102   for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++)
 103     scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst));
 104
 105   return wv;
 106 }
 107 #undef FUNC_NAME
 108
 109
 110 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 111             (SCM obj),
 112             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 113             "weak hashes are also weak vectors.")
 114 #define FUNC_NAME s_scm_weak_vector_p
 115 {
 116   return scm_from_bool (SCM_I_WVECTP (obj));
 117 }
 118 #undef FUNC_NAME
 119
 120
 121 struct weak_vector_ref_data
 122 {
 123   SCM wv;
 124   size_t k;
 125 };
 126
 127 static void*
 128 weak_vector_ref (void *data)
 129 {
 130   struct weak_vector_ref_data *d = data;
 131
 132   return SCM_SIMPLE_VECTOR_REF (d->wv, d->k);
 133 }
 134
 135 SCM
 136 scm_c_weak_vector_ref (SCM wv, size_t k)
 137 {
 138   struct weak_vector_ref_data d;
 139   void *ret;
 140
 141   d.wv = wv;
 142   d.k = k;
 143
 144   if (k >= SCM_I_VECTOR_LENGTH (wv))
 145     scm_out_of_range (NULL, scm_from_size_t (k));
 146
 147   ret = GC_call_with_alloc_lock (weak_vector_ref, &d);
 148
 149   if (ret)
 150     return SCM_PACK_POINTER (ret);
 151   else
 152     return SCM_BOOL_F;
 153 }
 154
 155
 156 void
 157 scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
 158 {
 159   SCM *elts;
 160   struct weak_vector_ref_data d;
 161   void *prev;
 162
 163   d.wv = wv;
 164   d.k = k;
 165
 166   if (k >= SCM_I_VECTOR_LENGTH (wv))
 167     scm_out_of_range (NULL, scm_from_size_t (k));
 168
 169   prev = GC_call_with_alloc_lock (weak_vector_ref, &d);
 170
 171   elts = SCM_I_VECTOR_WELTS (wv);
 172
 173   if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
 174     GC_unregister_disappearing_link ((void **) &elts[k]);
 175
 176   elts[k] = x;
 177
 178   if (SCM_HEAP_OBJECT_P (x))
 179     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
 180                                       SCM2PTR (x));
 181 }
 182
 183
 184 \f
 185 static void
 186 scm_init_weak_vector_builtins (void)
 187 {
 188 #ifndef SCM_MAGIC_SNARFER
 189 #include "libguile/weak-vector.x"
 190 #endif
 191 }
 192
 193 void
 194 scm_init_weak_vectors ()
 195 {
 196   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 197                             "scm_init_weak_vector_builtins",
 198                             (scm_t_extension_init_func)scm_init_weak_vector_builtins,
 199                             NULL);
 200 }
 201
 202
 203 /*
 204   Local Variables:
 205   c-file-style: "gnu"
 206   End:
 207 */