RIGAL/rigsc.446/src/erm.c

#include "globrig.h"
#include "define.h"
#include "defpage.h"
#include "nef2.h"
#include "cim.h"
#include "usemod.h"

Void usepas(n, pl, rez)
long n;
ptr_ *pl;
long *rez;
{
  /* number of option */
  /* pointer to argument list */
  /* result */
  a pp1, pp2;

  pp1 = pl->cel;
  next(pl);
  pp2 = pl->cel;
  next(pl);
  switch (n) {

  /*    n:   use_x(pp1,pp2,pl.cel,rez) */
  case 1:
    use_1(pp1, pp2, pl->cel, rez);
    break;

  case 2:
    use_2(pp1, pp2, pl->cel, rez);
    break;

  case 3:
    use_3(pp1, pp2, pl->cel, rez);
    break;

  case 4:
    use_4(pp1, pp2, pl->cel, rez);
    break;

  case 5:
    use_5(pp1, pp2, pl->cel, rez);
    break;

  case 6:
    use_6(pp1, pp2, pl->cel, rez);
    break;

  case 7:
    use_7(pp1, pp2, pl->cel, rez);
    break;

  case 8:
    use_8(pp1, pp2, pl->cel, rez);
    break;

  case 9:
    use_9(pp1, pp2, pl->cel, rez);
    break;

  case 10:
    use_10(pp1, pp2, pl->cel, rez);
    break;

  case 11:
    use_11(pp1, pp2, pl->cel, rez);
    break;

  case 12:
    use_12(pp1, pp2, pl->cel, rez);
    break;

  case 13:
    use_13(pp1, pp2, pl->cel, rez);
    break;

  case 14:
    use_14(pp1, pp2, pl->cel, rez);
    break;

  case 15:
    use_15(pp1, pp2, pl->cel, rez);
    break;

  case 16:
    use_16(pp1, pp2, pl->cel, rez);
    break;

  case 17:
    use_17(pp1, pp2, pl->cel, rez);
    break;

  case 18:
    use_18(pp1, pp2, pl->cel, rez);
    break;

  case 19:
    use_19(pp1, pp2, pl->cel, rez);
    break;

  case 20:
    use_20(pp1, pp2, pl->cel, rez);
    break;

  case 21:
    use_21(pp1, pp2, pl->cel, rez);
    break;

  case 22:
    use_22(pp1, pp2, pl->cel, rez);
    break;

  case 23:
    use_23(pp1, pp2, pl->cel, rez);
    break;

  case 24:
    use_24(pp1, pp2, pl->cel, rez);
    break;

  case 25:
    use_25(pp1, pp2, pl->cel, rez);
    break;

  case 26:
    use_26(pp1, pp2, pl->cel, rez);
    break;

  case 27:
    use_27(pp1, pp2, pl->cel, rez);
    break;

  case 28:
    use_28(pp1, pp2, pl->cel, rez);
    break;

  case 29:
    use_29(pp1, pp2, pl->cel, rez);
    break;

  case 30:
    use_30(pp1, pp2, pl->cel, rez);
    break;

  case 31:
    use_31(pp1, pp2, pl->cel, rez);
    break;

  case 32:
    use_32(pp1, pp2, pl->cel, rez);
    break;

  case 33:
    use_33(pp1, pp2, pl->cel, rez);
    break;

  case 34:
    use_34(pp1, pp2, pl->cel, rez);
    break;

  case 35:
    use_35(pp1, pp2, pl->cel, rez);
    break;

  case 36:
    use_36(pp1, pp2, pl->cel, rez);
    break;

  case 37:
    use_37(pp1, pp2, pl->cel, rez);
    break;

  case 38:
    use_38(pp1, pp2, pl->cel, rez);
    break;

  case 39:
    use_39(pp1, pp2, pl->cel, rez);
    break;

  case 40:
    use_40(pp1, pp2, pl->cel, rez);
    break;

  case 41:
    use_41(pp1, pp2, pl->cel, rez);
    break;

  case 42:
    use_42(pp1, pp2, pl->cel, rez);
    break;

  case 43:
    use_43(pp1, pp2, pl->cel, rez);
    break;

  case 44:
    use_44(pp1, pp2, pl->cel, rez);
    break;

  /* 45 & 46 are passed*/

  case 47:
    use_47(pp1, pp2, pl->cel, rez);
    break;

  case 48:
    use_48(pp1, pp2, pl->cel, rez);
    break;

  case 49:
    use_49(pp1, pp2, pl->cel, rez);
    break;

  case 50:
    use_50(pp1, pp2, pl->cel, rez);
    break;

  case 51:
    use_51(pp1, pp2, pl->cel, rez);
    break;

  case 52:
    use_52(pp1, pp2, pl->cel, rez);
    break;

  case 53:
    use_53(pp1, pp2, pl->cel, rez);
    break;

  case 54:
    use_54(pp1, pp2, pl->cel, rez);
    break;

  case 55:
    use_55(pp1, pp2, pl->cel, rez);
    break;

  case 56:
    use_56(pp1, pp2, pl->cel, rez);
    break;

  case 57:
    use_57(pp1, pp2, pl->cel, rez);
    break;

  case 58:
    use_58(pp1, pp2, pl->cel, rez);
    break;

  case 59:
    use_59(pp1, pp2, pl->cel, rez);
    break;

  case 60:
    use_60(pp1, pp2, pl->cel, rez);
    break;

  case 61:
    use_61(pp1, pp2, pl->cel, rez);
    break;

  case 62:
    use_62(pp1, pp2, pl->cel, rez);
    break;

  case 63:
    use_63(pp1, pp2, pl->cel, rez);
    break;

  case 64:
    use_64(pp1, pp2, pl->cel, rez);
    break;

  case 65:
    use_65(pp1, pp2, pl->cel, rez);
    break;

  case 66:
    use_66(pp1, pp2, pl->cel, rez);
    break;

  case 67:
    use_67(pp1, pp2, pl->cel, rez);
    break;

  case 68:
    use_68(pp1, pp2, pl->cel, rez);
    break;

  case 69:
    use_69(pp1, pp2, pl->cel, rez);
    break;

  case 70:
    use_70(pp1, pp2, pl->cel, rez);
    break;

  case 71:
    use_71(pp1, pp2, pl->cel, rez);
    break;

  case 72:
    use_72(pp1, pp2, pl->cel, rez);
    break;

  case 73:
    use_73(pp1, pp2, pl->cel, rez);
    break;

  case 74:
    use_74(pp1, pp2, pl->cel, rez);
    break;

  case 75:
    use_75(pp1, pp2, pl->cel, rez);
    break;

  case 76:
    use_76(pp1, pp2, pl->cel, rez);
    break;

  case 77:
    use_77(pp1, pp2, pl->cel, rez);
    break;

  case 78:
    use_78(pp1, pp2, pl->cel, rez);
    break;

  case 79:
    use_79(pp1, pp2, pl->cel, rez);
    break;

  case 80:
    use_80(pp1, pp2, pl->cel, rez);
    break;

  case 81:
    use_81(pp1, pp2, pl->cel, rez);
    break;

  case 82:
    use_82(pp1, pp2, pl->cel, rez);
    break;

  case 83:
    use_83(pp1, pp2, pl->cel, rez);
    break;

  case 84:
    use_84(pp1, pp2, pl->cel, rez);
    break;

  case 85:
    use_85(pp1, pp2, pl->cel, rez);
    break;

  case 86:
    use_86(pp1, pp2, pl->cel, rez);
    break;

  case 87:
    use_87(pp1, pp2, pl->cel, rez);
    break;

  case 88:
    use_88(pp1, pp2, pl->cel, rez);
    break;

  case 89:
    use_89(pp1, pp2, pl->cel, rez);
    break;

  case 90:
    use_90(pp1, pp2, pl->cel, rez);
    break;

  case 91:
    use_91(pp1, pp2, pl->cel, rez);
    break;

  case 92:
    use_92(pp1, pp2, pl->cel, rez);
    break;

  case 93:
    use_93(pp1, pp2, pl->cel, rez);
    break;

  case 94:
    use_94(pp1, pp2, pl->cel, rez);
    break;

  case 95:
    use_95(pp1, pp2, pl->cel, rez);
    break;

  case 96:
    use_96(pp1, pp2, pl->cel, rez);
    break;

  case 97:
    use_97(pp1, pp2, pl->cel, rez);
    break;

  case 98:
    use_98(pp1, pp2, pl->cel, rez);
    break;

  case 99:
    use_99(pp1, pp2, pl->cel, rez);
    break;

  case 100:
    use_100(pp1, pp2, pl->cel, rez);
    break;

  case 101:
    use_101(pp1, pp2, pl->cel, rez);
    break;

  case 102:
    use_102(pp1, pp2, pl->cel, rez);
    break;

  case 103:
    use_103(pp1, pp2, pl->cel, rez);
    break;

  case 104:
    use_104(pp1, pp2, pl->cel, rez);
    break;

  case 105:
    use_105(pp1, pp2, pl->cel, rez);
    break;

  case 106:
    use_106(pp1, pp2, pl->cel, rez);
    break;

  case 107:
    use_107(pp1, pp2, pl->cel, rez);
    break;

  case 108:
    use_108(pp1, pp2, pl->cel, rez);
    break;

  case 109:
    use_109(pp1, pp2, pl->cel, rez);
    break;

  case 110:
    use_110(pp1, pp2, pl->cel, rez);
    break;

  case 111:
    use_111(pp1, pp2, pl->cel, rez);
    break;

  case 112:
    use_112(pp1, pp2, pl->cel, rez);
    break;

  case 113:
    use_113(pp1, pp2, pl->cel, rez);
    break;

  case 114:
    use_114(pp1, pp2, pl->cel, rez);
    break;

  case 115:
    use_115(pp1, pp2, pl->cel, rez);
    break;

  case 116:
    use_116(pp1, pp2, pl->cel, rez);
    break;

  case 117:
    use_117(pp1, pp2, pl->cel, rez);
    break;

  case 118:
    use_118(pp1, pp2, pl->cel, rez);
    break;

  case 119:
    use_119(pp1, pp2, pl->cel, rez);
    break;

  case 120:
    use_120(pp1, pp2, pl->cel, rez);
    break;

  case 121:
    use_121(pp1, pp2, pl->cel, rez);
    break;

  case 122:
    use_122(pp1, pp2, pl->cel, rez);
    break;

  case 123:
    use_123(pp1, pp2, pl->cel, rez);
    break;

  case 124:
    use_124(pp1, pp2, pl->cel, rez);
    break;

  case 125:
    use_125(pp1, pp2, pl->cel, rez);
    break;

  case 126:
    use_126(pp1, pp2, pl->cel, rez);
    break;

  case 127:
    use_127(pp1, pp2, pl->cel, rez);
    break;

  case 128:
    use_128(pp1, pp2, pl->cel, rez);
    break;

  case 129:
    use_129(pp1, pp2, pl->cel, rez);
    break;

  case 130:
    use_130(pp1, pp2, pl->cel, rez);
    break;

  case 131:
    use_131(pp1, pp2, pl->cel, rez);
    break;

  case 132:
    use_132(pp1, pp2, pl->cel, rez);
    break;

  case 133:
    use_133(pp1, pp2, pl->cel, rez);
    break;

  case 134:
    use_134(pp1, pp2, pl->cel, rez);
    break;

  case 135:
    use_135(pp1, pp2, pl->cel, rez);
    break;

  case 136:
    use_136(pp1, pp2, pl->cel, rez);
    break;

  case 137:
    use_137(pp1, pp2, pl->cel, rez);
    break;

  case 138:
    use_138(pp1, pp2, pl->cel, rez);
    break;

  case 139:
    use_139(pp1, pp2, pl->cel, rez);
    break;

  case 140:
    use_140(pp1, pp2, pl->cel, rez);
    break;

  case 141:
    use_141(pp1, pp2, pl->cel, rez);
    break;

  case 142:
    use_142(pp1, pp2, pl->cel, rez);
    break;

  case 143:
    use_143(pp1, pp2, pl->cel, rez);
    break;

  case 144:
    use_144(pp1, pp2, pl->cel, rez);
    break;

  case 145:
    use_145(pp1, pp2, pl->cel, rez);
    break;

  case 146:
    use_146(pp1, pp2, pl->cel, rez);
    break;

  case 147:
    use_147(pp1, pp2, pl->cel, rez);
    break;

  case 148:
    use_148(pp1, pp2, pl->cel, rez);
    break;

  case 149:
    use_149(pp1, pp2, pl->cel, rez);
    break;

  case 150:
    use_150(pp1, pp2, pl->cel, rez);
    break;

  default:
    *rez = pp1;
    break;
  }
}




Void add(d, r)
long *d, *r;
{
  /*==============*/
  /*  d+:= r      */
  /*==============*/
  mpd x, y;
  numberdescriptor *WITH;

  /* deleted sign processing 2-oct-89 */
  if (*d == null_) {
    if (*r == null_)
      return;
    pointr(*r, &y.sa);
    if (y.snd->dtype == number) {
      /* instead of d:=r; changed 22-oct-90 */
      gets1(d, &x.sa);
      *x.snd = *y.snd;
    }
    return;
  }
  points(*d, &x.sa);
  if (x.snd->dtype != number) {
    *d = null_;
    err(9L);
    return;
  }
  if (*r == null_)
    return;
  pointr(*r, &y.sa);
  if (y.snd->dtype == number) {
    WITH = x.snd;
    WITH->val += y.snd->val;
  } else {  /* not number */
    *d = null_;
    err(10L);
  }

  /* a */
  /* a */
}  /* add */


Void arithm(op)
long op;
{
  /* kod operacii */
  /*======================================*/
  /* operacii + - * div mod               */
  /*      > < >= <=                       */
  /* whod:    v[base -2]  v[base -1]      */
  /*              a1        a2            */
  /* wyhod:   v[base -2]   oswob.         */
  /*           a1 op a2                   */
  /*======================================*/
  /* wyhod */

  mpd x;
  longint n[2];   /* changed 17-nov-90 */
  a rez;
  aa a_adr[2];
  char dts[2];

  longint k;
  long j;

  rez = null_;
  for (k = 2; k >= 1; k--) {
    getval(&v[base - k - 1]);
    if (v[base - k - 1] == null_) {
      n[2 - k] = 0;
      dts[2 - k] = dummy;
      /* a_adr - not used ! */
    } else {
      pointr(v[base - k - 1], &x.sa);

      dts[2 - k] = x.snd->dtype;
      if (dts[2 - k] == number)
	n[2 - k] = x.snd->val;
      else
	n[2 - k] = 0;
      a_adr[2 - k] = x.sad->name;
    }
  }





  if (dts[0] == dummy && dts[1] == dummy || dts[0] == number ||
      dts[1] == number) {
    if (op == cgt && n[0] > n[1] || op == clt && n[0] < n[1] ||
	op == cge && n[0] >= n[1] || op == cle && n[0] <= n[1])
      rez = atomt;
    else {  /* arifmetika */
      if (op >= cmult && op <= cminus) {  /* sozdatx atom rezulxtata */
	gets1(&rez, &x.sa);
	if (op == cadd)
	  k = n[0] + n[1];
	else if (op == cminus)
	  k = n[0] - n[1];
	else if (op == cmult)
	  k = n[0] * n[1];
	else if (op == cdiv)
	  k = n[0] / n[1];
	else if (op == cmod) {
	  k = n[0] % n[1];
/* p2c: erm.z, line 1070:
 * Note: Using % for possibly-negative arguments [317] */
	}
	x.snd->dtype = number;
	x.snd->val = k;
      }
    }

  } else {
    if (op >= cmult && op <= cminus) {
      gets1(&rez, &x.sa);
      x.snd->dtype = number;
      x.snd->val = 0;
    } else {  /* operations cgt,cge,clt.cle only */

      if (((1L << ((long)dts[0])) &
	   ((1L << ((long)atom)) | (1L << ((long)idatom)) |
	    (1L << ((long)keyword)) | (1L << ((long)tatom)))) != 0) {
	if (((1L << ((long)dts[1])) &
	     ((1L << ((long)atom)) | (1L << ((long)idatom)) |
	      (1L << ((long)keyword)) | (1L << ((long)tatom)))) != 0) {
	  switch (op) {

	  case clt:
	    j = 1;
	    break;

	  case cle:
	    j = 2;
	    break;

	  case cgt:
	    j = 3;
	    break;

	  case cge:
	    j = 4;
	    break;
	  }

	  if (compatom(j, a_adr[0], a_adr[1]))
	    rez = atomt;
	} else {
	  if (dts[1] == dummy) {
	    if (op == cgt || op == cge)
	      rez = atomt;
	  }
	}


      } else {
	if (dts[0] == dummy) {
	  if (((1L << ((long)dts[1])) &
	       ((1L << ((long)atom)) | (1L << ((long)idatom)) |
		(1L << ((long)keyword)) | (1L << ((long)tatom)))) != 0) {
	    if (op == clt || op == cle)
	      rez = atomt;
	  }
	}
      }
    }

  }

_L33:
  base--;
  v[base - 2] = rez;



}















Void unmins()
{
  mpd x, y;
  a rez;

  getval(&v[base - 2]);
  if (v[base - 2] == null_)
    goto _L99;
  pointr(v[base - 2], &y.sa);
  if (y.snd->dtype != number) {
    v[base - 2] = null_;
    goto _L99;
  }
  gets1(&rez, &x.sa);
  *x.snd = *y.snd;
  x.snd->val = -y.snd->val;   /* del sign change 3-oct-89 */
  v[base - 2] = rez;
_L99: ;
}  /* unmins*/


/* Local variables for bltin: */
struct LOC_bltin {
  long l;
} ;

Local long alen(k, LINK)
long k;
struct LOC_bltin *LINK;
{
  bl80 m;
  a t;


  t = k;
  pointa(t, m, &LINK->l);   /* [1] ibm/pc */
  return LINK->l;
}  /* alen */


Void bltin(rez, success, pl, n)
long *rez;
boolean *success;
ptr_ *pl;
long n;
{
  /* 1-j argument */
  /* nomer wstr.prawila */
  /*===========================*/
  /* wyzow wstroennogo prawila */
  /*===========================*/
  struct LOC_bltin V;
  /* wyhod */

  char rulenum;
  a k, s;
  mpd x, y;
  long t;
  longint li_;   /* 12- mar -91 */
  bl80 mm;
  numberdescriptor *WITH;
  atomdescriptor *WITH1;
  specdescriptor *WITH2;
  long FORLIM;


  rulenum = n;
  k = pl->cel;
  if ((k & 511) != 0 || k >= 65535L || k < 0)
    pointr(k, &x.sa);
  *success = true;
  *rez = k;
  switch (rulenum) {

  case 1:   /* #implode */
    implode(pl, rez);
    break;

  case 2:   /* #explode */
    if (k == null_)
      goto _L99;
    if (((1L << ((long)x.sad->dtype)) &
	 ((1L << ((long)fatom + 1)) - (1L << ((long)atom)))) != 0)
      explode(k, rez);
    else
      *success = false;
    break;

  case 3:   /* #atom */
    if (k == null_)
      goto _L99;
    *success = (((1L << ((long)x.sad->dtype)) &
		 ((1L << ((long)fatom + 1)) - (1L << ((long)atom)))) != 0);
    break;

  case 4:   /* #number */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == number);
    break;

  case 5:   /* #ident */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == idatom);
    break;

  case 6:   /* #list */
    if (k == null_)
      goto _L99;
    *success = (x.sad->dtype == listmain);
    break;

  case 7:   /* #tree */
    if (k == null_)
      goto _L99;
    *success = (x.sad->dtype == treemain);
    break;

  case 8:   /* #tatom */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == tatom);
    break;

  case 9:   /* #fatom */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == fatom);
    break;

  case 10:   /* #_keyword */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == keyword);
    break;

  case 11:   /* #_specdesc */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == spec);
    break;

  case 12:   /* #len */
    if (k == null_)
      *rez = 0;
    else {
      switch (x.sad->dtype) {

      case atom:
      case idatom:
      case keyword:
      case tatom:
      case fatom:
	*rez = alen(x.sad->name, &V);
	break;

      case number:
	/* pods~itatx ~islo zna~.cifr */
	li_ = x.snd->val;
	t = 0;
	while (li_ != 0) {
	  li_ /= 10;
	  t++;
	}
	if (t == 0)
	  t = 1;
	if (x.snd->val < 0)
	  t++;
	*rez = t;
	break;
	/* number */

      case listmain:
	*rez = x.smld->totalelnum;
	break;

      case treemain:
	*rez = x.smtd->totalarcnum;
	break;



      default:
	*rez = 0;
	break;
      }/* case */
    }
    gets1(&k, &x.sa);
    WITH = x.snd;
    WITH->dtype = number;
    WITH->val = *rez;
    *rez = k;
    break;
    /* #len */

  case 13:   /* #_specatom */
    if ((k & 511) != 0 || k >= 65535L || k < 0)
      *success = false;
    break;

  case 14:   /* #_rulename */
    if (k == null_)
      *success = false;
    else
      *success = (x.sad->dtype == rulename);
    break;

  case 15:   /* #_varname */
    if (k == null_)
      *success = false;
    else {
      *success = (((1L << ((long)x.sad->dtype)) &
	    ((1L << ((long)fvariable + 1)) - (1L << ((long)variable)))) != 0);
      points(k, &x.sa);
      x.svd->guard = true;
    }
    break;

  case 16:
  case 17:   /* #_ruletoatom, #_varntoatm */
    if (k == null_)
      *success = false;
    else {
      if (x.srd->dtype == rulename && rulenum == 16 ||
	  (((1L << ((long)x.svd->dtype)) &
	    ((1L << ((long)fvariable + 1)) - (1L << ((long)variable)))) != 0 &&
	   rulenum == 17)) {
	gets1(&s, &y.sa);
	WITH1 = y.sad;
	WITH1->dtype = idatom;
	if (rulenum == 16)   /* !!! vax !!! */
	  WITH1->name = x.srd->name;
	else
	  WITH1->name = x.svd->name;
	*rez = s;
      } else
	*success = false;
    }
    break;

  case 18:   /* #_vardesloc */
    if (((1L << ((long)x.svd->dtype)) &
	 ((1L << ((long)fvariable + 1)) - (1L << ((long)variable)))) != 0) {
      next(pl);
      s = pl->cel;
      pointr(s, &y.sa);
      points(k, &x.sa);
      x.svd->location = y.snd->val;
    } else
      *success = false;
    break;

  case 19:   /* #debug */
    if (eqatoms(pl->cel, atomrules)) {
      /*
           rules */
      debugrule = true;
    } else if (eqatoms(pl->cel, atomnorules)) {
      /* norules */
      debugrule = false;
    }
    break;

  case 20:   /* #_spectodsc */
    gets1(&s, &y.sa);
    if ((k & 511) == 0 && k < 65535L && k >= 0) {
      WITH2 = y.sspec;
      WITH2->dtype = spec;
      WITH2->val = k;
    } else
      *y.sspec = *x.sspec;
    *rez = s;
    break;

  case 21:   /* _content2 */
    if ((k & 511) == 0 && k < 65535L && k >= 0)
      *success = false;
    else {
      s = x.snd->val;
      gets1(&k, &x.sa);
      WITH = x.snd;
      WITH->dtype = number;
      WITH->val = s;

      *rez = k;
    }
    break;
    /* _content2 */

  case 22:   /* #chr */
    if ((k & 511) == 0 && k < 65535L && k >= 0) {
      *rez = null_;
      *success = false;
    } else if (x.snd->dtype != number || x.snd->val > 255 || x.snd->val < 0) {
      *rez = null_;
      *success = false;
    } else {
      t = x.snd->val;
      mm[0] = (Char)t;
      V.l = 1;
      putatm(mm, V.l, &s);
      gets1(&k, &x.sa);
      WITH1 = x.sad;
      if (is_rig_letter((int)t))
	WITH1->dtype = idatom;
      else
	WITH1->dtype = atom;
      WITH1->name = s;
      *rez = k;
    }
    break;
    /* chr */

  case 23:   /* parameter */
    *rez = null_;
    FORLIM = run_param_cnt;
    for (V.l = 1; V.l <= FORLIM; V.l++) {  /* see glovar.pas */
      printf(" %s", run_param_array[V.l - 1]);
      lconc(rez, str_to_atom(run_param_array[V.l - 1]));
    }
    putchar('\n');
    break;

  case 24:   /* #_totatom */
    if (k == null_)
      *success = false;
    else {
      gets1(&s, &y.sa);
      WITH1 = y.sad;
      WITH1->dtype = tatom;
      WITH1->name = x.sad->name;
      WITH1->flags = 0;
      *rez = s;
    }
    break;

  case 25:   /* #ord */
    if ((k & 511) == 0 && k < 65535L && k >= 0)
      goto _L99;
    if (((1L << ((long)x.sad->dtype)) &
	 (((1L << ((long)keyword + 1)) - (1L << ((long)atom))) |
	  (1L << ((long)tatom)))) != 0) {
      s = x.sad->name;
      pointa(s, mm, &V.l);
      gets1(&k, &y.sa);
      WITH = y.snd;
      WITH->dtype = number;
      WITH->val = mm[0];
      *rez = k;
    } else
      *success = false;
    break;
    /* ord */

  case 26:   /* call_pas */
    if ((k & 511) == 0 && k < 65535L && k >= 0) {
      *rez = null_;
      goto _L99;
    }
    if (x.snd->dtype != number) {
      *rez = null_;
      goto _L99;
    }
    next(pl);
    if (debugrule) {
      if (out_screen)
	printf("(%12ld)", x.snd->val);
      else
	fprintf(out, "(%12ld)", x.snd->val);
    }
    usepas(x.snd->val, pl, rez);
    break;



  }/* case */
_L99:
  if (*success) {
    if (pl->ptrtype != ptrtree)
      next(pl);
  } else
    *rez = null_;
}


boolean compnames(p, ld)
long p, ld;
{
  /* adres w sr-prostr. (<>0) deskr.atoma */
  /*    ili peremennoj w {ablone    */
  /* adres w st-prostr. (<>0) glawnogo */
  /* fragmenta deskr.spiska */
  /*=======================================*/
  /* esli r -atom, prowerqet rawen  li on  */
  /* imeni spiska(derewa) ld, da -true     */
  /*                         net -false    */
  /* esli r-peremennaq, to priswaiwaet ej  */
  /* imq  ili null, esli imeni             */
  /* net, wozwr. true.                     */
  /*=======================================*/
  boolean Result;
  mpd x, y;
  a w;


  pointr(p, &x.sa);
  /* polu~itx dostup k deskr. atoma ili peremennoj */
  Result = false;
  if (ld == null_)
    return Result;
  pointr(ld, &y.sa);
  /* polu~itx dostup k deskr.spiska */
  if (((1L << ((long)x.sad->dtype)) &
       ((1L << ((long)fatom + 1)) - (1L << ((long)atom)))) != 0)
  {  /* atom */
    w = y.smld->name;
    if ((w & 511) == 0 && w < 65536L && w >= 0) {
      /* u spiska net imeni */
      return false;
    }
    /* posmotretx deskr. imeni (atom ili spisok) */
    pointr(w, &y.sa);
    if (((1L << ((long)y.sad->dtype)) &
	 ((1L << ((long)fatom + 1)) - (1L << ((long)atom)))) != 0)
      return (eqatoms(p, w));
    return Result;
  }  /* atom */
  if (x.sad->dtype != spec) {
    v[mybase + x.svd->location - 1] = y.smld->name;
    /* peremennoj priswoitx spisok imen iz y.smld^.name */
    return true;
  }  /* specadres */

  /* specadres */
  w = y.smld->name;
  if ((w & 511) == 0 && w < 65536L && w >= 0)
    return (w == x.sspec->val);
  return Result;

  /* w {ablone - peremennaq */
}


Void concop(a1, a2)
long *a1, a2;
{
  /*======================================*/
  /* operaciq  a1 !! a2                   */
  /*       ( a1 !! a2 ) -> a1             */
  /*======================================*/
  /* wyhod */

  mpd x;
  ptr_ p1;
  a l;


  l = *a1;
  if (a2 == null_) {
    if (l == null_)
      goto _L99;
    else {
      pointr(l, &x.sa);
      if (x.smld->dtype == listmain)
	goto _L99;
      else {
	l = null_;
	goto _L99;
      }
    }
  }
  pointr(a2, &x.sa);
  if (x.smld->dtype != listmain) {
    l = null_;
    goto _L99;
  }
  if (l != null_) {
    pointr(l, &x.sa);
    if (x.smld->dtype != listmain) {
      l = null_;
      goto _L99;
    }
  }
  first(a2, &p1);
  while (p1.nel != 0) {
    lconc(&l, p1.cel);
    next(&p1);
  }
_L99:
  *a1 = l;
}  /* concop */


Void copyop()
{
  /*======================*/
  /*      v[base -1]      */
  /*whod:         a       */
  /*wyhod:  copy( a )     */
  /*======================*/
  /* wyhod */

  long k;
  mpd x, y, z;
  a r1, r2, r3;


  getval(&v[base - 2]);
  if (v[base - 2] == null_)
    goto _L99;
  pointr(v[base - 2], &x.sa);
  switch (x.sad->dtype) {

  case atom:
  case idatom:
  case keyword:
  case number:
  case tatom:
  case fatom:
  case variable:
  case idvariable:
  case nvariable:
  case fvariable:
  case spec:   /* coord removed */
    gets1(&r1, &y.sa);
    *y.sad = *x.sad;
    v[base - 2] = r1;
    break;

  case rulename:
  case object_d:
    gets2(&r1, &y.sa);
    *y.srd = *x.srd;
    v[base - 2] = r1;
    break;

  case listmain:
  case treemain:
    gets5(&r1, &y.sa);
    /* skopirowatx glawnyj deskriptor */
    *y.smld = *x.smld;
    v[base - 2] = r1;
    r2 = x.smld->next;
    while (r2 != null_) {
      pointr(r2, &x.sa);
      gets5(&r3, &z.sa);
      *z.smld = *x.smld;
      points(r1, &y.sa);
      y.smld->next = r3;
      r1 = r3;
      r2 = z.smld->next;
    }  /* while */
    break;

  }/* case */
_L99: ;   /* wyhod */
}  /* copyop */


Void epilog()
{
  long iii;
  longint dr, dw, dp;


  for (iii = 0; iii < filenum; iii++) {
    if (filetab[iii].isopen) {
      if (filetab[iii].screen)
	putchar('\n');
      else {
	putc('\n', files[iii]);
	if (files[iii] != NULL)
	  fclose(files[iii]);
	files[iii] = NULL;
      }



    }
  }
  printf("\n========== End of execution ==========\n");
  vola(&dr, &dw, &dp);
  if (dr + dw + dp > 0)
    printf("A-Space:%12ld/%12ld/%12ld pages \n", dr, dw, dp);
  vols(&dr, &dw, &dp);
  if (dr + dw + dp > 0)
    printf("S-Space :%12ld reads %12ld writes %12ld pages \n", dr, dw, dp);
  if (out_open) {
    if (out != NULL)
      fclose(out);
    out = NULL;
  }

  closea();
  closes();
}  /* epilog */



Void eqop(o)
long o;
{
  /* cequ(=), cnequ(<>) */
  /*====================================*/
  /*   rawenstwo/ nerawenstwo obxektow  */
  /* whod: v[base -2]     v[base -1]    */
  /*       a1             a2            */
  /* wyhod:  t / null     oswob.        */
  /*====================================*/
  boolean rez;


  getval(&v[base - 3]);
  getval(&v[base - 2]);
  eqop1(o, v[base - 3], v[base - 2], &rez);
  if (rez && o == cequ || !rez && o == cnequ)
    v[base - 3] = atomt;
  else
    v[base - 3] = null_;
  base--;
}  /* eqop */


Void eqop1(o, a1, a2, rez1)
long o, a1, a2;
boolean *rez1;
{
  /* cequ(=), cnequ(<>) */
  /*====================================*/
  /*   rawenstwo/ nerawenstwo obxektow  */
  /* whod: a1             a2            */
  /* wyhod:  true / false w rez1        */
  /*====================================*/
  /*wyhod */

  mpd x, y;
  boolean rez;
  ptr_ px, py;



  rez = true;
  if (a2 == null_) {
    if (a1 == null_)
      goto _L1;
    else {
      pointr(a1, &x.sa);
      rez = (((1L << ((long)x.smld->dtype)) &
	      ((1L << ((long)listmain)) | (1L << ((long)treemain)))) != 0 &&
	     x.smld->totalelnum == 0);
      goto _L1;
    }
  }  /* a2 =null */
  /* oba ne null */

  pointr(a2, &x.sa);
  if (a1 == null_) {
    rez = (((1L << ((long)x.smld->dtype)) &
	    ((1L << ((long)listmain)) | (1L << ((long)treemain)))) != 0 &&
	   x.smld->totalelnum == 0);
    goto _L1;
  }
  pointr(a1, &y.sa);
  switch (x.smld->dtype) {

  case variable:
  case idvariable:
  case nvariable:
  case fvariable:
  case spec:
  case rulename:   /* coord removed */
    rez = (memcmp(x.sc8, y.sc8, sizeof(atomdescriptor)) == 0);
    break;

  case number:
    /* added 20-jul-1989 in pc/at, changed 3-oct sign */
    rez = (y.snd->dtype == number && x.snd->val == y.snd->val);
    break;



  case atom:
  case idatom:
  case keyword:
  case tatom:
    rez = (((1L << ((long)y.sad->dtype)) & (((1L << ((long)keyword + 1)) -
		(1L << ((long)atom))) | (1L << ((long)tatom)))) != 0 &&
	   x.sad->name == y.sad->name);
    break;

  case fatom:
    rez = (y.sad->dtype == fatom && x.sad->name == y.sad->name);
    break;

  case listmain:
    rez = (x.smld->totalelnum == y.smld->totalelnum &&
	   y.smld->dtype == listmain);
    if (rez) {
      first(a1, &px);
      first(a2, &py);
      while (rez && px.nel != 0) {
	eqop1(o, px.cel, py.cel, &rez);
	next(&px);
	next(&py);
      }  /* while */
    }
    break;

  case treemain:
    rez = (x.smtd->totalarcnum == y.smtd->totalarcnum &&
	   y.smtd->dtype == treemain);
    if (rez) {
      first(a1, &px);
      while (rez && px.nel != 0) {
	first(a2, &py);
	while (py.nel != 0 && px.UU.U1.arc != py.UU.U1.arc)
	  next(&py);
	if (py.nel == 0)
	  rez = false;
	else
	  eqop1(o, px.cel, py.cel, &rez);
	next(&px);
      }  /* while */
    }
    break;
  }/* case */
_L1:

  *rez1 = rez;

  /* a2 <>null */
}  /* eqop */


Void explode(kk, rez)
long kk, *rez;
{
  /*=====================================*/
  /* sozdaet spisok odnobukwennyh atomow */
  /*=====================================*/
  a s, k;
  mpd x;
  longint l;   /* changed fron integer 17-nov-90 */
  string80 str_val;
  Char STR1[256];
  long FORLIM;

  *rez = null_;
  if (kk == null_)
    goto _L99;

  pointr(kk, &x.sa);
  switch (x.sad->dtype) {

  case fatom:   /* added 17-feb-92 */
    real_to_string(str_val, take_fatom(x.sad->name));
    break;

  case number:
    long_to_str(str_val, x.snd->val);
    break;

  case 5:
  case 6:
  case 7:
  case tatom:
    aa_str(str_val, x.sad->name);
    break;



  default:
    goto _L99;
    break;
  }/* case */
  /* w m sformirowan massiw simwolow */
  s = null_;   /* rez.spisok */
  FORLIM = strlen(str_val);
  for (l = 0; l < FORLIM; l++) {
    sprintf(STR1, "%c", str_val[l]);
    k = str_to_textatom(STR1);
    lconc(&s, k);
  }  /* for */
  *rez = s;
_L99: ;
}  /* explode */


#define max_digit       10   /* maximum for longint type */


/* Local variables for implode: */
struct LOC_implode {
  bl80 m, m1;
  mpd x;
  a k;
  long p1;   /* posledn.zanqtyj |l-t w m1 */
  string80 str_val;
} ;

Local Void pass(pl, LINK)
ptr_ *pl;
struct LOC_implode *LINK;
{
  ptr_ pl1;
  long t, l;

  while (pl->nel != 0) {
    LINK->k = pl->cel;
    if (LINK->k != null_) {
      pointr(LINK->k, &LINK->x.sa);
      if (LINK->x.smld->dtype == listmain) {
	first(LINK->k, &pl1);   /*, st */
	pass(&pl1, LINK);
      } else {  /* not list */
	if (((1L << ((long)LINK->x.sad->dtype)) &
	     ((1L << ((long)fatom + 1)) - (1L << ((long)atom)))) == 0)
	  goto _L99;

	if (LINK->x.sad->dtype == fatom) {   /* added 17-feb-92 */
	  real_to_string(LINK->str_val, take_fatom(LINK->x.sad->name));
	  l = strlen(LINK->str_val);
	  if (LINK->p1 + l > 80) {
	    err(25L);
	    goto _L99;
	  }
	  for (t = 0; t < l; t++)
	    LINK->m1[LINK->p1 + t] = LINK->str_val[t];
	  LINK->p1 += l;
	} else {
	  if (((1L << ((long)LINK->x.sad->dtype)) &
	       (((1L << ((long)keyword + 1)) - (1L << ((long)atom))) |
		(1L << ((long)tatom)))) != 0) {
	    /* wzqtx atom iz a-prostranstwa w m */
	    LINK->k = LINK->x.sad->name;
	    pointa(LINK->k, LINK->m, &l);   /* [1] ibm/pc */
	    if (LINK->p1 + l > 80) {
	      err(25L);
	      goto _L99;
	    }
	    for (t = 0; t < l; t++)
	      LINK->m1[LINK->p1 + t] = LINK->m[t];
	    LINK->p1 += l;
	  } else {  /* number */
	    /*==============================*/
	    /* perewesti ~islo w simwoly i  */
	    /* pomestitx w m [1..max_digit]         */
	    /*==============================*/
	    LINK->k = LINK->x.snd->val;
	    if (LINK->k < 0)   /* changed from abs call */
	      LINK->k = -LINK->k;
	    for (t = max_digit - 1; t >= 0; t--) {
	      l = LINK->k % 10;
/* p2c: erm.z, line 1925:
 * Note: Using % for possibly-negative arguments [317] */
	      LINK->k /= 10;
	      LINK->m[t] = (Char)(l + '0');
	    }
	    t = 1;
	    while (t < max_digit && LINK->m[t - 1] == '0')
	      t++;
	    if (LINK->x.snd->val < 0) {
	      if (LINK->p1 == 80) {
		err(25L);
		goto _L99;
	      }
	      LINK->p1++;
	      LINK->m1[LINK->p1 - 1] = '-';
	    }
	    if (LINK->p1 + max_digit - t > 79) {
	      err(25L);
	      goto _L99;
	    }
	    for (l = t - 1; l < max_digit; l++) {
	      LINK->p1++;
	      LINK->m1[LINK->p1 - 1] = LINK->m[l];
	    }
	  }  /* number */
	}
      }  /* not list */
    }  /* k<> null */
    next(pl);
  }  /* while */
_L99: ;


}  /* pass */


Void implode(pl, rez)
ptr_ *pl;
long *rez;
{
  /* 1-j argument */
  /*======================================*/
  /* skleiwanie  atomow a1 a2 ... an  do  */
  /* perwogo, otli~nogo ot atoma ili null */
  /*======================================*/
  struct LOC_implode V;
  longint l;
  /* rab. */
  /* change from integer 17-nov-90*/
  boolean id;
  long FORLIM;
  atomdescriptor *WITH;


  V.p1 = 0;
  pass(pl, &V);
  if (V.p1 == 0) {
    *rez = null_;
    return;
  }
  putatm(V.m1, V.p1, &V.k);
  id = is_rig_letter(V.m1[0]);
  FORLIM = V.p1;
  for (l = 0; l < FORLIM; l++)
    id &= is_rig_symbol(V.m1[l]);
  l = 1;
  gets1(rez, &V.x.sa);
  WITH = V.x.sad;
  if (id)
    WITH->dtype = idatom;
  else
    WITH->dtype = atom;
  WITH->name = V.k;

  /* zapisatx nowyj atom w a-prostr. */

}

#undef max_digit


Void indxop()
{
  /*==============================================*/
  /* whod:        v[base-2]       v[base-1]       */
  /*              l               x               */
  /* wyhod:       l[ x ]          oswoboditx      */
  /*                                              */
  /*   esli l -object, to i rezulxtat - object    */
  /*  l[ -1 ]  - poslednij |l-t spiska            */
  /*  l[ -2 ]  - predposlednij |l-t spiska  ...   */
  /*==============================================*/
  /* wyhod */

  mpd x, y, z;
  long k, n;
  a r, t;
  boolean wasobject, mainlist;
  objdescriptor *WITH;


  getval(&v[base - 2]);
  if (v[base - 2] == null_) {
    err(5L);
    v[base - 3] = null_;
    goto _L1;
  }
  /* proweritx, ~to x -~islo */
  pointr(v[base - 2], &x.sa);
  if (x.snd->dtype != number) {
    err(3L);
    v[base - 3] = null_;
    goto _L1;
  }
  n = x.snd->val;
  /* delete sign proc.*/
  wasobject = false;
  getval(&v[base - 3]);
  if (v[base - 3] == null_)   /* rezulxtat= null */
    goto _L1;
  /* opredelitx tip l */
  pointr(v[base - 3], &z.sa);
  if (z.smld->dtype == listmain)
    y = z;
  else {
    if (z.smld->dtype != object_d) {
      err(4L);
      v[base - 3] = null_;
      goto _L1;
    }
    wasobject = true;
    if (z.sobj->variable_)
      t = v[z.sobj->fragmorvar - 1];
    else {
      t = z.sobj->fragmorvar;
      pointr(t, &x.sa);
      switch (x.smld->dtype) {

      case listmain:
      case listfragm:
	t = x.sfld->elt[z.sobj->nel - 1];
	break;

      /* ****** very strange ******* */
      case treemain:
	t = x.smtd->arc[z.sobj->nel - 1].elt;
	break;

      case treefragm:
	t = x.sftd->arc[z.sobj->nel - 1].elt;
	break;
      }/* case */
    }
    /* t ukazywaet na glawn. deskriptor spiska */
    if (t == null_) {
      v[base - 3] = null_;
      goto _L1;
    }
    pointr(t, &y.sa);
    if (y.smld->dtype != listmain) {
      err(4L);
      v[base - 3] = null_;
      goto _L1;
    }
  }  /* object */
  /*============================================*/
  /* y ukazywaet na deskriptor glawnogo spiska  */
  /* z - na object, esli takoj byl              */
  /*============================================*/
  /* wy~islenie l[x] */
  k = y.smld->totalelnum;
  if (n < 0)
    n += k + 1;
  if (n < 1 || n > k) {
    err(5L);
    /*  indeks wne spiska */
    v[base - 3] = null_;
    goto _L1;
  }
  /*================================*/
  /* poisk |l-ta spiska             */
  /*================================*/
  if (n <= y.smld->elnum) {
    mainlist = true;
    r = y.smld->elt[n - 1];
  } else {
    mainlist = false;
    n -= y.smld->elnum;
    t = y.smld->next;
    pointr(t, &y.sa);
    while (n > y.sfld->elnum) {
      n -= y.sfld->elnum;
      t = y.sfld->next;
      pointr(t, &y.sa);
    }
    r = y.sfld->elt[n - 1];
  }
  /* w r rezulxtat = l [ x ]  */
  if (wasobject) {
    points(v[base - 3], &z.sa);
    WITH = z.sobj;
    WITH->variable_ = false;
    if (mainlist)
      WITH->nel = n + 2;
    else
      WITH->nel = n;
    WITH->fragmorvar = t;   /* with */
  }  /* wasobject */
  else
    v[base - 3] = r;
_L1:
  base--;

  /* o{ibka */
}  /* indxop */


Void nameop()
{
  /*================================================*/
  /* operaciq  a :: l                               */
  /* whod:      v[base-2]       v[base-1]           */
  /*              a               l ili t           */
  /* wyhod:       a::l            oswoboditx        */
  /*                                                */
  /*================================================*/
  /* wyhod */

  mpd x, y;


  getval(&v[base - 2]);
  if (v[base - 2] == null_) {
    v[base - 3] = null_;
    goto _L1;
  }
  getval(&v[base - 3]);
  /* if v[base - 2] = null then
     goto 1; */
  /* deleted 23-1-1992 for null::<.a:b.> <> null */
  if ((v[base - 3] & 511) != 0 || v[base - 3] >= 65536L || v[base - 3] < 0) {
    pointr(v[base - 3], &y.sa);
    /*   dostup k atomu  */
    if (((1L << ((long)y.sad->dtype)) &
	 (((1L << ((long)fatom + 1)) - (1L << ((long)atom))) |
	  (1L << ((long)spec)))) == 0) {
      err(7L);
      v[base - 3] = null_;
      goto _L1;
    }
  }
  points(v[base - 2], &x.sa);
  /*  polu~itx deskriptor spiska (derewa) */
  if (((1L << ((long)x.smld->dtype)) &
       ((1L << ((long)listmain)) | (1L << ((long)treemain)))) == 0) {
    err(6L);
    v[base - 3] = null_;
    goto _L1;
  }
  x.smld->name = v[base - 3];
  v[base - 3] = v[base - 2];
_L1:
  base--;
}


Void prolog(y, debug, code)
ptr_ *y;
boolean debug;
long code;
{
  /*===============*/
  /* inicializaciq */
  /*===============*/
  long k, k1;
  mpd x;
  long iii;
  Char m[10];
  a rez, s;
  atomdescriptor *WITH;

  k = 1;
  vs[0] = code;
  debugrule = debug;
  base = 1;
  sbase = 1;
  /* w na~ale wse fajly zakryty */
  for (iii = 0; iii < filenum; iii++)
    filetab[iii].isopen = false;
  /* sozdatx atom t */
  m[0] = 'T';
  k1 = 1;
  putatm(m, k1, &s);
  gets1(&atomt, &x.sa);
  WITH = x.sad;
  WITH->dtype = idatom;
  WITH->name = s;
  v[base - 1] = atomt;
  base++;
  /* ~toby ne propal pri sborke musora */
  m[0] = 'R';
  m[1] = 'U';
  m[2] = 'L';
  m[3] = 'E';
  m[4] = 'S';
  k1 = 5;
  putatm(m, k1, &s);
  gets1(&atomrules, &x.sa);
  WITH = x.sad;
  WITH->dtype = idatom;
  WITH->name = s;
  v[base - 1] = atomrules;
  base++;

  m[0] = 'N';
  m[1] = 'O';
  m[2] = 'R';
  m[3] = 'U';
  m[4] = 'L';
  m[5] = 'E';
  m[6] = 'S';
  k1 = 7;
  putatm(m, k1, &s);
  gets1(&atomnorules, &x.sa);
  WITH = x.sad;
  WITH->dtype = idatom;
  WITH->name = s;
  v[base - 1] = atomnorules;
  base++;

  /* wojti w s-kod rigal */
  first(vs[0], y);
  next(y);   /* mybase */
  rez = y->cel;
  points(rez, &x.sa);
  mybase = base - 1;
  x.snd->val = mybase;
  next(y);   /* ~islo lok.peremennyh */
  rez = y->cel;
  pointr(rez, &x.sa);
  base += x.snd->val + 1;
  /* inicializaciq lok.per. glawn.progr. */
  for (iii = mybase; iii < varnum; iii++)
    v[iii] = null_;
  next(y);
  fail = false;
  break_ = false;
  continue_ = true;
  teklexem = null_;

  printf("=========Start  of execution ==========\n");

}  /* prolog */










Void selctr()
{
  /*==============================================*/
  /* whod:        v[ base -2 ]    v[ base -1 ]    */
  /*                      t               x       */
  /* wyhod:       v[ base -2]                     */
  /*                t.x           oswoboditx      */
  /*      esli t- object, to i rezulxtat -object  */
  /*==============================================*/
  /* wyhod */

  mpd x, y, z;
  a n;   /* imq selektora */
  a t, glavnder;   /* s-adr.glawn.derewa */
  long ai, i;
  boolean wasobject;
  maintreedescriptor *WITH;
  long FORLIM;
  fragmtreedescriptor *WITH1;
  objdescriptor *WITH2;


  getval(&v[base - 2]);
  if (v[base - 2] == null_) {
    err(21L);
    v[base - 3] = null_;
    goto _L1;
  }
  /* prowerim, ~to x -ne~islowoj atom */
  pointr(v[base - 2], &x.sa);
  if (x.sad->dtype != idatom) {
    err(22L);
    v[base - 3] = null_;
    goto _L1;
  }
  n = x.sad->name;
  wasobject = false;
  getval(&v[base - 3]);
  if (v[base - 3] == null_)
    goto _L1;
  /* rezulxtat =null */

  /* opredelitx tip t */
  pointr(v[base - 3], &z.sa);
  if (z.smtd->dtype == treemain)
    y = z;
  else {
    if (z.smtd->dtype != object_d) {
      err(23L);
      v[base - 3] = null_;
      goto _L1;
    }

    wasobject = true;
    if (z.sobj->variable_)
      t = v[z.sobj->fragmorvar - 1];
    else {
      t = z.sobj->fragmorvar;
      pointr(t, &x.sa);
      switch (x.smld->dtype) {

      case listmain:
      case listfragm:
	t = x.sfld->elt[z.sobj->nel - 1];
	break;

      case treemain:
	t = x.smtd->arc[z.sobj->nel - 1].elt;
	break;

      case treefragm:
	t = x.sftd->arc[z.sobj->nel - 1].elt;
	break;
      }/* case */
    }
    if (t == null_) {
      v[base - 3] = null_;
      goto _L1;
    }
    /* added 20-jul-1989 in pc/at from 10-jul-89 on vax */

    pointr(t, &y.sa);
    if (y.smtd->dtype != treemain) {
      err(23L);
      v[base - 3] = null_;
      goto _L1;
    }
  }

  /*=====================================*/
  /*  y ukazywaet na glawn.deskr. derewa */
  /*  z  na object, esli takoj byl       */
  /*  t  na deskr.glawn. derewa          */
  /*=====================================*/
  glavnder = t;   /* sna~ala w glawnom derewe */
  /* wy~islenie y.x               */
  /* poisk selektora n w derewe y */

  WITH = y.smtd;   /* with */
  FORLIM = WITH->arcnum;
  for (i = 1; i <= FORLIM; i++) {
    if (WITH->arc[i - 1].arcname == n) {   /* na{li */
      ai = i;
      n = WITH->arc[i - 1].elt;
      goto _L2;
    }
  }
  t = WITH->next;
  /* prodolvaem poisk w fragmentah */
  while (t != null_) {
    pointr(t, &y.sa);
    WITH1 = y.sftd;
    FORLIM = WITH1->arcnum;
    for (i = 1; i <= FORLIM; i++) {
      if (WITH1->arc[i - 1].arcname == n) {   /* na{li */
	ai = i;
	n = WITH1->arc[i - 1].elt;
	goto _L2;
      }
    }
    t = WITH1->next;   /* with */
  }  /* while */

  /* ne na{li !  */
  v[base - 3] = null_;
  goto _L1;
_L2:   /* na{li */
  /*==============================*/
  /* w n -rezulxtat t.x           */
  /* w ai -nomer w arc[...]       */
  /* w t  -s-ssylka na fragment   */
  /*==============================*/
  if (wasobject) {
    points(v[base - 3], &z.sa);
    WITH2 = z.sobj;
    WITH2->variable_ = false;
    WITH2->nel = ai;
    WITH2->fragmorvar = t;
    WITH2->glavn = glavnder;
    /* with */
  }  /* wasobject */
  else
    v[base - 3] = n;
_L1:
  base--;

  /* t ukazywaet na glawn.deskriptor derewa */
  /* o{ibka */
}  /* selctr */


Void int11(debug, code)
boolean debug;
long code;
{
  ptr_ y;
  boolean success;
  a rez;

  /* inicializaciq */
  prolog(&y, debug, code);
  /* osnownoj cikl */

  success = true;
  while (y.cel != null_ && continue_) {
    statement(y.cel, &success, &rez);
    next(&y);
  }
  epilog();
}


Void push()
{
  /*========================================*/
  /* zanqtx w steke peremennu`, nomer       */
  /* per. (base - 1)                        */
  /*========================================*/
  base++;
  if (base > varnum)
     {err(1L); epilog();exit(1); } /* VADIM CHANGED 8/6/95 */
}


Void pratom(aa_)
long aa_;
{
  /* pe~atx atoma */
  bl80 m;
  long s, l;
  a k;

  k = aa_;
  pointa(k, m, &l);   /* ibm/pc [1] */
  for (s = 0; s < l; s++) {
    if (out_screen)
      putchar(m[s]);
    else
      putc(m[s], out);
  }
}  /* pratom */


Void prblt(nn)
long nn;
{
  /* adres nom.wstr.prawila */
  mpd x;
  long bn;
  string80 rn;

  pointr(nn, &x.sa);
  bn = x.snd->val;
  switch (bn) {

  case 1:
    strcpy(rn, "#IMPLODE");
    break;

  case 2:
    strcpy(rn, "#EXPLODE");
    break;

  case 3:
    strcpy(rn, "#ATOM");
    break;

  case 4:
    strcpy(rn, "#NUMBER");
    break;

  case 5:
    strcpy(rn, "#IDENT");
    break;

  case 6:
    strcpy(rn, "#LIST");
    break;

  case 7:
    strcpy(rn, "#TREE");
    break;

  case 8:
    strcpy(rn, "#TATOM");
    break;

  case 9:
    strcpy(rn, "#FATOM");
    break;

  case 10:
    strcpy(rn, "#_KEYWORD");
    break;

  case 11:
    strcpy(rn, "#_SPECDESC");
    break;

  case 12:
    strcpy(rn, "#LEN");
    break;

  case 13:
    strcpy(rn, "#_SPECATOM");
    break;

  case 14:
    strcpy(rn, "#_RULENAME");
    break;

  case 15:
    strcpy(rn, "#_VARNAME");
    break;

  case 16:
    strcpy(rn, "#_RULETOATOM");
    break;

  case 17:
    strcpy(rn, "#_VARNTOATOM");
    break;

  case 18:
    strcpy(rn, "#_VARDESLOC");
    break;

  case 19:
    strcpy(rn, "#DEBUG");
    break;

  case 20:
    strcpy(rn, "#_SPECTODSC");
    break;

  case 21:
    strcpy(rn, "#_CONTENT2");
    break;

  case 22:
    strcpy(rn, "#CHR");
    break;

  case 23:
    strcpy(rn, "#PARM");
    break;

  case 24:
    strcpy(rn, "#_TOTATOM");
    break;

  case 25:
    strcpy(rn, "#ORD");
    break;

  case 26:
    strcpy(rn, "#CALL_PAS");
    break;
  }/* case */
  if (out_screen)
    fputs(rn, stdout);
  else
    fputs(rn, out);
}  /* prblt */


Void srchrule(rd, pp)
long rd;
ptr_ *pp;
{
  /*=================*/
  /* rd w st-prostr. */
  /*=================*/
  /*(rd: a; (* adres deskriptora #l * )
          (* w st-prostranstwe

  var
    pp: ptr (* ukaz. na sled. posle #l |l-t w spiske
             programmy * ) ); */
  /*====================================*/
  /* poisk w spiske programmy |l-ta,    */
  /* sled. za #l.                       */
  /* esli w deskriptore #l net ssylki   */
  /* na |tot |l-t, to wstawitx ee w     */
  /*  deskriptor #l                     */
  /*====================================*/
  mpd x, z;
  ptr_ y;
  a v1, v, name;
  ruledescriptor *WITH;


  pointr(rd, &x.sa);
  /* polu~itx deskriptor #l */
  if (x.srd->fragmadr == 0) {
    /* nuven poisk w spiske programmy */
    name = x.srd->name;
    v1 = x.srd->nomintab;
    /* s-adres #l w sr-prostranstwe */
    first(vs[0], &y);
    /* y na na~alo spiska
                          programmy */
    v = y.cel;
    pointr(v, &z.sa);
    while (z.srd->name != name) {
      while (y.cel != 0)
	next(&y);
      next(&y);
      v = y.cel;
      pointr(v, &z.sa);
    }  /* #l najden */
    next(&y);
    /* y na "base  prawila #l"    */
    /* zapisatx informaci` w deskriptor #l */
    points(v1, &x.sa);
    x.srd->fragmadr = y.UU.U1.curfragment;
    x.srd->nomintab = y.nel;
  }  /* poisk */
  else {
    /* w deskriptore #l estx ssylka na spisok
           programmy*/
    v = x.srd->fragmadr;
    pointr(v, &z.sa);
    WITH = x.srd;
    if (z.smld->dtype == listmain)
      y.cel = z.smld->elt[WITH->nomintab - 1];
    else
      y.cel = z.sfld->elt[WITH->nomintab - 1];
    y.ptrtype = ptrlist;
    y.nel = WITH->nomintab;
    y.UU.U1.curfragment = WITH->fragmadr;
  }
  *pp = y;
}  /* srchrule */


Void srchrule1(rd, pp)
long rd;
ptr_ *pp;
{
  /*=================*/
  /* rd w sr-prostr. */
  /*=================*/
  /*(rd: a; (* adres deskriptora #l * )
            (* w sr-prostranstwe * )
     var pp: ptr (* ukaz. na sled.
                  posle #l |l-t w spiske
                  programmy * ) );
  */
  /*====================================*/
  /* poisk w spiske programmy |l-ta,    */
  /* sled. za #l.                       */
  /* esli w deskriptore #l net ssylki   */
  /* na |tot |l-t, to wstawitx ee w     */
  /*  deskriptor #l                     */
  /*====================================*/
  mpd x, z;
  ptr_ y;
  a v, name;
  ruledescriptor *WITH;


  pointr(rd, &x.sa);
  /* polu~itx deskriptor #l */
  if (x.srd->fragmadr == 0) {
    /* nuven poisk w spiske programmy */
    name = x.srd->name;
    first(vs[0], &y);
    /* y na na~alo spiska
                          programmy */
    v = y.cel;
    pointr(v, &z.sa);
    while (z.srd->name != name) {
      while (y.cel != 0)
	next(&y);
      next(&y);
      v = y.cel;
      pointr(v, &z.sa);
    }  /* #l najden */
    next(&y);
    /* y na "base  prawila #l"    */
    /* zapisatx informaci` w deskriptor #l */
    points(rd, &x.sa);
    x.srd->fragmadr = y.UU.U1.curfragment;
    x.srd->nomintab = y.nel;
  }  /* poisk */
  else {
    /* w deskriptore #l estx ssylka na spisok
           programmy*/
    v = x.srd->fragmadr;
    pointr(v, &z.sa);
    WITH = x.srd;
    if (z.smld->dtype == listmain)
      y.cel = z.smld->elt[WITH->nomintab - 1];
    else
      y.cel = z.sfld->elt[WITH->nomintab - 1];
    y.ptrtype = ptrlist;
    y.nel = WITH->nomintab;
    y.UU.U1.curfragment = WITH->fragmadr;
  }
  *pp = y;
}  /* srchrule */


Void lastop()
{
  /*================================================*/
  /*  whod:     v[base -2]        v[base -1]        */
  /*              #l               $e               */
  /* wyhod:       zna~enie         oswoboditx       */
  /*            perem. $e                           */
  /*                                                */
  /*================================================*/
  ptr_ p;
  mpd x;
  a k;


  srchrule(v[base - 3], &p);
  /*   p ukaz. na sled.posle #l |l-t w tabl.prawil*/
  k = p.cel;
  pointr(k, &x.sa);
  /*  polu~itx dostup k base poslednego wyzowa #l */
  k = x.snd->val;
  if (k >= 0) {   /* change from x.snd^.sign=true 3-oct-89 */
    pointr(v[base - 2], &x.sa);
    /* polu~itx dostup k deskr.$e  */
    v[base - 3] = v[k + x.svd->location - 1];
  } else
    v[base - 3] = null_;
  base--;   /* osw.stek */
}  /* lastop */




Static Void errstrmes(n, m)
long n;
Char *m;
{
  Char STR2[130];

  switch (n) {

  case 1:
    sprintf(m, "Interpreter stack size overflow (stack size = %d);",
	    varnum);
    break;

  case 2:
    strcpy(m, "Assignment left side is not list or tree");
    break;

  case 3:
    strcpy(m, "List index is not number");
    break;

  case 4:
    strcpy(m, "Using [..] not for list");
    break;

  case 5:
    strcpy(m, "Index value exceeds list bounds");
    break;

  case 6:
    strcpy(m, "Not list or tree after \"::\"");
    break;

  case 7:
    strcpy(m, "Not atomic name before \"::\"");
    break;

  case 8:
    strcpy(m, "NULL in left side of assignment");
    break;

  case 9:
    strcpy(m, "Not numerical value in left side of \"+:=\" statement");
    break;

  case 10:
    strcpy(m, "Not numerical value in right side of \"+:=\" statement");
    break;

  case 11:
    strcpy(m, "File specification is not atom");
    break;

  case 12:
    strcpy(m, "Too long file specification");
    break;

  case 13:
    strcpy(m, "Too much open text files");
    break;

  case 14:
    strcpy(m, "File not open for output");
    break;

  case 15:
    strcpy(m, "Wrong file name in SAVE statement ");
    break;

  case 16:
    strcpy(m, "File was not closed before new opening");
    break;

  case 17:
    strcpy(m, "Atom length exceeds file record length");
    break;

  case 18:
    strcpy(m, "Not exist file in LOAD statement ");
    break;

  case 19:
    strcpy(m, "Wrong file name in OPEN statement ");
    break;

  case 21:
    strcpy(m, "Selector after \".\" is not identifier ");
    break;

  case 22:
    strcpy(m, "Selector in tree constructor is not identifier ");
    break;

  case 23:
    strcpy(m, "Not tree before \".\" operation ");
    break;

  case 24:
    strcpy(m, "Not tree or list as base of FORALL-IN statement ");
    break;

  case 25:
    strcpy(m, "Atom length more than 80 bytes in #IMPLODE ");
    break;

  case 26:
    strcpy(m, "\"BRANCHES\" option cannot be used for lists ");
    break;



  default:
    strcpy(m, "Unknown error");
    break;
  }
}


Void err(n)
long n;
{
  /* kod o{ibki */
  string80 m, STR1;
  Char STR2[174];

  errstrmes(n, m);
  sprintf(m, "*** ERROR %s %s", long_to_str(STR1, n), strcpy(STR2, m));
  if (out_open)
    fprintf(out, "%s\n", m);
  puts(m);
}  /* err */


Void errstr(n, s)
long n;
Char *s;
{
  /* kod o{ibki */
  string80 m, STR1;
  Char STR3[254];

  errstrmes(n, m);
  sprintf(m, "*** ERROR %s %s%s", long_to_str(STR1, n), strcpy(STR3, m), s);
  if (out_open)
    fprintf(out, "%s\n", m);
  puts(m);
}  /* err */


Void getval(m)
long *m;
{
  /* ssylka na perem.ili obxekt   */

  /*========================================*/
  /* esli m -peremennaq, to w m pomestitx   */
  /* ssylku na ee zna~enie                  */
  /*                                        */
  /*========================================*/
  mpd x;


  if (((*m) & 511) == 0 && *m < 65535L && *m >= 0)
    return;
  pointr(*m, &x.sa);
  if (((1L << ((long)x.svd->dtype)) &
       ((1L << ((long)fvariable + 1)) - (1L << ((long)variable)))) != 0 &&
      !x.svd->guard)
    *m = v[mybase + x.svd->location - 1];
}



/* End. */