/***********************************************************************
     "intkaos.c": Kernel of "cAOS" generated code (C version).
***********************************************************************/

/***********************************
  (C) Copyright 1992-1993; dit/upm
   Distributed under the conditions stated in the
   TOPO General Public License (see file LICENSE)
 ***********************************
 $Log: intkaos.c,v $
 * Revision 1.1  1994/07/19  12:34:52  lotos
 * Initial revision
 *
 * Revision 1.1  1994/07/18  18:35:10  lotos
 * Initial revision
 *
 * Revision 2.4  1993/09/20  12:39:05  lotos
 * synchronized with kaos development
 * adpated to kdatum
 * udatum are not expected to be used
 * reduce number of reserved words: new user lexicon
 *
 * Revision 2.11  1993/06/10  14:04:29  lotos
 * new annotation CALL
 *
 * Revision 2.10  1993/06/01  13:35:09  lotos
 * los argumentos no pueden ser NULL
 *
 * Revision 2.9  1993/04/26  12:46:33  lotos
 * error en xd_free (mal la liberacion recursiva)
 * error en xd_draw (el buffer podia rebosar)
 * error en xd_draw (problemas al mezclar tipos externos e internos)
 *
 * Revision 2.8  1993/03/29  18:11:14  lotos
 * repair wrong debug messages
 *
 * Revision 2.7  1993/03/24  17:48:31  lotos
 * field RFC, removed
 *
 * Revision 2.6  1993/01/18  18:16:12  lotos
 * distribution issues
 *
 * Revision 2.5  1993/01/12  18:38:23  lotos
 * portability issues
 *
 * Revision 2.4  1993/01/12  14:26:55  lotos
 * use conf.h for portability
 *
 * Revision 2.3  1992/12/02  11:05:29  lotos
 * draw and parse functions are controled by options
 * format of parse, changed
 *
 * Revision 2.2  1992/11/17  18:35:08  lotos
 * separate internal (kdatum) and external (udatum)
 * new annotation ldc at the very and of the spec
 * new annotation ldcinit at the beginning
 *
 * Revision 2.1  1992/10/14  18:16:00  lotos
 * new philosophy to write ADTs,
 * every new expression is supposed to be pointed once,
 * in order to share a value, it has to be kd_copy'ed
 * functions assume their arguments are absolutely theirs
 *
 * Revision 1.8  1992/10/14  18:07:59  lotos
 * forget ophuscation.
 *
 * Revision 1.7  1992/09/02  14:04:23  lotos
 * avoid casting on LHS (for portability)
 *
 * Revision 1.6  92/05/06  18:46:39  lotos
 * vprintf() and exit(): fixed to shut lint up!
 * debug flag added
 *
 * Revision 1.5  92/03/03  17:45:25  lotos
 * fix visibility of _dr_result
 *
 * Revision 1.4  92/02/29  13:27:03  lotos
 * flags for pretty printing: optional
 *
 * Revision 1.3  92/01/15  12:45:10  lotos
 * ready to distribute
 *
 * Revision 1.2  91/11/20  13:28:54  lotos
 * parse and eval code added
 * gsuid uses a hash table and detects duplications
 * new private function gouid (like gsuid, but for operations)
 *
 * Revision 1.1  91/10/02  17:00:50  lotos
 * Initial revision
 *
 ***********************************/

/* KJT 29/10/04: changed to use "stdarg" instead of "varargs" */

/* KJT 08/08/06: changes for compatibility with CygWin 1.5.18-1/ gcc 3.4.4-1 */

#include "version.h"
#ifndef lint
static char rcsid[]= "$Id: intkaos.c,v 1.1 1994/07/19 12:34:52 lotos Exp $";
#endif

/* LINTLIBRARY */

#define intkaos_IMP

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <stdarg.h>
#include <assert.h>
#include "intkaos.hh"

/* Modified for Interpreter use */
#include "ldi.hh"

/* KJT 20/01/23: added function prototypes */
PUBLIC int _xd_opn (int sort, char *name);

/* Modified for Interpreter use */
#define BLOCK_SIZE 10
#define MSRS 0

/* KJT 20/01/23: added function prototypes */
PUBLIC int _xd_kd2sort(kdatum dat);

/* Modified for Interpreter use */
int backtracking=0;
int usrb = FALSE;
int extname = FALSE;

/*static IndentV=-2;*/
/* KJT 20/01/23: added "int" type */
static int IndentV=0;

static int firstopn= TRUE;
static int firstsort= TRUE;
/***** private functions headers *****/

/* Modified for Interpreter use */
PRIVATE int _chksons();
/***** lint passing functions *****/

#ifndef lint
#  define ALIN(type, ptr)	((type *)(ptr))
#else
#  define ALIN(type, ptr)	((type *)(int)&*(ptr))
#endif

#ifndef lint
#  define NOOP()	((void)0)
#else
   PRIVATE int __NOOP__= 0;

#  define NOOP()	((void)(++__NOOP__))
#endif

#ifndef lint
#  define TEST(cond)	(cond)
#else
   PRIVATE int __TEST__= 0;

#  define TEST(cond)	(__TEST__= (cond), __TEST__)
#endif

/***** error handling functions *****/

PUBLIC void
put_error (char *format, ...)
{
  va_list args;

  va_start(args, format);
  (void) vfprintf(stderr, format, args);
  va_end(args);
}

/***** programming error detection functions *****/

#ifndef NDEBUG
#  define abort_if(cond)			\
	  {					\
	    if (TEST(cond))			\
	      _cond_fail(__FILE__, __LINE__);	\
	  }
#else
#  define abort_if(cond)	{}
#endif

PRIVATE void
_cond_fail (file, line)
  char *file;
  int line;
{
  put_error("abnormal condition: file \"%s\", line %d\n", file, line);
  abort();
}

/***** memory allocation functions *****/

#define _talloc(lptr, rptr, nelem)				\
	  (((lptr)= ALIN(void, malloc((unsigned)		\
				      sizeof(*(rptr)) *		\
				      (nelem)))) == NULL?	\
	     _malloc_error(): NOOP()				\
	  )

#ifndef lint
#  define talloc(ptr, nelem)	_talloc(ptr, ptr, nelem)
#else
#  define talloc(ptr, nelem)	_talloc(ALIN(void, ptr), ptr, nelem)
#endif

PRIVATE void
_malloc_error ()
{
  put_error("malloc: not enough memory\n");
  exit(1);
}

#define _trealloc(lptr, rptr, nelem)				\
	  (((lptr)= ALIN(void, realloc(ALIN(char, rptr),	\
				       (unsigned)		\
				       sizeof(*(rptr)) *	\
				       (nelem)))) == NULL?	\
	     _realloc_error(): NOOP()				\
	  )

#ifndef lint
#  define trealloc(ptr, nelem)	_trealloc(ptr, ptr, nelem)
#else
#  define trealloc(ptr, nelem)	_trealloc(ALIN(void, ptr), ptr, nelem)
#endif

PRIVATE void
_realloc_error ()
{
  put_error("realloc: not enough memory\n");
  exit(1);
}

#define ffree(ptr)	((void) free(ALIN(char, ptr)))

/***** auxiliary data types *****/

typedef struct _Xdatum
{ int cnt;
  int nop;
  struct _Xdatum *next;
} *_xdatum;

/***** debugging functions *****/

#define CHK_HEAD	"INTKAOS EXCEPTION"

#define CHK_OK		 	 0
#define CHKSORT_NOTSTORED	-1
#define _CHKOPN_NOTSTORED	 2
#define _CHKOPN_WRONGSORT	 3
#define _CHKVAR_NOTSTORED	 4
#define _CHKVAR_WRONGSORT	 5
#define CHKDATUM_WRONGSORT	-6
#define CHKDATUM_WASKILLED	-7
#define CHKDATUM_BADSTRUCT	-8
#define CHKDATUM_CORRUPTED	-9
#define CHKDATUM_NULLDATUM	-10

PRIVATE int
chksort (sort)
  int sort;
{
  if (sort == _xd_internal)
    return CHK_OK;
  if (sort < 0 ||
      sort >= sort_tbl_size ||
      sort_tbl[sort].name == NULL)
    return CHKSORT_NOTSTORED;
  return CHK_OK;
}

PRIVATE int
_chkopn (sort, opn)
  int sort;
  int opn;
{
  if (opn < 0 ||
      opn >= opn_tbl_size)
    return _CHKOPN_NOTSTORED;
  else if (opn_tbl[opn].name == NULL)
    return _CHKOPN_NOTSTORED;
  else if (sort == _xd_internal)
    if (sort_tbl[opn_tbl[opn].sid].isextern)
      return _CHKOPN_WRONGSORT;
    else
      ;
  else if (opn_tbl[opn].sid != sort)
    return _CHKOPN_WRONGSORT;
  return CHK_OK;
}

PRIVATE int
_chkvar (sort, var)
  int sort;
  int var;
{
  if (var < 0 ||
      var >= var_tbl_size)
    return _CHKVAR_NOTSTORED;
  else if (var_tbl[var].use == IS_FREE)
    return _CHKVAR_NOTSTORED;
  else if (sort == _xd_internal)
    if (sort_tbl[var_tbl[var].sid].isextern)
      return _CHKVAR_WRONGSORT;
    else
      ;
  else if (var_tbl[var].sid != sort)
    return _CHKVAR_WRONGSORT;
  return CHK_OK;
}


PRIVATE int
_chkdatum (sort, exp)
  int sort;
  kdatum exp;
{

/* Modified for Interpreter use */
/* int _chksons(); */

  if (((_xdatum) exp)->cnt == 0)
    return CHKDATUM_WASKILLED;
  if (sort_tbl[sort].isextern)
    return CHK_OK;
  if (exp->opn >= 0) {
    if (_chkopn(sort, exp->opn) != CHK_OK)
      return CHKDATUM_WRONGSORT;
  } else {
    if (_chkvar(sort, -exp->opn) != CHK_OK)
      return CHKDATUM_WRONGSORT;
  }
  return _chksons(exp);
}

PRIVATE int
_chksons (exp)
  kdatum exp;
{
  int i, narg;
  int *sarg;
  klink l;
  int chk= CHK_OK;

  if (exp->opn < 0)
    return chk;

  narg= opn_tbl[exp->opn].narg;
  sarg= opn_tbl[exp->opn].sarg;
  for (i= 0, l= exp->lnk; i < narg; ++i, l= l->next)
  { if (l == NULL)
    { chk= CHKDATUM_BADSTRUCT;
      break;
    }
    if (l->arg == NULL)
    { chk= CHKDATUM_BADSTRUCT;
      continue;
    }
    switch (_chkdatum(sarg[i], l->arg))
    { case CHK_OK:
	break;
      case CHKDATUM_WRONGSORT:
      case CHKDATUM_BADSTRUCT:
	chk= CHKDATUM_BADSTRUCT;
	break;
      case CHKDATUM_WASKILLED:
      case CHKDATUM_CORRUPTED:
	return CHKDATUM_CORRUPTED;
      default:
	abort_if(TRUE)
    }
  }
  if (l != NULL)
    chk= CHKDATUM_BADSTRUCT;
  return chk;
}

PRIVATE int
chkdatum (sort, exp)
  int sort;
  kdatum exp;
{
  if (exp == NULL)
    return CHKDATUM_NULLDATUM;
  if (((_xdatum) exp)->cnt == 0)
    return CHKDATUM_WASKILLED;
  if (sort != _xd_internal)
  { if (chksort(sort) != CHK_OK)
      return CHK_OK;
    if (sort_tbl[sort].isextern)
      return CHK_OK;
  }
  if (exp->opn >= 0){
    if (_chkopn(sort, exp->opn) != CHK_OK)
      return CHKDATUM_WRONGSORT;
  }else{
    if (_chkvar(sort, -exp->opn) != CHK_OK)
      return CHKDATUM_WRONGSORT;
  }
  return _chksons(exp);
}

#ifndef NDEBUG
#define _chk_position() \
	  put_error("\"%s\", line %d: ", file, line)
#else
#define _chk_position()	{}
#endif

#define _chk_message(file, line, func, var, msg)	\
	{						\
	  put_error("%s: ", CHK_HEAD);			\
	  _chk_position();				\
	  put_error("%s of %s %s\n", var, func, msg);	\
	}

PRIVATE int
_chk_error (code, file, line, func, var)
  int code;
  char *file;
  int line;
  char *func;
  char *var;
{
  switch (code)
  { case CHK_OK:
      return FALSE;
    case CHKSORT_NOTSTORED:
      _chk_message(file, line, func, var, "is no sort");
      break;
    case CHKDATUM_WRONGSORT:
      _chk_message(file, line, func, var, "doesn't match sort");
      break;
    case CHKDATUM_WASKILLED:
      _chk_message(file, line, func, var, "was already killed");
      break;
    case CHKDATUM_BADSTRUCT:
      _chk_message(file, line, func, var, "badly built or corrupted");
      break;
    case CHKDATUM_CORRUPTED:
      _chk_message(file, line, func, var, "corrupted");
      break;
    case CHKDATUM_NULLDATUM:
      _chk_message(file, line, func, var, "is NULL");
      break;
    default:
      abort_if(TRUE)
  }
  return TRUE;
}

#ifndef NDEBUG
#define chk_error(code, func, var) \
	  _chk_error(code, __FILE__, __LINE__, func, var)
#else
#define chk_error(code, func, var) \
	  _chk_error(code, NULL, 0, func, var)
#endif

/***** data handling functions *****/

/* heap of items type */
#define tHEAP(item)	\
	struct		\
	{ struct	\
	  { item *head;	\
	  } old;	\
	  struct	\
	  { item *head;	\
	    item *tail;	\
	  } new;	\
	}

PRIVATE tHEAP(struct _Xdatum) DHEAP= { NULL, NULL, NULL };
PRIVATE tHEAP(struct Klink) LHEAP= { NULL, NULL, NULL };

#define DHEAP_INC	(BUFSIZ / sizeof(struct Kdatum))
#define LHEAP_INC	DHEAP_INC

PUBLIC kdatum
_xd_alloc ()
{
  _xdatum p;

  if (DHEAP.old.head == NULL)
  { if (DHEAP.new.head == DHEAP.new.tail)
    { talloc(DHEAP.new.head, DHEAP_INC);
      DHEAP.new.tail= DHEAP.new.head + DHEAP_INC;
    }
    p= DHEAP.new.head++;
  }
  else
  { p= DHEAP.old.head;
    DHEAP.old.head= DHEAP.old.head->next;
  }
  p->cnt= 1;
  p->nop= 0;
  p->next= NULL;
  return (kdatum) p;
}

PUBLIC klink
_xd_link ()
{
  klink p;

  if (LHEAP.old.head == NULL)
  { if (LHEAP.new.head == LHEAP.new.tail)
    { talloc(LHEAP.new.head, LHEAP_INC);
      LHEAP.new.tail= LHEAP.new.head + LHEAP_INC;
    }
    p= LHEAP.new.head++;
  }
  else
  { p= LHEAP.old.head;
    LHEAP.old.head= LHEAP.old.head->next;
  }
  p->arg= NULL;
  p->next= NULL;
  return p;
}

PUBLIC kdatum
_xd_copy (sort, exp)
  int sort;
  kdatum exp;
{
  if (kaos.debug )
  { char *func= sort == _xd_internal? "kd_copy": "ud_copy";
    char *arg1= sort == _xd_internal? "0th arg (sort)": "1st arg (sort)";
    char *arg2= sort == _xd_internal? "1st arg (exp)": "2nd arg (exp)";
    int err= FALSE;

    err= chk_error(chksort(sort), func, arg1)
	 || err;
    err= chk_error(chkdatum(sort, exp), func, arg2)
	 || err;
    if (err)
      abort();
  }
  abort_if(exp == NULL)
  if (sort == _xd_internal)
    sort= _xd_kd2sort (exp);
  if (((_xdatum) exp)->cnt > 0)
    ++((_xdatum) exp)->cnt;
  return exp;
}

PUBLIC kdatum
_xd_const (sort, exp)
  int sort;
  kdatum exp;
{
  if (kaos.debug)
  { char *func= sort == _xd_internal? "kd_const": "ud_const";
    char *arg1= sort == _xd_internal? "0th arg (sort)": "1st arg (sort)";
    char *arg2= sort == _xd_internal? "1st arg (exp)": "2nd arg (exp)";
    int err= FALSE;

    err= chk_error(chksort(sort), func, arg1)
	 || err;
    err= chk_error(chkdatum(sort, exp), func, arg2)
	 || err;
    if (err)
      abort();
  }
  abort_if(exp == NULL)
  abort_if(exp->opn <= 0)
  if (sort == _xd_internal)
    sort= opn_tbl[exp->opn].sid;
  if (((_xdatum) exp)->cnt > 0)
    ((_xdatum) exp)->cnt= -1;
  return exp;
}

PRIVATE void
__xd_free (sort, exp)
  int sort;
  kdatum exp;
{
  klink l, p;
  int i;

  if (sort_tbl[sort].isextern)
    if (sort_tbl[sort].free != NULL)
      (*sort_tbl[sort].free)(exp);
    else
      ;
  else
  { l= exp->lnk;
    i= 0;
    while (l != NULL)
    { if (((_xdatum) l->arg)->cnt > 1)
	--((_xdatum) l->arg)->cnt;
      else if (((_xdatum) l->arg)->cnt > 0){
	__xd_free(opn_tbl[exp->opn].sarg[i], l->arg);
      }
      l= (p= l)->next;
      p->arg= NULL;
      p->next= LHEAP.old.head;
      LHEAP.old.head= p;
      ++i;
    }
  }
  ((_xdatum) exp)->cnt= 0;
  ((_xdatum) exp)->next= DHEAP.old.head;
  DHEAP.old.head= (_xdatum) exp;
}

PUBLIC void
_xd_free (sort, exp)
  int sort;
  kdatum exp;
{
  if (kaos.debug)
  { char *func= sort == _xd_internal? "kd_free": "ud_free";
    char *arg1= sort == _xd_internal? "0th arg (sort)": "1st arg (sort)";
    char *arg2= sort == _xd_internal? "1st arg (exp)": "2nd arg (exp)";
    int err= FALSE;

    err= chk_error(chksort(sort), func, arg1)
	 || err;
    err= chk_error(chkdatum(sort, exp), func, arg2)
	 || err;
    if (err)
      abort();
  }
  abort_if(exp == NULL)
  if (sort == _xd_internal)
    sort= _xd_kd2sort (exp);
  if (((_xdatum) exp)->cnt > 1)
    --((_xdatum) exp)->cnt;
  else if (((_xdatum) exp)->cnt > 0)
    __xd_free(sort, exp);
}

PRIVATE int
vars(exp)
  kdatum exp;
{
  if (exp->opn < 0)
    return TRUE;

  if (exp->lnk != NULL) /* starts to analyze the arguments*/
  { klink n;

    for (n= exp->lnk; n!= NULL; n=n->next) {
      if (vars(n->arg)) {
	return TRUE;
      }
    }
  }
  return FALSE;
}

PRIVATE int
__xd_equal(sort, exp1, exp2)
  int sort;
  kdatum exp1, exp2;
{
  int res;

  if (sort_tbl[sort].isextern)
  { abort_if(sort_tbl[sort].equal == NULL)
    return (*sort_tbl[sort].equal)(exp1, exp2);
  }
  if ((exp1->opn < 0) && (exp2->opn <0)){ /* both of them are variables */
    if (exp1->opn == exp2->opn)
      return EQ; /* It is the same varible => the same value */
    else
      return UNDEF; /* differente variable => may be differente value */
  } else if ((exp1->opn < 0)||(exp2->opn < 0)){/* only one of them is variable*/
    return UNDEF;
  } else if (exp1->opn != exp2->opn){ /* they are differente operations */
    if (vars (exp1) || vars (exp2))
      return UNDEF; /* if there are variables I don't know */
    else
      return NEQ; /* no variables => they are differents */
  }

  res = EQ;
  if (exp1->lnk != NULL) /* It they are equal, starts to analyze the arguments*/
  { klink n1, n2;
    int i;

    n1= exp1->lnk;
    n2= exp2->lnk;
    for (i= 0;; ++i)
    { switch (__xd_equal(opn_tbl[exp1->opn].sarg[i], n1->arg, n2->arg)) {
	case EQ: break;
	case NEQ: return NEQ; break;
	case UNDEF: res = UNDEF; break;
	}
      n1= n1->next;
      n2= n2->next;
      if (n1 == NULL) break;
    }
  }
  return res;
}

PUBLIC int
_xd_equal (sort, exp1, exp2, mask)
  int sort;
  kdatum exp1, exp2;
  int mask;
{
  int r;

  if (kaos.debug)
  { char *kfunc= mask == _xd_preserve? "kd_equal": "kd_gequal";
    char *ufunc= mask == _xd_preserve? "ud_equal": "ud_gequal";
    char *func= sort == _xd_internal? kfunc: ufunc;
    char *arg1= sort == _xd_internal? "0th arg (sort)": "1st arg (sort)";
    char *arg2= sort == _xd_internal? "1st arg (exp1)": "2nd arg (exp1)";
    char *arg3= sort == _xd_internal? "2nd arg (exp2)": "3rd arg (exp2)";

    int err= FALSE;

    err= chk_error(chksort(sort), func, arg1)
	 || err;
    err= chk_error(chkdatum(sort, exp1), func, arg2)
	 || err;
    err= chk_error(chkdatum(sort == _xd_internal && !err?
			    opn_tbl[exp1->opn].sid: sort, exp2),
		   func, arg3)
	 || err;
    if (err)
      abort();
  }
  abort_if(exp1 == NULL ||
	   exp2 == NULL)
  if (sort == _xd_internal)
    if (exp1->opn > 0)
      sort= opn_tbl[exp1->opn].sid;
    else
      sort= var_tbl[-(exp1->opn)].sid;
  if (exp1 == exp2)
    r= EQ;
  else
    r= __xd_equal(sort, exp1, exp2);
  if (mask & 0x1) _xd_free(sort, exp1);
  if (mask & 0x2) _xd_free(sort, exp2);
  return r;
}

typedef struct
{ char *chr;
  int size;
  int level;
} tRBUF;	/* result (of drawing) buffer type */

PRIVATE tRBUF RBUF= { NULL, 0, 0 };

#define RBUF_INC	BUFSIZ

PRIVATE void
RBclear ()
{
  if (RBUF.size != 0)
  { ffree(RBUF.chr);
    RBUF.chr= NULL;
    RBUF.size= 0;
    RBUF.level= 0;
  }
}

PRIVATE void
RBinit ()
{
  abort_if(RBUF.size != 0)
  RBUF.size= RBUF_INC;
  talloc(RBUF.chr, RBUF.size + 1);
  RBUF.chr[0]= '\0';
}

PRIVATE void
RBadd (str)
  char *str;
{
  abort_if (str == NULL)
  if (RBUF.size != 0)
  { int lstr;

    lstr= strlen(str);
    if (RBUF.level + lstr > RBUF.size)
    { do
	RBUF.size+= RBUF_INC;
      while (RBUF.level + lstr > RBUF.size);
      trealloc(RBUF.chr, RBUF.size + 1);
    }
    (void) strcpy(RBUF.chr + RBUF.level, str);
    RBUF.level+= lstr;
  }
}

PRIVATE void
RBkeep (store)
  tRBUF *store;
{
  store->chr= RBUF.chr;
  store->size= RBUF.size;
  store->level= RBUF.level;
  RBUF.chr= NULL;
  RBUF.size= 0;
  RBUF.level= 0;
}

PRIVATE void
RBback (store)
  tRBUF *store;
{
  RBclear();
  RBUF.chr= store->chr;
  RBUF.size= store->size;
  RBUF.level= store->level;
}

#define RBvalue()	RBUF.chr

PRIVATE void
__xd_draw (sort, exp)
  int sort;
  kdatum exp;
{
  if (sort_tbl[sort].isextern)
  { char *r;

    if (sort_tbl[sort].draw == NULL)
      r= NULL;
    else
    { tRBUF b;

      RBkeep(&b);
      r= (*sort_tbl[sort].draw)(exp);
      RBback(&b);
    }
    if (r != NULL)
    { RBadd(r);
      return;
    }
    if (!kaos.try.draw)
    { RBclear();
      return;
    }
    RBadd("(... of ");
    RBadd(sort_tbl[sort].name);
    RBadd(")");
    return;
  }
/* Modified for Interprete usage */
  if (exp->opn<=0){
    /* modified for link variables usage  when extname = TRUE*/
    if (extname && (var_tbl[-(exp->opn)].lnk != 0 )){
      int vid;
      vid = get_lnk (exp->opn);
      RBadd(var_tbl[-vid].name);
    } else {
      RBadd(var_tbl[-(exp->opn)].name);
    }
  } else {
    if (opn_tbl[exp->opn].isinfix == TRUE ){
      RBadd("(");
      __xd_draw(opn_tbl[exp->opn].sid, exp->lnk->arg);
      RBadd(" ");
      RBadd(opn_tbl[exp->opn].name);
      RBadd(" ");
      __xd_draw(opn_tbl[exp->opn].sid, exp->lnk->next->arg);
      RBadd(")");
    } else {
      RBadd(opn_tbl[exp->opn].name);
      if (exp->lnk != NULL)
      { klink n;

	RBadd("(");
	n= exp->lnk;
	for (;;)
	{ __xd_draw(opn_tbl[exp->opn].sid, n->arg);
	  n= n->next;
	  if (n == NULL) break;
	  RBadd(", ");
	}
	RBadd(")");
      }
    }
  }
}

PUBLIC char *
_xd_draw (sort, exp, mask)
  int sort;
  kdatum exp;
  int mask;
{
  if (kaos.debug)
  { char *kfunc= mask == _xd_preserve? "kd_draw": "kd_gdraw";
    char *ufunc= mask == _xd_preserve? "ud_draw": "ud_gdraw";
    char *func= sort == _xd_internal? kfunc: ufunc;
    char *arg1= sort == _xd_internal? "0th arg (sort)": "1st arg (sort)";
    char *arg2= sort == _xd_internal? "1st arg (exp)": "2nd arg (exp)";
    int err= FALSE;

    err= chk_error(chksort(sort), func, arg1)
	 || err;
    err= chk_error(chkdatum(sort, exp), func, arg2)
	 || err;
    if (err)
      abort();
  }
  abort_if(exp == NULL)
  if (sort == _xd_internal)
    sort= _xd_kd2sort (exp);

  RBclear();
  RBinit();
  __xd_draw(sort, exp);
  if (mask & 0x1) _xd_free(sort, exp);
  return RBvalue();
}

PRIVATE void
__d_debug (sort, exp)
  int sort;
  kdatum exp;
{
  char* saux;
  saux = (char*) malloc ((unsigned)4);

  if (sort_tbl[sort].isextern)
  {
    RBadd("..externo..");
    return;
  }
/* Modified for Interprete usage */
  RBadd ("[");
  /* KJT 29/10/04: extracted "sprintf "call and used "saux" as argument */
  sprintf (saux, "%d", ((_xdatum)exp)->cnt);
  RBadd (saux);
  RBadd ("]");
  if (exp->opn<=0){
    RBadd(var_tbl[-(exp->opn)].name);
  } else {
    if (opn_tbl[exp->opn].isinfix == TRUE ){
      RBadd("(");
      __d_debug(opn_tbl[exp->opn].sid, exp->lnk->arg);
      RBadd(" ");
      RBadd(opn_tbl[exp->opn].name);
      RBadd(" ");
      __d_debug(opn_tbl[exp->opn].sid, exp->lnk->next->arg);
      RBadd(")");
    } else {
      RBadd(opn_tbl[exp->opn].name);
      if (exp->lnk != NULL)
      { klink n;

	RBadd("(");
	n= exp->lnk;
	for (;;)
	{ __d_debug(opn_tbl[exp->opn].sid, n->arg);
	  n= n->next;
	  if (n == NULL) break;
	  RBadd(", ");
	}
	RBadd(")");
      }
    }
  }
}
PUBLIC char *
_d_debug (exp)
  kdatum exp;
{
  int sort;

  abort_if(exp == NULL)

  sort= _xd_kd2sort (exp);

  RBclear();
  RBinit();
  __d_debug(sort, exp);
  return RBvalue();
}

#include "ocall.c"

/* KJT 08/08/06: commented out due to conflict with ctype.h */

/* #define isblank(chr)	(isascii(chr) && isspace(chr)) */

PRIVATE int
__xd_parse (intern, sort, ptr, r)
  int intern;
  int sort;
  char **ptr;
  kdatum *r;
{
  char *name;
  int opn;
  int narg;
  kdatum *arg;
  char *p;
  char c;
  kdatum _eval_opn();

  while (isblank(**ptr))
    ++*ptr;
  for (p= *ptr, name= p; *p != '\0'; ++p)
    if (isblank(*p) || *p == '(' ||
		       *p == ',' ||
		       *p == ')')
      break;
  if (name == p)
    return FALSE;
  c= *p;
  *p= '\0';
  opn= _xd_opn(sort, name);
  *p= c;
  if (opn < 0)
    return FALSE;
  *ptr= p;
  narg= opn_tbl[opn].narg;
  if (narg > 0)
  { int *sarg;
    int i;

    while (isblank(**ptr))
      ++*ptr;
    if (**ptr != '(')
      return FALSE;
    ++*ptr;
    talloc(arg, narg);
    sarg= opn_tbl[opn].sarg;
    i= 0;
    for (;;)
    { if (__xd_parse(FALSE, sarg[i], ptr, &arg[i]))
	;
      else
      { --i;
	break;
      }
      while (isblank(**ptr))
	++*ptr;
      if (++i == narg)
      { if (**ptr == ')')
	  ++*ptr;
	else
	  --i;
	break;
      }
      if (**ptr != ',')
      { --i;
	break;
      }
      ++*ptr;
    }
    if (i < narg)
    { for (; i >= 0; --i)
	_xd_free(sarg[i], arg[i]);
      ffree(arg);
      return FALSE;
    }
  }
  else
    arg= NULL;

  if (opn_tbl[opn].isinfix)
    (*r) = mkinfix (mknode (opn), arg[0], arg[1]);
  else {
    int i;
    klink sons = NULL;

    for (i = 0; i < narg; i++)
      sons = lnsnode (arg[i], sons);
    (*r) = mkprefix (mknode (opn), (klink)sons, FALSE);
  }
  if (narg > 0)
    ffree(arg);
  return TRUE;
}

PUBLIC int
_xd_parse (sort, ptr, r)
  int sort;
  char **ptr;
  kdatum *r;
{
  if (kaos.debug)
  { char *func= sort == _xd_internal? "kd_parse": "ud_parse";
    char *arg1= "1nd arg (sort)";

    if (chk_error(chksort(sort), func, arg1))
      abort();
  }
  abort_if(sort == _xd_internal)
  abort_if(r == NULL)
  if (ptr == NULL ||
      *ptr == NULL)
    return FALSE;
  return __xd_parse(FALSE, sort, ptr, r);
}

PUBLIC int
_xd_eval (sort, str, r)
  int sort;
  char *str;
  kdatum *r;
{
  kdatum p;
  char **ptr;

  if (kaos.debug)
  { char *func= sort == _xd_internal? "kd_eval": "ud_eval";
    char *arg1= "1nd arg (sort)";

    if (chk_error(chksort(sort), func, arg1))
      abort();
  }
  abort_if(sort == _xd_internal)
  abort_if(r == NULL)
  ptr= &str;
  if (_xd_parse(sort, ptr, &p))
  { while (isblank(**ptr))
      ++*ptr;
    if (**ptr == '\0')
    { *r= p;
      return TRUE;
    }
    else
    { _xd_free(sort, p);
      return FALSE;
    }
  }
  else
    return FALSE;
}

/**
  * Selecting a Hashing Algorithm
  * B.J. McKenzie, R. Harries and T. Bell
  * Software Practice & Experience
  * vol. 20(2), 209-224, Feb. 1990
 */

PRIVATE unsigned
HASHSIZE (size)
  unsigned size;
{
  return size / 4 * 2 + 1;
}

#define iscapital(chr)	(isascii(chr) && isupper(chr))
#define tosmall(chr)	(iscapital(chr)? tolower(chr): (chr))

PRIVATE int
hash (hsize, str)
  unsigned hsize;	/* some odd number */
  char *str;
{
  int h;

  h= 0;
  for (; *str != '\0'; ++str)
    h= 4 * h + tosmall(*str);
  h%= hsize;
  if (h < 0)
    h+= hsize;
  return h;
}

/* KJT 08/08/06: commented out as strcmp is standard */

/*
PRIVATE int
strcmp (s1, s2)
  char *s1, *s2;
{
  register char c1, c2;

  for (; *s1 != '\0'; ++s1, ++s2)
  { if (*s2 == '\0')
      return 1;
    c1= tosmall(*s1);
    c2= tosmall(*s2);
    if (c1 < c2)
      return -1;
    else if (c1 > c2)
      return 1;
  }
  if (*s2 == '\0')
    return 0;
  else
    return -1;
}
*/

typedef struct Sort_Snode
{ int sid;
  char *name;
  struct Sort_Snode *next;
} SORT_SNODE;

PRIVATE unsigned SORT_HSIZE= 0;
PRIVATE SORT_SNODE **sort_htbl= NULL;

PRIVATE void
_xd_sort_init ()
{
  int i;
  int h;
  SORT_SNODE *n;

  abort_if(SORT_HSIZE != 0)
  SORT_HSIZE= HASHSIZE(sort_tbl_size);
  talloc(sort_htbl, SORT_HSIZE);
  for (i= 0; i < SORT_HSIZE; i++)
    sort_htbl[i]= NULL;
  for (i= 0; i < sort_tbl_size; ++i)
  { if (sort_tbl[i].name == NULL)
      continue;
    h= hash(SORT_HSIZE, sort_tbl[i].name);
    for (n= sort_htbl[h]; n != NULL; n= n->next)
      if (strcmp(sort_tbl[i].name, n->name) == 0)
	break;
    if (n == NULL)
    { talloc(n, 1);
      n->sid= i;
      n->name= sort_tbl[i].name;
      n->next= sort_htbl[h];
      sort_htbl[h]= n;
    }
    else if (n->sid >= 0)
      n->sid= -n->sid;
  }
}

PUBLIC int
_xd_sort (name)
  char *name;
{
  SORT_SNODE *n;
  int sid= -1;

  if (firstsort)
  { _xd_sort_init();
    firstsort= FALSE;
  }
  if (name != NULL)
    for (n= sort_htbl[hash(SORT_HSIZE, name)]; n != NULL; n= n->next)
      if (strcmp(name, n->name) == 0)
      { if (n->sid >= 0)
	  sid= n->sid;
	break;
      }
  return sid;
}

typedef struct Opn_Snode
{ int oid;
  int sid;
  char *name;
  struct Opn_Snode *next;
} OPN_SNODE;

PRIVATE unsigned OPN_HSIZE= 0;
PRIVATE OPN_SNODE **opn_htbl= NULL;

PRIVATE void
_xd_opn_init ()
{
  int i;
  int h;
  OPN_SNODE *n;

  abort_if(OPN_HSIZE != 0)
  OPN_HSIZE= HASHSIZE(opn_tbl_size);
  talloc(opn_htbl, OPN_HSIZE);
  for (i= 0; i < OPN_HSIZE; i++)
    opn_htbl[i]= NULL;
  for (i= 0; i < opn_tbl_size; ++i)
  { if (opn_tbl[i].name == NULL)
      continue;
    h= hash(OPN_HSIZE, opn_tbl[i].name);
    for (n= opn_htbl[h]; n != NULL; n= n->next)
      if (opn_tbl[i].sid == n->sid &&
	  strcmp(opn_tbl[i].name, n->name) == 0)
	break;
    if (n == NULL)
    { talloc(n, 1);
      n->oid= i;
      n->sid= opn_tbl[i].sid;
      n->name= opn_tbl[i].name;
      n->next= opn_htbl[h];
      opn_htbl[h]= n;
    }
    else if (n->oid >= 0)
      n->oid= -n->oid;
  }
}

PUBLIC int
_xd_opn (sort, name)
  int sort;
  char *name;
{
  OPN_SNODE *n;
  int oid= -1;

  if (firstopn)
  { _xd_opn_init();
    firstopn= FALSE;
  }
  if (name != NULL)
    for (n= opn_htbl[hash(OPN_HSIZE, name)]; n != NULL; n= n->next)
      if (sort == n->sid &&
	  strcmp(name, n->name) == 0)
      { if (n->oid >= 0)
	  oid= n->oid;
	break;
      }
  return oid;
}

/* Modified for Interpreter use */
PUBLIC int
_xd_opn_sort (snm)
  char *snm;
{
  OPN_SNODE *n;
  int sort= -1;

  if (firstopn)
  { _xd_opn_init();
    firstopn= FALSE;
  }
  if (snm != NULL)
    for (n= opn_htbl[hash(OPN_HSIZE, snm)]; n != NULL; n= n->next)
      if (strcmp(snm, n->name) == 0) {
	if (sort >= 0)
	  return -1;
	if (n->sid >= 0)
	  sort= n->sid;
      }
  return sort;
}


/*
-----------------   FUNCTION LDCINIT --------------------------

    DESCRIPTION:
		- initialize the variables of the kaos. If it
		  is necessary, all the memory is set to free.

-----------------------------------------------------------------
*/
PUBLIC void
ldcinit ()
{
  nor = 0;
  firstsort=TRUE;
  firstopn=TRUE;
  if (OPN_HSIZE!=0){
    ffree (opn_htbl);
    OPN_HSIZE = 0;
  }
  if (SORT_HSIZE!=0){
    ffree (sort_htbl);
    SORT_HSIZE = 0;
  }
  if (var_size!=0){
    ffree (var_tbl);
    var_size = 0;
    var_tbl_size = 0;
  }
}


/* Interprete functions */
/*
-----------------   FUNCTION _xd_kd2sort ------------------------------

    PARAMETERS:
		- dat: kdatum to get its sort

    DESCRIPTION:
		- obtains the sort from a kdatum

-----------------------------------------------------------------
*/
PUBLIC int
_xd_kd2sort(dat)
  kdatum dat;
{
  abort_if (dat == NULL);
  abort_if (dat->opn == 0);

  if (dat->opn < 0)
    return var_tbl[-dat->opn].sid;
  else
    return opn_tbl[dat->opn].sid;
}

/*
-----------------   FUNCTION _xd_v_sort ------------------------------

    PARAMETERS:
		- name: name of the variable to search.

    DESCRIPTION:
		- obtains unique variable identifier of the
		  given name.

-----------------------------------------------------------------
*/
PUBLIC int
_xd_v_sort(snm)
  char *snm;
{
  int sort = 0;
  int n;

  if (snm!=NULL){
    for (n=1;n<var_size;n++){
      if (var_tbl[n].name==NULL)
	continue;
      if (cstrcmp(snm,var_tbl[n].name)==0){
	sort = var_tbl[n].sid;
	assert (var_tbl[n].use != IS_FREE);
	break;
      }
    }
  }
  return sort;
}

/*
-----------------   FUNCTION _xd_get_varid ------------------------------

    PARAMETERS:
		- snm: name of the variable to search.
		- sort: sort of the searched variable.

    DESCRIPTION:
		- obtains unique variable identifier of the
		  given name.
		   0 -> variable not found
		  >0 -> variable found with different sort
		  <0 -> variable found with the same sort
-----------------------------------------------------------------
*/
PUBLIC int
_xd_get_varid(snm,sort)
  char *snm;
  int sort;
{
  int oid = 0;
  int n;

  if (snm!=NULL){
    for (n=1;n<var_size;n++){
      if (var_tbl[n].name==NULL)
	continue;
      if (cstrcmp(snm,var_tbl[n].name)==0){
	if (sort==var_tbl[n].sid){
	  oid = -n;
	}else{
	  oid = n;
	}
	assert (var_tbl[n].use != IS_FREE);
	break;
      }
    }
  }
  return oid;
}
/*
-----------------   FUNCTION _xd_varid ------------------------------

    PARAMETERS:
		- snm: name of the variable to search.
		- sort: sort of the searched variable.

    DESCRIPTION:
		- obtains unique variable identifier of the
		  given name. If the variable is not found
		  a new variable is created.

-----------------------------------------------------------------
*/
PUBLIC int
_xd_varid(snm,sort)
  char *snm;
  int sort;
{
  int oid = 0;

  if (snm!=NULL){
    oid = _xd_get_varid (snm,sort);
    if (oid==0){
      /*
      for (n=1;n<var_size;n++){
	if (var_tbl[n].name==NULL){
	  oid = n;
	  assert (var_tbl[n].use != IS_FREE);
	  break;
	}
      }
      */
      if (oid==0 && var_size==var_tbl_size){
	var_tbl_size += BLOCK_SIZE;
	if (var_tbl_size==BLOCK_SIZE){
	  talloc (var_tbl,var_tbl_size);
	  var_tbl[0].name=NULL;
	  var_tbl[0].sid = 0;
	  var_tbl[0].value = NULL;
	  var_tbl[0].use = IS_FREE;
	  var_tbl[0].lnk = 0;		/* KJT 18/05/02: NULL -> 0 */
	  var_size++;
	}
	else
	  trealloc (var_tbl,var_tbl_size);
      }
      if (oid == 0){
	oid = var_size;
	var_size++;
      }

      talloc (var_tbl[oid].name,strlen(snm)+1);
      (void) strcpy (var_tbl[oid].name,snm);
      var_tbl[oid].sid = sort;
      var_tbl[oid].value = NULL;
      var_tbl[oid].use = NOT_FREE;
      var_tbl[oid].lnk = 0;		/* KJT 18/05/02: NULL -> 0 */
      oid = -oid;
    }
  }
  return oid;
}

/*
-----------------   FUNCTION LFVUID ------------------------------

    PARAMETERS:
		- snm: name of the variable to look for.
		- sort: sort of the variable to declare.

    DESCRIPTION:
		- obtains unique variable identifier of the
		  given name.

-----------------------------------------------------------------
*/
PUBLIC int
_xd_lfvarid(snm,sort)
  char *snm;
  int sort;
{
  int oid = 0;

  if (snm!=NULL){
    oid = _xd_get_varid (snm,sort);
    if (oid > 0)
      oid = 0;
  }
  return oid;
}

/***** Trace functions *****/

PRIVATE void
Indent  ()
{
  int i;
  for (i=1; i<=IndentV; i++)
    (void)printf ("|  ");
}

PRIVATE void
shownode (begin,org,end)
  char*  begin;
  kdatum org;
  char*  end;

{
  RBclear();
  RBinit();
  __xd_draw (opn_tbl[org->opn].sid,org);
  (void)printf ("%s%s%s", begin,RBUF.chr,end);
  (void) fflush (stdout);
}

PRIVATE void
showeqn (begin,eqnstr,end)
  char*  begin;
  char*  eqnstr;
  char*  end;

{
  (void)printf ("%s%s%s", begin,eqnstr,end);
  (void) fflush (stdout);
}


PRIVATE kdatum ap_rules ();
/*
-----------------   FUNCTION REP_NODE ----------------------------

    PARAMETERS:
		- oarg: variable to replace in kdatum tree format.
		- p: pointer to the structure that will be placed
		     in the output.
		- eqn: number of the equation being applied.
    DESCRIPTION:
		- it replaces a structure taking into account
		  the input variable.

    MMG:
		- oargn (N) -> oarg (N)
		-           -> r (+1)

-----------------------------------------------------------------
*/
PRIVATE kdatum
rep_node (oarg,p,eqn)
  kdatum oarg;
  klink p;
  int eqn;

{
  kdatum r,l;
  klink s,s2,new;
  a_list *a;
  int index;

  if (eqn>=0){
    nor++;
    eqn_tbl[eqn].counter++;
  }
  if ((eqn>=0) && (seqn>0)){
    if (sr>0){
      Indent ();
      shownode ("",oarg,"");
    }
    showeqn (" <",eqn_tbl[eqn].eqnstr,">\n");
  }
  if (p->arg->opn>0){
    r = kd_alloc ();
    r->opn = p->arg->opn;
    s = p->arg->lnk;
    s2 = NULL;
    while (s!=NULL){
      new = kd_link();
      new->arg = rep_node (oarg,s,-1);
      if (r->lnk==NULL){
	r->lnk = new;
      } else{
	s2->next = new;
      }
      s2 = new;
      s = s->next;
    }
  }
  else{
    a = (a_list *) p->arg->lnk;
    r = oarg ;
    while (a!=NULL){
      for (index=1,s=r->lnk;index!=a->argument;index++)
	s = s->next;
      a = a->next;
      r = kd_copy (s->arg);
    }
  }
  if ((eqn>0) && (seqn>0) && (sr>0)){
    Indent ();
    shownode ("=>",r,"\n");
  }
  if (r->opn > 0){
    if (i_opn_tbl[r->opn].cnode!=NULL){
      l = ap_rules (r,i_opn_tbl[r->opn].cnode);
      if (l!=NULL){
	kd_free (r);
	r = l;
      }
    }
    else if (i_opn_tbl[r->opn].rnode!=NULL){
      if (((_xdatum)(i_opn_tbl[r->opn].rnode->arg))->cnt!=-1){
	l = _xd_rw_node (i_opn_tbl[r->opn].rnode->arg);
	l = kd_const (l);
	i_opn_tbl[r->opn].rnode->arg = l;
      } else {
	l = kd_copy (i_opn_tbl[r->opn].rnode->arg);
      }
      kd_free (r);
      r = l;
    } else  if (opn_tbl[r->opn].narg == 0){
      i_opn_tbl[r->opn].rnode = kd_link();
      i_opn_tbl[r->opn].rnode->arg = kd_const (r);
    }
  }
  return r;
}

/*
-----------------   FUNCTION CHECK_PREC  -------------------------

    PARAMETERS:
		- oarg: expression whose precondition is to be
			checked.
		- p: pointer to the precondition to be checked.
    DESCRIPTION:
		- it checks if the precondition of a rule is
		  true or false.

-----------------------------------------------------------------
*/
PRIVATE int
check_prec (oarg,p)
  kdatum oarg;
  klink p;
{
  kdatum p1,p2;
  int r;

  oarg =  kd_copy (oarg);
  p1 = rep_node (oarg,p->arg->lnk,-1);
  p2 = rep_node (oarg,p->arg->lnk->next,-1);
  p1 = _xd_rw_node (p1);
  p2 = _xd_rw_node (p2);
  r = kd_equal (p1,p2);
  kd_free (oarg);
  return r;
}

/*
-----------------   FUNCTION AP_RULES  ---------------------------

    PARAMETERS:
		- oarg: expression to apply the rules.
		- c: pointer to the rules being applied.
    DESCRIPTION:
		- it applies recursively the necessary rules
		  to the input expression until there are not
		  more rules to use.
    MMG:
		- oargn (N) -> oarg (N)
		-           -> r (+1)

-----------------------------------------------------------------
*/

PRIVATE kdatum
ap_rules (oarg,c)
  kdatum oarg;
  c_node *c;
{
  kdatum r;
  klink s;
  v_node *v;
  int sfail = 1;
  int index,coid;

  if (usrb == TRUE){
    return kd_copy (oarg) ;
  }
  v = c->nvnode;
  if (c->narg!=0){
    int index2;
    r = oarg;
    for (index=1;index<=c->narg;index++){
      for (index2=1,s=r->lnk;index2!=c->argument[index];index2++)
	s = s->next;
      r = s->arg;
    }
    coid = r->opn;
  }
  else
    coid = 0;

  while (v!=NULL && sfail){
    if (coid==v->value || v->value==-1 || v->value==0){
      if (v->ncnode==NULL){
	if (v->npnode==NULL){
	  r = rep_node (oarg,v->nrnode,v->eqn);
	  sfail = 0;
	}
	else{
	  s = v->npnode;
	  while ((s != NULL)&&(sfail)){
	    if (EQ != check_prec (oarg,s))
	      sfail = 0;
	    s = s->next;
	  }
	  if (sfail){
	    r = rep_node (oarg,v->nrnode,v->eqn);
	    sfail=0;
	  }
	  else
	    sfail=1;
	}
      }
      else{
	r = ap_rules (oarg,v->ncnode);
	if (r!=NULL){
	  sfail = 0;
	}else if (!backtracking){
	  return NULL;
	}
      }
    }
    v = v->nvnode;
  }
  if (sfail){
    return NULL;
  }
  return r;
}

/*
-----------------   FUNCTION ANY_VARIABLE   ----------------------

    PARAMETERS:
		- p: pointer to the expression to check.
    DESCRIPTION:
		- it looks for variables in an expression,
		  and returns TRUE if any.

-----------------------------------------------------------------
*/

PRIVATE int
any_var (p)
  kdatum p;
{
  klink l;

  if (p == NULL)
    return FALSE;
  if (p->opn < 0)
    return TRUE;
  for (l= p->lnk; l != NULL; l= l->next)
    if (any_var(l->arg))
      return TRUE;
  return FALSE;
}

/*
-----------------   FUNCTION REWRITE_NODE   ----------------------

    PARAMETERS:
		- oarg: pointer to the expression being rewritten.
    DESCRIPTION:
		- it rewrites an expression, beginning with the
		  falls and going on towards the root.

    MMG:
		- oargn (N) -> oarg (N-1)
		-           -> r (+1)
-----------------------------------------------------------------
*/

PUBLIC kdatum
_xd_rw_node (oarg)
  kdatum oarg;
{
  kdatum r,l;
  klink prim;
  int rwf;
  int oldcnt;

  /*if ((IndentV == -2) && (sr>0)){*/

  if (oarg == NULL)
    return NULL;

  oldcnt = ((_xdatum)oarg)->cnt;
  if (oarg->opn<0){ /* if it is a constant */
    if (var_tbl[-(oarg->opn)].value!=NULL){
      var_tbl[-(oarg->opn)].value = kd_copy (var_tbl[-(oarg->opn)].value);
      if (sr>0){
	Indent ();
	shownode ("",oarg,"");
	shownode ("=>",var_tbl[-(oarg->opn)].value,"\n");
      }
      return var_tbl[-(oarg->opn)].value;
    } else
      return oarg;
  }


  IndentV++;
  assert (oarg->opn > 0);
  rwf = 0;
  prim=NULL;
  if (oarg->opn>0 && oarg->lnk!=NULL){/* we are going to rewrite arguments*/
    klink saux,p;

    saux = oarg->lnk;
    while (saux!=NULL){
      l = _xd_rw_node (kd_copy (saux->arg));/* rewriting arguments*/
      if (l!=saux->arg){ /* the result is a different value */
	rwf = 1;
	if (sr>0){
	  Indent ();
	  shownode ("",saux->arg,"");
	  shownode ("=>",l,"\n");
	}
      }
      if (prim==NULL){
	p = kd_link ();
	p->arg = l;
	prim = p;
      }
      else{
	p->next = kd_link ();
	p->next->arg = l;
	p = p->next;
      }
      saux = saux->next;
    }
  }
  if (rwf){/* some arguments has been rewritted*/
    r = kd_alloc ();
    r->opn = oarg->opn;
    r->lnk = prim;
    if (sr>0){
      Indent ();
      shownode ("",oarg,"");
      shownode ("=>",r,"\n");
    }
  }
  else {/* no argument has been rewritted */
    if (prim != NULL){/* to destroy partially built tree */
      r = kd_alloc ();
      r->opn = oarg->opn;
      r->lnk = prim;
      kd_free (r);
    }
    r = kd_copy (oarg);
  }
  if (i_opn_tbl[r->opn].cnode!=NULL){
    l = ap_rules (r,i_opn_tbl[r->opn].cnode);
    /* reescribo r por l */
    if (l!=NULL){
      kd_free (r);
      r = l;
    }
    else if (i_opn_tbl[r->opn].fnode!=NULL && !any_var(r))
      (void) fprintf (stderr,"Error: cannot rewrite '%s'.\n",kd_draw(r));
  }
  else if (i_opn_tbl[r->opn].rnode!=NULL){
    if (((_xdatum)(i_opn_tbl[r->opn].rnode->arg))->cnt!=-1){
      l = _xd_rw_node (i_opn_tbl[r->opn].rnode->arg);
      i_opn_tbl[r->opn].rnode->arg = kd_const(l);
    } else {
      /* it is a constant */
      l = i_opn_tbl[r->opn].rnode->arg;
    }
    kd_free (r);
    r = l;
  }
  else if (i_opn_tbl[r->opn].fnode!=NULL && !any_var(r))
    (void) fprintf (stderr,"Error: cannot rewrite '%s'.\n",kd_draw(r));
  else if (opn_tbl[r->opn].narg == 0) {
    i_opn_tbl[r->opn].rnode = kd_link();
    i_opn_tbl[r->opn].rnode->arg = kd_const (r);
  }

  assert ((((_xdatum)r)->cnt == -1) ||
	  (r != oarg) ||
	  ((r == oarg) && (((_xdatum)r)->cnt == oldcnt + 1)));
  (void) kd_free (oarg);

  IndentV--;
  return r;
}


#ifdef lint

/* ARGSUSED */
PUBLIC kdatum
kd_alloc ()
{ return NULL; }

/* ARGSUSED */
PUBLIC udatum
ud_alloc ()
{ return NULL; }

/* ARGSUSED */
PUBLIC klink
kd_link ()
{ return NULL; }

/* ARGSUSED */
PUBLIC kdatum
kd_copy (exp)
  kdatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC udatum
ud_copy (sort, exp)
  int sort;
  udatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC kdatum
kd_const (exp)
  kdatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC udatum
ud_const (sort, exp)
  int sort;
  udatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC void
kd_free (exp)
  kdatum exp;
{}

/* ARGSUSED */
PUBLIC void
ud_free (sort, exp)
  int sort;
  udatum exp;
{}

/* ARGSUSED */
PUBLIC int
kd_equal (exp1, exp2)
  kdatum exp1, exp2;
{ return FALSE; }

/* ARGSUSED */
PUBLIC int
ud_equal (sort, exp1, exp2)
  int sort;
  udatum exp1, exp2;
{ return FALSE; }

/* ARGSUSED */
PUBLIC int
kd_gequal (exp1, exp2, mask)
  kdatum exp1, exp2;
  int mask;
{ return FALSE; }

/* ARGSUSED */
PUBLIC int
ud_gequal (sort, exp1, exp2, mask)
  int sort;
  udatum exp1, exp2;
  int mask;
{ return FALSE; }

/* ARGSUSED */
PUBLIC char *
kd_draw (exp)
  kdatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC char *
ud_draw (sort, exp)
  int sort;
  udatum exp;
{ return NULL; }

/* ARGSUSED */
PUBLIC char *
kd_gdraw (exp, mask)
  kdatum exp;
  int mask;
{ return NULL; }

/* ARGSUSED */
PUBLIC char *
ud_gdraw (sort, exp, mask)
  int sort;
  udatum exp;
  int mask;
{ return NULL; }

/* ARGSUSED */
PUBLIC int
kd_parse (sort, ptr, r)
  int sort;
  char **ptr;
  kdatum *r;
{ return NULL; }

/* ARGSUSED */
PUBLIC int
ud_parse (sort, ptr, r)
  int sort;
  char **ptr;
  udatum *r;
{ return NULL; }

/* ARGSUSED */
PUBLIC int
kd_eval (sort, str, r)
  int sort;
  char *str;
  kdatum *r;
{ return NULL; }

/* ARGSUSED */
PUBLIC int
ud_eval (sort, str, r)
  int sort;
  char *str;
  udatum *r;
{ return NULL; }

/* ARGSUSED */
PUBLIC int
kd_sort (snm)
 char *snm;
{ return 0; }

/* ARGSUSED */ /* To use variables */
PUBLIC int
kd_v_sort(snm)
 char *snm;
{ return 0; }

/* ARGSUSED */
PUBLIC int
ud_sort(snm)
 char *snm;
{ return 0; }

/* Modified for Interpreter use */

/* ARGSUSED */
PUBLIC int
kd_opn(sort, snm)
 int  sort;
 char *snm;
{ return 0; }

/* ARGSUSED */
PUBLIC int
ud_opn(sort, snm)
 int  sort;
 char *snm;
{ return 0; }

/* ARGSUSED */
PUBLIC int
kd_opn_sort(snm)
 char *snm;
{ return 0; }

/* ARGSUSED */
PUBLIC int
ud_opn_sort(snm)
 char *snm;
{ return 0; }

/* ARGSUSED */
PUBLIC int
kd_var(snm)
  char *snm;
{ return 0;}

/* ARGSUSED */
PUBLIC int
kd_get_varid(snm,sort)
  char *snm;
  int sort;
{ return 0;}

/* ARGSUSED */
PUBLIC int
kd_varid(snm,sort)
  char *snm;
  int sort;
{ return 0;}

/* ARGSUSED */
PUBLIC int
kd_lfvarid(snm,sort)
  char *snm;
  int sort;
{ return 0;}

/* ARGSUSED */
PUBLIC kdatum
kd_rw_node (oarg)
  kdatum oarg;
{ return NULL; }

#endif
