libguile/weaks.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001 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
  48 #include "libguile/validate.h"
  49 #include "libguile/weaks.h"
  50
  51 \f
  52
  53 /* {Weak Vectors}
  54  */
  55
  56
  57 /* Allocate memory for a weak vector on behalf of the caller.  The allocated
  58  * vector will be of the given weak vector subtype.  It will contain size
  59  * elements which are initialized with the 'fill' object, or, if 'fill' is
  60  * undefined, with an unspecified object.
  61  */
  62 static SCM
  63 allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller)
  64 #define FUNC_NAME caller
  65 {
  66   if (SCM_INUMP (size))
  67     {
  68       size_t c_size;
  69       SCM v;
  70
  71       SCM_ASSERT_RANGE (1, size, SCM_INUM (size) >= 0);
  72       c_size = SCM_INUM (size);
  73
  74       SCM_NEWCELL2 (v);
  75       SCM_SET_WVECT_GC_CHAIN (v, SCM_EOL);
  76       SCM_SET_WVECT_TYPE (v, type);
  77
  78       if (c_size > 0)
  79         {
  80           scm_t_bits *base;
  81           size_t j;
  82
  83           if (SCM_UNBNDP (fill))
  84             fill = SCM_UNSPECIFIED;
  85
  86           SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH);
  87           base = scm_must_malloc (c_size * sizeof (scm_t_bits), FUNC_NAME);
  88           for (j = 0; j != c_size; ++j)
  89             base[j] = SCM_UNPACK (fill);
  90           SCM_SET_VECTOR_BASE (v, base);
  91           SCM_SET_VECTOR_LENGTH (v, c_size, scm_tc7_wvect);
  92           scm_remember_upto_here_1 (fill);
  93         }
  94       else
  95         {
  96           SCM_SET_VECTOR_BASE (v, NULL);
  97           SCM_SET_VECTOR_LENGTH (v, 0, scm_tc7_wvect);
  98         }
  99
 100       return v;
 101     }
 102   else if (SCM_BIGP (size))
 103     SCM_OUT_OF_RANGE (1, size);
 104   else
 105     SCM_WRONG_TYPE_ARG (1, size);
 106 }
 107 #undef FUNC_NAME
 108
 109
 110 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
 111             (SCM size, SCM fill),
 112             "Return a weak vector with @var{size} elements. If the optional\n"
 113             "argument @var{fill} is given, all entries in the vector will be\n"
 114             "set to @var{fill}. The default value for @var{fill} is the\n"
 115             "empty list.")
 116 #define FUNC_NAME s_scm_make_weak_vector
 117 {
 118   return allocate_weak_vector (0, size, fill, FUNC_NAME);
 119 }
 120 #undef FUNC_NAME
 121
 122
 123 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
 124
 125 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
 126            (SCM l),
 127             "@deffnx primitive list->weak-vector l\n"
 128             "Construct a weak vector from a list: @code{weak-vector} uses\n"
 129             "the list of its arguments while @code{list->weak-vector} uses\n"
 130             "its only argument @var{l} (a list) to construct a weak vector\n"
 131             "the same way @code{list->vector} would.")
 132 #define FUNC_NAME s_scm_weak_vector
 133 {
 134   SCM res;
 135   SCM *data;
 136   long i;
 137
 138   /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted
 139      while the vector is being created. */
 140   i = scm_ilength (l);
 141   SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
 142   res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
 143   data = SCM_VELTS (res);
 144
 145   while (!SCM_NULLP (l))
 146     {
 147       *data++ = SCM_CAR (l);
 148       l = SCM_CDR (l);
 149     }
 150
 151   return res;
 152 }
 153 #undef FUNC_NAME
 154
 155
 156 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 157             (SCM obj),
 158             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 159             "weak hashes are also weak vectors.")
 160 #define FUNC_NAME s_scm_weak_vector_p
 161 {
 162   return SCM_BOOL (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj));
 163 }
 164 #undef FUNC_NAME
 165
 166 \f
 167
 168 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0,
 169             (SCM size),
 170             "@deffnx primitive make-weak-value-hash-table size\n"
 171             "@deffnx primitive make-doubly-weak-hash-table size\n"
 172             "Return a weak hash table with @var{size} buckets. As with any\n"
 173             "hash table, choosing a good size for the table requires some\n"
 174             "caution.\n"
 175             "\n"
 176             "You can modify weak hash tables in exactly the same way you\n"
 177             "would modify regular hash tables. (@pxref{Hash Tables})")
 178 #define FUNC_NAME s_scm_make_weak_key_hash_table
 179 {
 180   return allocate_weak_vector (1, size, SCM_EOL, FUNC_NAME);
 181 }
 182 #undef FUNC_NAME
 183
 184
 185 SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0,
 186             (SCM size),
 187             "Return a hash table with weak values with @var{size} buckets.\n"
 188             "(@pxref{Hash Tables})")
 189 #define FUNC_NAME s_scm_make_weak_value_hash_table
 190 {
 191   return allocate_weak_vector (2, size, SCM_EOL, FUNC_NAME);
 192 }
 193 #undef FUNC_NAME
 194
 195
 196 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
 197             (SCM size),
 198             "Return a hash table with weak keys and values with @var{size}\n"
 199             "buckets.  (@pxref{Hash Tables})")
 200 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
 201 {
 202   return allocate_weak_vector (3, size, SCM_EOL, FUNC_NAME);
 203 }
 204 #undef FUNC_NAME
 205
 206
 207 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
 208            (SCM obj),
 209             "@deffnx primitive weak-value-hash-table? obj\n"
 210             "@deffnx primitive doubly-weak-hash-table? obj\n"
 211             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 212             "table. Note that a doubly weak hash table is neither a weak key\n"
 213             "nor a weak value hash table.")
 214 #define FUNC_NAME s_scm_weak_key_hash_table_p
 215 {
 216   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj));
 217 }
 218 #undef FUNC_NAME
 219
 220
 221 SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
 222             (SCM obj),
 223             "Return @code{#t} if @var{obj} is a weak value hash table.")
 224 #define FUNC_NAME s_scm_weak_value_hash_table_p
 225 {
 226   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 227 }
 228 #undef FUNC_NAME
 229
 230
 231 SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
 232             (SCM obj),
 233             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 234 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
 235 {
 236   return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 237 }
 238 #undef FUNC_NAME
 239
 240
 241 static void *
 242 scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
 243                          void *dummy2 SCM_UNUSED,
 244                          void *dummy3 SCM_UNUSED)
 245 {
 246   scm_weak_vectors = SCM_EOL;
 247
 248   return 0;
 249 }
 250
 251
 252 static void *
 253 scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
 254                              void *dummy2 SCM_UNUSED,
 255                              void *dummy3 SCM_UNUSED)
 256 {
 257   SCM w;
 258
 259   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 260     {
 261       if (SCM_IS_WHVEC_ANY (w))
 262         {
 263           SCM *ptr;
 264           SCM obj;
 265           long j;
 266           long n;
 267
 268           obj = w;
 269           ptr = SCM_VELTS (w);
 270           n = SCM_VECTOR_LENGTH (w);
 271           for (j = 0; j < n; ++j)
 272             {
 273               SCM alist;
 274
 275               alist = ptr[j];
 276               while (   SCM_CONSP (alist)
 277                      && !SCM_GCMARKP (alist)
 278                      && SCM_CONSP  (SCM_CAR (alist)))
 279                 {
 280                   SCM_SETGCMARK (alist);
 281                   SCM_SETGCMARK (SCM_CAR (alist));
 282                   alist = SCM_CDR (alist);
 283                 }
 284             }
 285         }
 286     }
 287
 288   return 0;
 289 }
 290
 291
 292 static void *
 293 scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
 294                        void *dummy2 SCM_UNUSED,
 295                        void *dummy3 SCM_UNUSED)
 296 {
 297   SCM *ptr, w;
 298   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 299     {
 300       if (!SCM_IS_WHVEC_ANY (w))
 301         {
 302           register long j, n;
 303
 304           ptr = SCM_VELTS (w);
 305           n = SCM_VECTOR_LENGTH (w);
 306           for (j = 0; j < n; ++j)
 307             if (SCM_FREE_CELL_P (ptr[j]))
 308               ptr[j] = SCM_BOOL_F;
 309         }
 310       else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
 311         {
 312           SCM obj = w;
 313           register long n = SCM_VECTOR_LENGTH (w);
 314           register long j;
 315           int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
 316           int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
 317
 318           ptr = SCM_VELTS (w);
 319
 320           for (j = 0; j < n; ++j)
 321             {
 322               SCM * fixup;
 323               SCM alist;
 324
 325               fixup = ptr + j;
 326               alist = *fixup;
 327
 328               while (   SCM_CONSP (alist)
 329                         && SCM_CONSP (SCM_CAR (alist)))
 330                 {
 331                   SCM key;
 332                   SCM value;
 333
 334                   key = SCM_CAAR (alist);
 335                   value = SCM_CDAR (alist);
 336                   if (   (weak_keys && SCM_FREE_CELL_P (key))
 337                          || (weak_values && SCM_FREE_CELL_P (value)))
 338                     {
 339                       *fixup = SCM_CDR (alist);
 340                     }
 341                   else
 342                     fixup = SCM_CDRLOC (alist);
 343                   alist = SCM_CDR (alist);
 344                 }
 345             }
 346         }
 347     }
 348
 349   return 0;
 350 }
 351
 352 \f
 353
 354 void
 355 scm_weaks_prehistory ()
 356 {
 357   scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0);
 358   scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0);
 359   scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
 360 }
 361
 362
 363 void
 364 scm_init_weaks ()
 365 {
 366 #ifndef SCM_MAGIC_SNARFER
 367 #include "libguile/weaks.x"
 368 #endif
 369 }
 370
 371
 372 /*
 373   Local Variables:
 374   c-file-style: "gnu"
 375   End:
 376 */