mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
remove weak pairs, rewrite weak vectors
* libguile/weak-vector.c: * libguile/weak-vector.h: Renamed from weaks.[ch]. Remove weak pairs. They were not safe to access with `car' and `cdr'. Remove weak alist vectors, as we have weak tables and sets. Reimplement weak vectors, moving the implementation here. * libguile/vectors.c: * libguile/vectors.h: Remove the extra header word. Use scm_c_weak_vector_ref / scm_c_weak_vector_set_x to access weak vectors. * libguile/snarf.h: Remove the extra header word in vectors. * libguile/threads.c (do_thread_exit, fat_mutex_lock, fat_mutex_unlock): Instead of weak pairs, store thread-owned mutexes in a list of one-element weak vectors. * libguile/guardians.c (finalize_guarded): Similarly, store object guardians in a list of one-element weak vectors. * libguile/modules.c (scm_module_reverse_lookup): We no longer need to handle the case of weak references. * libguile/print.c (iprin1): Use the standard vector accessor to print vectors. * libguile.h: * libguile/Makefile.am: * libguile/gc-malloc.c: * libguile/gc.c: * libguile/goops.c: * libguile/init.c: * libguile/objprop.c: * libguile/struct.c: Update includes. * module/ice-9/weak-vector.scm: Load weak vector definitions using an extension instead of %init-weaks-builtins. * test-suite/tests/weaks.test: Use the make-...-hash-table names instead of the old alist vector names.
This commit is contained in:
Andy Wingo
parent
c4e83f74c2
commit
a141db8604
22 changed files with 364 additions and 642 deletions
|
|
@ -117,7 +117,7 @@ extern "C" {
|
|||
#include "libguile/vports.h"
|
||||
#include "libguile/weak-set.h"
|
||||
#include "libguile/weak-table.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/weak-vector.h"
|
||||
#include "libguile/backtrace.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/stacks.h"
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
|
|||
vports.c \
|
||||
weak-set.c \
|
||||
weak-table.c \
|
||||
weaks.c
|
||||
weak-vector.c
|
||||
|
||||
DOT_X_FILES = \
|
||||
alist.x \
|
||||
|
|
@ -318,7 +318,7 @@ DOT_X_FILES = \
|
|||
vports.x \
|
||||
weak-set.x \
|
||||
weak-table.x \
|
||||
weaks.x
|
||||
weak-vector.x
|
||||
|
||||
# vm-related snarfs
|
||||
DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
|
||||
|
|
@ -421,7 +421,7 @@ DOT_DOC_FILES = \
|
|||
vports.doc \
|
||||
weak-set.doc \
|
||||
weak-table.doc \
|
||||
weaks.doc
|
||||
weak-vector.doc
|
||||
|
||||
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
|
||||
|
||||
|
|
@ -625,7 +625,7 @@ modinclude_HEADERS = \
|
|||
vports.h \
|
||||
weak-set.h \
|
||||
weak-table.h \
|
||||
weaks.h
|
||||
weak-vector.h
|
||||
|
||||
nodist_modinclude_HEADERS = version.h scmconfig.h
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
|
|||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/tags.h"
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
|
|||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/tags.h"
|
||||
|
||||
|
|
|
|||
|
|
@ -53,7 +53,6 @@
|
|||
#include "libguile/strings.h"
|
||||
#include "libguile/strports.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/vm.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
|||
|
|
@ -57,7 +57,6 @@
|
|||
#include "libguile/validate.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/deprecation.h"
|
||||
#include "libguile/eval.h"
|
||||
|
||||
|
|
@ -131,9 +130,12 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
|
|||
guardian_list = SCM_CDR (guardian_list))
|
||||
{
|
||||
SCM zombies;
|
||||
SCM guardian;
|
||||
t_guardian *g;
|
||||
|
||||
if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
|
||||
guardian = scm_c_weak_vector_ref (scm_car (guardian_list), 0);
|
||||
|
||||
if (scm_is_false (guardian))
|
||||
{
|
||||
/* The guardian itself vanished in the meantime. */
|
||||
#ifdef DEBUG_GUARDIANS
|
||||
|
|
@ -142,7 +144,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
|
|||
continue;
|
||||
}
|
||||
|
||||
g = GUARDIAN_DATA (SCM_CAR (guardian_list));
|
||||
g = GUARDIAN_DATA (guardian);
|
||||
if (g->live == 0)
|
||||
abort ();
|
||||
|
||||
|
|
@ -209,9 +211,11 @@ scm_i_guard (SCM guardian, SCM obj)
|
|||
|
||||
g->live++;
|
||||
|
||||
/* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
|
||||
collected before the objects it guards (see `guardians.test'). */
|
||||
guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL);
|
||||
/* Note: GUARDIANS_FOR_OBJ holds weak references to guardians so
|
||||
that a guardian can be collected before the objects it guards
|
||||
(see `guardians.test'). */
|
||||
guardians_for_obj = scm_cons (scm_make_weak_vector (SCM_INUM1, guardian),
|
||||
SCM_EOL);
|
||||
finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);
|
||||
|
||||
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded,
|
||||
|
|
|
|||
|
|
@ -133,7 +133,6 @@
|
|||
#include "libguile/version.h"
|
||||
#include "libguile/vm.h"
|
||||
#include "libguile/vports.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/guardians.h"
|
||||
#include "libguile/extensions.h"
|
||||
#include "libguile/uniform.h"
|
||||
|
|
@ -383,12 +382,11 @@ scm_i_init_guile (void *base)
|
|||
|
||||
scm_storage_prehistory ();
|
||||
scm_threads_prehistory (base); /* requires storage_prehistory */
|
||||
scm_weaks_prehistory (); /* requires storage_prehistory */
|
||||
scm_weak_table_prehistory (); /* requires storage_prehistory */
|
||||
#ifdef GUILE_DEBUG_MALLOC
|
||||
scm_debug_malloc_prehistory ();
|
||||
#endif
|
||||
scm_symbols_prehistory (); /* requires weaks_prehistory */
|
||||
scm_symbols_prehistory (); /* requires weak_table_prehistory */
|
||||
scm_modules_prehistory ();
|
||||
scm_init_array_handle ();
|
||||
scm_bootstrap_bytevectors (); /* Requires array-handle */
|
||||
|
|
@ -489,9 +487,9 @@ scm_i_init_guile (void *base)
|
|||
scm_init_throw (); /* Requires smob_prehistory */
|
||||
scm_init_trees ();
|
||||
scm_init_version ();
|
||||
scm_init_weaks ();
|
||||
scm_init_weak_set ();
|
||||
scm_init_weak_table ();
|
||||
scm_init_weak_vectors ();
|
||||
scm_init_guardians (); /* requires smob_prehistory */
|
||||
scm_init_vports ();
|
||||
scm_init_standard_ports (); /* Requires fports */
|
||||
|
|
|
|||
|
|
@ -960,16 +960,8 @@ SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
|
|||
{
|
||||
handle = SCM_CAR (ls);
|
||||
|
||||
if (SCM_UNPACK (SCM_CAR (handle)) == 0)
|
||||
{
|
||||
/* FIXME: We hit a weak pair whose car has become unreachable.
|
||||
We should remove the pair in question or something. */
|
||||
}
|
||||
else
|
||||
{
|
||||
if (scm_is_eq (SCM_CDR (handle), variable))
|
||||
return SCM_CAR (handle);
|
||||
}
|
||||
if (scm_is_eq (SCM_CDR (handle), variable))
|
||||
return SCM_CAR (handle);
|
||||
|
||||
ls = SCM_CDR (ls);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@
|
|||
#include "libguile/hashtab.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/weaks.h"
|
||||
|
||||
#include "libguile/objprop.h"
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,6 @@
|
|||
#include "libguile/macros.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/read.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/programs.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/struct.h"
|
||||
|
|
@ -653,10 +652,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
break;
|
||||
case scm_tc7_wvect:
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
if (SCM_IS_WHVEC (exp))
|
||||
scm_puts ("#wh(", port);
|
||||
else
|
||||
scm_puts ("#w(", port);
|
||||
scm_puts ("#w(", port);
|
||||
goto common_vector_printer;
|
||||
|
||||
case scm_tc7_bytevector:
|
||||
|
|
@ -676,26 +672,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
last = pstate->length - 1;
|
||||
cutp = 1;
|
||||
}
|
||||
if (SCM_I_WVECTP (exp))
|
||||
{
|
||||
/* Elements of weak vectors may not be accessed via the
|
||||
`SIMPLE_VECTOR_REF ()' macro. */
|
||||
for (i = 0; i < last; ++i)
|
||||
{
|
||||
scm_iprin1 (scm_c_vector_ref (exp, i),
|
||||
port, pstate);
|
||||
scm_putc (' ', port);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
for (i = 0; i < last; ++i)
|
||||
{
|
||||
scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
|
||||
scm_putc (' ', port);
|
||||
}
|
||||
}
|
||||
|
||||
for (i = 0; i < last; ++i)
|
||||
{
|
||||
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
|
||||
scm_putc (' ', port);
|
||||
}
|
||||
if (i == last)
|
||||
{
|
||||
/* CHECK_INTS; */
|
||||
|
|
|
|||
|
|
@ -119,9 +119,9 @@ SCM_SNARF_HERE( \
|
|||
) \
|
||||
SCM_SNARF_INIT( \
|
||||
/* Initialize the foreign. */ \
|
||||
scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
|
||||
scm_i_paste (FNAME, __raw_objtable)[1] = scm_i_paste (FNAME, __subr_foreign); \
|
||||
/* Initialize the procedure name (an interned symbol). */ \
|
||||
scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
|
||||
scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __name); \
|
||||
/* Initialize the objcode trampoline. */ \
|
||||
SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
|
||||
scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
|
||||
|
|
@ -366,12 +366,11 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
|
|||
|
||||
/* for primitive-generics, add a foreign to the end */
|
||||
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
|
||||
static SCM_ALIGNED (8) SCM c_name[4] = \
|
||||
static SCM_ALIGNED (8) SCM c_name[3] = \
|
||||
{ \
|
||||
SCM_PACK (scm_tc7_vector | (2 << 8)), \
|
||||
SCM_PACK (0), \
|
||||
foreign, \
|
||||
SCM_BOOL_F, /* the name */ \
|
||||
SCM_BOOL_F /* the name */ \
|
||||
}
|
||||
|
||||
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
|
||||
|
|
|
|||
|
|
@ -33,7 +33,6 @@
|
|||
#include "libguile/hash.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/gc.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@
|
|||
#include "libguile/chars.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/strings.h"
|
||||
|
|
|
|||
|
|
@ -56,7 +56,6 @@
|
|||
#include "libguile/init.h"
|
||||
#include "libguile/scmsigs.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/weaks.h"
|
||||
|
||||
#include <full-read.h>
|
||||
|
||||
|
|
@ -651,9 +650,9 @@ do_thread_exit (void *v)
|
|||
|
||||
while (!scm_is_null (t->mutexes))
|
||||
{
|
||||
SCM mutex = SCM_WEAK_PAIR_CAR (t->mutexes);
|
||||
SCM mutex = scm_c_weak_vector_ref (scm_car (t->mutexes), 0);
|
||||
|
||||
if (!SCM_UNBNDP (mutex))
|
||||
if (scm_is_true (mutex))
|
||||
{
|
||||
fat_mutex *m = SCM_MUTEX_DATA (mutex);
|
||||
|
||||
|
|
@ -667,7 +666,7 @@ do_thread_exit (void *v)
|
|||
scm_i_pthread_mutex_unlock (&m->lock);
|
||||
}
|
||||
|
||||
t->mutexes = SCM_WEAK_PAIR_CDR (t->mutexes);
|
||||
t->mutexes = scm_cdr (t->mutexes);
|
||||
}
|
||||
|
||||
scm_i_pthread_mutex_unlock (&t->admin_mutex);
|
||||
|
|
@ -1376,7 +1375,8 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
|
|||
The weak pair itself is eventually removed when MUTEX
|
||||
is unlocked. Note that `t->mutexes' lists mutexes
|
||||
currently held by T, so it should be small. */
|
||||
t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
|
||||
t->mutexes = scm_cons (scm_make_weak_vector (SCM_INUM1, mutex),
|
||||
t->mutexes);
|
||||
|
||||
scm_i_pthread_mutex_unlock (&t->admin_mutex);
|
||||
}
|
||||
|
|
@ -1520,6 +1520,25 @@ typedef struct {
|
|||
#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
|
||||
#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
|
||||
|
||||
static void
|
||||
remove_mutex_from_thread (SCM mutex, scm_i_thread *t)
|
||||
{
|
||||
SCM walk, prev;
|
||||
|
||||
for (prev = SCM_BOOL_F, walk = t->mutexes; scm_is_pair (walk);
|
||||
walk = SCM_CDR (walk))
|
||||
{
|
||||
if (scm_is_eq (mutex, scm_c_weak_vector_ref (SCM_CAR (walk), 0)))
|
||||
{
|
||||
if (scm_is_pair (prev))
|
||||
SCM_SETCDR (prev, SCM_CDR (walk));
|
||||
else
|
||||
t->mutexes = SCM_CDR (walk);
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static int
|
||||
fat_mutex_unlock (SCM mutex, SCM cond,
|
||||
const scm_t_timespec *waittime, int relock)
|
||||
|
|
@ -1564,7 +1583,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
|
|||
if (m->level == 0)
|
||||
{
|
||||
/* Change the owner of MUTEX. */
|
||||
t->mutexes = scm_delq_x (mutex, t->mutexes);
|
||||
remove_mutex_from_thread (mutex, t);
|
||||
m->owner = unblock_from_queue (m->waiting);
|
||||
}
|
||||
|
||||
|
|
@ -1612,7 +1631,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
|
|||
if (m->level == 0)
|
||||
{
|
||||
/* Change the owner of MUTEX. */
|
||||
t->mutexes = scm_delq_x (mutex, t->mutexes);
|
||||
remove_mutex_from_thread (mutex, t);
|
||||
m->owner = unblock_from_queue (m->waiting);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -67,9 +67,7 @@ scm_vector_elements (SCM vec, scm_t_array_handle *h,
|
|||
size_t *lenp, ssize_t *incp)
|
||||
{
|
||||
if (SCM_I_WVECTP (vec))
|
||||
/* FIXME: We should check each (weak) element of the vector for NULL and
|
||||
convert it to SCM_BOOL_F. */
|
||||
abort ();
|
||||
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
|
||||
|
||||
scm_generalized_vector_get_handle (vec, h);
|
||||
if (lenp)
|
||||
|
|
@ -86,9 +84,7 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
|
|||
size_t *lenp, ssize_t *incp)
|
||||
{
|
||||
if (SCM_I_WVECTP (vec))
|
||||
/* FIXME: We should check each (weak) element of the vector for NULL and
|
||||
convert it to SCM_BOOL_F. */
|
||||
abort ();
|
||||
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
|
||||
|
||||
scm_generalized_vector_get_handle (vec, h);
|
||||
if (lenp)
|
||||
|
|
@ -205,40 +201,29 @@ scm_vector_ref (SCM v, SCM k)
|
|||
SCM
|
||||
scm_c_vector_ref (SCM v, size_t k)
|
||||
{
|
||||
if (SCM_I_IS_VECTOR (v))
|
||||
if (SCM_I_IS_NONWEAK_VECTOR (v))
|
||||
{
|
||||
register SCM elt;
|
||||
|
||||
if (k >= SCM_I_VECTOR_LENGTH (v))
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
elt = (SCM_I_VECTOR_ELTS(v))[k];
|
||||
|
||||
if (SCM_UNPACK (elt) == 0 && SCM_I_WVECTP (v))
|
||||
/* ELT was a weak pointer and got nullified by the GC. */
|
||||
return SCM_BOOL_F;
|
||||
|
||||
return elt;
|
||||
return SCM_SIMPLE_VECTOR_REF (v, k);
|
||||
}
|
||||
else if (SCM_I_WVECTP (v))
|
||||
return scm_c_weak_vector_ref (v, k);
|
||||
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
|
||||
{
|
||||
scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
|
||||
SCM vv = SCM_I_ARRAY_V (v);
|
||||
if (SCM_I_IS_VECTOR (vv))
|
||||
{
|
||||
register SCM elt;
|
||||
|
||||
if (k >= dim->ubnd - dim->lbnd + 1)
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
||||
elt = (SCM_I_VECTOR_ELTS (vv))[k];
|
||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
||||
if (k >= dim->ubnd - dim->lbnd + 1)
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
|
||||
if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
|
||||
/* ELT was a weak pointer and got nullified by the GC. */
|
||||
return SCM_BOOL_F;
|
||||
|
||||
return elt;
|
||||
}
|
||||
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
|
||||
if (SCM_I_IS_NONWEAK_VECTOR (vv))
|
||||
return SCM_SIMPLE_VECTOR_REF (vv, k);
|
||||
else if (SCM_I_WVECTP (vv))
|
||||
return scm_c_weak_vector_ref (vv, k);
|
||||
else
|
||||
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
|
||||
}
|
||||
else
|
||||
return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
|
||||
|
|
@ -270,38 +255,27 @@ scm_vector_set_x (SCM v, SCM k, SCM obj)
|
|||
void
|
||||
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
|
||||
{
|
||||
if (SCM_I_IS_VECTOR (v))
|
||||
if (SCM_I_IS_NONWEAK_VECTOR (v))
|
||||
{
|
||||
if (k >= SCM_I_VECTOR_LENGTH (v))
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
(SCM_I_VECTOR_WELTS(v))[k] = obj;
|
||||
if (SCM_I_WVECTP (v))
|
||||
{
|
||||
/* Make it a weak pointer. */
|
||||
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK (link,
|
||||
(GC_PTR) SCM2PTR (obj));
|
||||
}
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
SCM_SIMPLE_VECTOR_SET (v, k, obj);
|
||||
}
|
||||
else if (SCM_I_WVECTP (v))
|
||||
scm_c_weak_vector_set_x (v, k, obj);
|
||||
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
|
||||
{
|
||||
scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
|
||||
SCM vv = SCM_I_ARRAY_V (v);
|
||||
if (SCM_I_IS_VECTOR (vv))
|
||||
{
|
||||
if (k >= dim->ubnd - dim->lbnd + 1)
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
||||
(SCM_I_VECTOR_WELTS (vv))[k] = obj;
|
||||
|
||||
if (SCM_I_WVECTP (vv))
|
||||
{
|
||||
/* Make it a weak pointer. */
|
||||
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK (link,
|
||||
(GC_PTR) SCM2PTR (obj));
|
||||
}
|
||||
}
|
||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
||||
if (k >= dim->ubnd - dim->lbnd + 1)
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
|
||||
if (SCM_I_IS_NONWEAK_VECTOR (vv))
|
||||
SCM_SIMPLE_VECTOR_SET (vv, k, obj);
|
||||
else if (SCM_I_WVECTP (vv))
|
||||
scm_c_weak_vector_set_x (vv, k, obj);
|
||||
else
|
||||
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
|
||||
}
|
||||
|
|
@ -339,28 +313,17 @@ SCM
|
|||
scm_c_make_vector (size_t k, SCM fill)
|
||||
#define FUNC_NAME s_scm_make_vector
|
||||
{
|
||||
SCM *vector;
|
||||
SCM vector;
|
||||
unsigned long int j;
|
||||
|
||||
vector = (SCM *)
|
||||
scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
|
||||
"vector");
|
||||
SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
|
||||
|
||||
if (k > 0)
|
||||
{
|
||||
SCM *base;
|
||||
unsigned long int j;
|
||||
vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
|
||||
|
||||
SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
|
||||
for (j = 0; j < k; ++j)
|
||||
SCM_SIMPLE_VECTOR_SET (vector, j, fill);
|
||||
|
||||
base = vector + SCM_I_VECTOR_HEADER_SIZE;
|
||||
for (j = 0; j != k; ++j)
|
||||
base[j] = fill;
|
||||
}
|
||||
|
||||
((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
|
||||
((scm_t_bits *) vector)[1] = 0;
|
||||
|
||||
return PTR2SCM (vector);
|
||||
return vector;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -388,72 +351,6 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/* Weak vectors. */
|
||||
|
||||
/* Allocate memory for the elements of a weak vector on behalf of the
|
||||
caller. */
|
||||
static SCM
|
||||
make_weak_vector (scm_t_bits type, size_t c_size)
|
||||
{
|
||||
SCM *vector;
|
||||
size_t total_size;
|
||||
|
||||
total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM);
|
||||
vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector");
|
||||
|
||||
((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect;
|
||||
((scm_t_bits *) vector)[1] = type;
|
||||
|
||||
return PTR2SCM (vector);
|
||||
}
|
||||
|
||||
/* Return a new weak vector. The allocated vector will be of the given weak
|
||||
vector subtype. It will contain SIZE elements which are initialized with
|
||||
the FILL object, or, if FILL is undefined, with an unspecified object. */
|
||||
SCM
|
||||
scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
|
||||
{
|
||||
SCM wv, *base;
|
||||
size_t c_size, j;
|
||||
|
||||
if (SCM_UNBNDP (fill))
|
||||
fill = SCM_UNSPECIFIED;
|
||||
|
||||
c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
|
||||
wv = make_weak_vector (type, c_size);
|
||||
base = SCM_I_WVECT_GC_WVELTS (wv);
|
||||
|
||||
for (j = 0; j != c_size; ++j)
|
||||
base[j] = fill;
|
||||
|
||||
return wv;
|
||||
}
|
||||
|
||||
/* Return a new weak vector with type TYPE and whose content are taken from
|
||||
list LST. */
|
||||
SCM
|
||||
scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
|
||||
{
|
||||
SCM wv, *elt;
|
||||
long c_size;
|
||||
|
||||
c_size = scm_ilength (lst);
|
||||
SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");
|
||||
|
||||
wv = make_weak_vector(type, (size_t) c_size);
|
||||
|
||||
for (elt = SCM_I_WVECT_GC_WVELTS (wv);
|
||||
scm_is_pair (lst);
|
||||
lst = SCM_CDR (lst), elt++)
|
||||
{
|
||||
*elt = SCM_CAR (lst);
|
||||
}
|
||||
|
||||
return wv;
|
||||
}
|
||||
|
||||
|
||||
|
||||
SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
|
||||
(SCM v),
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_VECTORS_H
|
||||
#define SCM_VECTORS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -63,31 +63,14 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
|
|||
|
||||
/* Internals */
|
||||
|
||||
/* Vectors have a 2-word header: 1 for the type tag, and 1 for the weak
|
||||
vector extra data (see below.) */
|
||||
#define SCM_I_VECTOR_HEADER_SIZE 2U
|
||||
|
||||
#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
|
||||
#define SCM_I_IS_NONWEAK_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7(x)==scm_tc7_vector))
|
||||
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
|
||||
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, SCM_I_VECTOR_HEADER_SIZE))
|
||||
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))
|
||||
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
|
||||
|
||||
SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
|
||||
|
||||
/* Weak vectors share implementation details with ordinary vectors,
|
||||
but no one else should. */
|
||||
|
||||
#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \
|
||||
SCM_TYP7 (x) == scm_tc7_wvect)
|
||||
#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
|
||||
#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
|
||||
#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
|
||||
#define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_1 (x))
|
||||
#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_1 ((x),(t)))
|
||||
|
||||
SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
|
||||
SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);
|
||||
|
||||
SCM_INTERNAL void scm_init_vectors (void);
|
||||
|
||||
|
|
|
|||
207
libguile/weak-vector.c
Normal file
207
libguile/weak-vector.c
Normal file
|
|
@ -0,0 +1,207 @@
|
|||
/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* as published by the Free Software Foundation; either version 3 of
|
||||
* the License, or (at your option) any later version.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this library; if not, write to the Free Software
|
||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
||||
|
||||
|
||||
/* {Weak Vectors}
|
||||
*/
|
||||
|
||||
#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
|
||||
|
||||
static SCM
|
||||
make_weak_vector (size_t len, SCM fill)
|
||||
#define FUNC_NAME "make-weak-vector"
|
||||
{
|
||||
SCM wv;
|
||||
size_t j;
|
||||
|
||||
SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
|
||||
|
||||
if (SCM_UNBNDP (fill))
|
||||
fill = SCM_UNSPECIFIED;
|
||||
|
||||
wv = PTR2SCM (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
|
||||
"weak vector"));
|
||||
|
||||
SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
|
||||
|
||||
if (SCM_NIMP (fill))
|
||||
{
|
||||
memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
|
||||
for (j = 0; j < len; j++)
|
||||
scm_c_weak_vector_set_x (wv, j, fill);
|
||||
}
|
||||
else
|
||||
for (j = 0; j < len; j++)
|
||||
SCM_SIMPLE_VECTOR_SET (wv, j, fill);
|
||||
|
||||
return wv;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
|
||||
(SCM size, SCM fill),
|
||||
"Return a weak vector with @var{size} elements. If the optional\n"
|
||||
"argument @var{fill} is given, all entries in the vector will be\n"
|
||||
"set to @var{fill}. The default value for @var{fill} is the\n"
|
||||
"empty list.")
|
||||
#define FUNC_NAME s_scm_make_weak_vector
|
||||
{
|
||||
return make_weak_vector (scm_to_size_t (size), fill);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
|
||||
|
||||
SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
|
||||
(SCM lst),
|
||||
"@deffnx {Scheme Procedure} list->weak-vector lst\n"
|
||||
"Construct a weak vector from a list: @code{weak-vector} uses\n"
|
||||
"the list of its arguments while @code{list->weak-vector} uses\n"
|
||||
"its only argument @var{l} (a list) to construct a weak vector\n"
|
||||
"the same way @code{list->vector} would.")
|
||||
#define FUNC_NAME s_scm_weak_vector
|
||||
{
|
||||
SCM wv;
|
||||
size_t i;
|
||||
long c_size;
|
||||
|
||||
SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size);
|
||||
|
||||
wv = make_weak_vector ((size_t) c_size, SCM_BOOL_F);
|
||||
|
||||
for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++)
|
||||
scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst));
|
||||
|
||||
return wv;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
|
||||
"weak hashes are also weak vectors.")
|
||||
#define FUNC_NAME s_scm_weak_vector_p
|
||||
{
|
||||
return scm_from_bool (SCM_I_WVECTP (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
struct weak_vector_ref_data
|
||||
{
|
||||
SCM wv;
|
||||
size_t k;
|
||||
};
|
||||
|
||||
static void*
|
||||
weak_vector_ref (void *data)
|
||||
{
|
||||
struct weak_vector_ref_data *d = data;
|
||||
|
||||
return SCM_SIMPLE_VECTOR_REF (d->wv, d->k);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_c_weak_vector_ref (SCM wv, size_t k)
|
||||
{
|
||||
struct weak_vector_ref_data d;
|
||||
void *ret;
|
||||
|
||||
d.wv = wv;
|
||||
d.k = k;
|
||||
|
||||
if (k >= SCM_I_VECTOR_LENGTH (wv))
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
|
||||
ret = GC_call_with_alloc_lock (weak_vector_ref, &d);
|
||||
|
||||
if (ret)
|
||||
return PTR2SCM (ret);
|
||||
else
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
|
||||
{
|
||||
SCM *elts;
|
||||
struct weak_vector_ref_data d;
|
||||
void *prev;
|
||||
|
||||
d.wv = wv;
|
||||
d.k = k;
|
||||
|
||||
if (k >= SCM_I_VECTOR_LENGTH (wv))
|
||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||
|
||||
prev = GC_call_with_alloc_lock (weak_vector_ref, &d);
|
||||
|
||||
elts = SCM_I_VECTOR_WELTS (wv);
|
||||
|
||||
if (prev && SCM_NIMP (PTR2SCM (prev)))
|
||||
GC_unregister_disappearing_link ((GC_PTR) &elts[k]);
|
||||
|
||||
elts[k] = x;
|
||||
|
||||
if (SCM_NIMP (x))
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k],
|
||||
(GC_PTR) SCM2PTR (x));
|
||||
}
|
||||
|
||||
|
||||
|
||||
static void
|
||||
scm_init_weak_vector_builtins (void)
|
||||
{
|
||||
#ifndef SCM_MAGIC_SNARFER
|
||||
#include "libguile/weak-vector.x"
|
||||
#endif
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_weak_vectors ()
|
||||
{
|
||||
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
|
||||
"scm_init_weak_vector_builtins",
|
||||
(scm_t_extension_init_func)scm_init_weak_vector_builtins,
|
||||
NULL);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
48
libguile/weak-vector.h
Normal file
48
libguile/weak-vector.h
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_WEAK_VECTOR_H
|
||||
#define SCM_WEAK_VECTOR_H
|
||||
|
||||
/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* as published by the Free Software Foundation; either version 3 of
|
||||
* the License, or (at your option) any later version.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this library; if not, write to the Free Software
|
||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
|
||||
/* Weak vectors. */
|
||||
|
||||
#define SCM_I_WVECTP(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_wvect)
|
||||
|
||||
SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
|
||||
SCM_API SCM scm_weak_vector (SCM l);
|
||||
SCM_API SCM scm_weak_vector_p (SCM x);
|
||||
SCM_INTERNAL SCM scm_c_weak_vector_ref (SCM v, size_t k);
|
||||
SCM_INTERNAL void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x);
|
||||
|
||||
SCM_INTERNAL void scm_init_weak_vectors (void);
|
||||
|
||||
|
||||
#endif /* SCM_WEAK_VECTOR_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
294
libguile/weaks.c
294
libguile/weaks.c
|
|
@ -1,294 +0,0 @@
|
|||
/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* as published by the Free Software Foundation; either version 3 of
|
||||
* the License, or (at your option) any later version.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this library; if not, write to the Free Software
|
||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/hashtab.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/weaks.h"
|
||||
|
||||
#include "libguile/bdw-gc.h"
|
||||
#include <gc/gc_typed.h>
|
||||
|
||||
|
||||
|
||||
/* Weak pairs for use in weak alist vectors and weak hash tables.
|
||||
|
||||
We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak
|
||||
pairs, the weak component(s) are not scanned for pointers and are
|
||||
registered as disapperaring links; therefore, the weak component may be
|
||||
set to NULL by the garbage collector when no other reference to that word
|
||||
exist. Thus, users should only access weak pairs via the
|
||||
`SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in
|
||||
`hashtab.c'. */
|
||||
|
||||
/* Type descriptors for weak-c[ad]r pairs. */
|
||||
static GC_descr wcar_pair_descr, wcdr_pair_descr;
|
||||
|
||||
|
||||
SCM
|
||||
scm_weak_car_pair (SCM car, SCM cdr)
|
||||
{
|
||||
scm_t_cell *cell;
|
||||
|
||||
cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
|
||||
wcar_pair_descr);
|
||||
|
||||
cell->word_0 = car;
|
||||
cell->word_1 = cdr;
|
||||
|
||||
if (SCM_NIMP (car))
|
||||
/* Weak car cells make sense iff the car is non-immediate. */
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
|
||||
(GC_PTR) SCM2PTR (car));
|
||||
|
||||
return (SCM_PACK (cell));
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_weak_cdr_pair (SCM car, SCM cdr)
|
||||
{
|
||||
scm_t_cell *cell;
|
||||
|
||||
cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
|
||||
wcdr_pair_descr);
|
||||
|
||||
cell->word_0 = car;
|
||||
cell->word_1 = cdr;
|
||||
|
||||
if (SCM_NIMP (cdr))
|
||||
/* Weak cdr cells make sense iff the cdr is non-immediate. */
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
|
||||
(GC_PTR) SCM2PTR (cdr));
|
||||
|
||||
return (SCM_PACK (cell));
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_doubly_weak_pair (SCM car, SCM cdr)
|
||||
{
|
||||
/* Doubly weak cells shall not be scanned at all for pointers. */
|
||||
scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
|
||||
"weak cell");
|
||||
|
||||
cell->word_0 = car;
|
||||
cell->word_1 = cdr;
|
||||
|
||||
if (SCM_NIMP (car))
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
|
||||
(GC_PTR) SCM2PTR (car));
|
||||
if (SCM_NIMP (cdr))
|
||||
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
|
||||
(GC_PTR) SCM2PTR (cdr));
|
||||
|
||||
return (SCM_PACK (cell));
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/* 1. The current hash table implementation in hashtab.c uses weak alist
|
||||
* vectors (formerly called weak hash tables) internally.
|
||||
*
|
||||
* 2. All hash table operations still work on alist vectors.
|
||||
*
|
||||
* 3. The weak vector and alist vector Scheme API is accessed through
|
||||
* the module (ice-9 weak-vector).
|
||||
*/
|
||||
|
||||
|
||||
/* {Weak Vectors}
|
||||
*/
|
||||
|
||||
|
||||
SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
|
||||
(SCM size, SCM fill),
|
||||
"Return a weak vector with @var{size} elements. If the optional\n"
|
||||
"argument @var{fill} is given, all entries in the vector will be\n"
|
||||
"set to @var{fill}. The default value for @var{fill} is the\n"
|
||||
"empty list.")
|
||||
#define FUNC_NAME s_scm_make_weak_vector
|
||||
{
|
||||
return scm_i_make_weak_vector (0, size, fill);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
|
||||
|
||||
SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
|
||||
(SCM l),
|
||||
"@deffnx {Scheme Procedure} list->weak-vector l\n"
|
||||
"Construct a weak vector from a list: @code{weak-vector} uses\n"
|
||||
"the list of its arguments while @code{list->weak-vector} uses\n"
|
||||
"its only argument @var{l} (a list) to construct a weak vector\n"
|
||||
"the same way @code{list->vector} would.")
|
||||
#define FUNC_NAME s_scm_weak_vector
|
||||
{
|
||||
return scm_i_make_weak_vector_from_list (0, l);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
|
||||
"weak hashes are also weak vectors.")
|
||||
#define FUNC_NAME s_scm_weak_vector_p
|
||||
{
|
||||
return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/* Weak alist vectors, i.e., vectors of alists.
|
||||
|
||||
The alist vector themselves are _not_ weak. The `car' (or `cdr', or both)
|
||||
of the pairs within it are weak. See `hashtab.c' for details. */
|
||||
|
||||
|
||||
/* FIXME: We used to have two implementations of weak hash tables: the one in
|
||||
here and the one in `hashtab.c'. The difference is that weak alist
|
||||
vectors could be used as vectors while (weak) hash tables can't. We need
|
||||
to unify that. */
|
||||
|
||||
SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
|
||||
(SCM size),
|
||||
"@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
|
||||
"@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
|
||||
"Return a weak hash table with @var{size} buckets. As with any\n"
|
||||
"hash table, choosing a good size for the table requires some\n"
|
||||
"caution.\n"
|
||||
"\n"
|
||||
"You can modify weak hash tables in exactly the same way you\n"
|
||||
"would modify regular hash tables. (@pxref{Hash Tables})")
|
||||
#define FUNC_NAME s_scm_make_weak_key_alist_vector
|
||||
{
|
||||
return scm_make_weak_key_hash_table (size);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
|
||||
(SCM size),
|
||||
"Return a hash table with weak values with @var{size} buckets.\n"
|
||||
"(@pxref{Hash Tables})")
|
||||
#define FUNC_NAME s_scm_make_weak_value_alist_vector
|
||||
{
|
||||
return scm_make_weak_value_hash_table (size);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
|
||||
(SCM size),
|
||||
"Return a hash table with weak keys and values with @var{size}\n"
|
||||
"buckets. (@pxref{Hash Tables})")
|
||||
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
|
||||
{
|
||||
return scm_make_doubly_weak_hash_table (size);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
|
||||
"@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
|
||||
"Return @code{#t} if @var{obj} is the specified weak hash\n"
|
||||
"table. Note that a doubly weak hash table is neither a weak key\n"
|
||||
"nor a weak value hash table.")
|
||||
#define FUNC_NAME s_scm_weak_key_alist_vector_p
|
||||
{
|
||||
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return @code{#t} if @var{obj} is a weak value hash table.")
|
||||
#define FUNC_NAME s_scm_weak_value_alist_vector_p
|
||||
{
|
||||
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return @code{#t} if @var{obj} is a doubly weak hash table.")
|
||||
#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
|
||||
{
|
||||
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
|
||||
SCM
|
||||
scm_init_weaks_builtins ()
|
||||
{
|
||||
#include "libguile/weaks.x"
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
void
|
||||
scm_weaks_prehistory ()
|
||||
{
|
||||
/* Initialize weak pairs. */
|
||||
GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
|
||||
GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
|
||||
|
||||
/* In a weak-car pair, only the second word must be scanned for
|
||||
pointers. */
|
||||
GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
|
||||
wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
|
||||
GC_WORD_LEN (scm_t_cell));
|
||||
|
||||
/* Conversely, in a weak-cdr pair, only the first word must be scanned for
|
||||
pointers. */
|
||||
GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
|
||||
wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
|
||||
GC_WORD_LEN (scm_t_cell));
|
||||
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_weaks ()
|
||||
{
|
||||
scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
|
||||
scm_init_weaks_builtins);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
101
libguile/weaks.h
101
libguile/weaks.h
|
|
@ -1,101 +0,0 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_WEAKS_H
|
||||
#define SCM_WEAKS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* as published by the Free Software Foundation; either version 3 of
|
||||
* the License, or (at your option) any later version.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this library; if not, write to the Free Software
|
||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
|
||||
|
||||
#define SCM_WVECTF_WEAK_KEY 1
|
||||
#define SCM_WVECTF_WEAK_VALUE 2
|
||||
|
||||
#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
|
||||
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)
|
||||
|
||||
#define SCM_I_WVECT_TYPE(x) (SCM_I_WVECT_EXTRA(x) & 7)
|
||||
#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA \
|
||||
((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
|
||||
#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
|
||||
#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
|
||||
#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
|
||||
#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
|
||||
|
||||
|
||||
/* Weak pairs. */
|
||||
|
||||
SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
|
||||
SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
|
||||
SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
|
||||
|
||||
/* Testing the weak component(s) of a cell for reachability. */
|
||||
#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
|
||||
(SCM_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0)
|
||||
#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
|
||||
(SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
|
||||
#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \
|
||||
(SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1))
|
||||
|
||||
#define SCM_WEAK_PAIR_DELETED_P(_cell) \
|
||||
((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \
|
||||
|| (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))
|
||||
|
||||
/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if
|
||||
the car/cdr has been collected. */
|
||||
#define SCM_WEAK_PAIR_WORD(_cell, _word) \
|
||||
(SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \
|
||||
? SCM_UNDEFINED \
|
||||
: SCM_CELL_OBJECT ((_cell), (_word)))
|
||||
#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0))
|
||||
#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1))
|
||||
|
||||
|
||||
|
||||
/* Weak vectors and weak hash tables. */
|
||||
|
||||
SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
|
||||
SCM_API SCM scm_weak_vector (SCM l);
|
||||
SCM_API SCM scm_weak_vector_p (SCM x);
|
||||
SCM_API SCM scm_make_weak_key_alist_vector (SCM k);
|
||||
SCM_API SCM scm_make_weak_value_alist_vector (SCM k);
|
||||
SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
|
||||
SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
|
||||
SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
|
||||
SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
|
||||
SCM_INTERNAL SCM scm_init_weaks_builtins (void);
|
||||
SCM_INTERNAL void scm_weaks_prehistory (void);
|
||||
SCM_INTERNAL void scm_init_weaks (void);
|
||||
|
||||
SCM_INTERNAL void scm_i_init_weak_vectors_for_gc (void);
|
||||
SCM_INTERNAL void scm_i_mark_weak_vector (SCM w);
|
||||
SCM_INTERNAL int scm_i_mark_weak_vectors_non_weaks (void);
|
||||
SCM_INTERNAL void scm_i_remove_weaks_from_weak_vectors (void);
|
||||
|
||||
|
||||
#endif /* SCM_WEAKS_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;; installed-scm-file
|
||||
|
||||
;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2003, 2006, 2011 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -19,13 +19,8 @@
|
|||
|
||||
|
||||
(define-module (ice-9 weak-vector)
|
||||
:export (make-weak-vector list->weak-vector weak-vector weak-vector?
|
||||
make-weak-key-alist-vector
|
||||
make-weak-value-alist-vector
|
||||
make-doubly-weak-alist-vector
|
||||
weak-key-alist-vector?
|
||||
weak-value-alist-vector?
|
||||
doubly-weak-alist-vector?) ; C
|
||||
)
|
||||
#:export (make-weak-vector list->weak-vector weak-vector weak-vector?))
|
||||
|
||||
(%init-weaks-builtins) ; defined in libguile/weaks.c
|
||||
(eval-when (load eval compile)
|
||||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_weak_vector_builtins"))
|
||||
|
|
|
|||
|
|
@ -68,28 +68,28 @@
|
|||
exception:wrong-type-arg
|
||||
(list->weak-vector 32)))
|
||||
|
||||
(with-test-prefix "make-weak-key-alist-vector"
|
||||
(with-test-prefix "make-weak-key-hash-table"
|
||||
(pass-if "create"
|
||||
(make-weak-key-alist-vector 17)
|
||||
(make-weak-key-hash-table 17)
|
||||
#t)
|
||||
(pass-if-exception "bad-args"
|
||||
exception:wrong-type-arg
|
||||
(make-weak-key-alist-vector '(bad arg))))
|
||||
(with-test-prefix "make-weak-value-alist-vector"
|
||||
(make-weak-key-hash-table '(bad arg))))
|
||||
(with-test-prefix "make-weak-value-hash-table"
|
||||
(pass-if "create"
|
||||
(make-weak-value-alist-vector 17)
|
||||
(make-weak-value-hash-table 17)
|
||||
#t)
|
||||
(pass-if-exception "bad-args"
|
||||
exception:wrong-type-arg
|
||||
(make-weak-value-alist-vector '(bad arg))))
|
||||
(make-weak-value-hash-table '(bad arg))))
|
||||
|
||||
(with-test-prefix "make-doubly-weak-alist-vector"
|
||||
(with-test-prefix "make-doubly-weak-hash-table"
|
||||
(pass-if "create"
|
||||
(make-doubly-weak-alist-vector 17)
|
||||
(make-doubly-weak-hash-table 17)
|
||||
#t)
|
||||
(pass-if-exception "bad-args"
|
||||
exception:wrong-type-arg
|
||||
(make-doubly-weak-alist-vector '(bad arg)))))
|
||||
(make-doubly-weak-hash-table '(bad arg)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -138,9 +138,9 @@
|
|||
(or (not value)
|
||||
(equal? value initial-value)))
|
||||
|
||||
(let ((x (make-weak-key-alist-vector 17))
|
||||
(y (make-weak-value-alist-vector 17))
|
||||
(z (make-doubly-weak-alist-vector 17))
|
||||
(let ((x (make-weak-key-hash-table 17))
|
||||
(y (make-weak-value-hash-table 17))
|
||||
(z (make-doubly-weak-hash-table 17))
|
||||
(test-key "foo")
|
||||
(test-value "bar"))
|
||||
(with-test-prefix
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue