guile/libguile/ephemerons.c

/* 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
   <https://www.gnu.org/licenses/>.  */




#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <assert.h>
#include <errno.h>
#include <fcntl.h>
#include <full-write.h>
#include <stdio.h>
#include <unistd.h>

#include "extensions.h"
#include "gc-internal.h"
#include "gsubr.h"
#include "ports.h"
#include "threads.h"
#include "version.h"

#include <gc-ephemeron.h>

#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 ("#<ephemeron ", port);
  scm_uintprint (SCM_UNPACK (exp), 16, port);
  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);
}