/***********************************************************************
     "kaos.o": 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: kaos.c,v $
 * Revision 2.12  1993/10/19  19:13:13  lotos
 * fix loose use of C scopesl ported to BSD/386
 *
 * 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" */

#include "version.h"
#ifndef lint
static char rcsid[]= "$Id: kaos.c,v 2.12 1993/10/19 19:13:13 lotos Exp $";
#endif

/* LINTLIBRARY */

#define kaos_IMP

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

PRIVATE int _chksons ();
PRIVATE void _xd_opn_init ();
PRIVATE int _xd_opn ();

/***** 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 tfree(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	"KAOS EXCEPTION"

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

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
_chkdatum (sort, exp)
  int sort;
  kdatum exp;
{
  if (((_xdatum) exp)->cnt == 0)
    return CHKDATUM_WASKILLED;
  if (sort_tbl[sort].isextern)
    return CHK_OK;
  if (_chkopn(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;

  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 (_chkopn(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= opn_tbl[exp->opn].sid;
  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)
  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= opn_tbl[exp->opn].sid;
  if (((_xdatum) exp)->cnt > 1)
    --((_xdatum) exp)->cnt;
  else if (((_xdatum) exp)->cnt > 0)
    __xd_free(sort, exp);
}

PRIVATE int
__xd_equal(sort, exp1, exp2)
  int sort;
  kdatum exp1, exp2;
{
  if (sort_tbl[sort].isextern)
  { abort_if(sort_tbl[sort].equal == NULL)
    return (*sort_tbl[sort].equal)(exp1, exp2);
  }
  if (exp1->opn != exp2->opn)
    return FALSE;
  if (exp1->lnk != NULL)
  { klink n1, n2;
    int i;

    n1= exp1->lnk;
    n2= exp2->lnk;
    for (i= 0;; ++i)
    { if (__xd_equal(opn_tbl[exp1->opn].sarg[i], n1->arg, n2->arg))
	;
      else
	return FALSE;
      n1= n1->next;
      n2= n2->next;
      if (n1 == NULL) break;
    }
  }
  return TRUE;
}

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)
    sort= opn_tbl[exp1->opn].sid;
  if (exp1 == exp2)
    r= TRUE;
  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)
  { tfree(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;
  }
  RBadd(opn_tbl[exp->opn].name);
  if (exp->lnk != NULL)
  { klink n;
    int i;

    RBadd("(");
    n= exp->lnk;
    for (i= 0;; ++i)
    { __xd_draw(opn_tbl[exp->opn].sarg[i], 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= opn_tbl[exp->opn].sid;
  RBclear();
  RBinit();
  __xd_draw(sort, exp);
  if (mask & 0x1) _xd_free(sort, exp);
  return RBvalue();
}

#include "ocall.c"

#define myisblank(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();

  if (!intern &&
      sort_tbl[sort].isextern)
  { char *q;

    p= *ptr;
    if (sort_tbl[sort].parse == NULL)
      q= NULL;
    else
      q= (*sort_tbl[sort].parse)(&p, r)? p: NULL;
    if (q != NULL)
    { *ptr= p;
      return TRUE;
    }
    if (!kaos.try.parse)
    { *ptr= p;
      return FALSE;
    }
    q= *ptr;
    if (__xd_parse(TRUE, sort, &q, r))
    { *ptr= q;
      return TRUE;
    }
    *ptr= p > q? p: q;
    return FALSE;
  }
  while (myisblank(**ptr))
    ++*ptr;
  for (p= *ptr, name= p; *p != '\0'; ++p)
    if (myisblank(*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 (myisblank(**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 (myisblank(**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]);
      tfree(arg);
      return FALSE;
    }
  }
  else
    arg= NULL;
  if (opn_tbl[opn].eval == _eval_opn)
    (*r)= (*opn_tbl[opn].eval)(opn, arg);
  else
    (*r)= ocall(opn_tbl[opn].eval, narg, arg);
  if (narg > 0)
    tfree(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 (myisblank(**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;
}

PRIVATE int
icstrcmp (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 (icstrcmp(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;
{
  static int first= TRUE;
  SORT_SNODE *n;
  int sid= -1;

  if (first)
  { _xd_sort_init();
    first= FALSE;
  }
  if (name != NULL)
    for (n= sort_htbl[hash(SORT_HSIZE, name)]; n != NULL; n= n->next)
      if (icstrcmp(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 &&
	  icstrcmp(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;
  }
}

PRIVATE int
_xd_opn (sort, name)
  int sort;
  char *name;
{
  static int first= TRUE;
  OPN_SNODE *n;
  int oid= -1;

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

#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 */
PUBLIC int
ud_sort (snm)
 char *snm;
{ return 0; }

#endif
