[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"
#include "chars.h"

#include "struct.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

\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);

SCM
scm_make_struct_layout (fields)
     SCM fields;
{
  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;
	  case 'R':
	  case 'W':
	  case 'O':
	    SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
			"self fields not allowed in tail array",
			s_struct_make_layout);
	    SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
			"tail array field must be last field in layout",
			s_struct_make_layout);
	    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


static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));

static void
init_struct (handle, tail_elts, inits)
     SCM handle;
     int tail_elts;
     SCM inits;
{
  SCM layout;
  SCM * data;
  unsigned char * fields_desc;
  unsigned char prot;
  int n_fields;
  SCM * mem;
  int tailp = 0;
  
  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
  n_fields = SCM_LENGTH (layout) / 2;
  mem = SCM_STRUCT_DATA (handle);
  while (n_fields)
    {
      if (!tailp)
	{
	  fields_desc += 2;
	  prot = fields_desc[1];
	  if (SCM_LAYOUT_TAILP (prot))
	    {
	      tailp = 1;
	      prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
	      *mem++ = tail_elts;
	      n_fields += tail_elts - 1;
	      if (n_fields == 0)
		break;
	    }
	}
      
      switch (*fields_desc)
	{
#if 0
	case 'i':
	  if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
	    *mem = 0;
	  else
	    {
	      *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
	      inits = SCM_CDR (inits);
	    }
	  break;
#endif

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

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

#if 0
	case 'd':
	  if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
	    *((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;
	}

      n_fields--;
      mem++;
    }
}


SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);

SCM
scm_struct_p (x)
     SCM x;
{
  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);

SCM
scm_struct_vtable_p (x)
     SCM x;
{
  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);

SCM
scm_make_struct (vtable, tail_array_size, init)
     SCM vtable;
     SCM tail_array_size;
     SCM init;
{
  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) * (scm_struct_n_extra_words
						+ basic_size
						+ tail_elts),
				"structure");
  data += scm_struct_n_extra_words;
  data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
				      + basic_size
				      + tail_elts);
  data[scm_struct_i_tag] = struct_num++;
  SCM_SETCDR (handle, data);
  SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
  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);

SCM
scm_make_vtable_vtable (extra_fields, tail_array_size, init)
     SCM extra_fields;
     SCM tail_array_size;
     SCM init;
{
  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) * (scm_struct_n_extra_words
						  + basic_size
						  + tail_elts),
				  "structure");
  data += scm_struct_n_extra_words;
  data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
				      + basic_size
				      + tail_elts);
  data[scm_struct_i_tag] = struct_num++;
  SCM_SETCDR (handle, data);
  SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
  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);

SCM
scm_struct_ref (handle, pos)
     SCM handle;
     SCM pos;
{
  SCM answer = SCM_UNDEFINED;
  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 = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
  
  SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);

  if (p * 2 < SCM_LENGTH (layout))
    {
      unsigned char ref;
      field_type = fields_desc[p * 2];
      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);
	}
    }
  else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')    
    field_type = fields_desc[SCM_LENGTH (layout) - 2];
  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);

SCM
scm_struct_set_x (handle, pos, val)
     SCM handle;
     SCM pos;
     SCM val;
{
  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 = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;

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

  if (p * 2 < SCM_LENGTH (layout))
    {
      unsigned char set_x;
      field_type = fields_desc[p * 2];
      set_x = fields_desc [p * 2 + 1];
      if (set_x != 'w')
	SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
    }
  else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')    
    field_type = fields_desc[SCM_LENGTH (layout) - 2];
  else
    {
      SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
    }
  
  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);

SCM
scm_struct_vtable (handle)
     SCM handle;
{
  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);

SCM
scm_struct_vtable_tag (handle)
     SCM handle;
{
  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


void
scm_init_struct ()
{
  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"
20e6290e JB	45	#include "chars.h"
	46
	47	#include "struct.h"
0f2d19dd	48
95b88819 GH	49	#ifdef HAVE_STRING_H
	50	#include <string.h>
	51	#endif
	52
0f2d19dd JB	53	\f
	54
	55	static SCM required_vtable_fields = SCM_BOOL_F;
	56	static int struct_num = 0;
	57
	58	\f
	59	SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
1cc91f1b	60
0f2d19dd JB	61	SCM
	62	scm_make_struct_layout (fields)
	63	SCM fields;
0f2d19dd JB	64	{
	65	SCM new_sym;
	66	SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
	67	fields, SCM_ARG1, s_struct_make_layout);
	68
	69	{
	70	char * field_desc;
	71	int len;
	72	int x;
	73
	74	len = SCM_ROLENGTH (fields);
	75	field_desc = SCM_ROCHARS (fields);
	76	SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
	77
	78	for (x = 0; x < len; x += 2)
	79	{
	80	switch (field_desc[x])
	81	{
	82	case 'u':
	83	case 'p':
	84	#if 0
	85	case 'i':
	86	case 'd':
	87	#endif
	88	case 's':
	89	break;
	90	default:
	91	SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
	92	}
	93
	94	switch (field_desc[x + 1])
	95	{
	96	case 'w':
2c36c351	97	SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
0f2d19dd JB	98	"self fields not writable", s_struct_make_layout);
	99
	100	case 'r':
	101	case 'o':
	102	break;
2c36c351 MD	103	case 'R':
	104	case 'W':
	105	case 'O':
	106	SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
	107	"self fields not allowed in tail array",
	108	s_struct_make_layout);
	109	SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
	110	"tail array field must be last field in layout",
	111	s_struct_make_layout);
	112	break;
0f2d19dd JB	113	default:
	114	SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
	115	}
	116	#if 0
	117	if (field_desc[x] == 'd')
	118	{
	119	SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
	120	x += 2;
	121	goto recheck_ref;
	122	}
	123	#endif
	124	}
	125	new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
	126	}
	127	return scm_return_first (new_sym, fields);
	128	}
	129
	130	\f
	131
	132
1cc91f1b JB	133
	134	static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));
	135
0f2d19dd JB	136	static void
	137	init_struct (handle, tail_elts, inits)
	138	SCM handle;
2c36c351	139	int tail_elts;
0f2d19dd	140	SCM inits;
0f2d19dd JB	141	{
	142	SCM layout;
	143	SCM * data;
	144	unsigned char * fields_desc;
2c36c351	145	unsigned char prot;
0f2d19dd JB	146	int n_fields;
0f2d19dd JB	147	SCM * mem;
2c36c351 MD	148	int tailp = 0;
2c36c351 MD	149
0f2d19dd JB	150	layout = SCM_STRUCT_LAYOUT (handle);
0f2d19dd JB	151	data = SCM_STRUCT_DATA (handle);
2c36c351	152	fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
0f2d19dd JB	153	n_fields = SCM_LENGTH (layout) / 2;
	154	mem = SCM_STRUCT_DATA (handle);
	155	while (n_fields)
	156	{
2c36c351 MD	157	if (!tailp)
	158	{
	159	fields_desc += 2;
	160	prot = fields_desc[1];
	161	if (SCM_LAYOUT_TAILP (prot))
	162	{
	163	tailp = 1;
	164	prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
	165	*mem++ = tail_elts;
	166	n_fields += tail_elts - 1;
	167	if (n_fields == 0)
	168	break;
	169	}
	170	}
	171
0f2d19dd JB	172	switch (*fields_desc)
	173	{
	174	#if 0
	175	case 'i':
2c36c351	176	if ((prot != 'r' && prot != 'w') \|\| inits == SCM_EOL)
0f2d19dd JB	177	*mem = 0;
	178	else
	179	{
	180	*mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
	181	inits = SCM_CDR (inits);
	182	}
	183	break;
	184	#endif
	185
	186	case 'u':
2c36c351	187	if ((prot != 'r' && prot != 'w') \|\| inits == SCM_EOL)
0f2d19dd JB	188	*mem = 0;
	189	else
	190	{
	191	*mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
	192	inits = SCM_CDR (inits);
	193	}
	194	break;
	195
	196	case 'p':
2c36c351	197	if ((prot != 'r' && prot != 'w') \|\| inits == SCM_EOL)
0f2d19dd JB	198	*mem = SCM_EOL;
	199	else
	200	{
	201	*mem = SCM_CAR (inits);
	202	inits = SCM_CDR (inits);
	203	}
	204
	205	break;
	206
	207	#if 0
	208	case 'd':
2c36c351	209	if ((prot != 'r' && prot != 'w') \|\| inits == SCM_EOL)
0f2d19dd JB	210	((double )mem) = 0.0;
	211	else
	212	{
	213	*mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
	214	inits = SCM_CDR (inits);
	215	}
	216	fields_desc += 2;
	217	break;
	218	#endif
	219
	220	case 's':
	221	*mem = handle;
	222	break;
	223	}
	224
0f2d19dd JB	225	n_fields--;
	226	mem++;
	227	}
	228	}
	229
	230
	231	SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
1cc91f1b	232
0f2d19dd JB	233	SCM
	234	scm_struct_p (x)
	235	SCM x;
0f2d19dd JB	236	{
	237	return ((SCM_NIMP (x) && SCM_STRUCTP (x))
	238	? SCM_BOOL_T
	239	: SCM_BOOL_F);
	240	}
	241
	242	SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
1cc91f1b	243
0f2d19dd JB	244	SCM
	245	scm_struct_vtable_p (x)
	246	SCM x;
0f2d19dd JB	247	{
	248	SCM layout;
	249	SCM * mem;
	250
	251	if (SCM_IMP (x))
	252	return SCM_BOOL_F;
	253
	254	if (!SCM_STRUCTP (x))
	255	return SCM_BOOL_F;
	256
	257	layout = SCM_STRUCT_LAYOUT (x);
	258
	259	if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
	260	return SCM_BOOL_F;
	261
	262	if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
	263	SCM_LENGTH (required_vtable_fields)))
	264	return SCM_BOOL_F;
	265
	266	mem = SCM_STRUCT_DATA (x);
	267
	268	if (mem[1] != 0)
	269	return SCM_BOOL_F;
	270
	271	if (SCM_IMP (mem[0]))
	272	return SCM_BOOL_F;
	273
	274	return (SCM_SYMBOLP (mem[0])
	275	? SCM_BOOL_T
	276	: SCM_BOOL_F);
	277	}
	278
	279	SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
1cc91f1b	280
0f2d19dd JB	281	SCM
	282	scm_make_struct (vtable, tail_array_size, init)
	283	SCM vtable;
	284	SCM tail_array_size;
	285	SCM init;
0f2d19dd JB	286	{
	287	SCM layout;
	288	int basic_size;
	289	int tail_elts;
	290	SCM * data;
	291	SCM handle;
	292
	293	SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
	294	vtable, SCM_ARG1, s_make_struct);
	295	SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);
	296
	297	layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
	298	basic_size = SCM_LENGTH (layout) / 2;
	299	tail_elts = SCM_INUM (tail_array_size);
	300	SCM_NEWCELL (handle);
	301	SCM_DEFER_INTS;
2c36c351 MD	302	data = (SCM)scm_must_malloc (sizeof (SCM) (scm_struct_n_extra_words
	303	+ basic_size
	304	+ tail_elts),
	305	"structure");
	306	data += scm_struct_n_extra_words;
	307	data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
	308	+ basic_size
	309	+ tail_elts);
	310	data[scm_struct_i_tag] = struct_num++;
0f2d19dd	311	SCM_SETCDR (handle, data);
35457f1e	312	SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
0f2d19dd JB	313	init_struct (handle, tail_elts, init);
	314	SCM_ALLOW_INTS;
	315	return handle;
	316	}
	317
	318
	319
	320	SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
1cc91f1b	321
0f2d19dd JB	322	SCM
	323	scm_make_vtable_vtable (extra_fields, tail_array_size, init)
	324	SCM extra_fields;
	325	SCM tail_array_size;
	326	SCM init;
0f2d19dd JB	327	{
	328	SCM fields;
	329	SCM layout;
	330	int basic_size;
	331	int tail_elts;
	332	SCM * data;
	333	SCM handle;
	334
	335	SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
	336	extra_fields, SCM_ARG1, s_make_vtable_vtable);
	337	SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
	338
	339
	340	fields = scm_string_append (scm_listify (required_vtable_fields,
	341	extra_fields,
	342	SCM_UNDEFINED));
	343	layout = scm_make_struct_layout (fields);
	344	basic_size = SCM_LENGTH (layout) / 2;
	345	tail_elts = SCM_INUM (tail_array_size);
	346	SCM_NEWCELL (handle);
	347	SCM_DEFER_INTS;
2c36c351 MD	348	data = (SCM ) scm_must_malloc (sizeof (SCM) (scm_struct_n_extra_words
	349	+ basic_size
	350	+ tail_elts),
	351	"structure");
	352	data += scm_struct_n_extra_words;
	353	data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
	354	+ basic_size
	355	+ tail_elts);
	356	data[scm_struct_i_tag] = struct_num++;
0f2d19dd	357	SCM_SETCDR (handle, data);
35457f1e	358	SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
0f2d19dd JB	359	SCM_STRUCT_LAYOUT (handle) = layout;
	360	init_struct (handle, tail_elts, scm_cons (layout, init));
	361	SCM_ALLOW_INTS;
	362	return handle;
	363	}
	364
	365	\f
	366
	367
	368	SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
1cc91f1b	369
0f2d19dd JB	370	SCM
	371	scm_struct_ref (handle, pos)
	372	SCM handle;
	373	SCM pos;
0f2d19dd	374	{
5e840c2e	375	SCM answer = SCM_UNDEFINED;
0f2d19dd JB	376	SCM * data;
	377	SCM layout;
	378	int p;
	379	int n_fields;
	380	unsigned char * fields_desc;
	381	unsigned char field_type;
	382
	383
	384	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	385	SCM_ARG1, s_struct_ref);
	386	SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
	387
	388	layout = SCM_STRUCT_LAYOUT (handle);
	389	data = SCM_STRUCT_DATA (handle);
	390	p = SCM_INUM (pos);
	391
	392	fields_desc = (unsigned char *)SCM_CHARS (layout);
2c36c351 MD	393	n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
	394
	395	SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
0f2d19dd	396
2c36c351 MD	397	if (p * 2 < SCM_LENGTH (layout))
	398	{
	399	unsigned char ref;
	400	field_type = fields_desc[p * 2];
	401	ref = fields_desc[p * 2 + 1];
	402	if ((ref != 'r') && (ref != 'w'))
	403	{
	404	if ((ref == 'R') \|\| (ref == 'W'))
	405	field_type = 'u';
	406	else
	407	SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
	408	}
	409	}
	410	else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
	411	field_type = fields_desc[SCM_LENGTH (layout) - 2];
	412	else
	413	{
	414	SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
	415	}
	416
0f2d19dd JB	417	switch (field_type)
	418	{
	419	case 'u':
	420	answer = scm_ulong2num (data[p]);
	421	break;
	422
	423	#if 0
	424	case 'i':
	425	answer = scm_long2num (data[p]);
	426	break;
	427
	428	case 'd':
	429	answer = scm_makdbl (((double )&(data[p])), 0.0);
	430	break;
	431	#endif
	432
	433	case 's':
	434	case 'p':
	435	answer = data[p];
	436	break;
	437
	438
	439	default:
	440	SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
	441	break;
	442	}
	443
	444	return answer;
	445	}
	446
	447
	448	SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
1cc91f1b	449
0f2d19dd JB	450	SCM
	451	scm_struct_set_x (handle, pos, val)
	452	SCM handle;
	453	SCM pos;
	454	SCM val;
0f2d19dd JB	455	{
	456	SCM * data;
	457	SCM layout;
	458	int p;
	459	int n_fields;
	460	unsigned char * fields_desc;
	461	unsigned char field_type;
	462
	463
	464
	465	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	466	SCM_ARG1, s_struct_ref);
	467	SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
	468
	469	layout = SCM_STRUCT_LAYOUT (handle);
	470	data = SCM_STRUCT_DATA (handle);
	471	p = SCM_INUM (pos);
	472
	473	fields_desc = (unsigned char *)SCM_CHARS (layout);
2c36c351	474	n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
0f2d19dd	475
2c36c351	476	SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
0f2d19dd	477
2c36c351 MD	478	if (p * 2 < SCM_LENGTH (layout))
	479	{
	480	unsigned char set_x;
	481	field_type = fields_desc[p * 2];
	482	set_x = fields_desc [p * 2 + 1];
	483	if (set_x != 'w')
	484	SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
	485	}
	486	else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
	487	field_type = fields_desc[SCM_LENGTH (layout) - 2];
	488	else
	489	{
	490	SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
	491	}
	492
0f2d19dd JB	493	switch (field_type)
	494	{
	495	case 'u':
	496	data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
	497	break;
	498
	499	#if 0
	500	case 'i':
	501	data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
	502	break;
	503
	504	case 'd':
	505	((double )&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
	506	break;
	507	#endif
	508
	509	case 'p':
	510	data[p] = val;
	511	break;
	512
	513	case 's':
	514	SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
	515	break;
	516
	517	default:
	518	SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
	519	break;
	520	}
	521
	522	return val;
	523	}
	524
	525
	526	SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
1cc91f1b	527
0f2d19dd JB	528	SCM
	529	scm_struct_vtable (handle)
	530	SCM handle;
0f2d19dd JB	531	{
	532	SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
	533	SCM_ARG1, s_struct_vtable);
	534	return SCM_STRUCT_VTABLE (handle);
	535	}
	536
	537
	538	SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
1cc91f1b	539
0f2d19dd JB	540	SCM
	541	scm_struct_vtable_tag (handle)
	542	SCM handle;
0f2d19dd JB	543	{
	544	SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
	545	handle, SCM_ARG1, s_struct_vtable_tag);
	546	return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
	547	}
	548
	549
	550	\f
	551
1cc91f1b	552
0f2d19dd JB	553	void
0f2d19dd JB	554	scm_init_struct ()
0f2d19dd JB	555	{
	556	required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
	557	scm_permanent_object (required_vtable_fields);
	558	scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
	559	#include "struct.x"
	560	}
	561