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