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

/*	Copyright (C) 1996 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program 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 General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */
\f

#include <stdio.h>
#include "_scm.h"

\f

static SCM required_vtable_fields = SCM_BOOL_F;
static int struct_num = 0;

\f
SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
#ifdef __STDC__
SCM
scm_make_struct_layout (SCM fields)
#else
SCM
scm_make_struct_layout (fields)
     SCM fields;
#endif
{
  SCM new_sym;
  SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
	      fields, SCM_ARG1, s_struct_make_layout);

  {
    char * field_desc;
    int len;
    int x;

    len = SCM_ROLENGTH (fields);
    field_desc = SCM_ROCHARS (fields);
    SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);

    for (x = 0; x < len; x += 2)
      {
	switch (field_desc[x])
	  {
	  case 'u':
	  case 'p':
#if 0
	  case 'i':
	  case 'd':
#endif
	  case 's':
	    break;
	  default:
	    SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
	  }

	switch (field_desc[x + 1])
	  {
	  case 'w':
	    SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
			"self fields not writable", s_struct_make_layout);
	      
	  case 'r':
	  case 'o':
	    break;
	  default:
	    SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
	  }
#if 0
	if (field_desc[x] == 'd')
	  {
	    SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
	    x += 2;
	    goto recheck_ref;
	  }
#endif
      }
    new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
  }
  return scm_return_first (new_sym, fields);
}

\f


#ifdef __STDC__
static void
init_struct (SCM handle, SCM tail_elts, SCM inits)
#else
static void
init_struct (handle, tail_elts, inits)
     SCM handle;
     SCM tail_elts;
     SCM inits;
#endif
{
  SCM layout;
  SCM * data;
  unsigned char * fields_desc;
  int n_fields;
  SCM * mem;

  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  fields_desc = (unsigned char *)SCM_CHARS (layout);
  n_fields = SCM_LENGTH (layout) / 2;
  mem = SCM_STRUCT_DATA (handle);
  while (n_fields)
    {
      switch (*fields_desc)
	{
#if 0
	case 'i':
	  if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
	      || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
	    *mem = 0;
	  else
	    {
	      *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
	      inits = SCM_CDR (inits);
	    }
	  break;
#endif

	case 'u':
	  if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
	      || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
	    *mem = 0;
	  else
	    {
	      *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
	      inits = SCM_CDR (inits);
	    }
	  break;

	case 'p':
	  if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
	      || (inits == SCM_EOL))
	    *mem = SCM_EOL;
	  else
	    {
	      *mem = SCM_CAR (inits);
	      inits = SCM_CDR (inits);
	    }
	      
	  break;

#if 0
	case 'd':
	  if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
	      || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
	    *((double *)mem) = 0.0;
	  else
	    {
	      *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
	      inits = SCM_CDR (inits);
	    }
	  fields_desc += 2;
	  break;
#endif

	case 's':
	  *mem = handle;
	  break;
	}

      fields_desc += 2;
      n_fields--;
      mem++;
    }
}


SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
#ifdef __STDC__
SCM
scm_struct_p (SCM x)
#else
SCM
scm_struct_p (x)
     SCM x;
#endif
{
  return ((SCM_NIMP (x) && SCM_STRUCTP (x))
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}

SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
#ifdef __STDC__
SCM
scm_struct_vtable_p (SCM x)
#else
SCM
scm_struct_vtable_p (x)
     SCM x;
#endif
{
  SCM layout;
  SCM * mem;

  if (SCM_IMP (x))
    return SCM_BOOL_F;

  if (!SCM_STRUCTP (x))
    return SCM_BOOL_F;

  layout = SCM_STRUCT_LAYOUT (x);

  if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
    return SCM_BOOL_F;

  if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
	       SCM_LENGTH (required_vtable_fields)))
    return SCM_BOOL_F;

  mem = SCM_STRUCT_DATA (x);

  if (mem[1] != 0)
    return SCM_BOOL_F;

  if (SCM_IMP (mem[0]))
    return SCM_BOOL_F;

  return (SCM_SYMBOLP (mem[0])
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}

SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
#ifdef __STDC__
SCM
scm_make_struct (SCM vtable, SCM tail_array_size, SCM init)
#else
SCM
scm_make_struct (vtable, tail_array_size, init)
     SCM vtable;
     SCM tail_array_size;
     SCM init;
#endif
{
  SCM layout;
  int basic_size;
  int tail_elts;
  SCM * data;
  SCM handle;

  SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
	      vtable, SCM_ARG1, s_make_struct);
  SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);

  layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
  basic_size = SCM_LENGTH (layout) / 2;
  tail_elts = SCM_INUM (tail_array_size);
  SCM_NEWCELL (handle);
  SCM_DEFER_INTS;
  data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
  *data = (SCM)(2 + basic_size + tail_elts);
  data[1] = struct_num++;
  data += 2;
  SCM_SETCDR (handle, data);
  SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
  init_struct (handle, tail_elts, init);
  SCM_ALLOW_INTS;
  return handle;
}


SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
#ifdef __STDC__
SCM
scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init)
#else
SCM
scm_make_vtable_vtable (extra_fields, tail_array_size, init)
     SCM extra_fields;
     SCM tail_array_size;
     SCM init;
#endif
{
  SCM fields;
  SCM layout;
  int basic_size;
  int tail_elts;
  SCM * data;
  SCM handle;

  SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
	      extra_fields, SCM_ARG1, s_make_vtable_vtable);
  SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
  

  fields = scm_string_append (scm_listify (required_vtable_fields,
					   extra_fields,
					   SCM_UNDEFINED));
  layout = scm_make_struct_layout (fields);
  basic_size = SCM_LENGTH (layout) / 2;
  tail_elts = SCM_INUM (tail_array_size);
  SCM_NEWCELL (handle);
  SCM_DEFER_INTS;
  data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
  *data = (SCM)(2 + basic_size + tail_elts);
  data[1] = struct_num++;
  data += 2;
  SCM_SETCDR (handle, data);
  SCM_SETCAR (handle, ((SCM)data) + 1);
  SCM_STRUCT_LAYOUT (handle) = layout;
  init_struct (handle, tail_elts, scm_cons (layout, init));
  SCM_ALLOW_INTS;
  return handle;
}

\f


SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
#ifdef __STDC__
SCM
scm_struct_ref (SCM handle, SCM pos)
#else
SCM
scm_struct_ref (handle, pos)
     SCM handle;
     SCM pos;
#endif
{
  SCM answer;
  SCM * data;
  SCM layout;
  int p;
  int n_fields;
  unsigned char * fields_desc;
  unsigned char field_type;
  

  SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	      SCM_ARG1, s_struct_ref);
  SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);

  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  p = SCM_INUM (pos);

  fields_desc = (unsigned char *)SCM_CHARS (layout);
  n_fields = SCM_LENGTH (layout) / 2;

  SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);

  field_type = fields_desc[p * 2];
  {
    unsigned char ref;
    ref = fields_desc [p * 2 + 1];
    if ((ref != 'r') && (ref != 'w'))
      {
	if ((ref == 'R') || (ref == 'W'))
	  field_type = 'u';
	else
	  SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
      }
  }
  switch (field_type)
    {
    case 'u':
      answer = scm_ulong2num (data[p]);
      break;

#if 0
    case 'i':
      answer = scm_long2num (data[p]);
      break;

    case 'd':
      answer = scm_makdbl (*((double *)&(data[p])), 0.0);
      break;
#endif

    case 's':
    case 'p':
      answer = data[p];
      break;


    default:
      SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
      break;
    }

  return answer;
}


SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
#ifdef __STDC__
SCM
scm_struct_set_x (SCM handle, SCM pos, SCM val)
#else
SCM
scm_struct_set_x (handle, pos, val)
     SCM handle;
     SCM pos;
     SCM val;
#endif
{
  SCM * data;
  SCM layout;
  int p;
  int n_fields;
  unsigned char * fields_desc;
  unsigned char field_type;
  

  SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	      SCM_ARG1, s_struct_ref);
  SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);

  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  p = SCM_INUM (pos);

  fields_desc = (unsigned char *)SCM_CHARS (layout);
  n_fields = SCM_LENGTH (layout) / 2;

  SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);

  field_type = fields_desc[p * 2];
  {
    unsigned char set_x;
    set_x = fields_desc [p * 2 + 1];
    if (set_x != 'w')
      SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
  }
  switch (field_type)
    {
    case 'u':
      data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
      break;

#if 0
    case 'i':
      data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
      break;

    case 'd':
      *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
      break;
#endif

    case 'p':
      data[p] = val;
      break;

    case 's':
      SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
      break;

    default:
      SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
      break;
    }

  return val;
}


SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
#ifdef __STDC__
SCM
scm_struct_vtable (SCM handle)
#else
SCM
scm_struct_vtable (handle)
     SCM handle;
#endif
{
  SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	      SCM_ARG1, s_struct_vtable);
  return SCM_STRUCT_VTABLE (handle);
}


SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
#ifdef __STDC__
SCM
scm_struct_vtable_tag (SCM handle)
#else
SCM
scm_struct_vtable_tag (handle)
     SCM handle;
#endif
{
  SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
	      handle, SCM_ARG1, s_struct_vtable_tag);
  return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
}


\f

#ifdef __STDC__
void
scm_init_struct (void)
#else
void
scm_init_struct ()
#endif
{
  required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
  scm_permanent_object (required_vtable_fields);
  scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
#include "struct.x"
}
Commit	Line	Data
0f2d19dd JB	1	/* Copyright (C) 1996 Free Software Foundation, Inc.
	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program 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
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
	15	* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	16	*
	17	* As a special exception, the Free Software Foundation gives permission
	18	* for additional uses of the text contained in its release of GUILE.
	19	*
	20	* The exception is that, if you link the GUILE library with other files
	21	* to produce an executable, this does not by itself cause the
	22	* resulting executable to be covered by the GNU General Public License.
	23	* Your use of that executable is in no way restricted on account of
	24	* linking the GUILE library code into it.
	25	*
	26	* This exception does not however invalidate any other reasons why
	27	* the executable file might be covered by the GNU General Public License.
	28	*
	29	* This exception applies only to the code released by the
	30	* Free Software Foundation under the name GUILE. If you copy
	31	* code from other Free Software Foundation releases into a copy of
	32	* GUILE, as the General Public License permits, the exception does
	33	* not apply to the code that you add in this way. To avoid misleading
	34	* anyone as to the status of such modified files, you must delete
	35	* this exception notice from them.
	36	*
	37	* If you write modifications of your own for GUILE, it is your choice
	38	* whether to permit this exception to apply to your modifications.
	39	* If you do not wish that, delete this exception notice.
	40	*/
	41	\f
	42
	43	#include <stdio.h>
	44	#include "_scm.h"
	45
	46	\f
	47
	48	static SCM required_vtable_fields = SCM_BOOL_F;
	49	static int struct_num = 0;
	50
	51	\f
	52	SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
	53	#ifdef __STDC__
	54	SCM
	55	scm_make_struct_layout (SCM fields)
	56	#else
	57	SCM
	58	scm_make_struct_layout (fields)
	59	SCM fields;
	60	#endif
	61	{
	62	SCM new_sym;
	63	SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
	64	fields, SCM_ARG1, s_struct_make_layout);
65
66	{
67	char * field_desc;
68	int len;
69	int x;
70
71	len = SCM_ROLENGTH (fields);
72	field_desc = SCM_ROCHARS (fields);
73	SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
74
75	for (x = 0; x < len; x += 2)
76	{
77	switch (field_desc[x])
78	{
79	case 'u':
80	case 'p':
81	#if 0
82	case 'i':
83	case 'd':
84	#endif
85	case 's':
86	break;
87	default:
88	SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
89	}
90
91	switch (field_desc[x + 1])
92	{
93	case 'w':
94	SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
95	"self fields not writable", s_struct_make_layout);
96
97	case 'r':
98	case 'o':
99	break;
100	default:
101	SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
102	}
103	#if 0
104	if (field_desc[x] == 'd')
105	{
106	SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
107	x += 2;
108	goto recheck_ref;
109	}
110	#endif
111	}
112	new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
113	}
114	return scm_return_first (new_sym, fields);
115	}
116
117	\f
118
119
120	#ifdef __STDC__
121	static void
122	init_struct (SCM handle, SCM tail_elts, SCM inits)
123	#else
124	static void
125	init_struct (handle, tail_elts, inits)
126	SCM handle;
127	SCM tail_elts;
128	SCM inits;
129	#endif
130	{
131	SCM layout;
132	SCM * data;
133	unsigned char * fields_desc;
134	int n_fields;
135	SCM * mem;
136
137	layout = SCM_STRUCT_LAYOUT (handle);
138	data = SCM_STRUCT_DATA (handle);
139	fields_desc = (unsigned char *)SCM_CHARS (layout);
140	n_fields = SCM_LENGTH (layout) / 2;
141	mem = SCM_STRUCT_DATA (handle);
142	while (n_fields)
143	{
144	switch (*fields_desc)
145	{
146	#if 0
147	case 'i':
148	if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
149	\|\| ((inits == SCM_EOL) \|\| !SCM_NUMBERP (SCM_CAR (inits))))
150	*mem = 0;
151	else
152	{
153	*mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
154	inits = SCM_CDR (inits);
155	}
156	break;
157	#endif
158
159	case 'u':
160	if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
161	\|\| ((inits == SCM_EOL) \|\| !SCM_NUMBERP (SCM_CAR (inits))))
162	*mem = 0;
163	else
164	{
165	*mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
166	inits = SCM_CDR (inits);
167	}
168	break;
169
170	case 'p':
171	if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
172	\|\| (inits == SCM_EOL))
173	*mem = SCM_EOL;
174	else
175	{
176	*mem = SCM_CAR (inits);
177	inits = SCM_CDR (inits);
178	}
179
180	break;
181
182	#if 0
183	case 'd':
184	if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
185	\|\| ((inits == SCM_EOL) \|\| !SCM_NUMBERP (SCM_CAR (inits))))
186	((double )mem) = 0.0;
187	else
188	{
189	*mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
190	inits = SCM_CDR (inits);
191	}
192	fields_desc += 2;
193	break;
194	#endif
195
196	case 's':
197	*mem = handle;
198	break;
199	}
200
201	fields_desc += 2;
202	n_fields--;
203	mem++;
204	}
205	}
206
207
208	SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
209	#ifdef __STDC__
210	SCM
211	scm_struct_p (SCM x)
212	#else
213	SCM
214	scm_struct_p (x)
215	SCM x;
216	#endif
217	{
218	return ((SCM_NIMP (x) && SCM_STRUCTP (x))
219	? SCM_BOOL_T
220	: SCM_BOOL_F);
221	}
222
223	SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
224	#ifdef __STDC__
225	SCM
226	scm_struct_vtable_p (SCM x)
227	#else
228	SCM
229	scm_struct_vtable_p (x)
230	SCM x;
231	#endif
232	{
233	SCM layout;
234	SCM * mem;
235
236	if (SCM_IMP (x))
237	return SCM_BOOL_F;
238
239	if (!SCM_STRUCTP (x))
240	return SCM_BOOL_F;
241
242	layout = SCM_STRUCT_LAYOUT (x);
243
244	if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
245	return SCM_BOOL_F;
246
247	if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
248	SCM_LENGTH (required_vtable_fields)))
249	return SCM_BOOL_F;
250
251	mem = SCM_STRUCT_DATA (x);
252
253	if (mem[1] != 0)
254	return SCM_BOOL_F;
255
256	if (SCM_IMP (mem[0]))
257	return SCM_BOOL_F;
258
259	return (SCM_SYMBOLP (mem[0])
260	? SCM_BOOL_T
261	: SCM_BOOL_F);
262	}
263
264	SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
265	#ifdef __STDC__
266	SCM
267	scm_make_struct (SCM vtable, SCM tail_array_size, SCM init)
268	#else
269	SCM
270	scm_make_struct (vtable, tail_array_size, init)
271	SCM vtable;
272	SCM tail_array_size;
273	SCM init;
274	#endif
275	{
276	SCM layout;
277	int basic_size;
278	int tail_elts;
279	SCM * data;
280	SCM handle;
281
282	SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
283	vtable, SCM_ARG1, s_make_struct);
284	SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);
285
286	layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
287	basic_size = SCM_LENGTH (layout) / 2;
288	tail_elts = SCM_INUM (tail_array_size);
289	SCM_NEWCELL (handle);
290	SCM_DEFER_INTS;
291	data = (SCM)scm_must_malloc (sizeof (SCM) (2 + basic_size + tail_elts), "structure");
292	*data = (SCM)(2 + basic_size + tail_elts);
293	data[1] = struct_num++;
294	data += 2;
295	SCM_SETCDR (handle, data);
296	SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
297	init_struct (handle, tail_elts, init);
298	SCM_ALLOW_INTS;
299	return handle;
300	}
301
302
303
304	SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
305	#ifdef __STDC__
306	SCM
307	scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init)
308	#else
309	SCM
310	scm_make_vtable_vtable (extra_fields, tail_array_size, init)
311	SCM extra_fields;
312	SCM tail_array_size;
313	SCM init;
314	#endif
315	{
316	SCM fields;
317	SCM layout;
318	int basic_size;
319	int tail_elts;
320	SCM * data;
321	SCM handle;
322
323	SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
324	extra_fields, SCM_ARG1, s_make_vtable_vtable);
325	SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
326
327
328	fields = scm_string_append (scm_listify (required_vtable_fields,
329	extra_fields,
330	SCM_UNDEFINED));
331	layout = scm_make_struct_layout (fields);
332	basic_size = SCM_LENGTH (layout) / 2;
333	tail_elts = SCM_INUM (tail_array_size);
334	SCM_NEWCELL (handle);
335	SCM_DEFER_INTS;
336	data = (SCM)scm_must_malloc (sizeof (SCM) (2 + basic_size + tail_elts), "structure");
337	*data = (SCM)(2 + basic_size + tail_elts);
338	data[1] = struct_num++;
339	data += 2;
340	SCM_SETCDR (handle, data);
341	SCM_SETCAR (handle, ((SCM)data) + 1);
342	SCM_STRUCT_LAYOUT (handle) = layout;
343	init_struct (handle, tail_elts, scm_cons (layout, init));
344	SCM_ALLOW_INTS;
345	return handle;
346	}
347
348	\f
349
350
351	SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
352	#ifdef __STDC__
353	SCM
354	scm_struct_ref (SCM handle, SCM pos)
355	#else
356	SCM
357	scm_struct_ref (handle, pos)
358	SCM handle;
359	SCM pos;
360	#endif
361	{
362	SCM answer;
363	SCM * data;
364	SCM layout;
365	int p;
366	int n_fields;
367	unsigned char * fields_desc;
368	unsigned char field_type;
369
370
371	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
372	SCM_ARG1, s_struct_ref);
373	SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
374
375	layout = SCM_STRUCT_LAYOUT (handle);
376	data = SCM_STRUCT_DATA (handle);
377	p = SCM_INUM (pos);
378
379	fields_desc = (unsigned char *)SCM_CHARS (layout);
380	n_fields = SCM_LENGTH (layout) / 2;
381
382	SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
383
384	field_type = fields_desc[p * 2];
385	{
386	unsigned char ref;
387	ref = fields_desc [p * 2 + 1];
388	if ((ref != 'r') && (ref != 'w'))
389	{
390	if ((ref == 'R') \|\| (ref == 'W'))
391	field_type = 'u';
392	else
393	SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
394	}
395	}
396	switch (field_type)
397	{
398	case 'u':
399	answer = scm_ulong2num (data[p]);
400	break;
401
402	#if 0
403	case 'i':
404	answer = scm_long2num (data[p]);
405	break;
406
407	case 'd':
408	answer = scm_makdbl (((double )&(data[p])), 0.0);
409	break;
410	#endif
411
412	case 's':
413	case 'p':
414	answer = data[p];
415	break;
416
417
418	default:
419	SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
420	break;
421	}
422
423	return answer;
424	}
425
426
427	SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
428	#ifdef __STDC__
429	SCM
430	scm_struct_set_x (SCM handle, SCM pos, SCM val)
431	#else
432	SCM
433	scm_struct_set_x (handle, pos, val)
434	SCM handle;
435	SCM pos;
436	SCM val;
437	#endif
438	{
439	SCM * data;
440	SCM layout;
441	int p;
442	int n_fields;
443	unsigned char * fields_desc;
444	unsigned char field_type;
445
446
447
448	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
449	SCM_ARG1, s_struct_ref);
450	SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
451
452	layout = SCM_STRUCT_LAYOUT (handle);
453	data = SCM_STRUCT_DATA (handle);
454	p = SCM_INUM (pos);
455
456	fields_desc = (unsigned char *)SCM_CHARS (layout);
457	n_fields = SCM_LENGTH (layout) / 2;
458
459	SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
460
461	field_type = fields_desc[p * 2];
462	{
463	unsigned char set_x;
464	set_x = fields_desc [p * 2 + 1];
465	if (set_x != 'w')
466	SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
467	}
468	switch (field_type)
469	{
470	case 'u':
471	data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
472	break;
473
474	#if 0
475	case 'i':
476	data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
477	break;
478
479	case 'd':
480	((double )&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
481	break;
482	#endif
483
484	case 'p':
485	data[p] = val;
486	break;
487
488	case 's':
489	SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
490	break;
491
492	default:
493	SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
494	break;
495	}
496
497	return val;
498	}
499
500
501	SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
502	#ifdef __STDC__
503	SCM
504	scm_struct_vtable (SCM handle)
505	#else
506	SCM
507	scm_struct_vtable (handle)
508	SCM handle;
509	#endif
510	{
511	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
512	SCM_ARG1, s_struct_vtable);
513	return SCM_STRUCT_VTABLE (handle);
514	}
515
516
517	SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
518	#ifdef __STDC__
519	SCM
520	scm_struct_vtable_tag (SCM handle)
521	#else
522	SCM
523	scm_struct_vtable_tag (handle)
524	SCM handle;
525	#endif
526	{
527	SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
528	handle, SCM_ARG1, s_struct_vtable_tag);
529	return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
530	}
531
532
533	\f
534
535	#ifdef __STDC__
536	void
537	scm_init_struct (void)
538	#else
539	void
540	scm_init_struct ()
541	#endif
542	{
543	required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
544	scm_permanent_object (required_vtable_fields);
545	scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
546	#include "struct.x"
547	}
548