[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];

/* Lower 16 bit of data must be zero. 
*/
void
scm_i_set_smob_flags (SCM x, scm_t_bits data)
{
  SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
}

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