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_VECTOR_BASE (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   long 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_VECTOR_BASE (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_VECTOR_BASE (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_VECTOR_BASE (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 SCM_UNUSED,
 221                          void *dummy2 SCM_UNUSED,
 222                          void *dummy3 SCM_UNUSED)
 223 {
 224   scm_weak_vectors = SCM_EOL;
 225
 226   return 0;
 227 }
 228
 229 static void *
 230 scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
 231                              void *dummy2 SCM_UNUSED,
 232                              void *dummy3 SCM_UNUSED)
 233 {
 234   SCM w;
 235
 236   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 237     {
 238       if (SCM_IS_WHVEC_ANY (w))
 239         {
 240           SCM *ptr;
 241           SCM obj;
 242           long j;
 243           long n;
 244
 245           obj = w;
 246           ptr = SCM_VELTS (w);
 247           n = SCM_VECTOR_LENGTH (w);
 248           for (j = 0; j < n; ++j)
 249             {
 250               SCM alist;
 251
 252               alist = ptr[j];
 253               while (   SCM_CONSP (alist)
 254                      && !SCM_GCMARKP (alist)
 255                      && SCM_CONSP  (SCM_CAR (alist)))
 256                 {
 257                   SCM_SETGCMARK (alist);
 258                   SCM_SETGCMARK (SCM_CAR (alist));
 259                   alist = SCM_CDR (alist);
 260                 }
 261             }
 262         }
 263     }
 264
 265   return 0;
 266 }
 267
 268 static void *
 269 scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
 270                        void *dummy2 SCM_UNUSED,
 271                        void *dummy3 SCM_UNUSED)
 272 {
 273   SCM *ptr, w;
 274   for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w))
 275     {
 276       if (!SCM_IS_WHVEC_ANY (w))
 277         {
 278           register long j, n;
 279
 280           ptr = SCM_VELTS (w);
 281           n = SCM_VECTOR_LENGTH (w);
 282           for (j = 0; j < n; ++j)
 283             if (SCM_FREE_CELL_P (ptr[j]))
 284               ptr[j] = SCM_BOOL_F;
 285         }
 286       else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
 287         {
 288           SCM obj = w;
 289           register long n = SCM_VECTOR_LENGTH (w);
 290           register long j;
 291           int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
 292           int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
 293
 294           ptr = SCM_VELTS (w);
 295
 296           for (j = 0; j < n; ++j)
 297             {
 298               SCM * fixup;
 299               SCM alist;
 300
 301               fixup = ptr + j;
 302               alist = *fixup;
 303
 304               while (   SCM_CONSP (alist)
 305                         && SCM_CONSP (SCM_CAR (alist)))
 306                 {
 307                   SCM key;
 308                   SCM value;
 309
 310                   key = SCM_CAAR (alist);
 311                   value = SCM_CDAR (alist);
 312                   if (   (weak_keys && SCM_FREE_CELL_P (key))
 313                          || (weak_values && SCM_FREE_CELL_P (value)))
 314                     {
 315                       *fixup = SCM_CDR (alist);
 316                     }
 317                   else
 318                     fixup = SCM_CDRLOC (alist);
 319                   alist = SCM_CDR (alist);
 320                 }
 321             }
 322         }
 323     }
 324
 325   return 0;
 326 }
 327
 328
 329 \f
 330
 331
 332 void
 333 scm_weaks_prehistory ()
 334 {
 335   scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0);
 336   scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0);
 337   scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
 338 }
 339
 340 void
 341 scm_init_weaks ()
 342 {
 343 #ifndef SCM_MAGIC_SNARFER
 344 #include "libguile/weaks.x"
 345 #endif
 346 }
 347
 348
 349 /*
 350   Local Variables:
 351   c-file-style: "gnu"
 352   End:
 353 */