/* (C) Copyright International Business Machines Corporation 23 January */
/* 1990.  All Rights Reserved. */
/*  */
/* See the file USERAGREEMENT distributed with this software for full */
/* terms and conditions of use. */
/* File: o_table.c */
/* Author: David F. Bacon */
#ifndef lint
static char sccsinfo[] = "@(#)o_table.c	1.23 3/13/90";
#endif

#define _BSD 43
/* 
  N.B.: When lazy-copying tables we don't always raise exceptions that
  ought to be raised.  Specifically, UnCopyable is never raised, and
  Depletion is not raised in cases where a deep copy would deplete.
  This has the side-effect that other instructions that modify tables
  can end up raising exceptions they aren't supposed to, because they
  make deep copies as their first step.  For example, a REMOVE
  operation could raise UnCopyable or Depletion!
 */ 

#include <rpc/rpc.h>
#include <varargs.h>
#include <stdio.h>

#include "sysdep.h"

#include "ops.h"
#include "ops_parm.h"
#include "storage.h"
#include "accessors.h"
#include "recursiv.h"

#include "predefined.cd"
#include "interpform.cd"

#define Component 0

#define NO_TBL   -1

#define FIND TRUE
#define GET FALSE

extern datarep dr_table, dr_integer, dr_bottom, dr_boolean, dr_ord_enumeration,
 dr_enumeration;
extern datarep *datarepmap[], *qdatarepmap[];

extern tbldes *tbldescriptors[];

static predef_exception doCopyOnWrite();
#define CopyOnWrite(objp) \
  (((objp)->value.table->refcount is 1) ? Normal : doCopyOnWrite(objp))

/* when the user specifies a key or index for lookup, he doesn't count the */
/* ordering.  but for representation numbers, the order comes first, so this */
/* macro normalizes the key number into a representation number. */
#define keynumtorepnum(t,n) ((t)->ordered ? ((n)+1) : (n))

#define foreach_tbl(tbl, tablenum, tblptr) \
  for ((tblptr) = & (tbl)->tbls[tablenum = 0]; tablenum < (tbl)->tblcount; \
       (tblptr) = & (tbl)->tbls[++tablenum])

#define for_lookups(tbl, tablenum, tblptr) \
  for_folltbl(tbl, tablenum, tblptr, firstlookup(tbl))

#define for_folltbl(tbl, tablenum, tblptr, firsttable) \
  for (tblptr = & tbl->tbls[tablenum = firsttable]; \
       tablenum < (tbl)->tblcount; \
       tblptr = & tbl->tbls[++tablenum])

#define forprev_tbl(tbl, tablenum, tblptr, lasttable) \
  for (tblptr = & tbl->tbls[tablenum = 0]; tablenum < lasttable; \
       tblptr = & tbl->tbls[++tablenum])

#define firstlookup(tbl) ((tbl)->ordered ? 1 : 0)

#define ordfunc(table, func) \
  (*(table)->tbls[ORDER_TBL].des->func)

#define doforeach(table) (*(table)->tbls[ORDER_TBL].des->foreach)

NILOP(o_size)
{
    OPCHK(SrcObj,table);
    Dst.integer = Src.table->size;
    set_init(DstObj, dr_integer);
}


NILOP(o_new_table)
{
    predef_exception cp_table();
    void fin_table();
    void re_finalize();

    predef_exception retcode;
    dfd_table *table;
    valcell nonlookinfo;
    valcell idxinfo;
    valcell reps;
    valcell indexset, keyset, lookup_info;
    trepnum tblnum;
    counter repcount;
    tblinfo *tblptr;
    flag nonlooked;
    int nlrepno;
    counter i;
    tbldes *des;
    extern flag cherm_flag;

    keyset.table = nil;
    indexset.table = nil;
    table = nil;

    nonlookinfo = dot(args->qualifiers, new_table_info__nonlookup);
    nonlooked = case_of(dot(args->qualifiers, new_table_info__nonlookup)) 
      isnt table_rep_type__none;
	
    if (case_of(dot(args->qualifiers, new_table_info__opt_reps)) is
	option__absent) {
	reps.table = nil;
	repcount = 1;
    }
    else {
	lookup_info = dot(dot(args->qualifiers, new_table_info__opt_reps),
			  Component);
	retcode = cp_table(&keyset, dot(lookup_info, lookup_info__keys));
	if (retcode is Normal)
	  retcode = cp_table(&indexset,
			     dot(lookup_info, lookup_info__indices));
	if (retcode isnt Normal)
	  goto cleanup;
	reps = dot(lookup_info, lookup_info__reps);
	repcount = size_of(reps) + (nonlooked ? 1 : 0);
    }
    
    retcode = Depletion;	/* any further errors are Depletion */

    table = (dfd_table *) 
      getmain(sizeof(dfd_table) + 
	      sizeof(tblinfo) * (repcount - ARBSIZE));
    if (table is nil) goto cleanup;
    
    for (i = 0; i < repcount; i++)
      table->tbls[i].des = nil;

    /* fill in preliminary info */
    table->refcount = 1;
    table->tsdr = & dr_bottom;
    table->size = 0;
    table->tblcount = repcount;
    table->ordered = FALSE;
    table->keyset = keyset;
    table->indexset = indexset;

    /* Fill in representation info for the non-lookup rep. */
    if (nonlooked) {
        valcell info;

	nlrepno = case_of(nonlookinfo);
	tblptr = & table->tbls[ORDER_TBL];
	des = tbldescriptors[nlrepno];
	/* the assembler leaves some components of the nonlookinfo */
	/* component uninit, contrary to the type definition.  The */
	/* allocation functions must notice when this happens so they */
	/* don't try to use information that's not present.  They test */
	/* this by checking for a zero valcell.  Problem is, not all */
	/* bottoms have a zero valcell.  This kluge just ensures that */
	/* a zero valcell is given in this case */
	if (drdot(nonlookinfo, Component)->number is dr_bottom.number)
	  info.nominal = nil;
	else
	  info = dot(nonlookinfo, Component);
	if (!(*des->alloc)(table, ORDER_TBL, info))
	  goto cleanup;
	tblptr->des = des;

	if (nlrepno is table_rep_type__vector or
	    nlrepno is table_rep_type__charstring or
	    nlrepno is table_rep_type__dublink)
	  table->ordered = TRUE;
    }

    /* Then do likewise for all the other reps */
    if (reps.table isnt nil)
      for_lookups(table, tblnum, tblptr) {
	  idxinfo = get_elem(reps, tblnum - firstlookup(table));
	  des = tbldescriptors[case_of(idxinfo)];
	  if (!(*des->alloc)(table, tblnum,
			     dot(idxinfo, Component)))
	    goto cleanup;
	  tblptr->des = des;
      }
    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

    Dst.table = table;
    set_init(DstObj, dr_table);
    return;

  cleanup:			/* here when a storage allocation fails */
    if (table isnt nil) {
	foreach_tbl(table, tblnum, tblptr) {
	    if (tblptr->des isnt nil)
	      /* Note: shallow finalization OK for all tbl reps */
	      /* because the table has no elements */
	      (*tblptr->des->finalize)(table, tblnum, SHALLOW, 
				       F_FREE, (schedblock *) nil);
	}
	{ freemain(table, 
		   sizeof(dfd_table) + sizeof(tblinfo)*(repcount - ARBSIZE)); }
    }
    if (keyset.table isnt nil)
      (void) fin_table(keyset, F_DISCARD, nil);
    if (indexset.table isnt nil)
      (void) fin_table(indexset, F_DISCARD, nil);
    raise(retcode);
}


NILOP(o_insert)
{
    predef_exception insertfunc();
    predef_exception retcode;

    OPCHK(DstObj,table);
    if ((retcode = insertfunc(args, FALSE)) isnt Normal)
      raise(retcode);
}


static predef_exception
insertfunc(args, insertat)
argblock *args;
flag insertat;
{
    predef_exception retcode;
    trepnum tblnum, ptblnum;
    tblinfo *tblptr, *ptblptr;


    retcode = CopyOnWrite(DstObj); /* make private copy if table is shared */
    if (retcode isnt Normal)
      return(retcode);

    foreach_tbl(Dst.table, tblnum, tblptr) {
	if (insertat and tblnum is ORDER_TBL)
	  retcode = (*tblptr->des->insert_at)(Dst.table, 
					      tblnum, Src, Src2.integer);
	else
	  retcode = (*tblptr->des->insert)(Dst.table, tblnum, Src);

	if (retcode isnt Normal) {
	    forprev_tbl(Dst.table, ptblnum, ptblptr, tblnum)
	      if (insertat and tblnum is ORDER_TBL)
		(*ptblptr->des->unmerge_at)(Dst.table, ptblnum, 
					    Src, Src2.integer, 1);
	      else
		(*ptblptr->des->uninsert)(Dst.table, ptblnum, Src);
	    /* there's no harm in not undoing the CopyOnWrite here */
	    return(retcode);
	}
    }
    Dst.table->tsdr = SrcObj->tsdr;	/* in case it's not yet set */
    Dst.table->size++;
    set_bottom(SrcObj);
    return(Normal);
}



NILOP(o_merge)
{
    predef_exception mergefunc();
    predef_exception retcode;

    OPCHK(SrcObj,table);
    OPCHK(DstObj,table);
    if ((retcode = mergefunc(args, FALSE)) isnt Normal)
      raise(retcode);
}



static predef_exception
mergefunc(args, mergeat)
argblock *args;
flag mergeat;
{
    predef_exception domerge();
    int undomerge();
    void finalize_table();

    predef_exception retcode;
    counter curelem, undoelem;
    trepnum curtbl;


    /* make private copies if tables are shared */
    if ((retcode = CopyOnWrite(Src1Obj)) isnt Normal)
      return(retcode);
    if ((retcode = CopyOnWrite(DstObj)) isnt Normal)
      return(retcode);
    
    if (size_of(Src1) isnt 0)	/* transfer tsdr in case dst is empty */
      Dst.table->tsdr = Src.table->tsdr; 

    curtbl = 0;
    if (mergeat) {
	retcode = ordfunc(Dst.table, merge_at)(Dst.table, ORDER_TBL,
					       Src1.table, Src2.integer);
	if (retcode isnt Normal)
	  return(retcode);
    }

    retcode = (predef_exception)
      doforeach(Src1.table)(Src1.table, FIRST_TBL, 
			    (int (*)()) domerge, &curelem, (int) Normal,
			    Dst.table, &curtbl, mergeat);
    if (retcode isnt Normal) {
	/* curelem and curtbl were left so as to indicate how far the */
	/* merge proceeded: all elements prior to curelem were merged */
	/* into all table reps; curelem was merged into all reps up to */
	/* but not including curtbl.  Table size was adjusted for */
	/* number of completely merged elements */
 	(void) doforeach(Src1.table) (Src1.table, FIRST_TBL, 
				      undomerge, &undoelem, CONT_FOREACH,
				      Dst.table, curelem, curtbl, mergeat);
	if (mergeat)
	  ordfunc(Dst.table, unmerge_at)(Dst.table, ORDER_TBL,
					 Src2.integer, Src1.table->size);
	return(retcode);
    }
    
    finalize_table(Src1.table, SHALLOW, F_FREE, (schedblock *) nil);
    set_bottom(Src1Obj);
    return(Normal);
}


/*ARGSUSED*/
static predef_exception
domerge(thetable, tblnum, val, curelem, argv)
dfd_table *thetable;
trepnum tblnum;
valcell val;
counter curelem;
va_list argv;
{
    predef_exception retcode;
    tblinfo *tblptr;
    flag mergeat;
    trepnum firsttbl;
    dfd_table *dsttable;
    trepnum *curtbl;

    dsttable = va_arg(argv, dfd_table *);
    curtbl = va_arg(argv, trepnum *);
    mergeat = va_arg(argv, flag);

    firsttbl = mergeat ? firstlookup(thetable) : FIRST_TBL;

    for_folltbl(dsttable, *curtbl, tblptr, firsttbl) {
	retcode = (*tblptr->des->insert)(dsttable, *curtbl, val);
	if (retcode isnt Normal)
	  return(retcode);
    }

    dsttable->size++;
    return(Normal);
}


/*ARGSUSED*/
static int
undomerge(thetable, tblnum, val, curelem, argv)
dfd_table *thetable;
trepnum tblnum;
valcell val;
counter curelem;
va_list argv;
{
    flag mergeat;
    counter lastelem;
    trepnum lasttbl;
    trepnum firsttbl;
    dfd_table *dsttable;
    tblinfo *tblptr;

    dsttable = va_arg(argv, dfd_table *);
    lastelem = va_arg(argv, counter);
    lasttbl = va_arg(argv, trepnum);
    mergeat = va_arg(argv, flag);

    firsttbl = mergeat ? firstlookup(thetable) : FIRST_TBL;

    if (curelem < lastelem) {
	/* element was merged into all reps... remove it */
	for_folltbl(dsttable, tblnum, tblptr, firsttbl) {
	    (*tblptr->des->uninsert)(dsttable, tblnum, val); 
	}

	dsttable->size--;
	return(CONT_FOREACH);
    }
    
    if (curelem > lastelem)
      /* past the range of elements that were merged, wholly or */
      /* partially */
      return(STOP_FOREACH);

    /* Element was partially merged... remove from tables up to but */
    /* not including lasttbl */
    for (tblptr = & dsttable->tbls[tblnum = firsttbl];
	 tblnum < lasttbl;
	 tblptr = & dsttable->tbls[++tblnum])
      (*tblptr->des->uninsert)(dsttable, tblnum, val);

    return(CONT_FOREACH);
}



NILOP(o_initget)
{
    void re_finalize();
    void init_selector();

    extern flag cherm_flag;

    OPCHK(SrcObj,table);
    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the iterator; */
    /* temporarily remove this test, since bottom valcells are not */
    /* necessarily zero... codegens have been fixed so they always */
    /* produce an integer_pair, but not all programs have been */
    /* recompiled, so we can't assume it's there yet.. */
#ifdef undefined
    if (args->qualifiers.record)
      init_selector(args, GET, 
		    dot(args->qualifiers, integer_pair__int_one).integer,
		    dot(args->qualifiers, integer_pair__int_two).integer);
    else
#endif
      init_selector(args, GET, 0, 0);
}


void
init_selector(args, findorget, repnum, startpos)
argblock *args;
flag findorget;
int repnum;
int startpos;
{
    handlr_stack *stackelem = nil;
    inspect_frame *frame = nil;
    tblinfo *tblptr;
    position pos;

    if ((frame = new(inspect_frame)) is nil) goto cleanup;
    frame->inspectobj = DstObj;
    frame->inspectee = SrcObj;
    frame->repnum = repnum;
    frame->rmvcount = 0;

    if ((stackelem = new(handlr_stack)) is nil) goto cleanup;
    stackelem->next = args->sched->ready->ep.h->info.context->estack;
    stackelem->handler = FALSE;
    stackelem->frame.inspect = frame;

    tblptr = & Src.table->tbls[repnum];

    if (findorget is GET) {
	if (!(*(tblptr->des->initget))(Src.table, repnum, & pos, startpos))
	  goto cleanup;
    }
    else {
	if (!(*(tblptr->des->initfind))
	    (Src.table, repnum, & pos, & args->operandstack[Src2Pos]))
	  goto cleanup;
    }
    stackelem->frame.inspect->pos = pos;
    args->sched->ready->ep.h->info.context->estack = stackelem;	
    return;

  cleanup:
    /* here when something failed... clean up and raise depletion */
    if (stackelem isnt nil)
      { dispose(stackelem, handlr_stack); }
    if (frame isnt nil)
      { dispose(frame, inspect_frame); }
    raise(Depletion);
}



NILOP(o_endget)
{
    void end_selector();

    OPCHK(SrcObj,table);
    end_selector(args, GET);
}


static void			/* raises no exceptions */
end_selector(args, findorget)
argblock *args;
flag findorget;
{
    handlr_stack *stackelem;
    inspect_frame *frame;
    tblinfo *tblptr;


    stackelem = args->sched->ready->ep.h->info.context->estack;
    frame = stackelem->frame.inspect;

#ifdef DEBUG
    if (frame->inspectobj isnt DstObj or frame->inspectee isnt SrcObj) {
	nilerror("end_selector", "mismatch in selector begin/end");
    }
#endif

    tblptr = & frame->inspectee->value.table->tbls[frame->repnum];

    if (findorget is GET)
      (*tblptr->des->endget)(Src.table, frame->repnum, & frame->pos);
    else
      (*tblptr->des->endfind)(Src.table, frame->repnum, & frame->pos);

    { dispose(frame, inspect_frame); }

    args->sched->ready->ep.h->info.context->estack = stackelem->next;
    { dispose(stackelem, handlr_stack); }
}


NILOP(o_get_or_err)
{
    predef_exception get();

    predef_exception retcode;

    OPCHK(SrcObj,table);
    retcode = get(args);

    if (retcode isnt Normal)
      raise(retcode);
}


NILOP(o_get_or_goto)
{
    predef_exception get();

    predef_exception retcode;

    OPCHK(SrcObj,table);
    retcode = get(args);

    if (retcode is Normal)
      return;

    if (retcode is NotFound) {
	args->nextop = args->qualifiers.integer;
				/* on NotFound, branch to target operation */
    }
    else
      raise(retcode);
}




static predef_exception
get(args)
argblock *args;
{
    inspect_frame *get_selector_frame();

    inspect_frame *frame;
    tblinfo *tblptr;
    predef_exception retcode;


    frame = get_selector_frame(args, DstObj);
    tblptr = & frame->inspectee->value.table->tbls[frame->repnum];
    
    retcode = (*tblptr->des->get)(Src.table, frame->repnum, & frame->pos, 
				  & Dst);

    if (retcode is Normal)
      DstObj->tsdr = qdatarepmap[Src.table->tsdr->number];
				/* give the quopy-equivalent to the */
				/* table element tsdr */

    return(retcode);
}


static inspect_frame *
get_selector_frame(args, obj)
argblock *args;
objectp obj;
{
    handlr_stack *stack;

    stack = args->sched->ready->ep.h->info.context->estack;

    while (stack) {
	if (not stack->handler)	/* is it an inspect frame? */
	  if (stack->frame.inspect->inspectobj is obj)
	    return (stack->frame.inspect);
	stack = cdr(stack);
    }

#ifdef DEBUG
    nilerror("get_selector_frame", "Couldn't find inspect object on stack");
#endif

    return(nil);
}


NILOP(o_remove)
{
    inspect_frame *get_selector_frame();
    predef_exception removefunc();
    predef_exception retcode;
    inspect_frame *frame;

    OPCHK(Src2Obj,table);
    frame = get_selector_frame(args, Src1Obj);
    retcode = removefunc(args, frame->repnum, frame->repnum, & frame->pos);
    if (retcode is Normal)
      frame->rmvcount++;
    else
      raise(retcode);
}


NILOP(o_fremove)
{
    predef_exception removefunc();
    predef_exception retcode;

    OPCHK(Src2Obj,table);
    retcode =
      removefunc(args, args->qualifiers.integer, NO_TBL, (position *) nil);
    if (retcode isnt Normal)
      raise(retcode);
}


static predef_exception
removefunc(args, keyrep, selrep, pos)
argblock *args;
trepnum keyrep;
trepnum selrep;
position *pos;
{
    void re_finalize();

    trepnum tblnum;
    tblinfo *tblptr;
    predef_exception retcode;
    extern flag cherm_flag;

    retcode = CopyOnWrite(Src2Obj); /* make private copy if table is shared */
    if (retcode isnt Normal)
      return(Depletion);

    foreach_tbl(Src2.table, tblnum, tblptr)
      (*tblptr->des->remove)(Src2.table, tblnum, Src1, keyrep, selrep, pos);
				/* just remove it from each table.  each */
				/*  implementation of remove must guarantee */
				/*  not to raise depletion. */

    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */
    *DstObj = *Src1Obj;		/* copy object */
    DstObj->tsdr = datarepmap[DstObj->tsdr->number]; /* set non-quopy tsdr */
    set_bottom(Src1Obj);	/* set source (inspected element) to bottom */

    Src2.table->size--;
    return(Normal);
}

/******************************************************************************
 *                        Generic Table Operations                            *
 *****************************************************************************/

void
fin_table(table, f_op, sched)
valcell table;
finalize_op f_op;
schedblock *sched;
{
    void finalize_table();

    finalize_table(table.table, DEEP, f_op, sched);
}


static void
finalize_table(table, depth, f_op, sched)
dfd_table *table;
flag depth;
finalize_op f_op;
schedblock *sched;
{
    trepnum tblnum;
    tblinfo *tblptr;

    if (--table->refcount isnt 0) /* only free if no more references. */
      return;

    foreach_tbl(table, tblnum, tblptr) {
	if (tblnum is FIRST_TBL)
	  (*tblptr->des->finalize)(table, tblnum, depth, f_op, sched);
	else
	  /* shallow finalize should never revive processes... passing */
	  /* nil for schedblock will cause hermi to abort if that happens */
	  (*tblptr->des->finalize)(table, tblnum, SHALLOW, f_op, nil);
    }

    /* pass nil for schedblock when finalizing auxiliary tables, as */
    /* they should never cause any processes to be revived */
    if (table->keyset.table)		/* get rid of the keys */
      finalize_table(table->keyset.table, DEEP, f_op, nil);
    if (table->indexset.table)	/* get rid of the indices */
      finalize_table(table->indexset.table, DEEP, f_op, nil);

    { freemain(table, sizeof(tblinfo) * (table->tblcount - ARBSIZE) +
	       sizeof(dfd_table)); }
}



predef_exception
cp_table(dst,src)
valcell *dst, src;
{
#ifndef DODEEPCOPY
    if (src.table->refcount is MAXCOUNTER) 
      return(Depletion);

    src.table->refcount++;
    dst->table = src.table;
    return(Normal);
#else
    predef_exception deep_cp_table();

    return(deep_cp_table(dst,src));
#endif
}


NILOP(o_privatize)
{
    predef_exception retcode;

    OPCHK(DstObj,table);
    retcode = CopyOnWrite(DstObj); /* make private copy if table is shared */
    if (retcode isnt Normal)
      raise(retcode);
}


/* called by the CopyOnWrite() macro, which first tests whether */
/* obj->value.table->refcount = 1; if it is, it does nothing; if it isn't, */
/* it calls doCopyOnWrite(). */
static predef_exception
doCopyOnWrite(obj)
object *obj;
{
    predef_exception deep_cp_table();
    predef_exception retcode;
    dfd_table *tbl;
    valcell newtbl;

    tbl = obj->value.table;


				/* make a private copy of the table */
    if ((retcode = deep_cp_table(&newtbl, obj->value)) isnt Normal)
      return(retcode);
    obj->value = newtbl;	/* install the new copy */
    tbl->refcount--;		/* and decrement refcount on shared copy. */
    return(Normal);
}


predef_exception
deep_cp_table(dst,src)
valcell *dst, src;
{
    predef_exception docopy();
    predef_exception retcode;
    counter elemcounter;
    valcell newtab;
    trepnum tblnum;
    tblinfo *tblptr;
    int i;

    newtab.table = (dfd_table *) 
      getmain(sizeof(dfd_table) + 
	      sizeof(tblinfo) * (src.table->tblcount - ARBSIZE));
    if (newtab.table is nil) goto cleanup;

    newtab.table->refcount = 1;
    newtab.table->tsdr = src.table->tsdr;
    newtab.table->ordered = src.table->ordered;
    newtab.table->tblcount = src.table->tblcount;
    newtab.table->size = 0;

    newtab.table->keyset.table = nil;
    newtab.table->indexset.table = nil;

    for (i = 0; i < newtab.table->tblcount; i++)
      newtab.table->tbls[i].des = nil;

    if (src.table->keyset.table) {
	retcode = cp_table(&newtab.table->keyset,src.table->keyset);
	if (retcode isnt Normal)
	  goto cleanup;
    }
    if (src.table->indexset.table) {
	retcode = cp_table(&newtab.table->indexset,src.table->indexset);
	if (retcode isnt Normal)
	  goto cleanup;
    }

    foreach_tbl(src.table, tblnum, tblptr) {
	if (!(*tblptr->des->precopy)(newtab.table, tblnum, src.table)) {
	    retcode = Depletion;
	    goto cleanup;
	}
	newtab.table->tbls[tblnum].des = tblptr->des;
    }

    retcode = (predef_exception)
      doforeach(src.table)(src.table, FIRST_TBL,
			   (int (*)()) docopy, &elemcounter, (int) Normal,
			   newtab.table);
    if (retcode isnt Normal)
      goto cleanup;

    /* copy operation succeeded... install the new copy */
    dst->table = newtab.table;
    return(Normal);


  cleanup:
    /* The copy failed somewhere... clean up and return exception code */
    if (newtab.table isnt nil) {
	if (newtab.table->size isnt 0) {
	    /* nonempty table is complete and consistent... just */
	    /* finalize it... nil for schedblock is ok since */
	    /* finalizing the new copies of table elements can never */
	    /* revive a process */
	    fin_table(newtab, F_DISCARD, nil);
	    return(retcode);
	}
	if (newtab.table->keyset.table isnt nil)
	  fin_table(newtab.table->keyset, F_DISCARD, nil);
	if (newtab.table->indexset.table isnt nil)
	  fin_table(newtab.table->indexset, F_DISCARD, nil);
	foreach_tbl(src.table, tblnum, tblptr)
	  if (newtab.table->tbls[tblnum].des isnt nil)
	    (*newtab.table->tbls[tblnum].des->finalize)
	      (newtab.table, tblnum, SHALLOW, F_FREE, (schedblock *) nil);
	{ freemain(newtab.table, sizeof(dfd_table) +
		   sizeof(tblinfo)*(src.table->tblcount - ARBSIZE)); }
    }
    return(retcode);
}


/*ARGSUSED*/
static predef_exception
docopy(srctable, srctblnum, val, elemcounter, argv)
dfd_table *srctable;
trepnum srctblnum;
valcell val;
counter elemcounter;
va_list argv;
{
    dfd_table *dsttable;
    trepnum tblnum, ptblnum;
    tblinfo *tblptr, *ptblptr;
    valcell newval;
    predef_exception retcode;


    dsttable = va_arg(argv, dfd_table *);

    retcode = (*srctable->tsdr->copy)(&newval,val);
				/* do the DEEP copy of the value */
    if (retcode isnt Normal)
      return(retcode);
    
    foreach_tbl(srctable, tblnum, tblptr) {
	retcode = (*tblptr->des->insert)(dsttable, tblnum, newval);
	if (retcode isnt Normal)  {
	    forprev_tbl(dsttable, ptblnum, ptblptr, tblnum)
	      (*ptblptr->des->uninsert)(dsttable, ptblnum, newval);
	    (*dsttable->tsdr->finalize)(newval, F_DISCARD, nil);
	    return(retcode);
	}
    }
    dsttable->size++;

    return(Normal);
}


status 
eq_table(t1, t2)
valcell t1, t2;
{
    if (t1.table is t2.table)
      return(SUCCESS);		/* lisp EQ for shared tables */

    if (t1.table->size isnt t2.table->size)
      return(FAILURE);

    if (t1.table->size is 0)
      return(SUCCESS);

    return((*(t1.table->tbls[FIRST_TBL].des->equal))
	   (t1.table, FIRST_TBL, t2.table));
}



comparison
cmp_table(t1, t2)
valcell t1, t2;
{
    if (t1.table is t2.table)
      return(CMP_EQUAL);	/* lisp EQ for shared tables */

    if (t1.table->size < t2.table->size)
      return(CMP_LESS);

    if (t1.table->size > t2.table->size)
      return(CMP_GREATER);

    if (t1.table->size is 0)
      return(CMP_EQUAL);

    return((*(t1.table->tbls[FIRST_TBL].des->comparekeys))
	   (t1.table, FIRST_TBL, t2.table));
}


void
prt_table(f, indent, v)
FILE *f;
int indent;
valcell v;
{
    int doprint();
    void print_keyset();
    void indent_for_print();
    void print_representations();

    datarep *tsdr;
    counter elemcounter;


    tsdr = v.table->tsdr;

    print_representations(f, v.table);

    if (v.table->size is 0) {
	(void) fprintf(f, "; EMPTY");
    }
    else
      (void) fprintf(f, "; %d elements of type %s", v.table->size, tsdr->name);

    if (v.table->keyset.table)
      print_keyset(f, v.table->keyset.table, "Keys");
    if (v.table->indexset.table)
      print_keyset(f, v.table->indexset.table, "Indices");

    if (v.table->size is 0) {
	(void) fprintf(f, "\n");
	return;
    }

    (void) fprintf(f, " --\n");

    if (v.table->ordered and 
	v.table->tbls[ORDER_TBL].des->number is table_rep_type__charstring) {
	indent_for_print(f, indent+1);
	(void) fprintf(f, " \"%s\"\n", 
		       v.table->tbls[ORDER_TBL].rep.chs->elements);
    }
    else {
	(void) doforeach(v.table)(v.table, FIRST_TBL,
				  doprint, &elemcounter, CONT_FOREACH,
				  f, indent+1);

	indent_for_print(f, indent);
	(void) fprintf(f, "End of Table\n");
    }
}



static void
print_representations(f, t)
FILE *f;
dfd_table *t;
{
    int i;

    for (i = 0; i < t->tblcount; i++)
      (void) fprintf(f, "%s%s", 
		     i is 0 ? "" : ",",
		     t->tbls[i].des->name);
}



/*ARGSUSED*/
static int
doprint(table, tblnum, val, elemcounter, argv)
dfd_table *table;
trepnum tblnum;
valcell val;
counter elemcounter;
va_list argv;
{
    void indent_for_print();

    FILE *f;
    int indent;

 
    f = va_arg(argv, FILE *);
    indent = va_arg(argv, int);

    indent_for_print(f, indent);
    if (table->ordered)
      (void) fprintf(f, "[%d] ", elemcounter);
    (*table->tsdr->print)(f, indent, val);

    return(CONT_FOREACH);
}


xdr_status
hxdr_table(xdrs, valp)
XDR *xdrs;
valcell *valp;
{
    int doxdr();
    xdr_status xdr_tblinfo();
    xdr_status xdr_lookup();
    void xdrfree_table();

    counter elemcounter;
    trepnum repnum;
    dfd_table *tbl = nil;
    counter size;
    int i;
    trepnum tblnum, ptblnum;
    tblinfo *tblptr, *ptblptr;
    valcell newval;
    predef_exception retcode;
    flag chsrep;
    char *chs_elements;

    /* XDR_FREE case handled separately because it just doesn't mesh */
    /* well with the rest of it */
    if (xdrs->x_op is XDR_FREE) {
	xdrfree_table(xdrs, valp);
	return(XDR_OK);
    }

    /* proceed with ENCODE and DECODE cases... */
    if (xdrs->x_op is XDR_ENCODE) {
	tbl = valp->table;
	repnum = tbl->tblcount;
	size = tbl->size;
    }
    /* prevent any deallocation if we fail before anything gets */
    /* allocated on a DECODE */
    if (xdrs->x_op is XDR_DECODE)
      valp->table = nil;

    /* first encode/decode number of representations */
    if (!xdr_int(xdrs, &repnum)) goto cleanup;

    /* allocate table structure for a DECODE operation, and */
    /* initialize fields not present in XDR stream */
    if (xdrs->x_op is XDR_DECODE) {
	tbl = (dfd_table *) getmain((counter) sizeof(dfd_table) +
				    sizeof(tblinfo)*(repnum-ARBSIZE));
	if (tbl is nil) goto cleanup;
	tbl->tblcount = repnum;
	tbl->refcount = 1;
	/* table is initially empty */
	tbl->size = 0;
	/* clear all table reps in case we don't make it all the way */
	/* through */
	for (i = 0; i < repnum; i++)
	  tbl->tbls[i].des = nil;
	/* same for key/index info */
	tbl->keyset.table = tbl->indexset.table = nil;
	/* save the table pointer so we can free it later if */
	/* needed */
	valp->table = tbl;
    }

    /* encode/decode other table-wide info */
    if (!xdr_datarep(xdrs, &tbl->tsdr)) goto cleanup;
    if (!xdr_u_int(xdrs,  &size)) goto cleanup;
    if (!myxdr_boolean(xdrs, &tbl->ordered)) goto cleanup;

    /* encode/decode representation-specific info for each rep */
    for (i = 0; i < repnum; i++)
      if (!xdr_tblinfo(xdrs, &tbl->tbls[i], tbl, i, size))
	goto cleanup;

    /* encode/decode the key/index information */
    if (!xdr_lookup(xdrs, &tbl->keyset)) goto cleanup;
    if (!xdr_lookup(xdrs, &tbl->indexset)) goto cleanup;
	
    /* check whether this table has a charstring representation */
    chsrep = tbl->ordered and
      (tbl->tbls[ORDER_TBL].des->number is table_rep_type__charstring);
    if (chsrep)
      chs_elements = &tbl->tbls[ORDER_TBL].rep.chs->elements[0];

    if (xdrs->x_op is XDR_ENCODE) {
        /* encode each table element */
        if (chsrep) {
	    /* special case to use packed external representation for */
	    /* charstrings */
	    if (!xdr_bytes(xdrs, &chs_elements, &size, size))
	      goto cleanup;
	}
	else
	  if (!((xdr_status) 
		doforeach(tbl)(tbl, FIRST_TBL,
			       (int (*)()) doxdr,
			       &elemcounter, (int) XDR_OK,
			       xdrs)))
	    goto cleanup;
    }
    else if (xdrs->x_op is XDR_DECODE) {
	/* decode each table element and insert it */
        if (chsrep) {
	    /* special case to read packed external representation for */
	    /* charstrings */
	    counter gotsize;

	    if (!xdr_bytes(xdrs, &chs_elements, &gotsize, size))
	      goto cleanup;
	    if (gotsize isnt size)
	      goto cleanup;
	}
	for (i = 0; i < size; i++) {
	    if (chsrep)
	      newval.enumeration = chs_elements[i];
	    else
	      if (!(*tbl->tsdr->xdr)(xdrs, &newval)) {	    
		  xdr_free(tbl->tsdr->xdr, &newval);
		  goto cleanup;
	      }
	    foreach_tbl(tbl, tblnum, tblptr) {
	        if (chsrep and (tblnum is ORDER_TBL))
		  retcode = Normal;
		else
		  retcode = (*tblptr->des->insert)(tbl, tblnum, newval);
		if (retcode isnt Normal) {
		    forprev_tbl(tbl, ptblnum, ptblptr, tblnum)
		      (*ptblptr->des->uninsert)(tbl, ptblnum, newval);
		    (*tbl->tsdr->finalize)(newval, F_DISCARD, nil);
		    goto cleanup;
		}
	    }
	    tbl->size++;
	}
    }
    return(XDR_OK);

  cleanup:
    /* something failed... xdr_free() will be explicitly called to */
    /* free up anything that got allocated */
    return(XDR_FAIL);
}


static void
xdrfree_table(xdrs, valp)
XDR *xdrs;
valcell *valp;
{
    if (valp->table isnt nil) {
	/* if table has elements, then it's a complete, consistent */
	/* table and we can use normal finalization stuff */
	if (valp->table->size isnt 0)
	  fin_table(*valp, F_FREE, (schedblock *) nil); 
				/* fix later: is this right?? */
	else {
	    /* free any pieces that may have been built */
	    if (valp->table->keyset.table isnt nil)
	      (void) xdr_lookup(xdrs, &valp->table->keyset);
	    if (valp->table->indexset.table isnt nil)
	      (void) xdr_lookup(xdrs, &valp->table->indexset);
	    /* free up storage for the table structure itself */
	    { freemain(valp->table, sizeof(dfd_table) + 
		       sizeof(tblinfo)*(valp->table->tblcount - ARBSIZE)); }
	}
    }
}

static xdr_status
xdr_lookup(xdrs, valp)
XDR *xdrs;
valcell *valp;
{
    flag islookup;		/* is there any lookup info here? */

    if (xdrs->x_op is XDR_DECODE)
      valp->table = nil;	/* in case we die before allocating anything */

    if (xdrs->x_op is XDR_ENCODE)
      islookup = valp->table isnt nil;

    if (!myxdr_boolean(xdrs, &islookup))
      return(XDR_FAIL);
    
    if (islookup)
      return(hxdr_table(xdrs, valp));
    else
      return(XDR_OK);
}


/* following routine only used for XDR_ENCODE operations */

/*ARGSUSED*/
static xdr_status
doxdr(tbl, tblnum, val, elemcount, argv)
dfd_table *tbl;
trepnum tblnum;
valcell val;
counter elemcount;
va_list argv;
{
    XDR *xdrs;

    xdrs = va_arg(argv, XDR *);

    return((*tbl->tsdr->xdr)(xdrs, & val));
}
    

static xdr_status
xdr_tblinfo(xdrs, infop, tbl, tblnum, size)
XDR *xdrs;
tblinfo *infop;
dfd_table *tbl;
trepnum tblnum;
counter size;
{
    status xdr_tbldes();
    tbldes *des;
    valcell nulval;
    status chs_alloc_to_size(), vec_alloc_to_size();

    if (not xdr_tbldes(xdrs, & infop->des))
      return(XDR_FAIL);

    /* allocate/deallocate representation-specific info */
    switch(xdrs->x_op) {
      case XDR_ENCODE:		/* nothing to do on ENCODE */
	break;			
      case XDR_DECODE:		/* allocate for DECODE */
	des = infop->des;
	infop->des = nil;	/* 'not allocated' signal for XDR_FREE */
	nulval.record = nil;
	/* special case for vector or charstring since we know the */
	/* initial allocation size precisely */
	switch (des->number) {
	case table_rep_type__vector:
	  if (!vec_alloc_to_size(tbl, tblnum, size))
	    return(XDR_FAIL);
	  break;
	case table_rep_type__charstring:
	  if (!chs_alloc_to_size(tbl, tblnum, size))
	    return(XDR_FAIL);
	  break;
	default:
	  if (!(*des->alloc)(tbl, tblnum, nulval))
	    return(XDR_FAIL);
	  break;
	}
	infop->des = des;
	break;
      case XDR_FREE:		/* deallocate for FREE, but only if */
	if (infop->des isnt nil)/* allocated  */
	  (*infop->des->finalize)(tbl, tblnum, SHALLOW, F_FREE,
				  (schedblock *) nil);
	break;
    }
    return(XDR_OK);
}


static xdr_status
xdr_tbldes(xdrs, despp)
XDR *xdrs;
tbldes **despp;
{
    trepnum desnum;

    if (xdrs->x_op is XDR_ENCODE)
      desnum = (*despp)->number;

    if (!xdr_int(xdrs, &desnum))
      return(XDR_FAIL);

    if (xdrs->x_op is XDR_DECODE)
      *despp = tbldescriptors[desnum];

    return(XDR_OK);
}

/******************************************************************************
 *                     Ordered Table Operations                               *
 *****************************************************************************/

NILOP(o_insert_at)
{
    predef_exception retcode;

    OPCHK(DstObj,table);
    OPCHK(Src2Obj,integer);
    if (Src2.integer > Dst.table->size or Src2.integer < 0)
      retcode = RangeError;
    else
      retcode = insertfunc(args, TRUE);
    if (retcode isnt Normal)
      raise(retcode);
}


NILOP(o_merge_at)
{
    predef_exception retcode;

    OPCHK(DstObj,table);
    OPCHK(Src1Obj,table);
    OPCHK(Src2Obj,integer);
    if (Src2.integer > Dst.table->size or Src2.integer < 0)
      raise(RangeError);
    else
      if ((retcode = mergefunc(args, TRUE)) isnt Normal)
	raise(retcode);
}

/* Note: remove_at raises NotFound instead of RangeError since it is used 
   for statements like

     remove e from r in t where (position of r = n);

   If N is out of the range of T, this will simply raise a NotFound exception.
 */

NILOP(o_remove_at)
{
    trepnum tblnum;
    tblinfo *tblptr;
    predef_exception retcode;

    OPCHK(Src1Obj,table);
    OPCHK(Src2Obj,integer);
    if (Src2.integer >= Src1.table->size or Src2.integer < 0) {
	raise(NotFound);
	return;
    }

    retcode = CopyOnWrite(Src1Obj); /* make private copy if table is shared */
    if (retcode isnt Normal) {
	raise(retcode);
	return;
    }

    ordfunc(Src1.table, remove_at)(Src1.table, ORDER_TBL,
				   & Dst, Src2.integer);

    for_lookups(Src1.table, tblnum, tblptr)
	(*tblptr->des->remove)(Src2.table, tblnum, -1, nil, Dst);
				/* just remove it from each table.  each */
				/*  implementation of remove must guarantee */
				/*  not to raise depletion. */

    Src1.table->size--;
    DstObj->tsdr = Src1.table->tsdr;
}


NILOP(o_scan_position)
{
    int doposition();

    counter elemcounter;

    OPCHK(Src2Obj,table);
    (void) doforeach(Src2.table)(Src2.table, ORDER_TBL,
				 doposition, &elemcounter, CONT_FOREACH,
				 Src1);
    Dst.integer = (dfd_integer) elemcounter;
    set_init(DstObj, dr_integer);
}


/*ARGSUSED*/
static int
doposition(srctable, srctblnum, val, elemcounter, argv)
dfd_table *srctable;
trepnum srctblnum;
valcell val;
counter elemcounter;
va_list argv;
{
    valcell findval;
			  
    findval = union_va_arg(argv, valcell);

    if (val.nominal is findval.nominal) 
      return(STOP_FOREACH);
    else
      return(CONT_FOREACH);
}


NILOP(o_position)
{
    inspect_frame *frame;
    dfd_table *thetable;

    frame = get_selector_frame(args, SrcObj);
    thetable = frame->inspectee->value.table;

    Dst.integer = frame->rmvcount +
        ordfunc(thetable, position_of)(thetable, ORDER_TBL, frame->pos);

    set_init(DstObj, dr_integer);
}


NILOP(o_lookup_at)
{
    void re_finalize();

    extern flag cherm_flag;

    OPCHK(Src1Obj,table);
    OPCHK(Src2Obj,integer);
    if (Src2.integer < 0 or Src2.integer >= Src1.table->size) {
	raise(NotFound);	/* NotFound, not RangeError, like remove */
	return;
    }

    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */
    ordfunc(Src1.table, lookup_at)(Src1.table, ORDER_TBL, & Dst,
				   Src2.integer);
    DstObj->tsdr = qdatarepmap[Src1.table->tsdr->number];
}

NILOP(o_lookup_at_or_goto)
{
    void re_finalize();

    extern flag cherm_flag;

    OPCHK(Src1Obj,table);
    OPCHK(Src2Obj,integer);
    if (Src2.integer < 0 or Src2.integer >= Src1.table->size) {
	args->nextop = args->qualifiers.integer;
	return;
    }

    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */
    ordfunc(Src1.table, lookup_at)(Src1.table, ORDER_TBL, & Dst,
				   Src2.integer);
    DstObj->tsdr = qdatarepmap[Src1.table->tsdr->number];
}

NILOP(o_concat)
{
    void re_finalize();

    object src1copy;
    object src2copy;
    objectp origDstObj;
    predef_exception retcode;
    extern flag cherm_flag;
    
    OPCHK(Src1Obj,table);
    OPCHK(Src2Obj,table);

    set_bottom(&src1copy);
    set_bottom(&src2copy);

    /* make copies of source operands to pass on to merge */
    if ((retcode = cp_table(&src1copy.value, Src1)) isnt Normal) goto cleanup;
    set_init(&src1copy, dr_table);
    if ((retcode = cp_table(&src2copy.value, Src2)) isnt Normal) goto cleanup;
    set_init(&src2copy, dr_table);

    /* pretend this is a MERGE operation */
    origDstObj = DstObj;	/* save original destination */
    DstObj = &src1copy;
    SrcObj = &src2copy;
    retcode = mergefunc(args, FALSE);
    if (retcode isnt Normal) goto cleanup;

    if (not cherm_flag)
      re_finalize(origDstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */
    *(origDstObj) = src1copy;
    return;

  cleanup:
    Finalize(&src1copy, F_DISCARD, args->sched); /* kill the temp copies */
    Finalize(&src2copy, F_DISCARD, args->sched);
    raise(retcode);		/* and raise appropriate exception */
}

/******************************************************************************
 *                   Keyed/Indexed Table Operations                           *
 *****************************************************************************/

NILOP(o_find)
{
    static status findfunc();

    OPCHK(Src1Obj,table);
    if (findfunc(args, args->qualifiers.integer) is FAILURE)
      raise(NotFound);
}


NILOP(o_find_or_goto)
{
    static status findfunc();

    OPCHK(Src1Obj,table);
    if (findfunc(args, 
		 dot(args->qualifiers, integer_pair__int_one).integer)
	is FAILURE)
      args->nextop = 
	dot(args->qualifiers, integer_pair__int_two).integer;
}


static status
findfunc(args, keynum)
argblock *args;
dfd_integer keynum;
{
    void re_finalize();

    int findrep;
    dfd_table *t;
    tbldes *d;
    object foundobj;
    extern flag cherm_flag;

    t = Src.table;
    findrep = keynumtorepnum(t, keynum);
    d = t->tbls[findrep].des;

    if ((* d->find)(t, findrep, & args->operandstack[Src2Pos], & foundobj)
	is SUCCESS) {

        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	*(DstObj) = foundobj;	/* "initialize" quopy result */
	DstObj->tsdr = qdatarepmap[t->tsdr->number];
	return(SUCCESS);
    }
    else
      return(FAILURE);
}

/******************************************************************************
 *                         Indexed Table Operations                           *
 *****************************************************************************/

NILOP(o_initidxfind)
{
    void re_finalize();
    void init_selector();

    int repnum;
    extern flag cherm_flag;

    OPCHK(Src1Obj,table);
    if (not cherm_flag)
      re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */
    repnum = keynumtorepnum(Src.table, args->qualifiers.integer);
    init_selector(args, FIND, repnum, 0);
}


NILOP(o_idxfind_or_err)
{
    predef_exception idxfindnext();

    predef_exception rc;

    OPCHK(SrcObj,table);
    if ((rc = idxfindnext(args)) isnt Normal)
      raise(rc);
}


NILOP(o_idxfind_or_goto)
{
    predef_exception idxfindnext();

    predef_exception rc;

    OPCHK(SrcObj,table);
    switch (rc = idxfindnext(args)) {
      case Normal: {
	  return;
      }

      case NotFound: {
	  args->nextop = args->qualifiers.integer;
	  return;
      }

      default: {
	  raise(rc);
	  return;
      }
    }
    /*NOTREACHED*/
}


NILOP(o_endidxfind)
{
    void end_selector();

    OPCHK(SrcObj,table);
    end_selector(args, FIND);
}


static predef_exception
idxfindnext(args)
argblock *args;
{
    inspect_frame *get_selector_frame();

    inspect_frame *frame;
    tblinfo *tblptr;
    predef_exception retcode;


    frame = get_selector_frame(args, DstObj);
    tblptr = & frame->inspectee->value.table->tbls[frame->repnum];
    
    retcode = (*tblptr->des->findnext)
      (Src.table, frame->repnum, & frame->pos, & Dst);

    if (retcode is Normal)
      DstObj->tsdr = qdatarepmap[Src.table->tsdr->number];

    return(retcode);
}



valcell
get_key(t, tblnum)
dfd_table *t;
trepnum tblnum;
{
    return(get_elem(t->keyset, tblnum - firstlookup(t)));
}
