/* classes: src_files */

/*	Copyright (C) 1995 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.
 */



#include "scm.h"


static SCM *
allocate_object (size, type_objp)
     int size;
     int type_objp;
{
  int extra;
  SCM * data;

  extra = type_objp ? (2 + n_header) : 0;
  data = (SCM *)scm_must_malloc (sizeof (SCM) * (extra + size), "struct");
  if (type_objp)
    {
      /* Ensure that the type data starts on an address
       * aligned on a 2-word boundry.
       */
      *data = 0;
      ++data;

      if ((unsigned long)data & 0x7)
	{
	  *data = 1;
	  ++data;
	}
      if ((unsigned long)data & 0x7)
	{
	  /* in case there are weird mallocs in the world */
	  ALLOW_INTS;
	  scm_lputs ("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
	  exit(EXIT_FAILURE);
	}
    }
  return data;
}

static int
free_object (obj, type_objp)
     SCM * obj;
     int type_objp;
{
  int extra;
  if (type_objp)
    {
      obj -= obj[-1];
      extra = 2;
    }
  else
    extra = 0;
  free (obj);
  return extra;
}
     




static char s_make_struct[]="make-struct";

SCM
_scm_make_struct (type, nelts, internal, typeobjp)
     SCM type;
     SCM nelts;
     int internal;
     int typeobjp;
{
  SCM answer;
  SCM format;
  int len;
  int dyn_len;
  SCM * mem;
  SCM type_saver;
  SCM gc_prot_handle;
  int shoudnt_make;

  /* As a special case, construct the 
   * the root type.
   */
  if (type == BOOL_F)
    {
      if (first_type != BOOL_F)
	return first_type;
      else
	{
	  SCM * protomem;
	  NEWCELL (type);
	  protomem = (SCM *)allocate_object (n_header, 1);
	  DEFER_INTS;
	  CDR (type) = (SCM)protomem;
	  CAR (type) = (SCM)protomem + 1;
	  protomem[struct_i_name] = CAR (scm_intern0 ("latte-type"));
	  protomem[struct_i_vcell] = 0;
	  protomem[struct_i_format] = CAR (scm_intern0 (latte_type_format));
	  protomem[struct_i_refcnt] = 0;
	  protomem[struct_i_self] = type;
	  protomem[struct_i_sekrit] = BOOL_F;
	  protomem[struct_i_vtab_size] = 0;
	  ALLOW_INTS;
	  first_type = type;
	  return type;
	}
    }
  
  ASSERT (NIMP (type) && STRUCT_TYPEP (type), type, ARG1, s_make_struct);
  if ((nelts == BOOL_F) || (nelts == SCM_UNDEFINED))
    nelts = MAKINUM (0);
  ASSERT (INUMP (nelts), nelts, ARG2, s_make_struct);

  format = STRUCT_TYPE_FORMAT (type);
  len = LENGTH (format);
  dyn_len = INUM (nelts);

  ASSERT ((dyn_len == 0) || ((len > 1) && ('*' == CHARS (format)[len - 2])),
	  dyn_len, OUTOFRANGE, s_make_struct);

  NEWCELL (answer);
  if (0 ==  STRUCT_TYPE_REFCNT(type))
    {
      NEWCELL (gc_prot_handle);
    }

  DEFER_INTS;
  if (0 ==  STRUCT_TYPE_REFCNT(type)++)
    {
      CAR (gc_prot_handle) = type;
      CDR (gc_prot_handle) = type_obj_list;
      type_obj_list = gc_prot_handle;
    }
  
  CAR (answer) = CDR (type) + 1;
  mem = allocate_object (len + dyn_len, typeobjp);
  CDR (answer) = (SCM)mem;
  {
    char * f;
    int i;
    SCM * pos;
    SCM last_val;
    int f_inc;
    int full_len;

    shoudnt_make = 0;
    f_inc = 1;
    full_len = len + dyn_len;
    for (i = 0, f = CHARS (format); i < full_len; ++i, (f += f_inc))
      {
	switch (*f)
	  {
	  case 'I':
	  case 'F':
	  case 'L':
	  case 'D':
	  case '.':
	    if (!internal)
	      shoudnt_make = 1;
	  case 'i':
	  case 'f':
	  case 'l':
	  case 'd':
	  case '2':
	    mem[i] = last_val = 0;
	    break;

	  case 'S':
	    if (!internal)
	      shoudnt_make = 1;
	  case 's':
	    mem[i] = last_val = EOL;
	    break;

	  case '*':
	    if (i != (len - 2))
	      {
		mem[i] = 0;
		shoudnt_make = 1;
	      }
	    else
	      {
		mem[i] = dyn_len;
		f += 1;
		f_inc = 0;
	      }
	    break;

	  default:
	    shoudnt_make = 1;
	    mem[i] = 0;
	    break;
	  }
      }
  }
  ALLOW_INTS;
  ASSERT (!shoudnt_make, type,
	  "This type can't be instantiated genericly.",
	  s_make_struct);
  return answer;
}



static char s_bottom_struct_type[] = "bottom-struct-type";

SCM 
scm_bottom_struct_type ()
{
  return _scm_make_struct (BOOL_F, 0, 1, 1);
}



SCM
scm_make_struct (type, nelts)
     SCM type;
     SCM nelts;
{
  return _scm_make_struct (type, nelts, 0, 0); /* fixme: typeobjp */
}



static char s_make_struct_type[] = "make-struct-type";
SCM
scm_make_struct_type (name, format, sekrit, vtable)
     SCM name;
     SCM format;
     SCM sekrit;
     SCM vtable;
{
  SCM root_type;
  SCM answer;
  int vtab_len;

  ASSERT (NIMP (name) && SYMBOLP (name), name, ARG1, s_make_struct_type);
  ASSERT (NIMP (format) && SYMBOLP (format), name, ARG2, s_make_struct_type);

  root_type = scm_bottom_struct_type ();
  vtab_len = scm_ilength (vtable);
  answer = _scm_make_struct (root_type, MAKINUM (vtab_len), 1, 1);
  STRUCT_TYPE_NAME (answer) = name;
  STRUCT_TYPE_VCELL (answer) = 0;
  STRUCT_TYPE_FORMAT (answer) = format;
  STRUCT_TYPE_REFCNT (answer) = 1;
  STRUCT_TYPE_SELF (answer) = answer;
  STRUCT_TYPE_SEKRIT (answer) = sekrit;
  STRUCT_TYPE_VTAB_SIZE (answer) = vtab_len;
  {
    int x;
    for (x = 0; vtable != EOL; ++x, vtable = CDR (vtable))
      STRUCT_TYPE_VTAB (answer)[x] = CAR (vtable);
  }
  return answer;
}



static char s_struct_type_name[] = "struct-type-name";

SCM
scm_struct_type_name (obj)
     SCM obj;
{
  ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_struct_type_name);
  return STRUCT_TYPE_NAME (obj);
}



static char s_struct_type_format[] = "struct-type-format";

SCM
scm_struct_type_format (obj)
     SCM obj;
{
  ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_struct_type_format);
  return STRUCT_TYPE_FORMAT (obj);
}




static char s_struct_type_secretp[] = "struct-type-secret?";

SCM 
scm_struct_type_secretp (obj, guess)
     SCM obj;
     SCM guess;
{
  ASSERT (NIMP (obj) && STRUCT_TYPEP (obj), obj, ARG1, s_struct_type_secretp);

  return (STRUCT_TYPE_SEKRIT (obj) == guess
	  ? BOOL_T
	  : BOOL_F);
}


static char s_struct_ref[] = "struct-ref";


SCM
_struct_ref (obj, i, anyp)
     SCM obj;
     int i;
     int anyp;
{
  SCM format;
  char field_type;

  format = STRUCT_TYPE(obj)[struct_i_format];
  if (   (i > 0)
      && (i >= (-1 + LENGTH (format)))
      && (CHARS(format)[i - 1] == '*'))
    field_type = CHARS (format)[-1 + LENGTH (format)];
  else
    {
      ASSERT ((0 <= i) && (i < LENGTH (format)),
	      MAKINUM (i), "ARG2 out of range", s_struct_ref);
      field_type = CHARS (format)[i];
    }

  switch (field_type)
    {
    case '2':
    default:
    illegal:
      scm_wta (MAKINUM (i), "illegal field", s_struct_ref);

    case 'S':
      if (!anyp) goto illegal;
    case 's':
      return ((SCM *)CDR (obj))[i];

    case 'I':
      if (!anyp) goto illegal;
    case 'i':
    case '*':
      return long2num (((SCM *)CDR (obj))[i]);
    case 'F':
      if (!anyp) goto illegal;
    case 'f':
      return scm_makdbl ((double)*(float *)&(((SCM *)CDR (obj))[i]), 0.0);
    case 'D':
      if (!anyp) goto illegal;
    case 'd':
      return scm_makdbl (*(double *)&(((SCM *)CDR (obj))[i]), 0.0);
    case 'L':
      if (!anyp) goto illegal;
    case 'l':
      {
	long * addr;
	addr = (long *)&(((SCM *)CDR (obj))[i]);
#ifdef LITTLE_ENDIAN
	return MAKINUM (0);
#else
	return MAKINUM (0);
#endif
      }
    }
}


SCM
scm_struct_ref (obj, n)
     SCM obj;
     SCM n;
{
  int i;
  SCM format;
  char field_type;

  ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_struct_ref);
  ASSERT (INUMP (n), n, ARG2, s_struct_ref);

  return _struct_ref (obj, INUM (n), 0);
}


static char s_vtab_ref[] = "vtab-ref";

SCM
scm_vtab_ref (obj, n)
     SCM obj;
     SCM n;
{
  int i;
  SCM format;
  char field_type;

  ASSERT (NIMP (obj) && STRUCT_TYPEP (obj), obj, ARG1, s_vtab_ref);
  ASSERT (INUMP (n), n, ARG2, s_vtab_ref);
  return _struct_ref (obj, struct_i_vtab + INUM (n), 1);
}




double
scm_num2dbl (num, why)
     SCM num;
     char * why;
{
  if (INUMP (num))
    return (double) INUM (num);

  ASSERT (NIMP (num), num, "not a number", why);

  if (REALP (num))
    return REALPART (num);

#ifdef BIGDIG
  if (BIGP (num))
    return scm_big2dbl (num);
#endif

  ASSERT (0, num, "not a number", why);
}





static char s_struct_set[] = "struct-set!";

SCM
scm_struct_set (obj, n, val)
     SCM obj;
     SCM n;
{
  int i;
  SCM format;
  char field_type;

  ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_struct_set);
  ASSERT (INUMP (n), n, ARG2, s_struct_set);

  i = INUM (n);
  format = STRUCT_TYPE(obj)[struct_i_format];
  if (   (i > 0)
      && (i >= (-1 + LENGTH (format)))
      && (CHARS(format)[i - 1] == '*'))
    field_type = CHARS (format)[-1 + LENGTH (format)];
  else
    {
      ASSERT ((0 <= i) && (i < LENGTH (format)),
	      n, "ARG2 out of range", s_struct_ref);
      field_type = CHARS (format)[i];
    }

  switch (field_type)
    {
    case '*':
    case '2':
    default:
      scm_wta (n, "illegal field", s_struct_set);

    case 's':
      ((SCM *)CDR (obj))[i] = val;
      break;

    case 'i':
      ((SCM *)CDR (obj))[i] = scm_num2long (val, (char *)ARG3, s_struct_set);
      break;

    case 'u':
      ((SCM *)CDR (obj))[i] = scm_num2ulong (val, (char *)ARG3, s_struct_set);
      break;

    case 'f':
      *((float *)&(((SCM *)CDR (obj))[i])) = scm_num2dbl (val);
      break;

    case 'd':
      *((double *)&(((SCM *)CDR (obj))[i])) = scm_num2dbl (val);
      break;

    case 'l':
      {
	long * addr;
	long lo;
	long hi;
	addr = (long *)&(((SCM *)CDR (obj))[i]);
	ASSERT (BOOL_T == scm_exactp (val), val, ARG1, s_struct_set);
	lo = 0xbabe;
	hi = 0xcafe;
#ifdef LITTLE_ENDIAN
	*addr = lo;
	*(addr + 1) = hi;
#else
	*addr = hi;
	*(addr + 1) = lo;
#endif
	break;
      }
    }
  return UNSPECIFIED;
}



static char s_structp[] = "struct?";
scm_structp(obj)
     SCM obj;
{
  return ((NIMP (obj) && STRUCTP (obj))
	  ? BOOL_T
	  : BOOL_F);
}

static char s_struct_typep [] = "struct-type?";
scm_struct_typep(obj)
     SCM obj;
{
  return ((NIMP (obj) && STRUCT_TYPEP (obj))
	  ? BOOL_T
	  : BOOL_F);
}

static char s_struct_type[]="struct-type";
SCM
struct_type (obj)
     SCM obj;
{
  ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_struct_type);
  return STRUCT_TYPE (obj)[struct_i_self];
}




void
scm_init_struct ()
{
 scm_make_gsubr (s_bottom_struct_type, 0, 0, 0, scm_bottom_struct_type);
 scm_make_gsubr (s_make_struct_type, 3, 0, 1, scm_make_struct_type);

 scm_make_gsubr (s_make_struct, 1, 1, 0, scm_make_struct);

 scm_make_gsubr (s_struct_type_name, 1, 0, 0, s_struct_type_name);
 scm_make_gsubr (s_struct_type_secretp, 2, 0, 0, scm_struct_type_secretp);
 scm_make_gsubr (s_struct_type_format, 1, 0, 0, s_struct_type_format);
 scm_make_gsubr (s_vtab_ref, 2, 0, 0, scm_vtab_ref);

 scm_make_gsubr (s_struct_ref, 2, 0, 0, scm_struct_ref);
 scm_make_gsubr (s_struct_set, 3, 0, 0, scm_struct_set);
 scm_make_gsubr (s_struct_type, 1, 0, 0, s_struct_type);
 scm_make_gsubr (s_struct_typep, 1, 0, 0, s_struct_typep);
 scm_make_gsubr (s_structp, 1, 0, 0, s_structp);
}


