/* 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"

#define n_header 5



static sizet
free_kobj (obj)
     SCM obj;
{
  int len;
  int waste;
  char * mem;

  len = KEYVECLEN (obj);
  mem = (char *)VELTS(obj);
  mem -= sizeof (SCM);
  if (*(SCM *)mem)
    {
      mem -= sizeof (SCM);
      waste = 4;
    }
  else
    waste = 0;
  scm_must_free (mem);
  return sizeof (SCM) + waste + (n_header + len) * sizeof (SCM);
}

static int
prin_kobj (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs("#<key-object ", port);
  scm_intprint(exp, 16, port);
  {
    SCM val_cell;
    val_cell = CDR(exp);
    if (CAR (val_cell) != SCM_UNDEFINED)
      {
	scm_lputs(" ", port);
	scm_iprin1 (CAR (val_cell), port, writing);
      }
  }
  scm_lputc('>', port);
  return 1;
}

SCM
mark_kobj (obj)
{
  if (!GC8MARKP (obj))
    {
      int x;
      SCM * elts;
      elts = VELTS (obj);
      SETGC8MARK (obj);
      for (x = KEYVECLEN (obj) - 1; x >= 0; --x)
	scm_gc_mark (elts[x + n_header]);
      scm_gc_mark (elts[3]);
      elts[1] = 1;
      return elts[0];
    }
  else
    return BOOL_F;
}

int scm_tc16_key_vector;
static scm_smobfuns key_object_smob = {mark_kobj, free_kobj, prin_kobj, 0};



static char s_key_vector[] = "key-vector";

SCM
scm_key_vector (name, format, keys)
     SCM name;
     SCM format;
     SCM keys;
{
  SCM answer;
  SCM * data;
  int len;
  int full_len;

  ASSERT (NIMP (format) && SYMBOLP (format), format, ARG2, s_key_vector);
  NEWCELL (answer);
  len = scm_ilength (keys);
  full_len = len + n_header;
  if (full_len & 1)
    full_len += 1;
  DEFER_INTS;
  data = (SCM *)scm_must_malloc (sizeof (SCM) * (len + n_header + 2),
				 "key-vector");
  {
    *data = 0;
    ++data;

    if ((unsigned long)data & 0x7)
      {
	*data = 1;
	++data;
      }

    if ((unsigned long)data & 0x7)
      {
	ALLOW_INTS;
	scm_lputs ("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
	exit(EXIT_FAILURE);
      }
  }
  data[0] = name;
  data[1] = 0; /* type marker ! */
  data[2] = answer;
  data[3] = format;
  data[4] = 0; /* reference count */
  {
    int x;
    for (x = 0; x < len; ++x, keys = CDR (keys))
      data[x + n_header] = CAR (keys);
  }
  CAR (answer) = (len << 16) | scm_tc16_key_vector;
  CDR (answer) = (SCM)data;
  ALLOW_INTS;
  return answer;
}


static char s_key_vector_format[] = "key-vector-format";
SCM
scm_key_vector_format (obj)
     SCM obj;
{
  ASSERT (NIMP (obj) && KEYVECP (obj), obj, ARG1, s_key_vector_format);
  return VELTS (obj)[3];
}


static char s_key_vector_ref[] = "key-vector-ref";
SCM
scm_key_vector_ref (obj, n)
     SCM obj;
     SCM n;
{
  ASSERT (NIMP (obj) && KEYVECP (obj), obj, ARG1, s_key_vector_ref);
  ASSERT (INUMP (n), n, "ARG2 out of range", s_key_vector_ref);
  ASSERT (   (INUM (n) >= 0)
	  && (INUM (n) < KEYVECLEN (obj)),
	  n, "ARG2 out of range", s_key_vector_ref);
  return VELTS (obj) [INUM (n) + n_header];
}



static char s_make_object[]="make-object";
SCM
scm_make_object (kobj)
     SCM kobj;
{
  SCM answer;
  SCM format;
  int len;
  SCM * mem;
  SCM type_saver;
  
  ASSERT (NIMP (kobj) && KEYVECP (kobj), kobj, ARG1, s_make_object);
  NEWCELL (answer);
  format = VELTS (kobj)[3];
  len = LENGTH (format);

  if (!VELTS (kobj)[4])
    {
      NEWCELL (type_saver);
    }
  else
    type_saver = BOOL_F;

  DEFER_INTS;

  if (0 == VELTS (kobj)[4]++)
    {
      CAR (type_saver) = kobj;
      CDR (type_saver) = type_obj_list;
      type_obj_list = type_saver;
    }
  
  CAR (answer) = CDR (kobj) + 1;
  mem = (SCM *)scm_must_malloc (len * sizeof (SCM), "latte object");
  CDR (answer) = (SCM)mem;
  {
    char * f;
    int i;

    for (i = 0, f = CHARS (format); i < len; ++i, ++f)
      {
	switch (*f)
	  {
	  case 'i':
	  case 'f':
	  case 'l':
	  case 'd':
	  case '2':
	    mem[i] = 0;
	    break;
	  case 's':
	  default:
	    mem[i] = EOL;
	    break;
	  }
      }
  }
  ALLOW_INTS;
  return answer;
}



static char s_object_ref[] = "object-ref";

SCM
scm_object_ref (obj, n)
     SCM obj;
     SCM n;
{
  int i;
  ASSERT (NIMP (obj) && OBJECTP (obj), obj, ARG1, s_object_ref);
  ASSERT (INUMP (n), n, ARG2, s_object_ref);
  i = INUM (n);
  ASSERT ((0 <= i) && (i < LENGTH (((SCM*)(CAR (obj) - 1L))[3])),
	  n, "ARG2 out of range", s_object_ref);

  switch (CHARS (((SCM*)(CAR (obj) - 1L))[3])[i])
    {
    case '*':
    case '2':
    default:
      scm_wta (n, "illegal field", s_object_ref);

    case 's':
      return ((SCM *)CDR (obj))[i];

    case 'i':
      return long2num (((SCM *)CDR (obj))[i]);

    case 'l':
    case 'f':
    case 'd':
      return BOOL_F;
    }
}

static char s_object_set[] = "object-set!";

SCM
scm_object_set (obj, n, val)
     SCM obj;
     SCM n;
{
  int i;
  ASSERT (NIMP (obj) && OBJECTP (obj), obj, ARG1, s_object_set);
  ASSERT (INUMP (n), n, ARG2, s_object_set);
  i = INUM (n);
  ASSERT ((0 <= i) && (i < LENGTH (((SCM*)(CAR (obj) - 1L))[3])),
	  n, "ARG2 out of range", s_object_set);

  switch (CHARS (((SCM*)(CAR (obj) - 1L))[3])[i])
    {
    case '*':
    case '2':
    default:
      scm_wta (n, "illegal field", s_object_set);

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

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

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

    case 'l':
    case 'f':
    case 'd':
      break;
    }
  return UNSPECIFIED;
}



void
scm_init_kobjs ()
{
  scm_tc16_key_vector = scm_newsmob (&key_object_smob);
  scm_make_gsubr (s_key_vector, 2, 0, 1, scm_key_vector);
  scm_make_gsubr (s_key_vector_format, 1, 0, 0, scm_key_vector_format);
  scm_make_gsubr (s_key_vector_ref, 2, 0, 0, scm_key_vector_ref);
  scm_make_gsubr (s_make_object, 1, 0, 0, scm_make_object);
  scm_make_gsubr (s_object_ref, 2, 0, 0, scm_object_ref);
  scm_make_gsubr (s_object_set, 3, 0, 0, scm_object_set);
  type_obj_list = EOL;
}
