[bpt/guile.git] / libguile / smob.c

/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
 *   2009, 2010, 2011, 2012, 2013, 2015 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
 */


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

#include <stdio.h>
#include <stdlib.h>
#include <errno.h>

#include "libguile/_scm.h"

#include "libguile/async.h"
#include "libguile/goops.h"
#include "libguile/instructions.h"
#include "libguile/programs.h"

#include "libguile/smob.h"

#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>


\f

/* 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);
}

/* {Mark}
 */

/* This function is vestigial.  It used to be the mark function's
   responsibility to set the mark bit on the smob or port, but now the
   generic marking routine in gc.c takes care of that, and a zero
   pointer for a mark function means "don't bother".  So you never
   need scm_mark0.

   However, we leave it here because it's harmless to call it, and
   people out there have smob code that uses it, and there's no reason
   to make their links fail.  */

SCM 
scm_mark0 (SCM ptr SCM_UNUSED)
{
  return SCM_BOOL_F;
}

SCM 
/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
   be used for real pairs. */
scm_markcdr (SCM ptr)
{
  return SCM_CELL_OBJECT_1 (ptr);
}

\f
/* {Free}
 */

size_t 
scm_free0 (SCM ptr SCM_UNUSED)
{
  return 0;
}

\f
/* {Print}
 */

int
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  long n = SCM_SMOBNUM (exp);
  scm_puts_unlocked ("#<", port);
  scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
  scm_putc_unlocked (' ', 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_unlocked ('>', port);
  return 1;
}

\f
/* {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;
}

\f

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_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
  scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
}

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);
}


\f
/* Marking SMOBs using user-supplied mark procedures.  */


/* The GC kind used for SMOB types that provide a custom mark procedure.  */
static int smob_gc_kind;

/* Mark stack pointer and limit, used by `scm_gc_mark'.  */
static scm_i_pthread_key_t current_mark_stack_pointer;
static scm_i_pthread_key_t current_mark_stack_limit;


/* The generic SMOB mark procedure that gets called for SMOBs allocated
   with smob_gc_kind.  */
static struct GC_ms_entry *
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
	   struct GC_ms_entry *mark_stack_limit, GC_word env)
{
  register SCM cell;
  register scm_t_bits tc, smobnum;

  cell = SCM_PACK_POINTER (addr);

  if (SCM_TYP7 (cell) != scm_tc7_smob)
    /* It is likely that the GC passed us a pointer to a free-list element
       which we must ignore (see warning in `gc/gc_mark.h').  */
    return mark_stack_ptr;

  tc = SCM_CELL_WORD_0 (cell);
  smobnum = SCM_TC2SMOBNUM (tc);

  if (smobnum >= scm_numsmob)
    /* The first word looks corrupt.  */
    abort ();

  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);
  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);
  mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
				     mark_stack_ptr,
				     mark_stack_limit, NULL);

  if (scm_smobs[smobnum].mark)
    {
      SCM obj;

      scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
      scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);

      /* Invoke the SMOB's mark procedure, which will in turn invoke
	 `scm_gc_mark', which may modify `current_mark_stack_pointer'.  */
      obj = scm_smobs[smobnum].mark (cell);

      mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);

      if (SCM_HEAP_OBJECT_P (obj))
	/* Mark the returned object.  */
	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
					   mark_stack_ptr,
					   mark_stack_limit, NULL);

      scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
      scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
    }

  return mark_stack_ptr;

}

/* Mark object O.  We assume that this function is only called during the mark
   phase, i.e., from within `smob_mark' or one of its descendants.  */
void
scm_gc_mark (SCM o)
{
  if (SCM_HEAP_OBJECT_P (o))
    {
      void *mark_stack_ptr, *mark_stack_limit;

      mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
      mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);

      if (mark_stack_ptr == NULL)
	/* The function was not called from a mark procedure.  */
	abort ();

      mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
					 mark_stack_ptr, mark_stack_limit,
					 NULL);
      scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
    }
}

\f
/* Finalize SMOB by calling its SMOB type's free function, if any.  */
static void
finalize_smob (void *ptr, void *data)
{
  SCM smob;
  size_t (* free_smob) (SCM);

  smob = SCM_PACK_POINTER (ptr);
#if 0
  printf ("finalizing SMOB %p (smobnum: %u)\n",
	  ptr, SCM_SMOBNUM (smob));
#endif

  free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
  if (free_smob)
    free_smob (smob);
}

/* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
   provide a custom mark procedure and it will be honored.  */
SCM
scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
{
  scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
  SCM ret;

  /* Use the smob_gc_kind if needed to allow the mark procedure to
     run.  Since the marker only deals with double cells, that case
     allocates a double cell.  We leave words 2 and 3 to there initial
     values, which is 0.  */
  if (scm_smobs [smobnum].mark)
    ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
  else
    ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
  
  SCM_SET_CELL_WORD_1 (ret, data);
  SCM_SET_CELL_WORD_0 (ret, tc);

  if (scm_smobs[smobnum].free)
    scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);

  return ret;
}

/* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
   provide a custom mark procedure and it will be honored.  */
SCM
scm_i_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;

  /* Use the smob_gc_kind if needed to allow the mark procedure to
     run.  */
  if (scm_smobs [smobnum].mark)
    ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
  else
    ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
  
  SCM_SET_CELL_WORD_3 (ret, data3);
  SCM_SET_CELL_WORD_2 (ret, data2);
  SCM_SET_CELL_WORD_1 (ret, data1);
  SCM_SET_CELL_WORD_0 (ret, tc);

  if (scm_smobs[smobnum].free)
    scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);

  return ret;
}


\f

SCM
scm_smob_type_class (scm_t_bits tc)
{
  scm_load_goops ();

  return scm_i_smob_class[SCM_TC2SMOBNUM (tc)];
}


\f
void
scm_smob_prehistory ()
{
  long i;

  scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
  scm_i_pthread_key_create (&current_mark_stack_limit, NULL);

  smob_gc_kind = GC_new_kind (GC_new_free_list (),
			      GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
			      0,
			      /* Clear new objects.  As of version 7.1, libgc
				 doesn't seem to support passing 0 here.  */
			      1);

  scm_numsmob = 0;
  for (i = 0; i < MAX_SMOB_COUNT; ++i)
    {
      scm_smobs[i].name       = 0;
      scm_smobs[i].size       = 0;
      scm_smobs[i].mark       = 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;
    }
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
01b69e79	1	/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
57898597	2	* 2009, 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc.
01b69e79	3	*
73be1d9e	4	* This library is free software; you can redistribute it and/or
53befeb7 NJ	5	* modify it under the terms of the GNU Lesser General Public License
	6	* as published by the Free Software Foundation; either version 3 of
	7	* the License, or (at your option) any later version.
0f2d19dd	8	*
53befeb7 NJ	9	* This library is distributed in the hope that it will be useful, but
53befeb7 NJ	10	* WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	11	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	12	* Lesser General Public License for more details.
0f2d19dd	13	*
73be1d9e MV	14	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	15	* License along with this library; if not, write to the Free Software
53befeb7 NJ	16	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
53befeb7 NJ	17	* 02110-1301 USA
73be1d9e	18	*/
1bbd0b84	19
1bbd0b84	20
0f2d19dd	21	\f
dbb605f5	22	#ifdef HAVE_CONFIG_H
f9fe039d RB	23	# include <config.h>
f9fe039d RB	24	#endif
0f2d19dd JB	25
0f2d19dd JB	26	#include <stdio.h>
34cf38c3	27	#include <stdlib.h>
e6e2e95a MD	28	#include <errno.h>
e6e2e95a MD	29
a0599745	30	#include "libguile/_scm.h"
20e6290e	31
4e047c3e	32	#include "libguile/async.h"
9511876f	33	#include "libguile/goops.h"
75c3ed28	34	#include "libguile/instructions.h"
75c3ed28	35	#include "libguile/programs.h"
d7ec6b9f	36
a0599745	37	#include "libguile/smob.h"
9dd5943c	38
1c44468d	39	#include "libguile/bdw-gc.h"
e9d635e5 LC	40	#include <gc/gc_mark.h>
	41
	42
0f2d19dd JB	43	\f
	44
	45	/* scm_smobs scm_numsmob
7a7f7c53	46	* implement a fixed sized array of smob records.
0f2d19dd JB	47	* Indexes into this table are used when generating type
	48	* tags for smobjects (if you know a tag you can get an index and conversely).
	49	*/
7a7f7c53	50
c891a40e LC	51	#define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
c891a40e LC	52
c014a02e	53	long scm_numsmob;
7a7f7c53	54	scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
0f2d19dd	55
197b0573 MV	56	void
	57	scm_assert_smob_type (scm_t_bits tag, SCM val)
	58	{
	59	if (!SCM_SMOB_PREDICATE (tag, val))
	60	scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
	61	}
	62
9dd5943c MD	63	/* {Mark}
	64	*/
	65
	66	/* This function is vestigial. It used to be the mark function's
	67	responsibility to set the mark bit on the smob or port, but now the
	68	generic marking routine in gc.c takes care of that, and a zero
	69	pointer for a mark function means "don't bother". So you never
	70	need scm_mark0.
	71
	72	However, we leave it here because it's harmless to call it, and
	73	people out there have smob code that uses it, and there's no reason
	74	to make their links fail. */
	75
	76	SCM
e81d98ec	77	scm_mark0 (SCM ptr SCM_UNUSED)
9dd5943c MD	78	{
	79	return SCM_BOOL_F;
	80	}
	81
	82	SCM
22a52da1 DH	83	/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
22a52da1 DH	84	be used for real pairs. */
6e8d25a6	85	scm_markcdr (SCM ptr)
9dd5943c	86	{
22a52da1	87	return SCM_CELL_OBJECT_1 (ptr);
9dd5943c MD	88	}
9dd5943c MD	89
3051344b	90	\f
9dd5943c MD	91	/* {Free}
	92	*/
	93
1be6b49c	94	size_t
e81d98ec	95	scm_free0 (SCM ptr SCM_UNUSED)
9dd5943c MD	96	{
	97	return 0;
	98	}
	99
3051344b	100	\f
9dd5943c MD	101	/* {Print}
	102	*/
	103
	104	int
e81d98ec	105	scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
9dd5943c	106	{
c014a02e	107	long n = SCM_SMOBNUM (exp);
0607ebbf AW	108	scm_puts_unlocked ("#<", port);
	109	scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
	110	scm_putc_unlocked (' ', port);
7a7f7c53	111	if (scm_smobs[n].size)
0345e278	112	scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
7a7f7c53	113	else
0345e278	114	scm_uintprint (SCM_UNPACK (exp), 16, port);
0607ebbf	115	scm_putc_unlocked ('>', port);
9dd5943c MD	116	return 1;
9dd5943c MD	117	}
1cc91f1b	118
75c3ed28	119	\f
0717dfd8 KN	120	/* {Apply}
	121	*/
	122
80be163f	123	static SCM scm_smob_trampolines[16];
75c3ed28	124
80be163f AW	125	/* (nargs * nargs) + nopt + rest * (nargs + 1) */
	126	#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
	127	scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
	128	+ nopt + rest * (nreq + nopt + rest + 1)]
	129
	130	static SCM
	131	apply_0 (SCM smob)
75c3ed28	132	{
80be163f AW	133	SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
	134	return subr (smob);
	135	}
	136
	137	static SCM
	138	apply_1 (SCM smob, SCM a)
75c3ed28	139	{
80be163f AW	140	SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
	141	return subr (smob, a);
	142	}
75c3ed28	143
80be163f AW	144	static SCM
	145	apply_2 (SCM smob, SCM a, SCM b)
	146	{
	147	SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
	148	return subr (smob, a, b);
	149	}
cb1c46c5 KN	150
cb1c46c5 KN	151	static SCM
80be163f	152	apply_3 (SCM smob, SCM a, SCM b, SCM c)
cb1c46c5	153	{
80be163f AW	154	SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
	155	return subr (smob, a, b, c);
	156	}
	157
	158	static SCM
	159	scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
	160	unsigned int rest)
	161	{
	162	SCM trampoline;
	163
75c3ed28 AW	164	if (SCM_UNLIKELY (rest > 1 \|\| nreq + nopt + rest > 3))
	165	scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
	166
80be163f AW	167	trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);
	168
	169	if (SCM_LIKELY (SCM_UNPACK (trampoline)))
	170	return trampoline;
	171
	172	switch (nreq + nopt + rest)
	173	{
	174	/* The + 1 is for the smob itself. */
	175	case 0:
	176	trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
	177	apply_0);
	178	break;
	179	case 1:
	180	trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
	181	apply_1);
	182	break;
	183	case 2:
	184	trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
	185	apply_2);
	186	break;
	187	case 3:
	188	trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
	189	apply_3);
	190	break;
	191	default:
	192	abort ();
	193	}
	194
	195	SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;
	196
	197	return trampoline;
cb1c46c5 KN	198	}
	199
	200	\f
7a7f7c53	201
92c2555f	202	scm_t_bits
da0e6c2b	203	scm_make_smob_type (char const *name, size_t size)
7a7f7c53	204	#define FUNC_NAME "scm_make_smob_type"
0f2d19dd	205	{
c014a02e	206	long new_smob;
7a7f7c53	207
cb8ea380	208	scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
7a7f7c53 DH	209	new_smob = scm_numsmob;
	210	if (scm_numsmob != MAX_SMOB_COUNT)
	211	++scm_numsmob;
cb8ea380	212	scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
7a7f7c53 DH	213
	214	if (new_smob == MAX_SMOB_COUNT)
	215	scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
	216
	217	scm_smobs[new_smob].name = name;
3051344b	218	scm_smobs[new_smob].size = size;
7a7f7c53	219
d7ec6b9f	220	/* Make a class object if Goops is present. */
57898597 AW	221	if (SCM_UNPACK (scm_i_smob_class[0]) != 0)
57898597 AW	222	scm_i_smob_class[new_smob] = scm_make_extended_class (name, 0);
7a7f7c53 DH	223
7a7f7c53 DH	224	return scm_tc7_smob + new_smob * 256;
0f2d19dd	225	}
7a7f7c53 DH	226	#undef FUNC_NAME
7a7f7c53 DH	227
0f2d19dd	228
9dd5943c	229	void
92c2555f	230	scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
9dd5943c MD	231	{
	232	scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
	233	}
	234
	235	void
92c2555f	236	scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
9dd5943c MD	237	{
	238	scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
	239	}
	240
	241	void
92c2555f	242	scm_set_smob_print (scm_t_bits tc, int (print) (SCM, SCM, scm_print_state))
9dd5943c MD	243	{
	244	scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
	245	}
	246
	247	void
92c2555f	248	scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
9dd5943c MD	249	{
	250	scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
	251	}
	252
0717dfd8	253	void
92c2555f	254	scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
7c58e21b	255	unsigned int req, unsigned int opt, unsigned int rst)
0717dfd8	256	{
80be163f AW	257	SCM trampoline = scm_smob_trampoline (req, opt, rst);
	258
	259	scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
	260	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;
cb1c46c5	261
57898597 AW	262	if (SCM_UNPACK (scm_i_smob_class[0]) != 0)
57898597 AW	263	scm_i_inherit_applicable (scm_i_smob_class[SCM_TC2SMOBNUM (tc)]);
75c3ed28	264	}
cb1c46c5	265
9dd5943c	266	SCM
92c2555f	267	scm_make_smob (scm_t_bits tc)
9dd5943c	268	{
4a6a4b49	269	scm_t_bits n = SCM_TC2SMOBNUM (tc);
1be6b49c	270	size_t size = scm_smobs[n].size;
16d4699b	271	scm_t_bits data = (size > 0
4c9419ac	272	? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
16d4699b	273	: 0);
4a6a4b49 LC	274
4a6a4b49 LC	275	SCM_RETURN_NEWSMOB (tc, data);
9dd5943c MD	276	}
9dd5943c MD	277
ceef3208	278
378f2625 LC	279	\f
	280	/* Marking SMOBs using user-supplied mark procedures. */
	281
378f2625	282
1f7de769 LC	283	/* The GC kind used for SMOB types that provide a custom mark procedure. */
1f7de769 LC	284	static int smob_gc_kind;
378f2625	285
01b69e79 LC	286	/* Mark stack pointer and limit, used by `scm_gc_mark'. */
	287	static scm_i_pthread_key_t current_mark_stack_pointer;
	288	static scm_i_pthread_key_t current_mark_stack_limit;
	289
378f2625	290
27583e74 AW	291	/* The generic SMOB mark procedure that gets called for SMOBs allocated
27583e74 AW	292	with smob_gc_kind. */
378f2625 LC	293	static struct GC_ms_entry *
	294	smob_mark (GC_word addr, struct GC_ms_entry mark_stack_ptr,
	295	struct GC_ms_entry *mark_stack_limit, GC_word env)
	296	{
	297	register SCM cell;
194c0a3e LC	298	register scm_t_bits tc, smobnum;
194c0a3e LC	299
21041372	300	cell = SCM_PACK_POINTER (addr);
194c0a3e LC	301
	302	if (SCM_TYP7 (cell) != scm_tc7_smob)
	303	/* It is likely that the GC passed us a pointer to a free-list element
	304	which we must ignore (see warning in `gc/gc_mark.h'). */
	305	return mark_stack_ptr;
378f2625	306
378f2625 LC	307	tc = SCM_CELL_WORD_0 (cell);
	308	smobnum = SCM_TC2SMOBNUM (tc);
	309
	310	if (smobnum >= scm_numsmob)
194c0a3e	311	/* The first word looks corrupt. */
378f2625 LC	312	abort ();
378f2625 LC	313
378f2625 LC	314	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
	315	mark_stack_ptr,
	316	mark_stack_limit, NULL);
	317	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
	318	mark_stack_ptr,
	319	mark_stack_limit, NULL);
	320	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
	321	mark_stack_ptr,
	322	mark_stack_limit, NULL);
	323
	324	if (scm_smobs[smobnum].mark)
	325	{
	326	SCM obj;
	327
01b69e79 LC	328	scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
01b69e79 LC	329	scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
378f2625 LC	330
378f2625 LC	331	/* Invoke the SMOB's mark procedure, which will in turn invoke
01b69e79	332	`scm_gc_mark', which may modify `current_mark_stack_pointer'. */
378f2625 LC	333	obj = scm_smobs[smobnum].mark (cell);
378f2625 LC	334
01b69e79	335	mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
378f2625	336
8c5bb729	337	if (SCM_HEAP_OBJECT_P (obj))
378f2625 LC	338	/* Mark the returned object. */
	339	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
	340	mark_stack_ptr,
	341	mark_stack_limit, NULL);
	342
01b69e79 LC	343	scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
01b69e79 LC	344	scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
378f2625 LC	345	}
	346
	347	return mark_stack_ptr;
	348
	349	}
	350
01b69e79 LC	351	/* Mark object O. We assume that this function is only called during the mark
01b69e79 LC	352	phase, i.e., from within `smob_mark' or one of its descendants. */
378f2625 LC	353	void
	354	scm_gc_mark (SCM o)
	355	{
8c5bb729	356	if (SCM_HEAP_OBJECT_P (o))
378f2625	357	{
01b69e79	358	void mark_stack_ptr, mark_stack_limit;
378f2625	359
01b69e79 LC	360	mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
	361	mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
	362
	363	if (mark_stack_ptr == NULL)
378f2625 LC	364	/* The function was not called from a mark procedure. */
	365	abort ();
	366
	367	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
01b69e79	368	mark_stack_ptr, mark_stack_limit,
378f2625	369	NULL);
01b69e79	370	scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
378f2625 LC	371	}
	372	}
	373
e9d635e5 LC	374	\f
e9d635e5 LC	375	/* Finalize SMOB by calling its SMOB type's free function, if any. */
27583e74	376	static void
6922d92f	377	finalize_smob (void ptr, void data)
e9d635e5	378	{
10fb3386	379	SCM smob;
e9d635e5 LC	380	size_t (* free_smob) (SCM);
e9d635e5 LC	381
21041372	382	smob = SCM_PACK_POINTER (ptr);
10fb3386 LC	383	#if 0
	384	printf ("finalizing SMOB %p (smobnum: %u)\n",
	385	ptr, SCM_SMOBNUM (smob));
	386	#endif
	387
e9d635e5 LC	388	free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
	389	if (free_smob)
	390	free_smob (smob);
e9d635e5	391	}
378f2625	392
27583e74 AW	393	/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
	394	provide a custom mark procedure and it will be honored. */
	395	SCM
	396	scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
	397	{
	398	scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
	399	SCM ret;
	400
	401	/* Use the smob_gc_kind if needed to allow the mark procedure to
	402	run. Since the marker only deals with double cells, that case
	403	allocates a double cell. We leave words 2 and 3 to there initial
	404	values, which is 0. */
	405	if (scm_smobs [smobnum].mark)
21041372	406	ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
27583e74	407	else
21041372	408	ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
27583e74 AW	409
	410	SCM_SET_CELL_WORD_1 (ret, data);
	411	SCM_SET_CELL_WORD_0 (ret, tc);
	412
	413	if (scm_smobs[smobnum].free)
6978c673	414	scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
27583e74 AW	415
	416	return ret;
	417	}
	418
	419	/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
	420	provide a custom mark procedure and it will be honored. */
	421	SCM
	422	scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
	423	scm_t_bits data2, scm_t_bits data3)
	424	{
	425	scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
	426	SCM ret;
	427
	428	/* Use the smob_gc_kind if needed to allow the mark procedure to
	429	run. */
	430	if (scm_smobs [smobnum].mark)
21041372	431	ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
27583e74	432	else
21041372	433	ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
27583e74 AW	434
	435	SCM_SET_CELL_WORD_3 (ret, data3);
	436	SCM_SET_CELL_WORD_2 (ret, data2);
	437	SCM_SET_CELL_WORD_1 (ret, data1);
	438	SCM_SET_CELL_WORD_0 (ret, tc);
	439
	440	if (scm_smobs[smobnum].free)
6978c673	441	scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
27583e74 AW	442
	443	return ret;
	444	}
	445
1bbf7f75 AW	446
	447	\f
	448
	449	SCM
	450	scm_smob_type_class (scm_t_bits tc)
	451	{
	452	scm_load_goops ();
	453
	454	return scm_i_smob_class[SCM_TC2SMOBNUM (tc)];
	455	}
	456
	457
378f2625	458	\f
0f2d19dd JB	459	void
0f2d19dd JB	460	scm_smob_prehistory ()
0f2d19dd	461	{
c014a02e	462	long i;
e841c3e0	463
01b69e79 LC	464	scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
	465	scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
	466
1f7de769	467	smob_gc_kind = GC_new_kind (GC_new_free_list (),
378f2625	468	GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
62779634 LC	469	0,
	470	/* Clear new objects. As of version 7.1, libgc
	471	doesn't seem to support passing 0 here. */
	472	1);
378f2625	473
0f2d19dd	474	scm_numsmob = 0;
7a7f7c53 DH	475	for (i = 0; i < MAX_SMOB_COUNT; ++i)
	476	{
	477	scm_smobs[i].name = 0;
	478	scm_smobs[i].size = 0;
	479	scm_smobs[i].mark = 0;
	480	scm_smobs[i].free = 0;
	481	scm_smobs[i].print = scm_smob_print;
	482	scm_smobs[i].equalp = 0;
	483	scm_smobs[i].apply = 0;
80be163f	484	scm_smobs[i].apply_trampoline = SCM_BOOL_F;
7a7f7c53	485	}
0f2d19dd	486	}
89e00824 ML	487
	488	/*
	489	Local Variables:
	490	c-file-style: "gnu"
	491	End:
	492	*/