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

/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */


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

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

#include "libguile/_scm.h"

#include "libguile/objects.h"
#include "libguile/ports.h"

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#include "libguile/smob.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 256
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];

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

/* {Free}
 */

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

size_t
scm_smob_free (SCM obj)
{
  long n = SCM_SMOBNUM (obj);
  if (scm_smobs[n].size > 0)
    scm_gc_free ((void *) SCM_CELL_WORD_1 (obj), 
		 scm_smobs[n].size, SCM_SMOBNAME (n));
  return 0;
}

/* {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_intprint (SCM_CELL_WORD_1 (exp), 16, port);
  else
    scm_intprint (SCM_UNPACK (exp), 16, port);
  scm_putc ('>', port);
  return 1;
}

/* {Apply}
 */

#define SCM_SMOB_APPLY0(SMOB) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
#define SCM_SMOB_APPLY1(SMOB, A1) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)

static SCM
scm_smob_apply_0_010 (SCM smob)
{
  return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_020 (SCM smob)
{
  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_030 (SCM smob)
{
  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_0_001 (SCM smob)
{
  return SCM_SMOB_APPLY1 (smob, SCM_EOL);
}

static SCM
scm_smob_apply_0_011 (SCM smob)
{
  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_0_021 (SCM smob)
{
  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_0_error (SCM smob)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_1_020 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_1_030 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_1_001 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
}

static SCM
scm_smob_apply_1_011 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
}

static SCM
scm_smob_apply_1_021 (SCM smob, SCM a1)
{
  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
}

static SCM
scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
}

static SCM
scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
}

static SCM
scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
}

static SCM
scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
}

static SCM
scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

static SCM
scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  if (!SCM_NULLP (SCM_CDR (rst)))
    scm_wrong_num_args (smob);
  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
}

static SCM
scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
}

static SCM
scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
}

static SCM
scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
{
  return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
}

static SCM
scm_smob_apply_3_error (SCM smob,
			SCM a1 SCM_UNUSED,
			SCM a2 SCM_UNUSED,
			SCM rst SCM_UNUSED)
{
  scm_wrong_num_args (smob);
}

\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_ENTER_A_SECTION;  /* scm_numsmob */
  new_smob = scm_numsmob;
  if (scm_numsmob != MAX_SMOB_COUNT)
    ++scm_numsmob;
  SCM_EXIT_A_SECTION;

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

  scm_smobs[new_smob].name = name;
  if (size != 0)
    {
      scm_smobs[new_smob].size = size;
      scm_smobs[new_smob].free = scm_smob_free;
    }

  /* Make a class object if Goops is present. */
  if (scm_smob_class)
    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 (*apply_0) (SCM);
  SCM (*apply_1) (SCM, SCM);
  SCM (*apply_2) (SCM, SCM, SCM);
  SCM (*apply_3) (SCM, SCM, SCM, SCM);
  int type = SCM_GSUBR_MAKTYPE (req, opt, rst);

  if (rst > 1 || req + opt + rst > 3)
    {
      puts ("Unsupported smob application type");
      abort ();
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (0, 0, 0):
      apply_0 = apply; break;
    case SCM_GSUBR_MAKTYPE (0, 1, 0):
      apply_0 = scm_smob_apply_0_010; break;
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_0 = scm_smob_apply_0_020; break;
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_0 = scm_smob_apply_0_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_0 = scm_smob_apply_0_001; break;
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_0 = scm_smob_apply_0_011; break;
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_0 = scm_smob_apply_0_021; break;
    default:
      apply_0 = scm_smob_apply_0_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (1, 0, 0):
    case SCM_GSUBR_MAKTYPE (0, 1, 0):
      apply_1 = apply; break;
    case SCM_GSUBR_MAKTYPE (1, 1, 0):
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_1 = scm_smob_apply_1_020; break;
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_1 = scm_smob_apply_1_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_1 = scm_smob_apply_1_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_1 = scm_smob_apply_1_011; break;
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_1 = scm_smob_apply_1_021; break;
    default:
      apply_1 = scm_smob_apply_1_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (2, 0, 0):
    case SCM_GSUBR_MAKTYPE (1, 1, 0):
    case SCM_GSUBR_MAKTYPE (0, 2, 0):
      apply_2 = apply; break;
    case SCM_GSUBR_MAKTYPE (2, 1, 0):
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_2 = scm_smob_apply_2_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_2 = scm_smob_apply_2_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_2 = scm_smob_apply_2_011; break;
    case SCM_GSUBR_MAKTYPE (2, 0, 1):
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_2 = scm_smob_apply_2_021; break;
    default:
      apply_2 = scm_smob_apply_2_error; break;
    }

  switch (type)
    {
    case SCM_GSUBR_MAKTYPE (3, 0, 0):
    case SCM_GSUBR_MAKTYPE (2, 1, 0):
    case SCM_GSUBR_MAKTYPE (1, 2, 0):
    case SCM_GSUBR_MAKTYPE (0, 3, 0):
      apply_3 = scm_smob_apply_3_030; break;
    case SCM_GSUBR_MAKTYPE (0, 0, 1):
      apply_3 = scm_smob_apply_3_001; break;
    case SCM_GSUBR_MAKTYPE (1, 0, 1):
    case SCM_GSUBR_MAKTYPE (0, 1, 1):
      apply_3 = scm_smob_apply_3_011; break;
    case SCM_GSUBR_MAKTYPE (2, 0, 1):
    case SCM_GSUBR_MAKTYPE (1, 1, 1):
    case SCM_GSUBR_MAKTYPE (0, 2, 1):
      apply_3 = scm_smob_apply_3_021; break;
    default:
      apply_3 = scm_smob_apply_3_error; break;
    }

  scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
  scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
  
  if (scm_smob_class)
    scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}

SCM
scm_make_smob (scm_t_bits tc)
{
  long 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);
  return scm_cell (tc, data);
}

\f
/* {Initialization for the type of free cells}
 */

static int
free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  char buf[100];
  sprintf (buf, "#<freed cell %p; GC missed a reference>",
	   (void *) SCM_UNPACK (exp));
  scm_puts (buf, port);
  
#if (SCM_DEBUG_CELL_ACCESSES == 1)
  if (scm_debug_cell_accesses_p)
    abort();
#endif
  

  return 1;
}

void
scm_smob_prehistory ()
{
  long i;
  scm_t_bits tc;

  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_0    = 0;
      scm_smobs[i].apply_1    = 0;
      scm_smobs[i].apply_2    = 0;
      scm_smobs[i].apply_3    = 0;
      scm_smobs[i].gsubr_type = 0;
    }

  /* WARNING: This scm_make_smob_type call must be done first.  */
  tc = scm_make_smob_type ("free", 0);
  scm_set_smob_print (tc, free_print);
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
74b6d6e4	1	/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
0f2d19dd	2	*
73be1d9e MV	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public
	5	* License as published by the Free Software Foundation; either
	6	* version 2.1 of the License, or (at your option) any later version.
0f2d19dd	7	*
73be1d9e MV	8	* This library is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	* Lesser General Public License for more details.
0f2d19dd	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	16	*/
1bbd0b84	17
1bbd0b84	18
0f2d19dd	19	\f
f9fe039d RB	20	#if HAVE_CONFIG_H
	21	# include <config.h>
	22	#endif
0f2d19dd JB	23
0f2d19dd JB	24	#include <stdio.h>
e6e2e95a MD	25	#include <errno.h>
e6e2e95a MD	26
a0599745	27	#include "libguile/_scm.h"
20e6290e	28
a0599745 MD	29	#include "libguile/objects.h"
a0599745 MD	30	#include "libguile/ports.h"
d7ec6b9f	31
0f2d19dd JB	32	#ifdef HAVE_MALLOC_H
	33	#include <malloc.h>
	34	#endif
	35
a0599745	36	#include "libguile/smob.h"
9dd5943c	37
0f2d19dd JB	38	\f
	39
	40	/* scm_smobs scm_numsmob
7a7f7c53	41	* implement a fixed sized array of smob records.
0f2d19dd JB	42	* Indexes into this table are used when generating type
	43	* tags for smobjects (if you know a tag you can get an index and conversely).
	44	*/
7a7f7c53 DH	45
7a7f7c53 DH	46	#define MAX_SMOB_COUNT 256
c014a02e	47	long scm_numsmob;
7a7f7c53	48	scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
0f2d19dd	49
9dd5943c MD	50	/* {Mark}
	51	*/
	52
	53	/* This function is vestigial. It used to be the mark function's
	54	responsibility to set the mark bit on the smob or port, but now the
	55	generic marking routine in gc.c takes care of that, and a zero
	56	pointer for a mark function means "don't bother". So you never
	57	need scm_mark0.
	58
	59	However, we leave it here because it's harmless to call it, and
	60	people out there have smob code that uses it, and there's no reason
	61	to make their links fail. */
	62
	63	SCM
e81d98ec	64	scm_mark0 (SCM ptr SCM_UNUSED)
9dd5943c MD	65	{
	66	return SCM_BOOL_F;
	67	}
	68
	69	SCM
22a52da1 DH	70	/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
22a52da1 DH	71	be used for real pairs. */
6e8d25a6	72	scm_markcdr (SCM ptr)
9dd5943c	73	{
22a52da1	74	return SCM_CELL_OBJECT_1 (ptr);
9dd5943c MD	75	}
	76
	77	/* {Free}
	78	*/
	79
1be6b49c	80	size_t
e81d98ec	81	scm_free0 (SCM ptr SCM_UNUSED)
9dd5943c MD	82	{
	83	return 0;
	84	}
	85
1be6b49c	86	size_t
9dd5943c MD	87	scm_smob_free (SCM obj)
9dd5943c MD	88	{
4c9419ac MV	89	long n = SCM_SMOBNUM (obj);
	90	if (scm_smobs[n].size > 0)
	91	scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
	92	scm_smobs[n].size, SCM_SMOBNAME (n));
	93	return 0;
9dd5943c MD	94	}
	95
	96	/* {Print}
	97	*/
	98
	99	int
e81d98ec	100	scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
9dd5943c	101	{
c014a02e	102	long n = SCM_SMOBNUM (exp);
9dd5943c	103	scm_puts ("#<", port);
2c16a78a	104	scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
9dd5943c	105	scm_putc (' ', port);
7a7f7c53 DH	106	if (scm_smobs[n].size)
	107	scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
	108	else
	109	scm_intprint (SCM_UNPACK (exp), 16, port);
9dd5943c MD	110	scm_putc ('>', port);
	111	return 1;
	112	}
1cc91f1b	113
0717dfd8 KN	114	/* {Apply}
	115	*/
	116
cb1c46c5 KN	117	#define SCM_SMOB_APPLY0(SMOB) \
cb1c46c5 KN	118	SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
34d19ef6	119	#define SCM_SMOB_APPLY1(SMOB, A1) \
cb1c46c5	120	SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
34d19ef6	121	#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
cb1c46c5	122	SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
34d19ef6	123	#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
cb1c46c5 KN	124	SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
cb1c46c5 KN	125
cb1c46c5 KN	126	static SCM
cb1c46c5 KN	127	scm_smob_apply_0_010 (SCM smob)
0717dfd8	128	{
cb1c46c5	129	return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
0717dfd8 KN	130	}
0717dfd8 KN	131
cb1c46c5 KN	132	static SCM
cb1c46c5 KN	133	scm_smob_apply_0_020 (SCM smob)
0717dfd8	134	{
cb1c46c5	135	return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
0717dfd8 KN	136	}
0717dfd8 KN	137
cb1c46c5 KN	138	static SCM
cb1c46c5 KN	139	scm_smob_apply_0_030 (SCM smob)
0717dfd8	140	{
cb1c46c5	141	return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
0717dfd8 KN	142	}
0717dfd8 KN	143
cb1c46c5 KN	144	static SCM
cb1c46c5 KN	145	scm_smob_apply_0_001 (SCM smob)
0717dfd8	146	{
cb1c46c5 KN	147	return SCM_SMOB_APPLY1 (smob, SCM_EOL);
	148	}
	149
	150	static SCM
	151	scm_smob_apply_0_011 (SCM smob)
	152	{
	153	return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
	154	}
	155
	156	static SCM
	157	scm_smob_apply_0_021 (SCM smob)
	158	{
	159	return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
	160	}
	161
	162	static SCM
	163	scm_smob_apply_0_error (SCM smob)
	164	{
	165	scm_wrong_num_args (smob);
	166	}
	167
cb1c46c5 KN	168	static SCM
	169	scm_smob_apply_1_020 (SCM smob, SCM a1)
	170	{
	171	return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
	172	}
	173
	174	static SCM
	175	scm_smob_apply_1_030 (SCM smob, SCM a1)
	176	{
	177	return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
	178	}
	179
	180	static SCM
	181	scm_smob_apply_1_001 (SCM smob, SCM a1)
	182	{
1afff620	183	return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
cb1c46c5 KN	184	}
	185
	186	static SCM
	187	scm_smob_apply_1_011 (SCM smob, SCM a1)
	188	{
	189	return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
	190	}
	191
	192	static SCM
	193	scm_smob_apply_1_021 (SCM smob, SCM a1)
	194	{
	195	return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
	196	}
	197
	198	static SCM
e81d98ec	199	scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
cb1c46c5 KN	200	{
	201	scm_wrong_num_args (smob);
	202	}
	203
cb1c46c5 KN	204	static SCM
	205	scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
	206	{
	207	return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
	208	}
	209
	210	static SCM
	211	scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
	212	{
1afff620	213	return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
7c58e21b	214	}
cb1c46c5 KN	215
	216	static SCM
	217	scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
	218	{
1afff620	219	return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
cb1c46c5 KN	220	}
	221
	222	static SCM
	223	scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
	224	{
	225	return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
	226	}
	227
	228	static SCM
e81d98ec	229	scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
cb1c46c5 KN	230	{
	231	scm_wrong_num_args (smob);
	232	}
	233
	234	static SCM
	235	scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
	236	{
	237	if (!SCM_NULLP (SCM_CDR (rst)))
	238	scm_wrong_num_args (smob);
	239	return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
	240	}
	241
	242	static SCM
	243	scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
	244	{
	245	return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
0717dfd8 KN	246	}
0717dfd8 KN	247
cb1c46c5 KN	248	static SCM
	249	scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
	250	{
	251	return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
	252	}
	253
	254	static SCM
	255	scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
	256	{
	257	return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
	258	}
	259
	260	static SCM
e81d98ec DH	261	scm_smob_apply_3_error (SCM smob,
	262	SCM a1 SCM_UNUSED,
	263	SCM a2 SCM_UNUSED,
	264	SCM rst SCM_UNUSED)
cb1c46c5 KN	265	{
	266	scm_wrong_num_args (smob);
	267	}
	268
	269	\f
7a7f7c53	270
92c2555f	271	scm_t_bits
da0e6c2b	272	scm_make_smob_type (char const *name, size_t size)
7a7f7c53	273	#define FUNC_NAME "scm_make_smob_type"
0f2d19dd	274	{
c014a02e	275	long new_smob;
7a7f7c53 DH	276
	277	SCM_ENTER_A_SECTION; /* scm_numsmob */
	278	new_smob = scm_numsmob;
	279	if (scm_numsmob != MAX_SMOB_COUNT)
	280	++scm_numsmob;
	281	SCM_EXIT_A_SECTION;
	282
	283	if (new_smob == MAX_SMOB_COUNT)
	284	scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
	285
	286	scm_smobs[new_smob].name = name;
	287	if (size != 0)
2500356c	288	{
7a7f7c53 DH	289	scm_smobs[new_smob].size = size;
7a7f7c53 DH	290	scm_smobs[new_smob].free = scm_smob_free;
2500356c	291	}
7a7f7c53	292
d7ec6b9f MD	293	/* Make a class object if Goops is present. */
d7ec6b9f MD	294	if (scm_smob_class)
74b6d6e4	295	scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
7a7f7c53 DH	296
7a7f7c53 DH	297	return scm_tc7_smob + new_smob * 256;
0f2d19dd	298	}
7a7f7c53 DH	299	#undef FUNC_NAME
7a7f7c53 DH	300
0f2d19dd	301
9dd5943c	302	void
92c2555f	303	scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
9dd5943c MD	304	{
	305	scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
	306	}
	307
	308	void
92c2555f	309	scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
9dd5943c MD	310	{
	311	scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
	312	}
	313
	314	void
92c2555f	315	scm_set_smob_print (scm_t_bits tc, int (print) (SCM, SCM, scm_print_state))
9dd5943c MD	316	{
	317	scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
	318	}
	319
	320	void
92c2555f	321	scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
9dd5943c MD	322	{
	323	scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
	324	}
	325
0717dfd8	326	void
92c2555f	327	scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
7c58e21b	328	unsigned int req, unsigned int opt, unsigned int rst)
0717dfd8	329	{
cb1c46c5 KN	330	SCM (*apply_0) (SCM);
	331	SCM (*apply_1) (SCM, SCM);
	332	SCM (*apply_2) (SCM, SCM, SCM);
	333	SCM (*apply_3) (SCM, SCM, SCM, SCM);
	334	int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
	335
7c58e21b	336	if (rst > 1 \|\| req + opt + rst > 3)
cb1c46c5 KN	337	{
	338	puts ("Unsupported smob application type");
	339	abort ();
	340	}
	341
	342	switch (type)
	343	{
	344	case SCM_GSUBR_MAKTYPE (0, 0, 0):
7c58e21b	345	apply_0 = apply; break;
cb1c46c5 KN	346	case SCM_GSUBR_MAKTYPE (0, 1, 0):
	347	apply_0 = scm_smob_apply_0_010; break;
	348	case SCM_GSUBR_MAKTYPE (0, 2, 0):
	349	apply_0 = scm_smob_apply_0_020; break;
	350	case SCM_GSUBR_MAKTYPE (0, 3, 0):
	351	apply_0 = scm_smob_apply_0_030; break;
	352	case SCM_GSUBR_MAKTYPE (0, 0, 1):
	353	apply_0 = scm_smob_apply_0_001; break;
	354	case SCM_GSUBR_MAKTYPE (0, 1, 1):
	355	apply_0 = scm_smob_apply_0_011; break;
	356	case SCM_GSUBR_MAKTYPE (0, 2, 1):
	357	apply_0 = scm_smob_apply_0_021; break;
	358	default:
	359	apply_0 = scm_smob_apply_0_error; break;
	360	}
	361
	362	switch (type)
	363	{
	364	case SCM_GSUBR_MAKTYPE (1, 0, 0):
	365	case SCM_GSUBR_MAKTYPE (0, 1, 0):
7c58e21b	366	apply_1 = apply; break;
cb1c46c5 KN	367	case SCM_GSUBR_MAKTYPE (1, 1, 0):
	368	case SCM_GSUBR_MAKTYPE (0, 2, 0):
	369	apply_1 = scm_smob_apply_1_020; break;
	370	case SCM_GSUBR_MAKTYPE (1, 2, 0):
	371	case SCM_GSUBR_MAKTYPE (0, 3, 0):
	372	apply_1 = scm_smob_apply_1_030; break;
	373	case SCM_GSUBR_MAKTYPE (0, 0, 1):
	374	apply_1 = scm_smob_apply_1_001; break;
	375	case SCM_GSUBR_MAKTYPE (1, 0, 1):
	376	case SCM_GSUBR_MAKTYPE (0, 1, 1):
	377	apply_1 = scm_smob_apply_1_011; break;
	378	case SCM_GSUBR_MAKTYPE (1, 1, 1):
	379	case SCM_GSUBR_MAKTYPE (0, 2, 1):
	380	apply_1 = scm_smob_apply_1_021; break;
	381	default:
	382	apply_1 = scm_smob_apply_1_error; break;
	383	}
	384
	385	switch (type)
	386	{
	387	case SCM_GSUBR_MAKTYPE (2, 0, 0):
	388	case SCM_GSUBR_MAKTYPE (1, 1, 0):
	389	case SCM_GSUBR_MAKTYPE (0, 2, 0):
7c58e21b	390	apply_2 = apply; break;
cb1c46c5 KN	391	case SCM_GSUBR_MAKTYPE (2, 1, 0):
	392	case SCM_GSUBR_MAKTYPE (1, 2, 0):
	393	case SCM_GSUBR_MAKTYPE (0, 3, 0):
	394	apply_2 = scm_smob_apply_2_030; break;
	395	case SCM_GSUBR_MAKTYPE (0, 0, 1):
	396	apply_2 = scm_smob_apply_2_001; break;
	397	case SCM_GSUBR_MAKTYPE (1, 0, 1):
	398	case SCM_GSUBR_MAKTYPE (0, 1, 1):
	399	apply_2 = scm_smob_apply_2_011; break;
	400	case SCM_GSUBR_MAKTYPE (2, 0, 1):
	401	case SCM_GSUBR_MAKTYPE (1, 1, 1):
	402	case SCM_GSUBR_MAKTYPE (0, 2, 1):
	403	apply_2 = scm_smob_apply_2_021; break;
	404	default:
	405	apply_2 = scm_smob_apply_2_error; break;
	406	}
	407
	408	switch (type)
	409	{
	410	case SCM_GSUBR_MAKTYPE (3, 0, 0):
	411	case SCM_GSUBR_MAKTYPE (2, 1, 0):
	412	case SCM_GSUBR_MAKTYPE (1, 2, 0):
	413	case SCM_GSUBR_MAKTYPE (0, 3, 0):
	414	apply_3 = scm_smob_apply_3_030; break;
	415	case SCM_GSUBR_MAKTYPE (0, 0, 1):
	416	apply_3 = scm_smob_apply_3_001; break;
	417	case SCM_GSUBR_MAKTYPE (1, 0, 1):
	418	case SCM_GSUBR_MAKTYPE (0, 1, 1):
	419	apply_3 = scm_smob_apply_3_011; break;
	420	case SCM_GSUBR_MAKTYPE (2, 0, 1):
	421	case SCM_GSUBR_MAKTYPE (1, 1, 1):
	422	case SCM_GSUBR_MAKTYPE (0, 2, 1):
	423	apply_3 = scm_smob_apply_3_021; break;
	424	default:
	425	apply_3 = scm_smob_apply_3_error; break;
	426	}
	427
03416a99	428	scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
cb1c46c5 KN	429	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
	430	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
	431	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
	432	scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
68b06924	433	scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
74b6d6e4 MD	434
	435	if (scm_smob_class)
	436	scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
0717dfd8 KN	437	}
0717dfd8 KN	438
9dd5943c	439	SCM
92c2555f	440	scm_make_smob (scm_t_bits tc)
9dd5943c	441	{
c014a02e	442	long n = SCM_TC2SMOBNUM (tc);
1be6b49c	443	size_t size = scm_smobs[n].size;
16d4699b	444	scm_t_bits data = (size > 0
4c9419ac	445	? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
16d4699b	446	: 0);
228a24ef	447	return scm_cell (tc, data);
9dd5943c MD	448	}
9dd5943c MD	449
ceef3208	450	\f
534c55a9	451	/* {Initialization for the type of free cells}
0f2d19dd JB	452	*/
0f2d19dd JB	453
ceef3208	454	static int
e81d98ec	455	free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
ceef3208 JB	456	{
ceef3208 JB	457	char buf[100];
e841c3e0 KN	458	sprintf (buf, "#<freed cell %p; GC missed a reference>",
e841c3e0 KN	459	(void *) SCM_UNPACK (exp));
ceef3208	460	scm_puts (buf, port);
1e71eafb HWN	461
	462	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	463	if (scm_debug_cell_accesses_p)
	464	abort();
	465	#endif
	466
ceef3208 JB	467
	468	return 1;
	469	}
	470
0f2d19dd JB	471	void
0f2d19dd JB	472	scm_smob_prehistory ()
0f2d19dd	473	{
c014a02e	474	long i;
92c2555f	475	scm_t_bits tc;
e841c3e0	476
0f2d19dd	477	scm_numsmob = 0;
7a7f7c53 DH	478	for (i = 0; i < MAX_SMOB_COUNT; ++i)
	479	{
	480	scm_smobs[i].name = 0;
	481	scm_smobs[i].size = 0;
	482	scm_smobs[i].mark = 0;
	483	scm_smobs[i].free = 0;
	484	scm_smobs[i].print = scm_smob_print;
	485	scm_smobs[i].equalp = 0;
	486	scm_smobs[i].apply = 0;
	487	scm_smobs[i].apply_0 = 0;
	488	scm_smobs[i].apply_1 = 0;
	489	scm_smobs[i].apply_2 = 0;
	490	scm_smobs[i].apply_3 = 0;
	491	scm_smobs[i].gsubr_type = 0;
	492	}
9dd5943c	493
534c55a9	494	/* WARNING: This scm_make_smob_type call must be done first. */
e841c3e0 KN	495	tc = scm_make_smob_type ("free", 0);
e841c3e0 KN	496	scm_set_smob_print (tc, free_print);
0f2d19dd	497	}
89e00824 ML	498
	499	/*
	500	Local Variables:
	501	c-file-style: "gnu"
	502	End:
	503	*/