/* "record.c" Scheme record support.
   Copyright 1994 Radey Shouman.

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 1, 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 program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

#include "scm.h"

typedef struct
  {
    SCM rtd;
    SCM name;
    SCM fields;
    SCM printer;
  } rtd_type;

typedef union
  {
    struct
      {
	SCM proc;
	SCM rtd;
      } pred;
    struct
      {
	SCM proc;
	SCM rtd;
	SCM index;
      } acc;
    struct
      {
	SCM proc;
	SCM rtd;
	SCM recsize;
	SCM indices;
      } constr;
  } rec_cclo;

long scm_tc16_record;

/* Record-type-descriptor for record-type-descriptors */
static SCM the_rtd_rtd;

/* Record <= [rtd, ... elts ... ] */
#define REC_RTD(x) (VELTS(x)[0])
#define RECP(x) (scm_tc16_record==TYP16(x))
#define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x))
#define RTD_NAME(x) (((rtd_type *)CDR(x))->name)
#define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields)
#define RTD_PRINTER(x) (((rtd_type *)CDR(x))->printer)
#define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd)

#ifdef ARRAYS
#define MAKE_REC_INDS(n) scm_make_uve((long)n, MAKINUM(1))
#define REC_IND_REF(x, i) VELTS(x)[(i)]
#define REC_IND_SET(x, i, val) VELTS(x)[(i)] = (val)
#else
#define MAKE_REC_INDS(n) scm_make_vector(MAKINUM(n), INUM0)
#define REC_IND_REF(x, i) INUM(VELTS(x)[(i)])
#define REC_IND_SET(x, i, val) VELTS(x)[(i)] = MAKINUM(val)
#endif

static char s_record[] = "record";
static char s_recordp[] = "record?";
SCM 
scm_recordp (obj)
     SCM obj;
{
  return (NIMP (obj) && RECP (obj) ? BOOL_T : BOOL_F);
}
static char s_rec_pred1[] = " record-predicate-procedure";
SCM 
scm_rec_pred1 (cclo, obj)
     SCM cclo, obj;
{
  if (NIMP (obj) && RECP (obj) && (REC_RTD (obj) == RCLO_RTD (cclo)))
    return BOOL_T;
  return BOOL_F;
}
static SCM f_rec_pred1;
static char s_rec_pred[] = "record-predicate";
SCM 
scm_rec_pred (rtd)
     SCM rtd;
{
  SCM cclo = scm_makcclo (f_rec_pred1, 2L);
  ASSERT (NIMP (rtd) && RTDP (rtd), rtd, ARG1, s_rec_pred);
  RCLO_RTD (cclo) = rtd;
  return cclo;
}

static char s_rec_rtd[] = "record-type-descriptor";
SCM 
scm_rec_rtd (rec)
     SCM rec;
{
  if (IMP (rec) || !RECP (rec))
    return BOOL_F;
  return REC_RTD (rec);
}

static SCM f_rec_constr1;
static char s_rec_constr[] = "record-constructor";
SCM 
scm_rec_constr (rtd, flds)
     SCM rtd, flds;
{
  SCM flst, fld;
  SCM cclo = scm_makcclo (f_rec_constr1, (long) sizeof (rec_cclo) / sizeof (SCM));
  rec_cclo *ptr = (rec_cclo *) CDR (cclo);
  sizet i, j;
  ASSERT (NIMP (rtd) && RTDP (rtd), rtd, ARG1, s_rec_constr);
  ptr->constr.rtd = rtd;
  i = scm_ilength (RTD_FIELDS (rtd));
  ptr->constr.recsize = MAKINUM (i);
  if UNBNDP
    (flds)
    {
      ptr->constr.indices = MAKE_REC_INDS (i);
      while (i--)
	REC_IND_SET (ptr->constr.indices, i, i + 1);
    }
  else
    {
      ASSERT (NIMP (flds) && CONSP (flds), flds, ARG2, s_rec_constr);
      ptr->constr.indices = MAKE_REC_INDS (scm_ilength (flds));
      for (i = 0; NIMP (flds); i++, flds = CDR (flds))
	{
	  fld = CAR (flds);
	  ASSERT (NIMP (fld) && SYMBOLP (fld), fld, ARG2, s_rec_constr);
	  flst = RTD_FIELDS (rtd);
	  for (j = 0;; j++, flst = CDR (flst))
	    {
	      if (fld == CAR (flst))
		{
		  REC_IND_SET (ptr->constr.indices, i, j + 1);
		  break;
		}
	      ASSERT (NNULLP (flst), fld, ARG2, s_rec_constr);
	    }
	}
    }
  return cclo;
}
static char s_rec_constr1[] = " record-constructor-procedure";
SCM 
scm_rec_constr1 (args)
     SCM args;
{
  SCM cclo = CAR (args);
  SCM rec, inds = (((rec_cclo *) CDR (cclo))->constr.indices);
  sizet i = INUM (((rec_cclo *) CDR (cclo))->constr.recsize);
  args = CDR (args);
  NEWCELL (rec);
  DEFER_INTS;
  SETCHARS (rec, scm_must_malloc ((i + 1L) * sizeof (SCM), s_record));
  SETNUMDIGS (rec, i + 1L, scm_tc16_record);
  ALLOW_INTS;
  while (i--)
    VELTS (rec)[i + 1] = UNSPECIFIED;
  REC_RTD (rec) = RCLO_RTD (cclo);
  for (i = 0; i < LENGTH (inds); i++, args = CDR (args))
    {
      ASSERT (NNULLP (args), SCM_UNDEFINED, WNA, s_rec_constr1);
      VELTS (rec)[REC_IND_REF (inds, i)] = CAR (args);
    }
  ASSERT (NULLP (args), SCM_UNDEFINED, WNA, s_rec_constr1);
  return rec;

}

/* Makes an accessor or modifier.
   A cclo with 2 env elts -- rtd and field-number. */
static SCM 
makrecclo (proc, rtd, field, what)
     SCM proc, rtd, field;
     char *what;
{
  SCM flst;
  SCM cclo = scm_makcclo (proc, 3L);
  int i;
  ASSERT (RTDP (rtd), rtd, ARG1, what);
  ASSERT (NIMP (field) && SYMBOLP (field), field, ARG2, what);
  RCLO_RTD (cclo) = rtd;
  flst = RTD_FIELDS (rtd);
  for (i = 1;; i++)
    {
      ASSERT (NNULLP (flst), field, ARG2, what);
      if (CAR (flst) == field)
	break;
      flst = CDR (flst);
    }
  (((rec_cclo *) CDR (cclo))->acc.index) = MAKINUM (i);
  return cclo;
}
static char s_rec_accessor1[] = " record-accessor-procedure";
SCM 
scm_rec_accessor1 (cclo, rec)
     SCM cclo, rec;
{
  ASSERT (NIMP (rec) && RECP (rec), rec, ARG1, s_rec_accessor1);
  ASSERT (RCLO_RTD (cclo) == REC_RTD (rec), rec, ARG1, s_rec_accessor1);
  return VELTS (rec)[INUM (((rec_cclo *) CDR (cclo))->acc.index)];
}
static char s_rec_modifier1[] = " record-modifier-procedure";
SCM 
scm_rec_modifier1 (cclo, rec, val)
     SCM cclo, rec, val;
{
  ASSERT (NIMP (rec) && RECP (rec), rec, ARG1, s_rec_modifier1);
  ASSERT (RCLO_RTD (cclo) == REC_RTD (rec), rec, ARG1, s_rec_modifier1);
  VELTS (rec)[INUM (((rec_cclo *) CDR (cclo))->acc.index)] = val;
  return UNSPECIFIED;
}
static SCM f_rec_accessor1;
static char s_rec_accessor[] = "record-accessor";
SCM 
scm_rec_accessor (rtd, field)
     SCM rtd, field;
{
  return makrecclo (f_rec_accessor1, rtd, field, s_rec_accessor);
}
static SCM f_rec_modifier1;
static char s_rec_modifier[] = "record-modifier";
SCM 
scm_rec_modifier (rtd, field)
     SCM rtd, field;
{
  return makrecclo (f_rec_modifier1, rtd, field, s_rec_accessor);
}

static char s_makrectyp[] = "make-record-type";
SCM *scm_loc_makrtd;
SCM 
scm_makrectyp (name, fields, args)
SCM name, fields, args;
{
  SCM n;
  SCM printer;

#ifndef RECKLESS
  ASSERT(SYMBOLP(name), name, ARG1, s_makrectyp);

  if (scm_ilength (fields) < 0)
  errout:scm_wta (fields, (char *) ARG2, s_makrectyp);
  for (n = fields; NIMP (n); n = CDR (n))
    if (!SYMBOLP (CAR (n)))
      goto errout;

  if (NIMP(args) && CONSP(args)) {
    printer = CAR(args);
    args = CDR(args);
  } else
    printer = BOOL_F;

#endif
  return scm_apply(*scm_loc_makrtd,
		   name, scm_cons2 (fields, printer, listofnull));
}

static SCM 
markrec (ptr)
     SCM ptr;
{
  sizet i;
  if GC8MARKP
    (ptr) return BOOL_F;
  SETGC8MARK (ptr);
  for (i = NUMDIGS (ptr); --i;)
    if NIMP
      (VELTS (ptr)[i]) scm_gc_mark (VELTS (ptr)[i]);
  return REC_RTD (ptr);
}

static sizet 
freerec (ptr)
     CELLPTR ptr;
{
  scm_must_free (CHARS (ptr));
  return sizeof (SCM) * NUMDIGS (ptr);
}

static int 
recprin1 (exp, port, writing)
     SCM exp, port;
     int writing;
{
  SCM rtd = REC_RTD(exp);
  SCM name = RTD_NAME(rtd);
  SCM pfunc = RTD_PRINTER(rtd);

  if (pfunc == BOOL_F) {
    sizet i;
    SCM names = RTD_FIELDS (rtd);

    scm_lputs ("#s(", port);
    scm_iprin1 (name, port, 0);

    for (i = 1; i < NUMDIGS (exp); i++)
      {
	scm_lputc (' ', port);
	scm_iprin1 (CAR (names), port, 0);
	names = CDR (names);
	scm_lputc (' ', port);
	scm_iprin1 (VELTS (exp)[i], port, writing);
      }
    scm_lputc (')', port);
  } else if (scm_procedurep(pfunc) != BOOL_F)
    scm_apply(pfunc,
	      exp, scm_cons2(port, writing ? BOOL_T : BOOL_F, listofnull));
  else {
    scm_lputs("#<", port);
    scm_iprin1(name, port, 0);
    scm_lputc(' ', port);
    scm_intprint(exp, 16, port);
    scm_lputc('>', port);
  }

  return 1;
}

SCM 
scm_recequal (rec0, rec1)
     SCM rec0, rec1;
{
  sizet i = NUMDIGS (rec0);
  if (i != NUMDIGS (rec1))
    return BOOL_F;
  if (REC_RTD (rec0) != REC_RTD (rec1))
    return BOOL_F;
  while (--i)
    if (FALSEP (scm_equal (VELTS (rec0)[i], VELTS (rec1)[i])))
	return BOOL_F;
  return BOOL_T;
}

static scm_smobfuns recsmob = {markrec, freerec, recprin1, scm_recequal};

static scm_iproc subr1s[] =
{
  {s_recordp, scm_recordp},
  {s_rec_pred, scm_rec_pred},
  {s_rec_rtd, scm_rec_rtd},
  {0, 0}};
static scm_iproc subr2s[] =
{
  {s_rec_accessor, scm_rec_accessor},
  {s_rec_modifier, scm_rec_modifier},
  {0, 0}};

static char s_name[] = "name";
static char s_fields[] = "fields";
static char s_printer[] = "printer";

void 
scm_init_record ()
{
  SCM i_name = CAR (scm_intern (s_name, (sizeof s_name) - 1));
  SCM i_fields = CAR (scm_intern (s_fields, (sizeof s_fields) - 1));
  SCM i_printer = CAR (scm_intern (s_printer, (sizeof s_printer) - 1));

  scm_tc16_record = scm_newsmob (&recsmob);

  NEWCELL (the_rtd_rtd);
  SETCHARS (the_rtd_rtd, scm_must_malloc ((long) sizeof (rtd_type), s_record));
  SETNUMDIGS (the_rtd_rtd, (long) sizeof (rtd_type) / sizeof (SCM), scm_tc16_record);

  REC_RTD (the_rtd_rtd) = the_rtd_rtd;
  RTD_NAME (the_rtd_rtd) = scm_makfromstr (s_record, (sizeof s_record) - 1, 0);
  RTD_FIELDS (the_rtd_rtd) =
      scm_cons(i_name, scm_cons2(i_fields, i_printer, EOL));
  RTD_PRINTER (the_rtd_rtd) = BOOL_F;

  scm_sysintern ("record:rtd", the_rtd_rtd);

  f_rec_pred1 = scm_make_subr (s_rec_pred1, tc7_subr_2, scm_rec_pred1);
  f_rec_constr1 = scm_make_subr (s_rec_constr1, tc7_lsubr, scm_rec_constr1);
  f_rec_accessor1 = scm_make_subr (s_rec_accessor1, tc7_subr_2, scm_rec_accessor1);
  f_rec_modifier1 = scm_make_subr (s_rec_modifier1, tc7_subr_3, scm_rec_modifier1);

  scm_make_subr (s_rec_constr, tc7_subr_2o, scm_rec_constr);
  scm_init_iprocs (subr1s, tc7_subr_1);
  scm_init_iprocs (subr2s, tc7_subr_2);
  scm_make_subr (s_makrectyp, tc7_lsubr_2, scm_makrectyp);

  scm_sysintern ("record-type-descriptor?", scm_rec_pred (the_rtd_rtd));
  scm_sysintern ("record-type-name", scm_rec_accessor (the_rtd_rtd, i_name));
  scm_sysintern ("record-type-field-names", scm_rec_accessor (the_rtd_rtd, i_fields));

  scm_loc_makrtd = &CDR (scm_sysintern ("RTD:make", scm_rec_constr (the_rtd_rtd, SCM_UNDEFINED)));

  scm_add_feature (s_record);
}
