/* Copyright 2025 Free Software Foundation, Inc.
This file is part of Guile.
Guile 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.
Guile 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 Guile. If not, see
. */
#ifdef HAVE_CONFIG_H
# include
#endif
#include
#include
#include
#include
#include
#include
#include "extensions.h"
#include "gc-internal.h"
#include "gsubr.h"
#include "ports.h"
#include "threads.h"
#include "version.h"
#include
#include "ephemerons.h"
#define SCM_EPHEMERON_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron))
#define SCM_VALIDATE_EPHEMERON(pos, x) \
SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_P, "ephemeron")
static inline SCM ref_to_scm (struct gc_ref ref)
{
return SCM_PACK (gc_ref_value (ref));
}
static inline struct gc_ref scm_to_ref (SCM scm)
{
return gc_ref (SCM_UNPACK (scm));
}
SCM_DEFINE_STATIC (scm_ephemeron_p, "ephemeron?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is an ephemeron, or "
"@code{#f} otherwise.")
#define FUNC_NAME s_scm_ephemeron_p
{
return scm_from_bool (SCM_EPHEMERON_P (x));
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_make_ephemeron, "make-ephemeron", 2, 0, 0,
(SCM key, SCM val),
"Make an ephemeron that will reference @var{val} as long "
"as @var{key} and the ephemeron itself are alive.")
#define FUNC_NAME s_scm_make_ephemeron
{
SCM_MAKE_VALIDATE (1, key, HEAP_OBJECT_P);
struct scm_thread *thread = SCM_I_CURRENT_THREAD;
struct gc_ephemeron *ephemeron = gc_allocate_ephemeron (thread->mutator);
SCM ret = SCM_PACK_POINTER (ephemeron);
SCM_SET_CELL_WORD_0 (ret, scm_tc7_ephemeron);
gc_ephemeron_init (thread->mutator, ephemeron, scm_to_ref (key),
scm_to_ref (val));
return ret;
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_ephemeron_key, "ephemeron-key", 1, 0, 0,
(SCM ephemeron),
"Return the key for an ephemeron, or @code{#f} if the "
"ephemeron is dead.")
#define FUNC_NAME s_scm_ephemeron_key
{
SCM_VALIDATE_EPHEMERON (1, ephemeron);
struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron);
struct gc_ref ret = gc_ephemeron_key (e);
return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret);
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_ephemeron_value, "ephemeron-value", 1, 0, 0,
(SCM ephemeron),
"Return the value for an ephemeron, or @code{#f} if the "
"ephemeron is dead.")
#define FUNC_NAME s_scm_ephemeron_value
{
SCM_VALIDATE_EPHEMERON (1, ephemeron);
struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron);
struct gc_ref ret = gc_ephemeron_value (e);
return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret);
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_ephemeron_mark_dead_x, "ephemeron-mark-dead!", 1, 0, 0,
(SCM ephemeron),
"Remove the key-value association for this ephemeron.")
#define FUNC_NAME s_scm_ephemeron_mark_dead_x
{
SCM_VALIDATE_EPHEMERON (1, ephemeron);
struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron);
gc_ephemeron_mark_dead (e);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
int
scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#", port);
return 1;
}
static void
scm_init_ephemerons (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "ephemerons.x"
#endif
}
void
scm_register_ephemerons (void)
{
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_ephemerons",
(scm_t_extension_init_func)scm_init_ephemerons,
NULL);
}