guile/libguile/smob.c

/* Copyright 1995-1996,1998-2001,2003-2004,2006,2009-2013,2015,2018,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 <errno.h>
#include <stdio.h>
#include <stdlib.h>

#include "async.h"
#include "atomics-internal.h"
#include "bdw-gc.h"
#include "finalizers.h"
#include "goops.h"
#include "gsubr.h"
#include "instructions.h"
#include "numbers.h"
#include "ports.h"
#include "programs.h"

#include "smob.h"




/* scm_smobs scm_numsmob
 * implement a fixed sized array of smob records.
 * Indexes into this table are used when generating type
 * tags for smobjects (if you know a tag you can get an index and conversely).
 */

#define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT

long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];

void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
  if (!SCM_SMOB_PREDICATE (tag, val))
    scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
}


/* {Print}
 */

int
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  long n = SCM_SMOBNUM (exp);
  scm_puts ("#<", port);
  scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
  scm_putc (' ', port);
  if (scm_smobs[n].size)
    scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
  else
    scm_uintprint (SCM_UNPACK (exp), 16, port);
  scm_putc ('>', port);
  return 1;
}


/* {Apply}
 */

static SCM scm_smob_trampolines[16];
  
/* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
  scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
                       + nopt + rest * (nreq + nopt + rest + 1)]

static SCM
apply_0 (SCM smob)
{
  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
  return subr (smob);
}

static SCM
apply_1 (SCM smob, SCM a)
{
  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
  return subr (smob, a);
}

static SCM
apply_2 (SCM smob, SCM a, SCM b)
{
  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
  return subr (smob, a, b);
}

static SCM
apply_3 (SCM smob, SCM a, SCM b, SCM c)
{
  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
  return subr (smob, a, b, c);
}

static SCM
scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
                     unsigned int rest)
{
  SCM trampoline;

  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
    scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
      
  trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);

  if (SCM_LIKELY (SCM_UNPACK (trampoline)))
    return trampoline;

  switch (nreq + nopt + rest)
    {
      /* The + 1 is for the smob itself.  */
    case 0:
      trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
                                     apply_0);
      break;
    case 1:
      trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
                                     apply_1);
      break;
    case 2:
      trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
                                     apply_2);
      break;
    case 3:
      trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
                                     apply_3);
      break;
    default:
      abort ();
    }

  SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;

  return trampoline;
}



scm_t_bits 
scm_make_smob_type (char const *name, size_t size)
#define FUNC_NAME "scm_make_smob_type"
{
  long new_smob;

  scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
  new_smob = scm_numsmob;
  if (scm_numsmob != MAX_SMOB_COUNT)
    ++scm_numsmob;
  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);

  if (new_smob == MAX_SMOB_COUNT)
    scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);

  scm_smobs[new_smob].name = name;
  scm_smobs[new_smob].size = size;

  /* Make a class object if Goops is present. */
  if (SCM_UNPACK (scm_i_smob_class[0]) != 0)
    scm_i_smob_class[new_smob] = scm_make_extended_class (name, 0);

  return scm_tc7_smob + new_smob * 256;
}
#undef FUNC_NAME


void
scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
}

void
scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
}

void
scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
}

void
scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
		    unsigned int req, unsigned int opt, unsigned int rst)
{
  SCM trampoline = scm_smob_trampoline (req, opt, rst);

  scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;

  if (SCM_UNPACK (scm_i_smob_class[0]) != 0)
    scm_i_inherit_applicable (scm_i_smob_class[SCM_TC2SMOBNUM (tc)]);
}

SCM
scm_make_smob (scm_t_bits tc)
{
  scm_t_bits n = SCM_TC2SMOBNUM (tc);
  size_t size = scm_smobs[n].size;
  scm_t_bits data = (size > 0
		     ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
		     : 0);

  SCM_RETURN_NEWSMOB (tc, data);
}



/* Finalize SMOB by calling its SMOB type's free function, if any.  */
void
scm_i_finalize_smob (struct scm_thread *thread, SCM smob)
{
  scm_t_bits *first_word_loc = SCM_UNPACK_POINTER (smob);
  scm_t_bits first_word = *first_word_loc;
  scm_t_bits smobnum = SCM_TC2SMOBNUM (first_word & SCM_SMOB_TYPE_MASK);

  /* Frob the object's type in place, re-setting it to be the "finalized
     smob" type.  This will prevent other routines from accessing its
     internals in a way that assumes that the smob data is valid.  */
  scm_t_bits finalized_word = first_word & ~(scm_t_bits) 0xff00;
  scm_atomic_set_bits (first_word_loc, finalized_word);

#if 0
  printf ("finalizing SMOB %p (smobnum: %u)\n", first_word_loc, smobnum);
#endif

  size_t (* free_smob) (SCM) = scm_smobs[smobnum].free;
  if (free_smob)
    free_smob (smob);
}

/* Return a SMOB with typecode TC.  */
SCM
scm_new_smob (scm_t_bits tc, scm_t_bits data)
{
  scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
  SCM ret = scm_cell (tc, data);

  if (SCM_UNLIKELY (scm_smobs[smobnum].free))
    scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);

  return ret;
}

/* Return a SMOB with typecode TC.  */
SCM
scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
                     scm_t_bits data2, scm_t_bits data3)
{
  scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
  SCM ret = scm_double_cell (tc, data1, data2, data3);

  if (SCM_UNLIKELY (scm_smobs[smobnum].free))
    scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);

  return ret;
}




SCM
scm_smob_type_class (scm_t_bits tc)
{
  scm_load_goops ();

  return scm_i_smob_class[SCM_TC2SMOBNUM (tc)];
}



void
scm_smob_prehistory ()
{
  long i;
  scm_t_bits finalized_smob_tc16;

  scm_numsmob = 0;
  for (i = 0; i < MAX_SMOB_COUNT; ++i)
    {
      scm_smobs[i].name       = 0;
      scm_smobs[i].size       = 0;
      scm_smobs[i].free       = 0;
      scm_smobs[i].print      = scm_smob_print;
      scm_smobs[i].equalp     = 0;
      scm_smobs[i].apply      = 0;
      scm_smobs[i].apply_trampoline = SCM_BOOL_F;
    }

  finalized_smob_tc16 = scm_make_smob_type ("finalized smob", 0);
  if (SCM_TC2SMOBNUM (finalized_smob_tc16) != 0) abort ();
}