/*  COMPSUP.C:  Compiler support primitives */

#include "zip.h"

extern int *G, *modptr, *getheap(), *CL;
extern int syswords[], buffname[];

#define LENXRTAB 256
#define MAXXRTAB &xrtable[LENXRTAB-1]
#define LENCODETAB 1024
#define MAXCODETAB &emitcode[LENCODETAB-1]
#define LENVARTAB 256
#define MAXVARTAB &vartab[LENVARTAB-1]

int xrp, clatom, clarity, clref;
int xrtable[LENXRTAB];

/* primcom0.  initialise compiler support */

prcom0()
{
  xrp = 0;
}


/*
  implement primcom1(Type,Item,Arity,Index).
  write an XR Table entry.  Type: 0=const, 1=proc, 2=funct
  XR references are origin 0.
  If the entry is a clause reference, then increment its reference count.
  Return the table index.
*/

prcom1()
{
  int t, a, n, *h, bs, i;
  char s;
  getarg(1,t);
  proctrap((tag(t) != INT),301);
  if (val(t) == 0)  getarg(2,a)
  else if (val(t) <= 2)
  {
    getarg(2,a);
    proctrap((tag(a) != ATOM),302);
    getarg(3,n);
    proctrap((tag(n) != INT),303);
    a = findfunct(a,val(n), TRUE);
    if (val(t) == 1)  a = findproc(a,*modptr,TRUE);
  }
  else processortrap(301);
  i = 0;
  s = TRUE;
  while ((i < xrp) && s) if (xrtable[i] == a) s = FALSE; else i++;
  if (s)
  {
    if (i >= LENXRTAB-1)  fatality(46);
    switch(tag(a))
    {
      case FLOAT:
        if ((int *) val(a) < G)
        {
          h = getheap(3);
          *(h) = makeword(BLOCK,8);
          *(h+1) = memoff(a,1);
          *(h+2) = memoff(a,2);
          a = makeword(FLOAT,(int)h);
        }
        break;
      case BOX:
        if ((int *) val(a) < G)
        {
          bs = blocksize(val(memoff0(a)));
          h = getheap(bs);
          blkmov(bs,(int *) val(a), h);
          a = makeword(BOX,(int)h);
        }
        break;
      case CLAUSE:
        memoff(a,CLAFLAOFF) += CFREFINC;
        break;
    }
    t = xrp;
    xrtable[xrp++] = a;
  }
  t = i;
  return(t);
}


/* construct a clause and return it */

static int packup(k,t,d,mfs)
int k, t, d, mfs;
{
  int nwd, i, mc, *cl, *bl, *b;
  nwd = blocksize(val(buffname[0]));
  if (nwd > 1)
  {
    cl = getheap(CLAUSELEN + xrp + nwd);
    *(cl+CLAKEYOFF) = k;
    *(cl+CLAFLAOFF) = makeword(INT,mfs);
    if (d & 1)
    {
      *(cl+CLAFLAOFF) |= CFRECORD;
      memoff(t,PROFLAOFF) |= PFRECORD;
    }
    *(cl+CLASIZOFF) = makeword(INT,CLAUSELEN + xrp);
    *(cl+CLAFOROFF) = TERMIN;
    *(cl+CLAPROOFF) = t;
    bl = cl + (CLAUSELEN + xrp);
    *(cl+CLATEXOFF) = makeword(BOX,(int)bl);
    b = buffname;
    while (nwd--) *bl++ = *b++;
    if (xrp > 0) for (i = 0; i < xrp; i++) *(cl + (CLAUSELEN + i)) = xrtable[i];
    mc = makeword(CLAUSE,(int) cl);
  } else mc = TERMIN;
  return(mc);
}


int prcom3()
{
  int a, k, t, u, c;
  getarg(1,t);
  proctrap((tag(t) != ATOM),291);
  clatom = t;
  getarg(2,u);
  proctrap((tag(u) != INT),292);
  clarity = u;
  t = findproc(findfunct(t,val(u),TRUE),*modptr,TRUE);
  getarg(3,k);
  if (tag(k) == UNDEF)  k = UNDEF;
  else
  {
    getarg(4,a);
    if (tag(a) == INT)
    {
      a = val(a);
      if (k == syswords[SWDOT] && a == 2) k = makeword(CONS,0);
      else k = findfunct(k,a,TRUE);
    }
  }
  getarg(5,a);
  proctrap((tag(a) != INT),2992);
  a = val(a);
  getarg(6,u);
  if (!cvtlisbox(u)) processortrap(2991);
  getarg(8,u);
  proctrap((tag(u) != INT),299);
  c = packup(k,t,u,a);
  clref = c;
  getarg(7,u);
  proctrap((tag(u) != INT),298);
  linkclause(c,t,val(u));
  return(TRUE);
}


/*
  Ensure that it is legal to assert a clause for functor f, arity a.
  A procedure is legal if (a) it is visible in this module, and (b)
  if this is not the defining module and the procedure is not sacred.
*/

int prcm11()
{
  int a,f,p;
  getarg(1,f);
  proctrap((tag(f) != ATOM),1111);
  getarg(2,a);
  proctrap((tag(a) != INT),1112);
  p = findproc(findfunct(f,val(a),TRUE), *modptr, TRUE);
  if (tag(p) == TERMIN) return(FALSE);
  return(!(*modptr != memoff(p,PRODEFOFF) && (memoff(p,PROFLAOFF) & PFSACRED)));
}