[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_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_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;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = 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 = 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
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 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);
0607ebbf AW	109	scm_puts_unlocked ("#<", port);
	110	scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
	111	scm_putc_unlocked (' ', 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);
0607ebbf	116	scm_putc_unlocked ('>', port);
9dd5943c MD	117	return 1;
9dd5943c MD	118	}
1cc91f1b	119
75c3ed28	120	\f
0717dfd8 KN	121	/* {Apply}
	122	*/
	123
80be163f	124	static SCM scm_smob_trampolines[16];
75c3ed28	125
80be163f 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	{
80be163f 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	{
80be163f AW	141	SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
	142	return subr (smob, a);
	143	}
75c3ed28	144
80be163f 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
80be163f	153	apply_3 (SCM smob, SCM a, SCM b, SCM c)
cb1c46c5	154	{
80be163f 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
80be163f 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	{
80be163f AW	258	SCM trampoline = scm_smob_trampoline (req, opt, rst);
	259
	260	scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
	261	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;
cb1c46c5	262
75c3ed28 AW	263	if (SCM_UNPACK (scm_smob_class[0]) != 0)
	264	scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
	265	}
cb1c46c5	266
9dd5943c	267	SCM
92c2555f	268	scm_make_smob (scm_t_bits tc)
9dd5943c	269	{
4a6a4b49	270	scm_t_bits n = SCM_TC2SMOBNUM (tc);
1be6b49c	271	size_t size = scm_smobs[n].size;
16d4699b	272	scm_t_bits data = (size > 0
4c9419ac	273	? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
16d4699b	274	: 0);
4a6a4b49 LC	275
4a6a4b49 LC	276	SCM_RETURN_NEWSMOB (tc, data);
9dd5943c MD	277	}
9dd5943c MD	278
ceef3208	279
378f2625 LC	280	\f
	281	/* Marking SMOBs using user-supplied mark procedures. */
	282
378f2625	283
1f7de769 LC	284	/* The GC kind used for SMOB types that provide a custom mark procedure. */
1f7de769 LC	285	static int smob_gc_kind;
378f2625	286
01b69e79 LC	287	/* Mark stack pointer and limit, used by `scm_gc_mark'. */
	288	static scm_i_pthread_key_t current_mark_stack_pointer;
	289	static scm_i_pthread_key_t current_mark_stack_limit;
	290
378f2625	291
27583e74 AW	292	/* The generic SMOB mark procedure that gets called for SMOBs allocated
27583e74 AW	293	with smob_gc_kind. */
378f2625 LC	294	static struct GC_ms_entry *
	295	smob_mark (GC_word addr, struct GC_ms_entry mark_stack_ptr,
	296	struct GC_ms_entry *mark_stack_limit, GC_word env)
	297	{
	298	register SCM cell;
194c0a3e LC	299	register scm_t_bits tc, smobnum;
194c0a3e LC	300
21041372	301	cell = SCM_PACK_POINTER (addr);
194c0a3e LC	302
	303	if (SCM_TYP7 (cell) != scm_tc7_smob)
	304	/* It is likely that the GC passed us a pointer to a free-list element
	305	which we must ignore (see warning in `gc/gc_mark.h'). */
	306	return mark_stack_ptr;
378f2625	307
378f2625 LC	308	tc = SCM_CELL_WORD_0 (cell);
	309	smobnum = SCM_TC2SMOBNUM (tc);
	310
	311	if (smobnum >= scm_numsmob)
194c0a3e	312	/* The first word looks corrupt. */
378f2625 LC	313	abort ();
378f2625 LC	314
378f2625 LC	315	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
	316	mark_stack_ptr,
	317	mark_stack_limit, NULL);
	318	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
	319	mark_stack_ptr,
	320	mark_stack_limit, NULL);
	321	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
	322	mark_stack_ptr,
	323	mark_stack_limit, NULL);
	324
	325	if (scm_smobs[smobnum].mark)
	326	{
	327	SCM obj;
	328
01b69e79 LC	329	scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
01b69e79 LC	330	scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
378f2625 LC	331
378f2625 LC	332	/* Invoke the SMOB's mark procedure, which will in turn invoke
01b69e79	333	`scm_gc_mark', which may modify `current_mark_stack_pointer'. */
378f2625 LC	334	obj = scm_smobs[smobnum].mark (cell);
378f2625 LC	335
01b69e79	336	mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
378f2625	337
8c5bb729	338	if (SCM_HEAP_OBJECT_P (obj))
378f2625 LC	339	/* Mark the returned object. */
	340	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
	341	mark_stack_ptr,
	342	mark_stack_limit, NULL);
	343
01b69e79 LC	344	scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
01b69e79 LC	345	scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
378f2625 LC	346	}
	347
	348	return mark_stack_ptr;
	349
	350	}
	351
01b69e79 LC	352	/* Mark object O. We assume that this function is only called during the mark
01b69e79 LC	353	phase, i.e., from within `smob_mark' or one of its descendants. */
378f2625 LC	354	void
	355	scm_gc_mark (SCM o)
	356	{
8c5bb729	357	if (SCM_HEAP_OBJECT_P (o))
378f2625	358	{
01b69e79	359	void mark_stack_ptr, mark_stack_limit;
378f2625	360
01b69e79 LC	361	mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
	362	mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
	363
	364	if (mark_stack_ptr == NULL)
378f2625 LC	365	/* The function was not called from a mark procedure. */
	366	abort ();
	367
	368	mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
01b69e79	369	mark_stack_ptr, mark_stack_limit,
378f2625	370	NULL);
01b69e79	371	scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
378f2625 LC	372	}
	373	}
	374
e9d635e5 LC	375	\f
e9d635e5 LC	376	/* Finalize SMOB by calling its SMOB type's free function, if any. */
27583e74	377	static void
6922d92f	378	finalize_smob (void ptr, void data)
e9d635e5	379	{
10fb3386	380	SCM smob;
e9d635e5 LC	381	size_t (* free_smob) (SCM);
e9d635e5 LC	382
21041372	383	smob = SCM_PACK_POINTER (ptr);
10fb3386 LC	384	#if 0
	385	printf ("finalizing SMOB %p (smobnum: %u)\n",
	386	ptr, SCM_SMOBNUM (smob));
	387	#endif
	388
e9d635e5 LC	389	free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
	390	if (free_smob)
	391	free_smob (smob);
e9d635e5	392	}
378f2625	393
27583e74 AW	394	/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
	395	provide a custom mark procedure and it will be honored. */
	396	SCM
	397	scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
	398	{
	399	scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
	400	SCM ret;
	401
	402	/* Use the smob_gc_kind if needed to allow the mark procedure to
	403	run. Since the marker only deals with double cells, that case
	404	allocates a double cell. We leave words 2 and 3 to there initial
	405	values, which is 0. */
	406	if (scm_smobs [smobnum].mark)
21041372	407	ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
27583e74	408	else
21041372	409	ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
27583e74 AW	410
	411	SCM_SET_CELL_WORD_1 (ret, data);
	412	SCM_SET_CELL_WORD_0 (ret, tc);
	413
	414	if (scm_smobs[smobnum].free)
6978c673	415	scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
27583e74 AW	416
	417	return ret;
	418	}
	419
	420	/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
	421	provide a custom mark procedure and it will be honored. */
	422	SCM
	423	scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
	424	scm_t_bits data2, scm_t_bits data3)
	425	{
	426	scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
	427	SCM ret;
	428
	429	/* Use the smob_gc_kind if needed to allow the mark procedure to
	430	run. */
	431	if (scm_smobs [smobnum].mark)
21041372	432	ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
27583e74	433	else
21041372	434	ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
27583e74 AW	435
	436	SCM_SET_CELL_WORD_3 (ret, data3);
	437	SCM_SET_CELL_WORD_2 (ret, data2);
	438	SCM_SET_CELL_WORD_1 (ret, data1);
	439	SCM_SET_CELL_WORD_0 (ret, tc);
	440
	441	if (scm_smobs[smobnum].free)
6978c673	442	scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
27583e74 AW	443
	444	return ret;
	445	}
	446
378f2625	447	\f
0f2d19dd JB	448	void
0f2d19dd JB	449	scm_smob_prehistory ()
0f2d19dd	450	{
c014a02e	451	long i;
e841c3e0	452
01b69e79 LC	453	scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
	454	scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
	455
1f7de769	456	smob_gc_kind = GC_new_kind (GC_new_free_list (),
378f2625	457	GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
62779634 LC	458	0,
	459	/* Clear new objects. As of version 7.1, libgc
	460	doesn't seem to support passing 0 here. */
	461	1);
378f2625	462
0f2d19dd	463	scm_numsmob = 0;
7a7f7c53 DH	464	for (i = 0; i < MAX_SMOB_COUNT; ++i)
	465	{
	466	scm_smobs[i].name = 0;
	467	scm_smobs[i].size = 0;
	468	scm_smobs[i].mark = 0;
	469	scm_smobs[i].free = 0;
	470	scm_smobs[i].print = scm_smob_print;
	471	scm_smobs[i].equalp = 0;
	472	scm_smobs[i].apply = 0;
80be163f	473	scm_smobs[i].apply_trampoline = SCM_BOOL_F;
7a7f7c53	474	}
0f2d19dd	475	}
89e00824 ML	476
	477	/*
	478	Local Variables:
	479	c-file-style: "gnu"
	480	End:
	481	*/