/*  PRIMITIVE.C:  support for Built-in Predicates */


#include "zip.h"

#ifdef os370
#include "systimes.h"
#endif

#ifdef BERK41
#include <sys/types.h>
#include <sys/times.h>
#endif

#ifdef BERK42
typedef int time_t;
#include <sys/times.h>
#endif

#ifdef PANOS
#endif

extern int *TRTOP;
extern int *CL, *BL, *BG, *TR, *L, clatom, clarity, clref, *alloc(), M1;
extern int cvtboxlis(), compare();
extern int cvtlisbox(), cvtintlis(), cvtlisint();
extern int unifyatomic();
extern int T0, T1, syswords[], modstk[], *modptr;
extern jmp_buf jump_env;
extern fileentry *currsee, *currtell;
extern char chtype[];

int clref2;  /* set by primcom8, used by primcom9. */


/* unify an atomic term w with CL argument n */

int unifyatomic(n,w)
int n,w;
{
  register int U0;
  U0 = (int) *(CL+ARGOFF+n);
  deref(U0);
  if (tag(U0) == UNDEF)
  {
    memoff0(U0) = w;
    if ((int *) val(U0) < BL)
    {
      *TR++ = U0;
      if (TR > TRTOP) fatality(68);
    }
    return(TRUE);
  }
  else return(U0 == w);
}


/* claim a clause.  Used by primcom8-10 when returning a clause reference */

static claimclause(c)
{
  register int *fp;
  proctrap((tag(c) != CLAUSE),510);
  fp = ((int *) val(c)) + CLAFLAOFF;
  if (*fp & CFCLAIMED) return;
  *fp |= CFCLAIMED;
  *TR++ = c;
  if (TR > TRTOP) fatality(68);
}


/* erase a clause.  Unchain immediately, but deallocation is done safely. */

static int doerase(t)
int t;
{
  int i;
  if (tag(t) != CLAUSE) return(FALSE);
  i = memoff(t,CLAPROOFF);
  if (memoff(i,PROFLAOFF) & (PFTRANS | PFSACRED)) return(FALSE);
  i = memoff(t,CLAFLAOFF);
  if (!(i & CFDOOMED))
  {
    memoff(t,CLAFLAOFF) = i | CFDOOMED;
    unchain(t);
    if (!(i & (CFCLAIMED | CFREFMASK))) dealloc(t);
  }
  return(TRUE);
}


/* The Primitive Handler */

int primhandle(index)
int index;
{
  int succeed, i,j,b,t,u, *p;
  fileentry *f;
#ifdef PANOS
#else
  struct tms the_time;
#endif
  succeed = TRUE;
  switch(index)
  {
    case 1:  /* primflag(Mask,Old,New) */
      getarg(1,i);
      i = val(i);
      if (unifyatomic(2,makeword(INT, T0 & i)))
      {
        getarg(3,t);
        if (tag(t) == INT)
        {
          T0 = (~i & T0) | val(t);
          return(TRUE);
        }
      }
      return(FALSE);
    case 2:  /* see(X) */
      getarg(1,t);
      return(prseetell(t,TRUE));
    case 3:  /* tell(X) */
      getarg(1,t);
      return(prseetell(t,FALSE));
    case 4:  /* get_file_status(See,Name,Line,Column,Width,Depth) */
      getarg(1,t);
      f = val(t) ? currsee : currtell;
      succeed = unifyatomic(2,f->name);
      if (succeed) succeed = unifyatomic(3,makeword(INT,f->line));
      if (succeed) succeed = unifyatomic(4,makeword(INT,f->column));
      if (succeed) succeed = unifyatomic(5,makeword(INT,f->colmax));
      if (succeed) succeed = unifyatomic(6,makeword(INT,f->depmax));
      return(succeed);
    case 5:  /* put_file_status(See,Name,Line,Column,Width,Depth) */
      getarg(1,t);
      f = (val(t)) ? currsee : currtell;
      if (unifyatomic(2,f->name))
      {
        getarg(3,t);
        if (tag(t) == INT) f->line = val(t);
        getarg(4,t);
        if (tag(t) == INT) f->column = val(t);
        getarg(5,t);
        if (tag(t) == INT) f->colmax = val(t);
        getarg(6,t);
        if (tag(t) == INT) f->depmax = val(t);
      }
      break;
    case 6:  /* seen */
      prseentold(TRUE);
      break;
    case 7:  /* told */
      prseentold(FALSE);
      break;
    case 8:  /* get0(X) */
      return(unifyatomic(1,makeword(INT,getch())));
    case 9:  /* put(X) */
      getarg(1,t);
      putch(val(t) & ASCMASK);
      break;
    case 10:  /* primcompare(X,Y,Z) */
      getarg(1,t);
      getarg(2,u);
      return(unifyatomic(3,makeword(INT,val(compare(t,u)))));
    case 11:  /* tokenread(Ch,Token,NextCh) */
      getarg(1,i);
      t = tokenread(val(i));
      u = getch();
      succeed = unifyatomic(2,t);
      if (succeed) unifyatomic(3,makeword(INT,u));
      return(succeed);
    case 12:  /* primcom12 */
      clref = clref2 = TERMIN;
      return(FALSE);
    case 13:  /* erase(X) */
      getarg(1,t);
      return(doerase(t));
    case 14:  /* simpleterm(X) */
      getarg(1,t);
      return((tag(t) != TERM) && (tag(t) != CONS));
      break;
    case 15:  /* tokenalpha(Atom) */
      getarg(1,t);
      return(tokenalpha(t));
    case 16:  /* primcom1(Type,Atom,Arity,Index) */
      return(unifyatomic(4,makeword(INT,prcom1())));
      break;
    case 17:  /* VACANT */
      return(FALSE);
    case 18:  /* primcom3(Atom,Arity,Key,Kind,MaxFS,Bytes,N,D) */
      return(prcom3());
    case 19:  /* primcom0 */
      return(prcom0());
    case 20:  /* primcom11 */
      return(prcm11());
    case 21: /* tokenother(Atom) */
      getarg(1,t);
      return(tokenother(t));
    case 22:  /* get1(X) */
      succeed = FALSE;
      break;
    case 23:  /* putflush */
      succeed = FALSE;
      break;
    case 24: /* vacant */
    case 25:  /* eraselast */
/*
display("eraselast",M1);
*/
      return(doerase(M1));
    case 26:  /* vacant */
    case 27:  /* primcom9(R) */
      if (clref2 == TERMIN) return(FALSE);
      succeed = unifyatomic(1,clref2);
/*
display("primcom9",clref2);
*/
      if (succeed) claimclause(clref2);
      return(succeed);
    case 28:  /* tokenput(X,Y) */
      getarg(1,i);
      getarg(2,j);
      tokenput(i,val(j));
      break;
    case 29:  /* primcom10(R) */
/*
display("primcom10",M1);
*/
      succeed = unifyatomic(1,M1);
      if (succeed) claimclause(M1);
      return(succeed);
    case 30:  /* VACANT */
      break;
    case 31:  /*  vacant */
      break;
    case 32:  /* primcom8(Atom,Arity,Ref) */
      if (clref == TERMIN) return(FALSE);
      succeed = unifyatomic(1,clatom);
      if (succeed) succeed = unifyatomic(2,clarity);
      if (succeed) succeed = unifyatomic(3,clref);
      clref2 = clref;
/*
display("primcom8",clref);
*/
      claimclause(clref);
      break;
    case 33:  /* VACANT */
      break;
    case 34:  /* VACANT */
      succeed = FALSE;
      break;
    case 35:  /* VACANT */
      break;
    case 36:  /* VACANT */
      break;
    case 37:  /* get(X) */
      do { i = getch(); } while (chtype[i] == BLANK);
      succeed = unifyatomic(1,makeword(INT,i));
      break;
    case 38:  /* vacant */
    case 39:  /* VACANT */
      break;
    case 40:  /* VACANT */
      break;
    case 41:  /* VACANT */
      break;
    case 42:  /* vacant */
      break;
    case 43:  /* statistics(Time,Inst) */
#ifdef os370
      succeed = unifyatomic(1,makeword(INT, clock()/1000));
#else
#ifdef PANOS
/* as yet I do not know how to read the time here */
      succeed = unifyatomic(1,makeword(INT, 0));
#else
      times(&the_time);
      succeed = unifyatomic(1,makeword(INT,(the_time.tms_utime*1000+30)/60));
#endif
#endif
      if (succeed) succeed = unifyatomic(2,makeword(INT,T1));
      break;
    case 44:  /* vacant */
      break;
    case 45:  /* vacant */
      break;
    case 46:  /* vacant */
      break;
    case 47:  /* vacant */
      break;
    case 48:  /* vacant */
      break;
    case 49:  /* skip(X) */
      while (!unifyatomic(1,makeword(INT,getch()))) ;
      break;
    case 50:  /* abort */
      /* first close all files */
      longjmp(jump_env,LJ_ABORT);
      break;
    case 51:  /* primvisa(F,A,N) */
      getarg(1,t);
      getarg(2,i);
      t = findproc(findfunct(t,val(i),TRUE),*modptr,TRUE);
      getarg(3,u);
      memoff(t,PROFLAOFF) |= val(u);
      break;
    case 52:  /* primimport(F,A,M,E) */
      getarg(1,t);
      getarg(2,i);
      getarg(3,u);
      unifyatomic(4,makeword(INT,improc(findfunct(t,val(i),TRUE),u)));
      break;
    case 53:  /* primmodule(X,E) */
      b = TRUE;
      getarg(1,t);
      p = &modstk[0];
      while (b && (p <= modptr)) if (t == *p++) b = FALSE;
      i = makeword(INT,0);
      if (b)
      {
        if (modptr+1 > MAXMODSTK) i = makeword(INT,64);
        else *++modptr = t;
      }
      else i = makeword(INT,63);
      return(unifyatomic(2,i));
    case 54:  /* primendmodule */
      getarg(1,t);
      if (t == *modptr) --modptr; else succeed = FALSE;
      break;
    case 55:  /* halt */
      longjmp(jump_env,LJ_HALT);
      break;
    case 56:  /* primlen(L,N) */
      i = 0;
      getarg(1,t);
      while (succeed && (t != syswords[SWNIL]))
      {
        if (tag(t) == CONS)
        {
          i++;
          t = memoff(t,1);
        }
        else succeed = FALSE;
      }
      if (succeed) succeed = unifyatomic(2,makeword(INT,i));
      break;
    case 57:  /* name(X,Y) */
      succeed = FALSE;
      getarg(2,t);
      if (tag(t) == UNDEF)
      {
        getarg(1,t);
        if (tag(t) == ATOM) t = memoff(t,ATOCHOFF);
        if (tag(t) == BOX) succeed = unifyatomic(2,cvtboxlis(t));
        else if (tag(t) == INT) succeed = unifyatomic(2,cvtintlis(t));
      }
      else
      {
        getarg(2,t);
        if ((i = cvtlisint(t)) != UNDEF) succeed = unifyatomic(1,i);
        else if (cvtlisbox(t)) succeed = unifyatomic(1,findatom());
      }
      break;
    case 58:  /* VACANT */
    case 59:  /* VACANT */
      succeed = FALSE;
      break;
    case 60:  /* char_class(X,N) */
      succeed = FALSE;
      getarg(1,t);
      if (tag(t) == INT)
        succeed = unifyatomic(2,makeword(INT,chtype[val(t) & ASCMASK]));
      break;
    case 61:  /* save(X,Y) */
      succeed = FALSE;
      getarg(1,t);
      if (tag(t) == ATOM)
      {
        if (saveimage(memoff(t,ATOCHOFF)))
          succeed = unifyatomic(2,makeword(INT,0));
      }
      break;
    case 62:  /* restore(X) */
      succeed = FALSE;
      getarg(1,t);
      if (tag(t) == ATOM)
      {
        if (restimage(memoff(t,ATOCHOFF)))
          /* now we return as though from save(X,1) */
          succeed = unifyatomic(2,makeword(INT,1));
      }
      break;
    default:
      processortrap(24);
  }
  return(succeed);
}