libguile/weaks.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001, 2003 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of this library.
  20  *
  21  * The exception is that, if you link this library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking this library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by
  31  * Free Software Foundation as part of this library.  If you copy
  32  * code from other releases distributed under the terms of the GPL into a copy of
  33  * this library, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from such code.
  37  *
  38  * If you write modifications of your own for this library, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #include "libguile/_scm.h"
  46 #include "libguile/vectors.h"
  47 #include "libguile/lang.h"
  48 #include "libguile/hashtab.h"
  49
  50 #include "libguile/validate.h"
  51 #include "libguile/weaks.h"
  52
  53 \f
  54
  55 /* 1. The current hash table implementation in hashtab.c uses weak alist
  56  *    vectors (formerly called weak hash tables) internally.
  57  *
  58  * 2. All hash table operations still work on alist vectors.
  59  *
  60  * 3. The weak vector and alist vector Scheme API is accessed through
  61  *    the module (ice-9 weak-vector).
  62  */
  63
  64
  65 /* {Weak Vectors}
  66  */
  67
  68
  69 /* Allocate memory for a weak vector on behalf of the caller.  The allocated
  70  * vector will be of the given weak vector subtype.  It will contain size
  71  * elements which are initialized with the 'fill' object, or, if 'fill' is
  72  * undefined, with an unspecified object.
  73  */
  74 SCM
  75 scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller)
  76 #define FUNC_NAME caller
  77 {
  78   if (SCM_INUMP (size))
  79     {
  80       size_t c_size;
  81       SCM v;
  82
  83       SCM_ASSERT_RANGE (1, size, SCM_INUM (size) >= 0);
  84       c_size = SCM_INUM (size);
  85
  86       if (c_size > 0)
  87         {
  88           scm_t_bits *base;
  89           size_t j;
  90
  91           if (SCM_UNBNDP (fill))
  92             fill = SCM_UNSPECIFIED;
  93
  94           SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH);
  95           base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector");
  96           for (j = 0; j != c_size; ++j)
  97             base[j] = SCM_UNPACK (fill);
  98           v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect),
  99                                (scm_t_bits) base,
 100                                type,
 101                                SCM_UNPACK (SCM_EOL));
 102           scm_remember_upto_here_1 (fill);
 103         }
 104       else
 105         {
 106           v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect),
 107                                (scm_t_bits) NULL,
 108                                type,
 109                                SCM_UNPACK (SCM_EOL));
 110         }
 111
 112       return v;
 113     }
 114   else if (SCM_BIGP (size))
 115     SCM_OUT_OF_RANGE (1, size);
 116   else
 117     SCM_WRONG_TYPE_ARG (1, size);
 118 }
 119 #undef FUNC_NAME
 120
 121 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
 122             (SCM size, SCM fill),
 123             "Return a weak vector with @var{size} elements. If the optional\n"
 124             "argument @var{fill} is given, all entries in the vector will be\n"
 125             "set to @var{fill}. The default value for @var{fill} is the\n"
 126             "empty list.")
 127 #define FUNC_NAME s_scm_make_weak_vector
 128 {
 129   return scm_i_allocate_weak_vector (0, size, fill, FUNC_NAME);
 130 }
 131 #undef FUNC_NAME
 132
 133
 134 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
 135
 136 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
 137            (SCM l),
 138             "@deffnx {Scheme Procedure} list->weak-vector l\n"
 139             "Construct a weak vector from a list: @code{weak-vector} uses\n"
 140             "the list of its arguments while @code{list->weak-vector} uses\n"
 141             "its only argument @var{l} (a list) to construct a weak vector\n"
 142             "the same way @code{list->vector} would.")
 143 #define FUNC_NAME s_scm_weak_vector
 144 {
 145   SCM res;
 146   SCM *data;
 147   long i;
 148
 149   /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted
 150      while the vector is being created. */
 151   i = scm_ilength (l);
 152   SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
 153   res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
 154
 155   /*
 156     no alloc, so  this loop is safe.
 157   */
 158   data = SCM_WRITABLE_VELTS (res);
 159   while (!SCM_NULL_OR_NIL_P (l))
 160     {
 161       *data++ = SCM_CAR (l);
 162       l = SCM_CDR (l);
 163     }
 164
 165   return res;
 166 }
 167 #undef FUNC_NAME
 168
 169
 170 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 171             (SCM obj),
 172             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 173             "weak hashes are also weak vectors.")
 174 #define FUNC_NAME s_scm_weak_vector_p
 175 {
 176   return SCM_BOOL (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj));
 177 }
 178 #undef FUNC_NAME
 179
 180 \f
 181
 182 SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
 183             (SCM size),
 184             "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
 185             "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
 186             "Return a weak hash table with @var{size} buckets. As with any\n"
 187             "hash table, choosing a good size for the table requires some\n"
 188             "caution.\n"
 189             "\n"
 190             "You can modify weak hash tables in exactly the same way you\n"
 191             "would modify regular hash tables. (@pxref{Hash Tables})")
 192 #define FUNC_NAME s_scm_make_weak_key_alist_vector
 193 {
 194   return scm_i_allocate_weak_vector
 195     (1, SCM_UNBNDP (size) ? SCM_MAKINUM (31) : size, SCM_EOL, FUNC_NAME);
 196 }
 197 #undef FUNC_NAME
 198
 199
 200 SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
 201             (SCM size),
 202             "Return a hash table with weak values with @var{size} buckets.\n"
 203             "(@pxref{Hash Tables})")
 204 #define FUNC_NAME s_scm_make_weak_value_alist_vector
 205 {
 206   return scm_i_allocate_weak_vector
 207     (2, SCM_UNBNDP (size) ? SCM_MAKINUM (31) : size, SCM_EOL, FUNC_NAME);
 208 }
 209 #undef FUNC_NAME
 210
 211
 212 SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
 213             (SCM size),
 214             "Return a hash table with weak keys and values with @var{size}\n"
 215             "buckets.  (@pxref{Hash Tables})")
 216 #define FUNC_NAME s_scm_make_doubly_weak_alist_vector
 217 {
 218   return scm_i_allocate_weak_vector
 219     (3, SCM_UNBNDP (size) ? SCM_MAKINUM (31) : size, SCM_EOL, FUNC_NAME);
 220 }
 221 #undef FUNC_NAME
 222
 223
 224 SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
 225            (SCM obj),
 226             "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
 227             "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
 228             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 229             "table. Note that a doubly weak hash table is neither a weak key\n"
 230             "nor a weak value hash table.")
 231 #define FUNC_NAME s_scm_weak_key_alist_vector_p
 232 {
 233   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj));
 234 }
 235 #undef FUNC_NAME
 236
 237
 238 SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
 239             (SCM obj),
 240             "Return @code{#t} if @var{obj} is a weak value hash table.")
 241 #define FUNC_NAME s_scm_weak_value_alist_vector_p
 242 {
 243   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 244 }
 245 #undef FUNC_NAME
 246
 247
 248 SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
 249             (SCM obj),
 250             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 251 #define FUNC_NAME s_scm_doubly_weak_alist_vector_p
 252 {
 253   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 254 }
 255 #undef FUNC_NAME
 256
 257
 258 static void *
 259 scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
 260                          void *dummy2 SCM_UNUSED,
 261                          void *dummy3 SCM_UNUSED)
 262 {
 263   scm_weak_vectors = SCM_EOL;
 264
 265   return 0;
 266 }
 267
 268
 269 static void *
 270 scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
 271                              void *dummy2 SCM_UNUSED,
 272                              void *dummy3 SCM_UNUSED)
 273 {
 274   SCM w;
 275
 276   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 277     {
 278       if (SCM_IS_WHVEC_ANY (w))
 279         {
 280           SCM const *ptr;
 281           SCM obj;
 282           long j;
 283           long n;
 284
 285           obj = w;
 286           ptr = SCM_VELTS (w);
 287           n = SCM_VECTOR_LENGTH (w);
 288           for (j = 0; j < n; ++j)
 289             {
 290               SCM alist;
 291
 292               alist = ptr[j];
 293               while (   SCM_CONSP (alist)
 294                      && !SCM_GC_MARK_P (alist)
 295                      && SCM_CONSP  (SCM_CAR (alist)))
 296                 {
 297                   SCM_SET_GC_MARK (alist);
 298                   SCM_SET_GC_MARK (SCM_CAR (alist));
 299                   alist = SCM_CDR (alist);
 300                 }
 301             }
 302         }
 303     }
 304
 305   return 0;
 306 }
 307
 308 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
 309
 310 static void *
 311 scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
 312                        void *dummy2 SCM_UNUSED,
 313                        void *dummy3 SCM_UNUSED)
 314 {
 315   SCM *ptr, w;
 316   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 317     {
 318       if (!SCM_IS_WHVEC_ANY (w))
 319         {
 320           register long j, n;
 321
 322           ptr = SCM_GC_WRITABLE_VELTS (w);
 323           n = SCM_VECTOR_LENGTH (w);
 324           for (j = 0; j < n; ++j)
 325             if (UNMARKED_CELL_P (ptr[j]))
 326               ptr[j] = SCM_BOOL_F;
 327         }
 328       /* check if we should scan the alist vector here (hashtables
 329          have their own scan function in hashtab.c). */
 330       else if (!SCM_WVECT_NOSCAN_P (w))
 331         {
 332           SCM obj = w;
 333           register long n = SCM_VECTOR_LENGTH (w);
 334           register long j;
 335           int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
 336           int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
 337
 338           ptr = SCM_GC_WRITABLE_VELTS (w);
 339
 340           for (j = 0; j < n; ++j)
 341             {
 342               SCM * fixup;
 343               SCM alist;
 344
 345               fixup = ptr + j;
 346               alist = *fixup;
 347
 348               while (SCM_CONSP (alist)
 349                      && SCM_CONSP (SCM_CAR (alist)))
 350                 {
 351                   SCM key;
 352                   SCM value;
 353
 354                   key = SCM_CAAR (alist);
 355                   value = SCM_CDAR (alist);
 356                   if (   (weak_keys && UNMARKED_CELL_P (key))
 357                          || (weak_values && UNMARKED_CELL_P (value)))
 358                     {
 359                       *fixup = SCM_CDR (alist);
 360                     }
 361                   else
 362                     fixup = SCM_CDRLOC (alist);
 363                   alist = SCM_CDR (alist);
 364                 }
 365             }
 366         }
 367     }
 368
 369   return 0;
 370 }
 371
 372 \f
 373
 374 void
 375 scm_weaks_prehistory ()
 376 {
 377   scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0);
 378   scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0);
 379   scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
 380 }
 381
 382
 383 SCM
 384 scm_init_weaks_builtins ()
 385 {
 386 #include "libguile/weaks.x"
 387   return SCM_UNSPECIFIED;
 388 }
 389
 390 void
 391 scm_init_weaks ()
 392 {
 393   scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
 394                       scm_init_weaks_builtins);
 395 }
 396
 397
 398 /*
 399   Local Variables:
 400   c-file-style: "gnu"
 401   End:
 402 */