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

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

\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_CRITICAL_SECTION_START;
  new_smob = scm_numsmob;
  if (scm_numsmob != MAX_SMOB_COUNT)
    ++scm_numsmob;
  SCM_CRITICAL_SECTION_END;

  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_smob_class[0]) != 0)
    scm_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;
  /* In 2.2 this field is renamed to "apply_trampoline".  */
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline;

  if (SCM_UNPACK (scm_smob_class[0]) != 0)
    scm_i_inherit_applicable (scm_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 = PTR2SCM (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_NIMP (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_NIMP (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 = PTR2SCM (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 = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
  else
    ret = PTR2SCM (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 = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
  else
    ret = PTR2SCM (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

/* These two are internal details of the previous implementation of
   SCM_NEWSMOB and are no longer used.  They are still here to preserve
   ABI stability in the 2.0 series.  */
void
scm_i_finalize_smob (void *ptr, void *data)
{
  finalize_smob (ptr, data);
}

SCM
scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits word1,
                               scm_t_bits word2, scm_t_bits word3)
{
  return scm_new_double_smob (tc, word1, word2, word3);
}


\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_objcode = SCM_BOOL_F;
    }
}

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