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