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., 51 Franklin Street, Fifth Floor,
  16  * Boston, MA 02110-1301 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 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
  70             (SCM size, SCM fill),
  71             "Return a weak vector with @var{size} elements. If the optional\n"
  72             "argument @var{fill} is given, all entries in the vector will be\n"
  73             "set to @var{fill}. The default value for @var{fill} is the\n"
  74             "empty list.")
  75 #define FUNC_NAME s_scm_make_weak_vector
  76 {
  77   return scm_i_allocate_weak_vector (0, size, fill);
  78 }
  79 #undef FUNC_NAME
  80
  81
  82 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
  83
  84 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
  85            (SCM l),
  86             "@deffnx {Scheme Procedure} list->weak-vector l\n"
  87             "Construct a weak vector from a list: @code{weak-vector} uses\n"
  88             "the list of its arguments while @code{list->weak-vector} uses\n"
  89             "its only argument @var{l} (a list) to construct a weak vector\n"
  90             "the same way @code{list->vector} would.")
  91 #define FUNC_NAME s_scm_weak_vector
  92 {
  93   scm_t_array_handle handle;
  94   SCM res, *data;
  95   long i;
  96
  97   i = scm_ilength (l);
  98   SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
  99
 100   res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
 101   data = scm_vector_writable_elements (res, &handle, NULL, NULL);
 102
 103   while (scm_is_pair (l) && i > 0)
 104     {
 105       *data++ = SCM_CAR (l);
 106       l = SCM_CDR (l);
 107       i--;
 108     }
 109
 110   scm_array_handle_release (&handle);
 111
 112   return res;
 113 }
 114 #undef FUNC_NAME
 115
 116
 117 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 118             (SCM obj),
 119             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 120             "weak hashes are also weak vectors.")
 121 #define FUNC_NAME s_scm_weak_vector_p
 122 {
 123   return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
 124 }
 125 #undef FUNC_NAME
 126
 127 \f
 128
 129 SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
 130             (SCM size),
 131             "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
 132             "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
 133             "Return a weak hash table with @var{size} buckets. As with any\n"
 134             "hash table, choosing a good size for the table requires some\n"
 135             "caution.\n"
 136             "\n"
 137             "You can modify weak hash tables in exactly the same way you\n"
 138             "would modify regular hash tables. (@pxref{Hash Tables})")
 139 #define FUNC_NAME s_scm_make_weak_key_alist_vector
 140 {
 141   return scm_i_allocate_weak_vector
 142     (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 143 }
 144 #undef FUNC_NAME
 145
 146
 147 SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
 148             (SCM size),
 149             "Return a hash table with weak values with @var{size} buckets.\n"
 150             "(@pxref{Hash Tables})")
 151 #define FUNC_NAME s_scm_make_weak_value_alist_vector
 152 {
 153   return scm_i_allocate_weak_vector
 154     (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 155 }
 156 #undef FUNC_NAME
 157
 158
 159 SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
 160             (SCM size),
 161             "Return a hash table with weak keys and values with @var{size}\n"
 162             "buckets.  (@pxref{Hash Tables})")
 163 #define FUNC_NAME s_scm_make_doubly_weak_alist_vector
 164 {
 165   return scm_i_allocate_weak_vector
 166     (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 167 }
 168 #undef FUNC_NAME
 169
 170
 171 SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
 172            (SCM obj),
 173             "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
 174             "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
 175             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 176             "table. Note that a doubly weak hash table is neither a weak key\n"
 177             "nor a weak value hash table.")
 178 #define FUNC_NAME s_scm_weak_key_alist_vector_p
 179 {
 180   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
 181 }
 182 #undef FUNC_NAME
 183
 184
 185 SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
 186             (SCM obj),
 187             "Return @code{#t} if @var{obj} is a weak value hash table.")
 188 #define FUNC_NAME s_scm_weak_value_alist_vector_p
 189 {
 190   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 191 }
 192 #undef FUNC_NAME
 193
 194
 195 SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
 196             (SCM obj),
 197             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 198 #define FUNC_NAME s_scm_doubly_weak_alist_vector_p
 199 {
 200   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 201 }
 202 #undef FUNC_NAME
 203
 204
 205 static void *
 206 scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
 207                          void *dummy2 SCM_UNUSED,
 208                          void *dummy3 SCM_UNUSED)
 209 {
 210   scm_weak_vectors = SCM_EOL;
 211
 212   return 0;
 213 }
 214
 215
 216 static void *
 217 scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
 218                              void *dummy2 SCM_UNUSED,
 219                              void *dummy3 SCM_UNUSED)
 220 {
 221   SCM w;
 222
 223   for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w))
 224     {
 225       if (SCM_IS_WHVEC_ANY (w))
 226         {
 227           SCM const *ptr;
 228           SCM obj;
 229           long j;
 230           long n;
 231
 232           obj = w;
 233           ptr = SCM_I_WVECT_GC_WVELTS (w);
 234           n = SCM_I_WVECT_LENGTH (w);
 235           for (j = 0; j < n; ++j)
 236             {
 237               SCM alist;
 238
 239               alist = ptr[j];
 240               while (   scm_is_pair (alist)
 241                      && !SCM_GC_MARK_P (alist)
 242                      && scm_is_pair  (SCM_CAR (alist)))
 243                 {
 244                   SCM_SET_GC_MARK (alist);
 245                   SCM_SET_GC_MARK (SCM_CAR (alist));
 246                   alist = SCM_CDR (alist);
 247                 }
 248             }
 249         }
 250     }
 251
 252   return 0;
 253 }
 254
 255 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
 256
 257 static void *
 258 scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
 259                        void *dummy2 SCM_UNUSED,
 260                        void *dummy3 SCM_UNUSED)
 261 {
 262   SCM *ptr, w;
 263   for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w))
 264     {
 265       if (!SCM_IS_WHVEC_ANY (w))
 266         {
 267           register long j, n;
 268
 269           ptr = SCM_I_WVECT_GC_WVELTS (w);
 270           n = SCM_I_WVECT_LENGTH (w);
 271           for (j = 0; j < n; ++j)
 272             if (UNMARKED_CELL_P (ptr[j]))
 273               ptr[j] = SCM_BOOL_F;
 274         }
 275       /* check if we should scan the alist vector here (hashtables
 276          have their own scan function in hashtab.c). */
 277       else if (!SCM_WVECT_NOSCAN_P (w))
 278         {
 279           SCM obj = w;
 280           register long n = SCM_I_WVECT_LENGTH (w);
 281           register long j;
 282           int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
 283           int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
 284
 285           ptr = SCM_I_WVECT_GC_WVELTS (w);
 286
 287           for (j = 0; j < n; ++j)
 288             {
 289               SCM * fixup;
 290               SCM alist;
 291
 292               fixup = ptr + j;
 293               alist = *fixup;
 294
 295               while (scm_is_pair (alist)
 296                      && scm_is_pair (SCM_CAR (alist)))
 297                 {
 298                   SCM key;
 299                   SCM value;
 300
 301                   key = SCM_CAAR (alist);
 302                   value = SCM_CDAR (alist);
 303                   if (   (weak_keys && UNMARKED_CELL_P (key))
 304                          || (weak_values && UNMARKED_CELL_P (value)))
 305                     {
 306                       *fixup = SCM_CDR (alist);
 307                     }
 308                   else
 309                     fixup = SCM_CDRLOC (alist);
 310                   alist = SCM_CDR (alist);
 311                 }
 312             }
 313         }
 314     }
 315
 316   return 0;
 317 }
 318
 319 \f
 320
 321 void
 322 scm_weaks_prehistory ()
 323 {
 324   scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0);
 325   scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0);
 326   scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
 327 }
 328
 329
 330 SCM
 331 scm_init_weaks_builtins ()
 332 {
 333 #include "libguile/weaks.x"
 334   return SCM_UNSPECIFIED;
 335 }
 336
 337 void
 338 scm_init_weaks ()
 339 {
 340   scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
 341                       scm_init_weaks_builtins);
 342 }
 343
 344
 345 /*
 346   Local Variables:
 347   c-file-style: "gnu"
 348   End:
 349 */