{program pasccomp( output);}{issue 11}
(*kvrm *)module pasccomp( output);          (* kvrm*){issue 11}
(*kvadd program pasccomp( output,intxt,mublfile); kvadd*)
{changes for issue 11 commented issue 11}
type lo8 = packed array[1..8] of char;
addrlo8 = ^lo8;
lo32 = set of 0..31; {issue 11}
(*kvadd byte = 0..255;                        kvadd*)
(*kvadd var prog,resfile : addrlo8;           kvadd*)
(*kvadd     par3,par4    : integer;           kvadd*)
(*kvadd     intxt : text;                     kvadd*)
(*kvadd     mublfile : packed file of byte;   kvadd*)
function findn(p1 : addrlo8; p2 : integer): lo32; external;
function findp(p1 : lo32; p2,p3 : integer): integer; external; {issue 11}
function addbound(var index:char ; length : integer) : addrlo8 ;external;{issue
11}
(*$Y+*)
procedure pascal(prog,resfile : addrlo8; par3,par4 : integer);{1}

label 1;

const
{issue 11}
{ptv firstcompwsseg = 30;
     nocompwssegs = 1; ptv}
{vax firstcompwsseg = %22;
     nocompwssegs = 2; vax}
{mu6 firstcompwsseg = %22;
     nocompwssegs = 2; mu6}
{gem firstcompwsseg = %22;
   nocompwssegs = 2; gem}
{the following tlseg1nos are shifted up 16 then handed to tlseg}
{any to ptv tlseg1no = %5c; any to ptv}
{any to gem tlseg1no = %21; any to gem}
{any to vax tlseg1no = %21; any to vax}
{any to mu6 tlseg1no = %84; any to mu6}
{issue 11}
     maxidarray = 10240;
{any to mc68000 initin16 = true; any to mc68000}
{any to mu6 initin16 = false; any to mu6}
{any to vax initin16 = false; any to vax} {issue 11}
{mc68000 rlit32 = true; mc68000}
{vax rlit32 = false; vax}
{mu6 rlit32 = false; mu6}{issue 11}
     {vax  maxint = %7ffffffe;  vax}
{cv maxint = %7ffffffe; cv}
{mc68000 maxint = %7fff; mc68000}{issue 11}
{mu6 maxint = %7ffffffe; mu6}
     {ptvmaxids = 1800; ptv}
{gem maxids = 1800; gem}
{cv maxids = 1800; cv}
{vax  maxids = 1800;  vax}  { the maximum number of idrecs that
			will fit in a vax segment }
{mu6 maxids = 7200; mu6}
{vax      maxintpower = 1000000000;  vax}
{cv maxintpower = 1000000000; cv}
{mc68000 maxintpower = 10000; mc68000}
{mu6 maxintpower = 1000000000; mu6}
{vax intfns32only = true; vax}
{mc68000 intfns32only = false; mc68000}{issue 11}
{mu6 intfns32only = true; mu6}{issue 11}
     errormax = 10;
     space = ' ';
     displaylimit = 20;
     globallevel = 1;
     linemax = 180;
{vax      maxdecintlength = 10;  vax}
{cv maxdecintlenth = 10; cv}
{mc68000 maxdecintlength = 5; mc68000}
{mu6 maxdecintlength = 10; mu6}
     maxdecreallength = 20;
     maxhexintlength = 8;
     maxhexreallength = 16;
     maxidentlength = 12;
     maxstringlength = 140;
     maxsetelement = 127;
     minsetelement = 0;
{mc68000 mincaseconstant = 0;maxcaseconstant = 127;mc68000}
{vax      maxcaseconstant = 1000;
     mincaseconstant = -1000; vax}
{cv maxcaseconstant = 1000;mincaseconstant = -1000; cv}
{mu6 maxcaseconstant = 1000;mincaseconstant = -1000; mu6}

(*kvmod*)nodelimiters = 37;
     spaces = '            ';
     ilinefeed = 10;
     realdecimallength = 8;
     ordzero = %30;
     orda = %41;
     ordtab = %09;
     {constants used in code generation}
     breg = %2000;
     areg = %3000;
     dreg = %1005;
     bregfunccode = %00;
     aregfunccode = %20;
     dregfunccode = %60;
     cclabelbasictype = %30;
     ccboolbasictype = %20;
     cccharbasictype = %80;
     ccint8basictype = %40;
     ccint16basictype = %44;
     ccint32basictype = %4c;
{any to vax  ccint=%4c;  any to vax}
{any to cv ccint=%4c; any to cv}
{any to mc68000 ccint=%44; any to mc68000}
{any to mu6 ccint = %4c; any to mu6}
     ccpointerbasictype = %83;
     cc8basictype = %80;
     cc16basictype = %84;
     cc32basictype = %8c;
     cc64basictype = %9c;
     ccaggraddadj = %40;
     ccaggrshladj = %04;
     ccunboundeditempointer = %01;
     ccundefineditempointer = %03;
     ccvecitem = %02;
     cclabelpointer = %2c;
     ccboundeditempointer = %03;
     ccprocpointer = %28;
(*kvrm *)     ccexportedprocnature = %4008;       (* kvrm*)
(*kvadd      ccexportedprocnature = %4000;  kvadd*)
(*kvrm *)     ccextprocnature = %8008;            (* kvrm*)
(*kvadd      ccextprocnature = %8000;       kvadd*)
(*kvmod*)ccimpdecl = %8000;
(*kvmod*)ccexpdecl = %4000;

     ccuseractualprocnature = %00;
     ccuserformalprocnature = %10;
     ccprockind = %04;
     ccuserlabel = %00;
     cccompilerlabel = %02;
     ccconvkindadjustment = %4000;

{ a & b register operation codes }
     store = 0;
     loadneg = 1;
     load = 2;
     logicalnoneq = 3;
     logicaland = 4;
     logicalor = 5;
     logicallshift = 6;
     logicalrshift = 7;
     add = 8;
     subtract = 9;
     revsubtract = 10;
     multiply = 11;
     divide = 12;
     revdivide = 13;
     logicaleq = 14;
     comp = 15;
     loadbnd = 17;
     mfn = 18;
     andstore = 20;
     orstore = 21;
     modf = 1;

{ d register operation codes }
     loadref = 1;
     selfld = 3;
     selel = 4;
     selalt = 5;
     base = 6;
     limit = 7;
     loadaddress = 11;

{ organisational operation codes }
     stkl = %40;
     stkpar = %41;
     enter = %42;
     return = %43;
     convareg = %45;
     setareg = %46;
     stk = %47;
     ifeqtr = %49;
     ifnetr = %4a;
     ifgetr = %4b;
     iflttr = %4c;
     ifletr = %4d;
     ifgttr = %4e;
     uncondjump = %50;
     samesegtr = %4f;

{ special operand codes }
     ccitemreferenced = %1004;
     ccrefonstack = %1005;
     tregeq = %1008;
     tregne = %1009;
     tregge = %100a;
     treggt = %100b;
     tregle = %100c;
     treglt = %100d;
     ccdataonstack = %1003;

     papthrow = %c;
type
    integer8 = -128..127;
     integer16 = -32767..32767;
     idarrlength = 0..maxidarray;
     idnames = array[1..maxidarray] of char;
     hashno = 0..511;
     mutlname = -32767..32767;
(*kvmod*)chtype = (d0,d1,d2,d3,d4,d5,d6,d7,d8,d9,sundersc,la,lb,lc,ld,le,lf,lg,l
h,
     li,lj,lk,ll,lm,ln,lo,lp,lq,lr,ls,lt,lu,lv,lw,lx,ly,lz,
     squote,soparen,scolon,sdot,slt,sgt,smul,sshriek,sdquote,spound,sdollar,
     sand,seq,sbslash,sat,sopbracket,splus,sscolon,sminus,sarrow,sclparen,
     sgrave,stilda,sbar,sclbracket,scomma,sslash,squestion,sspace,
     snewline,spercent,sothers);
     filenm = packed array [1..8] of char;
     errcode = 0..127;
	  identlength = 1 .. maxidentlength;
     lineposition = 1 .. linemax;
     delimrange = 1 .. nodelimiters;
     symboltype = (ident, charconst, intconst, realconst, stringconst, nilsy, no
tsy,
	  mulop, addop, arrow, period, comma, semicolon, colon, relop, becomes,
	  leftparent, rightparent, leftbracket, rightbracket, beginsy, dosy,
(*kvmod*) tosy, endsy, ifsy, ofsy, programsy, modulesy, thensy, untilsy, labelsy
, constsy,
	  typesy, varsy, funcsy, procsy, packedsy, setsy, arraysy, recordsy,
	  filesy, casesy, repeatsy, whilesy, forsy, withsy, gotosy, elsesy,
	  othersy, otherwisesy, ddot);
     optype = (mul, rdiv, revrdiv, andop, idiv, revidiv, plus, minus,
	  revminus, orop,
	  ltop, leop, geop, gtop, neop, eqop, inop, notop, modop);
     constkind = (boolkind,charkind,intkind,realkind,pointerkind,stringkind);
     fldselkind = (fld, alt);
     declarationkind = (standard, declared);
     prockind = (actual, formal);
     paramkind = (procparam, funcparam, varparam,
				valparam, confparam, auxparam);
     scopekind = (bloc, pseudobloc, withst);
     stackkind = (variable, reference, konstant, data, default, statementbase);
     regkind = (b, a, d);
     fileopkind = (inp, outp);
     opkind = (scalararithmetic, scalarlogical, scalarassignment,
	  scalarcomparison,
	  pointerassignment, pointercomparison, setarithmetic, setcomparison,
	  setassignment, inset, strcomparison, stringassignment,
	  structassignment, confassignment);
     typeform = (scalars, subranges, pointers, sets, arrays, records, files,
	  varparts, variant);
     idclass = (consts, field,types, vars,  proc, func, null);
     kindofvars = (normalvar, refvar, filevar);
     standprocs = (newp, disposep, packp, unpackp, closep, rewritep,
	  putp, writep, writelnp,
	  pagep, resetp, getp, readp, readlnp, eoff, eolnf,
	  succf, predf, ordf,
	  chrf, truncf, roundf, absf, oddf, sqrf, sqrtf,
	  sinf, cosf, lnf,
	  expf, logf, tanf, arcsinf, arccosf, arctanf, sinhf, coshf, tanhf);
     opofstandproc = (filehandling, dynamstore, transf, maths, ordinals,
		 conv);
     desckind = (ordinal, reals, undefpointer, defpointer, struct, sett);
     iokind = (readscalar, readstructured, writescalar, writestructured);
     fileseqkind = (chars, binary, units, recs);

     setofsymbols = set of symboltype;
     setofidclass = set of idclass;

     identname = packed array[identlength] of char;
     charstring =  array[1 .. maxstringlength] of char;

     fieldselentry = ^fldselrec;
     typentry = ^typerec;
     identry = -1..maxids;
     stackentry = ^stackrec;
     formalentry = ^formalrec;
     filentry = ^filerec;
     labelentry = ^labelrec;
     scopentry = ^scoperec;
procdeclentry = ^procdeclrec;

     constrec = record {description of constant}
	  case kind : constkind of
	  boolkind   : (bval : boolean);
	  charkind   : (cval : char);
	  intkind    : (ival : integer);
	  realkind   : (rval : real);
	  stringkind : (length : integer; stringlittlname : mutlname)
	  end;
     descriptor = record {describing properties of a type - see typerec}
	  vector : boolean;
	  size : integer;
  packname, typename : mutlname;
	  case kind : desckind of
	  sett, ordinal : (min, max : integer);
	  defpointer : (bounded : boolean);
	  undefpointer : (domtypename : mutlname; dimen : integer)
	  end;
     fldselrec = record
	  next : fieldselentry;
	  kind : fldselkind;
	  opd : mutlname
	  end;
     typerec = record {describing compile-time properties of a type}
	  next : typentry;
	  desc : descriptor;
	  case form : typeform of
	  scalars   : (case scalarkind : declarationkind of
	  declared : (constidroot : identry));
	  subranges : (rangetype : typentry;
	  min, max : integer);
	  pointers  : (domaintype : typentry);
	  sets      : (basetype : typentry;
	  setpacked : boolean);
	  arrays    : (elemtype, indextype : typentry;
	  arrpacked : boolean;
	  low, high : identry);
	  records   : (fieldscope, fixedfieldroot : identry;recpacked : boolean;
	  varpart : typentry);
	  files     : (componenttype : typentry;
     bufalt : integer8;
	  sequence : fileseqkind);
	  varparts  : (tagfield : identry;
	  variantroot : typentry;
	  serial : mutlname);
	  variant   : (varfieldroot : identry;
	  subvarpart, nextvariant : typentry;
	  aslastvariant : boolean;
	  distinctvariantcount : integer16;
	  val : constrec)
	  end;
     idrec = record {describing compile-time properties of an identifier}
     notyetdefined : boolean;
	  iindex,length : idarrlength;
	  topscope, signature : integer16;
	  textlevel : integer8;
	  idtype : typentry;
	  nxthash, next : identry;
	  tlname : mutlname;
	  case class : idclass of
	  consts : (val : constrec);
	  vars   : (case varkind : kindofvars of
	  normalvar : (assigned, canassign : boolean);
	  refvar  : (conform : boolean);
	  filevar : (case reffilevar : boolean of
	  false : (permanent : boolean)));
	  field  : (selectroot : fieldselentry; tagf : boolean;

	  serial : integer8);
	  proc,
	       func   : (case kind : declarationkind of
	  standard : (index : standprocs);
	  declared : (decl : procdeclentry))
	  end;
     labelrec = record {describing properties of a label}
	  next : labelentry;
	  reftlname, labeltlname : mutlname;
    val : integer16;
	nottobeused, jumpto, nottobedefined, defined : boolean
	  end;
     allowedlabelentry = ^allowedlabelrec;
     allowedlabelrec = record
				labl : labelentry;
				next : allowedlabelentry
				end;
     formalrec = record {describing a formal parameter}
	  next : formalentry;
	  id : identry;
	  ptype : typentry;
	  ptypename : mutlname;
	  case kind : paramkind of
		confparam : (copy : boolean);
	  procparam,
	       funcparam : (formalroot : formalentry)

	  end;
     stackrec = record {describing an entry on the hypothetical stack}
	  next : stackentry;
	  desc : descriptor;

	  case kind : stackkind of
	  variable  : (tlname : mutlname);
	  reference : (boundedref : boolean;
	  case refinreg : boolean of
	  false : (case refonstack : boolean of
	  false : (selvartlname : mutlname)));
	  data      : (datainreg, dataonstack : boolean;
	  case register : regkind of
	  d : (bounded : boolean;
	  storename : mutlname));
	  konstant  : (val : constrec)
	  end;
     filerec = record {describing the properties of a file}
	  next : filentry;
	  declared : boolean;
	  name, mussequiv, length : idarrlength;
	  end;
idchain = record head,tail : identry end;
     scoperec = record {describing the scope of identifiers, types and labels
			 in a procedure or with statement}
	  idscope : identry;
	  case scope : scopekind of
	  bloc,
	       pseudobloc : (filechain : idchain;
typeroot : typentry;
	  initialtlname : mutlname;
	  labelroot : labelentry);
	  withst     : (withbase : stackentry)
	  end;

procdeclrec = record
		formalroot : formalentry;
		case declkind : prockind of
		  actual :(case external:boolean of
		    false:(restlname:mutlname;
			   forwardproc : boolean;
			   formalscope : scopentry);
		    true :(restypnm : mutlname));
    		  formal : (formaltlname : mutlname)
		end;
(*kvadd
#include "kvtyp.pas"
 kvadd*)
var
     (*$D7*)
     idarray : idnames;
     (*$D0*)
     idindex : idarrlength;
     forwardref : boolean;
     sig : integer16;
     currentpageno,currentlineno : integer;{issue 11}
     ch, linefeed : char;
     operator : optype;
     symbol : symboltype;
     errorindex : lineposition;
     listsource, listerrors, iso, trace : boolean;
     printpar : integer;
     errorsdiscovered : 0 .. errormax;
     totalerrorsdiscovered : integer16;
     erroroverflow : boolean;
     errorlist : array[1 .. errormax] of record
	  position : lineposition;
	  code : errcode
	  end;
     idname : identname;
     idnamelength : integer8;
     constant, defaulconstant : constrec;
delimstart,delimend : array[0..maxidentlength] of integer8;
delimiter : array[1..nodelimiters] of record
	name : identname;
	signature : integer16;
	symb : symboltype;
	op : optype
	end;
     charsymbol : array[squote..squestion] of record
	  symb : symboltype;
	  op : optype
	  end;
     infileid, outfileid : identry;
     missingsymbolerrorcode : array[symboltype] of errcode;
     defaultid : array[idclass] of identry;
  display : array[0..displaylimit] of scoperec;
     permfileroot : filentry;
     pfileidchain : idchain;
     createidentry, defauldeclaration : boolean;
     stringelement : ^charstring;
     blockbegsys, constbegsys, simptypebegsys, facbegsys, parambegsys,
	  statbegsys, typedeclsys, typebegsys, selectsys : setofsymbols;
     lengthofstandproc : array[standprocs] of idarrlength;
nameofstandproc : array[standprocs] of identname;
     fileoperation : array[closep .. eolnf] of fileopkind;
     groupofstandproc : array[standprocs] of opofstandproc;
     nullsymbname, worksymbname : identry;
     filedesc, booldesc, chardesc, intdesc, realdesc,
      setdesc, stringdesc, pointerdesc, defaultdesc : descriptor;
     booltype, chartype, inttype, real32type, real64type,realcompiletimetype, te
xttype, pointertype, settype : typentry;{issue 11}
     top, level, levelfound : integer8;

     retainentry : boolean;
     topstackentry : stackentry;
     {variables used in code generation}
     entryusing : array[regkind] of stackentry;
     initstagepassed, linenumpassed : boolean;
     tlnamecount : mutlname;
     usebreg : boolean;
     oppoperator : array[optype] of optype;
     ccregfunccode, ccregname : array[regkind] of mutlname;
     ccitempointer : array[boolean] of mutlname;
     cctregstate : array[ltop .. eqop] of mutlname;
     ccopcode, ccsetopcode : array[optype] of mutlname;
     ccmfncode : array[absf .. tanhf] of mutlname;
     settypename, zerotlname,singleset,
	emptyset, niltlname,
{issue11}sitlname, sotlname,
     ienqtlname, inchtlname,
     ibstlname, sltlname, outchtlname, pinbintlname, poutbintlname,
     pinrectlname, poutrectlname, initlname,
     outitlname,outrealtlname,inbooltlname,obooltlname,sptlname,nltlname,
{issue11}nextchtlname,pbuffvtlname, traptlname, outstrtlname,inrealtlname,instrt
lname : mutlname;
     aregmode : mutlname;
outlinenotlname : mutlname;
freedreg : boolean;
export, checking : boolean;
idstr : ^ identname;
progstream : integer;
ci : integer;
setelemtlname, setoptlname,setrangetlname, complementtlname,
cc128basictype, empty128tlname, worksettlname : mutlname;
inpfiletlname, outpfiletlname, typnm,address, filtypename,pgettlname,pclosetlnam
e: mutlname;
filetypename, heapaddr,maketlname,removetlname,inittlname,heaptemp : mutlname;
ccjumpop : array[ltop..eqop] of mutlname;
simplereln, endtypedefinition : boolean;
relnoperator : optype;
movearraytlname : mutlname;
chval : chtype;
chvals : array[char] of chtype;
(*$D6*)
idrecs : array[0..maxids] of idrec;
(*$D0*)
maxtop, topid,lastfreeid : identry;
valchs : array[d0 .. lz] of char;
putcode : boolean;
withtop : integer8;
ccrealbasictype : mutlname;
misused : boolean;
realid : identry;
hashtable : array[hashno] of identry;
packerror, tagfld : boolean;
nilconst : constrec;
assigntype : mutlname;
scopenumber : integer16;
in16, packedset : boolean;
inpnotdecl,outpnotdecl : boolean;
ccintbasictype, heapcheck : mutlname;
{issue 11} i:integer;
(*kvmod*)programcomp : boolean;
(*kvmod*)outerleveltest : integer;
(*kvadd
#include "kvvar.pas"
#include "pmubl.pas"
 kvadd*)
(*$S4*)
(*$Y-*)
procedure errormessage(code : errcode);forward;
      procedure error(errorcode : errcode); forward;

procedure initstack;{2}
     begin
     topstackentry := nil
     end;

procedure stack(entry : stackentry);{3}
     begin
     entry^.next := topstackentry;
     topstackentry := entry
     end;

function  unstack: stackentry;{4}
     begin
     if topstackentry <> nil
	  then begin
	  unstack := topstackentry;
	  topstackentry := topstackentry^.next
	  end
     else unstack := nil;
     end;

procedure freestack( entry : stackentry);{5}
     var reg : regkind;
     begin
     if entry <> nil
	  then begin
	  for reg := b to d do
	       if entryusing[reg] = entry
	       then entryusing[reg] := nil;
	  dispose(entry)
	  end
     end;

procedure stackdefault;{6}
     var
	       entry : stackentry;
     begin
     new(entry);
     with entry^ do
	  begin
	  desc := defaultdesc;
	  kind := default
	  end;
     stack(entry)
     end;

procedure releaseregister(reg : regkind; onstack : boolean) ; forward;

procedure freeregisters;{7}
     var
	       reg : regkind;
     begin
     aregmode := 0;
     for reg := b to d do
	  entryusing[reg] := nil
     end;

procedure openbody;{8}
     begin
     initstack;
     freeregisters
     end;

procedure traceproc; forward;

procedure openstatement;{10}
     var
	       entry : stackentry;
     begin
     traceproc;
     new(entry);
     with entry^ do
	  begin
	  desc := defaultdesc;
	  kind := statementbase
	  end;
     stack(entry)
     end;

procedure closestatement;{11}
     var
	       entry : stackentry;
     begin
     if topstackentry <> nil
	  then begin
	  while topstackentry^.kind <> statementbase do
	       begin
	       entry := unstack;
	       freestack(entry)
	       end;
	  entry := 	  unstack;
	  freestack(entry)
	  end
     end;

      procedure stackvariable(name : mutlname; sdesc : descriptor);{12}
     var
	       entry : stackentry;
     begin
     new(entry);
     with entry^ do
	  begin
	  desc := sdesc;
	  kind := variable;
	  tlname := name
	  end;
     stack(entry)
     end;

procedure stackreference(name : mutlname; sdesc : descriptor);{13}
     var
	       entry : stackentry;
     begin
     new(entry);
     with entry^ do
	  begin
	  desc := sdesc;
	  kind := reference;
	  refinreg := false;
	  refonstack := false;
	  selvartlname := name
	  end;
     stack(entry)
     end;

procedure stackdata(reg : regkind; sdesc : descriptor);{14}
     var
	       entry : stackentry;
     begin
     new(entry);
     entryusing[reg] := entry;
     with entry^ do
	  begin
	  desc := sdesc;
	  kind := data;
	  datainreg := true;
	  register := reg;
	  if reg = d
	       then if sdesc.kind = defpointer
	       then bounded := sdesc.bounded
	  else bounded := false
	  end;
     stack(entry)
     end;

procedure stackconstant(c : constrec;sdesc : descriptor);{15}
     var
	       entry : stackentry;
     begin
     if c.kind = stringkind then
	sdesc.size := c.length;

     new(entry);
     with entry^ do
	  begin
	  desc := sdesc;
	  kind := konstant;
	  val := c
	  end;
     stack(entry)
     end;

procedure stackboolconstant(val : boolean);{16}
     var
	       c : constrec;
     begin
     with c do
	  begin
	  kind := boolkind;
	  bval := val
	  end;
     stackconstant(c, booldesc)
     end;

procedure stackcharconstant(val : char);{17}
     var
	       c : constrec;
     begin
     with c do
	  begin
	  kind := charkind;
	  cval := val
	  end;
     stackconstant(c, chardesc)
     end;

procedure stackintconstant(val : integer);{18}
     var
	       c : constrec;
     begin
     with c do
	  begin
	  kind := intkind;
	  ival := val
	  end;
     stackconstant(c, intdesc)
     end;

procedure stackrealconstant(val : real);{19}
     var
	       c : constrec;
     begin
     with c do
	  begin
	  kind := realkind;
	  rval := val
	  end;
     stackconstant(c, realcompiletimetype^.desc){issue 11}
     end;
{procedures used to plant mutl}
(*kvadd function addbound(var index : char;length : integer):symbolicnamentry;ex
tern;  kvadd*)
procedure tlnameallocation(var nameallocated : mutlname);{20}
     begin
     tlnamecount  := tlnamecount + 1;
     nameallocated := tlnamecount
     end;

function desctypename(desc : descriptor) : integer;{21}
     begin
     with desc do
	  if kind = undefpointer
	  then desctypename := domtypename + ccboundeditempointer
     else desctypename := typename
     end;

procedure xxplant(opcode, operand : integer);{22}
     begin
		if putcode then
     tlpl(opcode, operand)
     end;

procedure xxstarttypedefinition(symbname : identry; nature : integer; var newnam
e : mutlname);{23}
     begin
     with idrecs[symbname] do
	  tltype(addbound(idarray[iindex + 1], length), nature);
     tlnameallocation(newname);
     newname := (newname + ccaggraddadj) * ccaggrshladj
     end;

procedure xxstaticstoreallocation(symbname : identry; typename, dimension : inte
ger; var newname : mutlname);{24}
(*kvmod*)var expimpbit : integer;
     begin
(*kvmod*)expimpbit := 0;
(*kvmod*)if (outerleveltest = 0) and
(*kvmod*)   (symbname <> nullsymbname) then
(*kvmod*)begin
(*kvmod*)   if programcomp then
(*kvmod*)   begin
(*kvmod*)      expimpbit := ccexpdecl;
(*kvmod*)   end else
(*kvmod*)   begin
(*kvmod*)      expimpbit := ccimpdecl;
(*kvmod*)   end;
(*kvmod*)end;
     with idrecs[symbname] do
(*kvmod*)   tlsdecl(addbound(idarray[iindex + 1],length), typename + expimpbit,
dimension);
     tlnameallocation(newname)
     end;

{issue 11}{alternative kvproc
procedure zzstaticstoreallocation(symbnamep : pointidentname; typename, dimensio
n : integer; var newname : mutlname);
var expimpbit : integer;
     begin
expimpbit := 0;
if outerleveltest = 0 then
begin
   if programcomp then
   begin
      expimpbit := ccexpdecl;
   end else
   begin
      expimpbit := ccimpdecl;
   end;
end;
   tlsdecl(pstrtrunc(symbnamep), typename + expimpbit, dimension);
     tlnameallocation(newname)
     end;
}{issue 11}

procedure xxselectvardeclaration(var newname : mutlname);{25}
     begin
     tlselectvar;
     tlnameallocation(newname)
     end;

procedure plantentry(opcode : integer; reg : regkind; entry : stackentry); forwa
rd;

procedure plantintconstant(opcode : integer; reg : regkind; val : integer);{26}
     var
	       entry : stackentry;
     begin
     stackintconstant(val);
     entry:=unstack;
     retainentry := false;
     plantentry(opcode, reg, entry);
     retainentry := true
     end;


procedure xxnameclit(var  newname : mutlname);{27}
     begin
     tllit(nil,0);
     tlnameallocation(newname)
     end;

procedure xxstringaslit;{28}
     var
	       i : integer;
     begin
     with constant do
	  begin
	  xxstaticstoreallocation(nullsymbname, cccharbasictype, -1, stringlittlname);
	  tlass(stringlittlname, -1);
	  tlclits(cccharbasictype, addbound(stringelement^[1], length));
	  tlassvalue(0, 1);
	  tlassend
	  end
     end;

procedure xxprocspecification(id : identry);{29}
     var
	       restypename, nature, typname : integer;
	  formalbase : formalentry;
     begin
     with idrecs[id] do
	with decl^ do
	  begin
          if external then
	     restypename := restypnm
          else if idtype = nil
	       then restypename := 0
	  else restypename := idtype^.desc.typename;
	  if restypename = ccundefineditempointer then
	     restypename := idtype^.desc.domtypename + ccboundeditempointer;
	  if declkind = formal
	       then begin
	       tlprocspec(addbound(idarray[iindex+1],length), ccuserformalprocnature);
	       tlnameallocation(formaltlname);
	       formaltlname := formaltlname + %2000

	       end
	  else begin
	       if external
		    then nature := ccextprocnature
	       else if export then nature := ccexportedprocnature
		else nature := ccuseractualprocnature;
	       tlprocspec(addbound(idarray[iindex+1],length), nature);
	       tlnameallocation(tlname)
	       end;
	  formalbase := formalroot
	  end;
     while formalbase <> nil do
	  with formalbase^ do
	  begin
	  if ptype = nil then tlprocparam(ptypename,0)
		else if ((kind = valparam)) and (ptype^.form = arrays)
		  then tlprocparam(ptypename,ptype^.desc.size)
	       else tlprocparam(ptypename,0);
	  formalbase := next
	  end;
     tlprocresult(restypename)
     end;

procedure xxstartprocdefinition(id : identry);{30}
     var
	       formalbase : formalentry;
     begin
     with idrecs[id] do
	  begin
	  tlproc(tlname);
	  tlprockind(ccprockind);
	  formalbase := decl^.formalroot
	  end;
     while formalbase <> nil do
	  with formalbase^ do
	  begin
	  if id <> -1 then
	    tlnameallocation(idrecs[id].tlname);
	  formalbase := next
	  end;
     with idrecs[id] do
	with decl^ do
	  if declkind = actual
	  then if not external
	  then if idtype <> nil
	  then xxstaticstoreallocation(nullsymbname, idtype^.desc.typename, 0, restlnam
e)
     end;

procedure xxlabelspecification(symbname : identry; labeltype : integer; var labe
lname : mutlname);{31}
     begin
     with idrecs[symbname] do
       if labeltype = ccuserlabel then
          idstr^ := idname
       else idstr^ := spaces;
     tllabelspec(pstrtrunc(idstr), labeltype);
     tlnameallocation(labelname)
     end;

procedure xxendproccallseq(tlname : integer);{32}
     var
	       reg : regkind;
     begin
     for reg := b to d do
	  releaseregister(reg, false);
     aregmode := 0;
     xxplant(enter, tlname)
     end;


procedure xxsetaregmode(mode : integer);{33}
     begin
     if aregmode <> mode
	  then begin
	  aregmode := mode;
	  xxplant(setareg, mode)
	  end
     end;

procedure xxconvaregmode(entry : stackentry; kind : integer; restype : typentry)
;{34}
     var
	       typename : integer;
     begin
     if (entry^.kind <> konstant) or (entry^.desc.kind = reals) then
     begin
     if entryusing[a] <> entry
	  then begin
	if entry^.kind <> variable then
	   releaseregister(a,false);
	plantentry(load, a, entry);
	end;
     typename := restype^.desc.typename;
     kind := kind*ccconvkindadjustment + typename;
     if aregmode <> typename then
       xxplant(convareg, kind);
     aregmode := typename;
     end;
     entry^.desc := restype^.desc
     end;

procedure xxtlinitialisation;{35}
type lo32 = set of 0..31;{set used to give 32 bit param to mutl in 16 bit mode;}
var t : mutlname;
{any to ptv segaddr: lo32; any to ptv}
{any to gem segaddr: lo32; any to gem}
procedure piotlproc(var tlname:mutlname);{35a}{issue 11}
  begin
   tlprocspec(pstrtrunc(idstr),ccextprocnature + 1);
   tlnameallocation(tlname);
   tlprocparam(filetypename+ccunboundeditempointer,0);
   tlprocparam(ccint,0);
   tlprocresult(0);
 end;
     begin
{issue 11}{check 3rd param ok on 16bit machines}
{any to ptv segaddr := [18,19,20,22]; any to ptv}
{any to gem segaddr := [16,21]; any to gem}
{any to ptv tlseg(1, 0, segaddr, -3, %e); any to ptv}
{any to gem tlseg(1,0,segaddr,-3,%E); any to gem}
{any to vax tlseg(1,0,%210000,-3,%E); any to vax}
{any to mu6 tlseg(1,0,%840000,-3,%E); any to mu6}
     tlload(1, 2);
(*kvrm *) tldataarea(2);   (* kvrm*)
(*kvadd tldataarea(0);  kvadd*)
xxstarttypedefinition(nullsymbname,0,typnm);
tltypecomp(ccunboundeditempointer,0,nil);
tlendtype(1);
(*mu6g*)tltypecomp(ccundefineditempointer,0,nil);
tlendtype(0);
(*kvadd idstr^ := '_heaptemp   ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,typnm,0,heaptemp);
   (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,typnm,0,heaptemp);                     kva
dd*)
(*kvadd idstr^ := '_heapaddr   ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,ccint32basictype,0,heapaddr);
   (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,ccint32basictype,0,heapaddr);          kva
dd*)
xxstarttypedefinition(nullsymbname,1,t);
tltypecomp(cccharbasictype,0,nil);
tlendtype(1);
tltypecomp(ccboolbasictype,0,nil);
tlendtype(1);
tltypecomp(ccint16basictype,0,nil);{issue 11}
tlendtype(1);
tltypecomp(ccint32basictype,0,nil);{issue 11}
tlendtype(1);
tltypecomp(%c, 0, nil);
tlendtype(1);
tltypecomp(%1c,0,nil);
tlendtype(1);
tltypecomp(ccundefineditempointer,0,nil);
tlendtype(1);
tltypecomp(ccunboundeditempointer,0,nil);
tlendtype(0);
xxstarttypedefinition(nullsymbname,ccimpdecl,filetypename);
tltypecomp(ccint16basictype,0,nil);
tltypecomp(ccint16basictype,0,nil);
tltypecomp(ccpointerbasictype,0,nil);
tltypecomp(t,0,nil);
tlendtype(0);
(*kvadd idstr^ := '_inpfile    ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,filetypename,0,inpfiletlname);
      (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,filetypename,0,inpfiletlname);
kvadd*)
(*kvadd idstr^ := '_outpfile   ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,filetypename,0,outpfiletlname);
      (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,filetypename,0,outpfiletlname);
kvadd*)
xxstarttypedefinition(nullsymbname,ccimpdecl,cc128basictype);
tltypecomp(cc64basictype,0,nil);
tltypecomp(cc64basictype,0,nil);
tlendtype(0);
(*kvadd idstr^ := '_empty128   ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,cc128basictype,0,empty128tlname
);    (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,cc128basictype,0,empty128tlname);
kvadd*)
(*kvadd idstr^ := '_workset    ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,cc128basictype,0,worksettlname)
;     (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,cc128basictype,0,worksettlname);
kvadd*)
(*kvadd idstr^ := '_heapcheck  ';   kvadd*)
(*kvrm *)   xxstaticstoreallocation(nullsymbname,ccint8basictype,0,heapcheck);
  (* kvrm*)
(*kvadd zzstaticstoreallocation(idstr,ccint8basictype,0,heapcheck);         kvad
d*)
idstr^ := 'setop       ';
tlprocspec(pstrtrunc(idstr),ccextprocnature + 1);
tlnameallocation(setoptlname);
tlprocparam(cc128basictype,0);
tlprocparam(cc128basictype,0);
tlprocparam(ccint,0);
tlprocresult(0);
idstr^ := 'complement  ';
tlprocspec(pstrtrunc(idstr),ccextprocnature + 1);
tlnameallocation(complementtlname);
tlprocparam(cc128basictype,0);
tlprocresult(0);
idstr^ := 'pinbin      ';{issue 11}
piotlproc(pinbintlname);
idstr^ := 'poutbin     ';
piotlproc(poutbintlname);
idstr^ := 'pinrec      ';
piotlproc(pinrectlname);
idstr^ := 'poutrec     ';
piotlproc(poutrectlname);
tldataarea(0);
     end;

procedure xxretainreg(reg : regkind);{36}
     begin
     case reg of
b : tlreg(1);
a : tlreg(2);
d : tlreg(4)
     end
     end;

function xxpointertypedecl(name : mutlname) : mutlname;{37}
var newname : mutlname;
begin
xxstarttypedefinition(nullsymbname,1,newname);
tltypecomp(name,0,nil);
tlendtype(0);
xxpointertypedecl := newname
end;

procedure plantname(opcode : integer; reg : regkind; opdname : integer);{38}
     begin
     opcode := opcode + ccregfunccode[reg];
     xxplant(opcode, opdname)
     end;


{new proc to cope with 128-bit sets}
procedure xxconvsettype(tlname,type1, type2 : integer);{37a}
begin
if (type1 = cc128basictype) and (type2 <> cc128basictype) then
   begin
   if tlname <> ccitemreferenced then
      begin
      releaseregister(d,false);
      if tlname = areg then
	 begin
	 releaseregister(a,false);
	 plantentry(loadref,d,topstackentry)
	 end
      else plantname(loadref,d,tlname)
      end;
   plantname(selfld,d,1);
   xxconvsettype(ccitemreferenced,cc64basictype,type2)
   end
else begin
   if tlname <> areg then
      begin
      releaseregister(a,true);
      xxsetaregmode(type1);
      plantname(load,a,tlname)
      end;
   if type1 <> type2 then
      if type2 = cc128basictype then
	 begin
	 releaseregister(d,false);
	 plantname(loadref,d,worksettlname);
	 if type1 <> cc64basictype then
	    xxplant(convareg,cc64basictype);
	 plantname(selfld,d,1);
	 plantname(store,a,ccitemreferenced);
	 plantname(loadref,d,worksettlname);
	 plantname(selfld,d,0);
(*kvrm *)  tlclit64(cc64basictype,0);        (* kvrm*)
(*kvadd   tlclit64(cc64basictype,[]);  kvadd*)
	 plantname(load,a,0);
	 plantname(store,a,ccitemreferenced);
	 xxsetaregmode(cc128basictype);
	 plantname(load,a,worksettlname)
	 end
      else xxplant(convareg,type2);
   end;
   if entryusing[a] <> nil then
   entryusing[a]^.desc.typename := type2
end;

function operandtlname(entry : stackentry) : mutlname; forward;

procedure releaseregister;{39}
     var
	       reg1 : regkind;
	noelems : integer;
	  entry : stackentry;
     begin
     entry := entryusing[reg];
     if entry <> nil
	  then begin
	  entryusing[reg] := nil;
	  if freedreg and (reg = d) then 	   begin
	   onstack := false;
	   freedreg := false
	   end;
	  with entry^ do
	       case kind of
     reference : if refinreg then begin
	       if onstack
		    then xxplant(stk, dreg)
	       else begin
	    if boundedref and (desc.kind <> undefpointer) then
		    begin
		    xxstaticstoreallocation(nullsymbname,desc.typename +
			ccboundeditempointer, 0, selvartlname);
		   releaseregister(a,false);
		   {issue 11}xxsetaregmode(desc.typename + ccboundeditempointer);
		   plantname(loadref,a,ccitemreferenced);
		   plantname(store,a,selvartlname);
		   end
		    else begin
		   xxselectvardeclaration(selvartlname);
		    plantname(store, d, selvartlname)
		   end
		    end;
	       refinreg := false;
	       refonstack := onstack
	       end;
     data      : if datainreg then begin
	       if register = reg then if onstack
		    then  begin
		    xxplant(stk, operandtlname(entry));
		    datainreg := false;
		    dataonstack := true
		    end
	       else if register = d
		    then begin
		    xxselectvardeclaration(storename);
		    plantname(store, d, storename);
		    datainreg := false;
		    dataonstack := false
		    end
	       else begin
		    kind := variable;
		    if entry^.desc.vector then
			noelems := entry^.desc.size
		    else noelems := 0;
		    xxstaticstoreallocation(nullsymbname, desc.typename, noelems, tlname);
		    plantname(store, reg, tlname);
		    for reg1 := b to d do
			 if entryusing[reg1] = entry then entryusing[reg1] := nil
		    end
	       end
	  end
	  end
     end;


function choosetlclit(name : integer) : integer;{40}
begin
choosetlclit := 0;
if name <= %8c then tlclit32(name,0)
else if name = %9c then (*kvrm *) tlclit64(name,0) (* kvrm*)
			 (*kvadd  tlclit64(name,[])  kvadd*)
     else choosetlclit := empty128tlname
end;

function operandtlname;{41}
     var
	  c : char;
	  tname, i : integer;
     begin
     with entry^ do
	  case kind of
variable  : with desc do
	  if kind = struct
	  then if tlname = emptyset then
	     operandtlname := choosetlclit(desc.typename)
	  else operandtlname := tlname
     else operandtlname := tlname;
     reference : begin
	  operandtlname := ccitemreferenced;
	  if refinreg
	       then
	  else begin
	       if refonstack
		    then i := ccrefonstack
	       else i := selvartlname;
	       refinreg := true;
	       if entryusing[d] <> nil
		    then releaseregister(d, true);
	       entryusing[d] := entry;
	       with desc do
		    if kind = undefpointer
		    then tldtype(domtypename + ccboundeditempointer,0);
	       plantname(load, d, i)
	       end;
	  end;
data      : if datainreg
	  then operandtlname := ccregname[register]
     else if dataonstack
	  then operandtlname := ccdataonstack
     else begin
	  if entryusing[d] <> nil
	       then releaseregister(d, true);
	  plantname(load, d, storename);
	  operandtlname := dreg;
	  datainreg := true
	  end;
     konstant  : begin
	  tname := desc.typename;
	  operandtlname := 0;
	  with val do
	       case kind of
     boolkind   : tlclit32(tname, ord(bval));
     charkind   :  tlclit32(tname,ord(cval));
     intkind    : tlclit32(tname,ival);
     realkind   :{issue 11}tlclit64(tname,rval);{overloaded param rval}
		(*kvadd  tlclitr32(tname, rval);  kvadd*)
     pointerkind : tlcnull(desctypename(desc));
     stringkind : begin
if entryusing[d] <> nil then releaseregister(d,true);
plantname(loadref,d,stringlittlname);
tlclit32(ccintbasictype, length -1);
plantname(load,b,0);
plantname(limit,d,0);
operandtlname := ccitemreferenced
end;
	  end
	  end;
     default,
     statementbase : operandtlname := 0
     end
     end;

procedure plantentry;{42}
     var
	       opdname : integer;
	  freeentry : boolean;
     begin
     freeentry := false;
     opdname := operandtlname(entry);
     if not (((opdname = ccregname[reg]) and (opcode = load)) or
	((opdname = ccitemreferenced) and (opcode = loadref) and (reg = d)))

			{ no instruction required }
	  then begin
	  if (opcode = load) or (opcode = loadref) or (opcode = loadneg)
	       then begin{get register on loads}
	       if entryusing[reg] <> entry
		    then releaseregister(reg, true);
	       if retainentry
		    then begin
		    entryusing[reg] := entry;
		    with entry^ do
			 if (opcode = loadref) and (reg=d)
			 then begin
			 kind := reference;
			 boundedref := desc.vector;
			 refinreg := true
			 end
		    else begin
			 kind := data;
			 datainreg := true;
			 register := reg;
			 if reg = d
			      then bounded := false
			 end
		    end
	       else freeentry := true
	       end
	  else freeentry := true;
	  if reg = a {set mutl mode when loading a}
	       then if (opcode = load) or (opcode = loadneg)
			then if assigntype > entry^.desc.typename then
			begin
			entry^.desc.typename := assigntype;
			xxsetaregmode(assigntype)
			end
			else with entry^.desc do
 			if kind = undefpointer then
			   xxsetaregmode(domtypename+
					 ccboundeditempointer)
			else  if vector then
		    begin
tlclit32(ccintbasictype, size);
xxsetaregmode(typename + ccvecitem)
end
	       else begin
		if typename = ccboolbasictype then
		simplereln := false;
		xxsetaregmode(typename)
		end
	  else {do nothing}
	  else if (reg = d) and (opcode = load)
	       then with entry^.desc do
	       if kind = undefpointer
	       then tldtype(domtypename,dimen);
	  plantname(opcode, reg, opdname);{to plant instruction}
	  if freeentry
	       then freestack(entry)
	  end
     else if not retainentry then freestack(entry)
     end;


procedure jumponfalse(labelname : integer);{43}
     var
	       entry : stackentry;
     begin
     entry := unstack;
     if entryusing[a] <> entry
	  then plantentry(load, a, entry);
     tlclit32(ccboolbasictype, 0);
     plantname(comp, a, 0);
     xxplant(ifeqtr, labelname);
     freestack(entry)
     end;

procedure float(entry : stackentry; typ : typentry);{44}
     var
	       ivalkept : integer;
     begin
     with entry^ do
	  if kind = konstant
	  then begin
	  {issue 11}desc := realcompiletimetype^.desc;
	  with val do
	       begin
	       ivalkept := ival;
	       kind := realkind;
	       rval := ivalkept
	       end
	  end
     else xxconvaregmode(entry, 0, typ)
     end;

procedure negate(op : opkind);{45}
     begin
     with topstackentry^ do
	  case op of
scalararithmetic : if kind = konstant
	  then with val do
	  if kind = realkind
	  then rval := - rval
     else ival := - ival
     else plantentry(loadneg, a, topstackentry);
scalarlogical    : if kind = konstant
	  then with val do
	  bval := not bval
     else begin
	  if entryusing[a] <> topstackentry
	       then plantentry(load, a, topstackentry);
	  tlclit32(ccboolbasictype, 1);
	  plantname(logicalnoneq, a, 0)
	  end
     end
     end;

procedure stacknamedparam(tlname,mode : integer);{46}
     begin
     if tlname <> areg then begin
	releaseregister(a,false);
	xxsetaregmode(mode);
	plantname(load,a,tlname)
	end;
     xxplant(stkpar, areg)
     end;

procedure stackdescribedparam;{47}
     var
	       entry : stackentry;
     begin
     entry :=unstack;
     plantentry(load,a,entry);
     xxplant(stkpar, areg);
     freestack(entry)
     end;

procedure traceproc;{48}
     begin
     address := tlline(currentlineno);{issue 11}
     if trace
	  then begin
	  tlprint(0);
	  xxplant(stkl, sotlname);
	  stacknamedparam(zerotlname,ccintbasictype);
	  xxplant(enter, 0);
	  xxplant(stkl, outlinenotlname);
	  tlclit32(ccintbasictype, currentlineno);{issue 11}
	  stacknamedparam(0,ccintbasictype);
	  xxplant(enter, 0);
	  xxplant(stkl, nltlname);
	  tlclit32(ccintbasictype, 1);
	  stacknamedparam(0,ccintbasictype);
	  xxplant(enter, 0);
     tlprint(printpar)
	  end
     end;
procedure runtimeerror(errcode : integer);{49}
begin
xxplant(stkl, traptlname);
stacknamedparam(zerotlname,ccintbasictype);
tlclit32(ccintbasictype, errcode);
stacknamedparam(0,ccintbasictype);
xxendproccallseq(0)
end;
{end of procedures used to plant mutl}


{new procedure to use new mutl range chaecking }
procedure check(desc : descriptor);{50}
var s : set of 0..63;
    low, high : mutlname; reg : integer;
begin
if usebreg then
   begin
   plantentry(load,b,topstackentry);
   reg := breg
   end
else begin
     plantentry(load,a,topstackentry);
     reg := areg
     end;
with desc do
     if kind = sett then
	begin
	s := [min];
	tlclit64(typename,s);
	xxnameclit(low);
	s := [min..max];
	tlclit64(typename,s);
	xxnameclit(high);
	tlrange(reg, 5, low, high)
	end
     else tlrange(reg,0,min,max)
end;

function constval(c : constrec):integer;{50a}
begin
with c do
  case kind of
  boolkind : constval := ord(bval);
  charkind : constval := ord(cval);
  intkind  : constval := ord(ival);
  stringkind,pointerkind,realkind : constval := 0
  end
end;

procedure performoperation(operation : opkind; operator : optype; restype : typ
entry);{51}
     var
	       left, right, opd : stackentry;
	 min,max : integer;
	  reg : regkind;
	restypename : mutlname;
	  willrelease : boolean;
	
{choosetlclit moved to page 7 }

     { new proc to deal with conformal param assignments }
     procedure stackconfparam(entry : stackentry);
     begin
     releaseregister(a,false);
     xxsetaregmode(entry^.desc.typename + ccboundeditempointer);
     with entry^ do
	   if refinreg then
	      plantname(loadref, a, ccitemreferenced)
	   else if refonstack then
	      begin
	      releaseregister(d,false);
	      plantname(load,d,ccrefonstack);
	      plantname(loadref,a,ccitemreferenced)
	      end
	      else plantname(load, a, selvartlname);
     xxplant(stkpar, areg);
     freestack(entry)
     end;

     procedure compiletimeoperation;{52}
	  var i : integer;
	
	  procedure boolarithmetic(left, right : boolean);{53}
	       var
			 result : boolean;
	       begin
	       case operator of
	  andop : result := left and right;
	  orop  : result := left or right
	       end;
	       stackboolconstant(result)
	       end;
	
	  procedure intarithmetic(left, right : integer);{54}
	       var
			 result : integer;
	       begin
	       case operator of
	  plus  : result := left + right;
	  minus : result := left - right;
	  modop : if right > 0 then result := left mod right
		   else error(73);
	  mul   : result := left * right;
	  idiv  : if right = 0
		    then begin
		    result := 0;
		    error(104)
		    end
	       else result := left div right
	       end;
	       stackintconstant(result)
	       end;
	
	  procedure realarithmetic(left, right : real);{55}
	       var
			 result : real;
	       begin
	       case operator of
	  plus  : result := left + right;
	  minus : result := left - right;
	  mul   : result := left * right;
	  rdiv  : if right = 0
		    then begin
		    result := 0;
		    error(104)
		    end
	       else result := left / right
	       end;
	       stackrealconstant(result)
	       end;
	
	
	  procedure comparison(left, right : real);{56}
	       var
			 result : boolean;
	       begin
	       case operator of
	  ltop : result := (left < right);
	  leop : result := (left <= right);
	  neop : result := (left <> right);
	  eqop : result := (left = right);
	  geop : result := (left >= right);
	  gtop : result := (left > right)
	       end;
	       stackboolconstant(result)
	       end;
	
	     begin { compiletimeoperation }
	  case operation of
     scalararithmetic : if restype = inttype
	       then intarithmetic(left^.val.ival, right^.val.ival)
	  else if (restype=real32type)or (restype = real64type)
	       then realarithmetic(left^.val.rval,right^.val.rval)
	  else begin
	       i:=ord(left^.val.cval);
	       if operator=plus
		    then i:=i+1
	       else i:=i-1;
	       stackcharconstant(chr(i))
	       end;
     scalarlogical    : boolarithmetic(left^.val.bval, right^.val.bval);
     scalarcomparison : begin simplereln := false;
	case left^.val.kind of
	  boolkind : comparison(ord(left^.val.bval),ord(right^.val.bval));
	  charkind : comparison(ord(left^.val.cval),ord(right^.val.cval));
	  intkind : comparison(left^.val.ival, right^.val.ival);
	  realkind : comparison(left^.val.rval,right^.val.rval)
	end
	end
	  end;
	  freestack(left);
	  freestack(right)
	  end; { compiletimeoperation }

     procedure comparisonoperation;{57}
	  begin
	  releaseregister(a, true);
	  xxsetaregmode(ccboolbasictype);
	  plantname(load, a, cctregstate[operator]);
	  stackdata(a, booldesc)
	  end;

procedure checkmod;{58}
var lab : mutlname;
begin
xxlabelspecification(nullsymbname,cccompilerlabel,lab);
xxretainreg(a);
plantname(comp,a,zerotlname);
xxplant(ifgttr,lab);
xxplant(stk,areg);
runtimeerror(2048);
plantname(load,a,ccdataonstack+ccintbasictype);
tllabel(lab)
end;
     begin { performoperation }
     if restype^.form = sets
	then settypename := restype^.desc.typename;
     retainentry := false;
     right := unstack;
     left := unstack;
     if (left^.kind = konstant) and (right^.kind = konstant) and
	  (operation in [scalararithmetic, scalarlogical, scalarcomparison])
	  then compiletimeoperation
     else case operation of
          strcomparison,
     scalararithmetic,
     pointercomparison,
	  scalarlogical,
     scalarcomparison     : begin
      if usebreg and (operator <> modop)
	       then reg := b
	  else reg := a;
	  if (right = entryusing[reg]) and ( operator <> modop)
	       then begin
	       freestack(right);
	       opd := left;
	       if operator in [minus, idiv, rdiv,
		    ltop, leop, geop, gtop]
		    then operator := oppoperator[operator]
	       end
	  else begin
	       if entryusing[reg] = right then releaseregister(reg,false);
	       opd := right;
	       if entryusing[reg] = left
		    then freestack(left)
	       else plantentry(load, reg, left)
	       end;
	  if operation in [ scalarcomparison,strcomparison,pointercomparison ]
	       then begin
	       plantentry(comp, reg, opd);
	       if simplereln then
		relnoperator := operator
	       else comparisonoperation
	       end
	  else if operator = modop
	       then
	       begin
	       if checking then checkmod;
		if (aregmode <> ccint32basictype) and intfns32only then xxplant(convareg,ccint
32basictype);{issue 11}
	       plantname(mfn, a, modf);
	       plantname(load, a, operandtlname(opd));
	       plantname(mfn, a, modf+1);
		xxplant(convareg,restype^.desc.typename);
	       stackdata(a, restype^.desc)
	       end
	  else begin
	       restypename := restype^.desc.typename;
	       {issue 11}if (restypename <> aregmode ) and ( not usebreg )then
		  begin
		  xxplant(convareg,restypename);
		  aregmode := restypename
		  end;
	       plantentry(ccopcode[operator], reg, opd);
	       stackdata(reg, restype^.desc)
	       end
	  end;
     confassignment : begin
	   xxplant(stkl, movearraytlname);
	   stackconfparam(right);
	   stackconfparam(left);
(*kvmod*)  tlctype(ccintbasictype,0,left^.desc.typename);
	   stacknamedparam(0,ccintbasictype);
	   xxendproccallseq(0)
	   end;
     setassignment,
     stringassignment,
     pointerassignment,
     scalarassignment,
     structassignment : begin
         if left^.desc.kind=ordinal then
            begin
	     min:=left^.desc.min;
	     max:=left^.desc.max;
            if right^.kind=konstant then
	       if right^.val.kind = intkind then
               if (right^.val.ival<min)
                  or (right^.val.ival>max) then
                  error(107)
	    end;
	    if entryusing[a]=right
	       then freestack(right)
	       else plantentry(load,a,right);
	    plantentry(store,a,left)
	  end;
      inset : begin
if entryusing[a] = right then releaseregister(a,false);
			if right^.desc.typename = cc128basictype then
			   begin
			   xxsetaregmode(cc128basictype);
			   plantname(load,a,empty128tlname);
			   plantname(store,a,worksettlname);
			   xxplant(stkl, setelemtlname);
			   plantentry(load,a,left);
			   xxplant(convareg,ccint);
			   xxplant(stkpar,areg);
			   xxendproccallseq(0);
			   xxsetaregmode(cc128basictype);
			   plantname(load,a,worksettlname)
			   end
			 else
			   begin
			   xxconvsettype(singleset,cc32basictype,right^.desc.typename);
			   plantentry(logicallshift, a, left);
			   end;
			   stackdata(a, right^.desc);
			   if aregmode = cc128basictype then
			      releaseregister(a,false);
			   stack(right);
                        performoperation(setcomparison, leop, restype)
                        end;

	  setarithmetic,
     setcomparison	: begin
         if operator in [minus, leop]
            then begin
		  if (entryusing[a]=left)and(aregmode=cc128basictype) then
		     releaseregister(a,false);
		   plantentry(load,a,right);
		  if right^.desc.typename = cc128basictype then
		     begin
		     xxplant(stkl, complementtlname);
		     xxplant(stkpar,areg);
		     xxendproccallseq(0);
		     xxsetaregmode(cc128basictype);
		     plantname(load,a,worksettlname)
		     end
		  else
		     plantname(logicaleq,a,choosetlclit(right^.desc.typename));
                 opd := left;
                 operator := mul
                 end
            else if operator=geop then
                    begin
		  if (entryusing[a]=right)and(aregmode=cc128basictype) then
		     releaseregister(a,false);
		  plantentry(load,a,left);
		  if left^.desc.typename = cc128basictype then
		     begin
		     xxplant(stkl, complementtlname);
		     xxplant(stkpar,areg);
		     xxendproccallseq(0);
		     xxsetaregmode(cc128basictype);
		     plantname(load,a,worksettlname)
		     end
		  else
		     plantname(logicaleq,a,choosetlclit(left^.desc.typename));
                    opd := right;
                    operator := mul
                    end
                 else if entryusing[a]=right then
                            begin
                            freestack(right);
                            opd := left
                            end
                         else begin
                              plantentry(load, a, left);
                                 opd := right
                                 end;
	       if (aregmode = cc128basictype) and (operator in [mul,plus]) then
	       begin
	       xxplant(stkl, setoptlname);
	       xxplant(stkpar,areg);
	       plantentry(load,a,opd);
	       xxplant(stkpar,areg);
	       tlclit32(ccintbasictype, ord(ccsetopcode[operator]));
	       stacknamedparam(0,ccintbasictype);
	       xxendproccallseq(0);
	       xxsetaregmode(cc128basictype);
	       plantname(load,a,worksettlname)
	       end
	       else plantentry(ccsetopcode[operator], a, opd);
               if operation = setcomparison then
                  begin
                  if operator = mul then
                     begin
		     plantname(comp,a,choosetlclit(aregmode));
                     operator := eqop
                     end;
		  if simplereln then
			relnoperator := operator
                  else comparisonoperation
                  end
               else stackdata(a, restype^.desc)
	  end;
     end;
     retainentry := true
     end; { performoperation }
procedure setbounds(entrystacked, setlow, sethigh : boolean; lowbound, highboun
d : integer);{59}
     var
	       entry : stackentry;
     begin
     if entrystacked
	  then begin
	  entry := unstack;
	  plantentry(load, b, entry);
	  freestack(entry)
	  end;
     if entryusing[d] <> topstackentry
	  then releaseregister(d, false);
     plantentry(loadref, d, topstackentry);
     if entrystacked
	  then begin
	  if setlow
	       then begin
	       if lowbound <> 0
		    then plantintconstant(add, b, - lowbound);
	       plantname(base, d, 1);
	       entrystacked := false
	       end
	  else plantintconstant(add, b, - 1)
	  end;
     if sethigh
	  then begin
	  if not entrystacked
	       then plantintconstant(load, b, highbound);
	  plantname(limit, d, 0)
	  end
     end;

{iooperation moved inside fileproc}
{ new proc to access elements of conformant array params }
procedure confreference(t : typentry);{60}
var
     l,h : integer;
     indexentry, arrayentry : stackentry;
begin
l := idrecs[t^.low].tlname;
indexentry := unstack;
arrayentry := unstack;
if entryusing[b] <> indexentry then
   plantentry(load,b,indexentry);
if checking then tlrange(breg,5,l,idrecs[t^.high].tlname);
freestack(indexentry);
plantname(subtract,b,l);
plantentry(loadref,d,arrayentry);
if t^.elemtype^.form = arrays then
   with t^.elemtype^ do
      if desc.size = -1 then
	  begin
	  l := idrecs[low].tlname;
	  h := idrecs[high].tlname;
	  releaseregister(a,true);
	  xxsetaregmode(indextype^.desc.typename);
	  plantname(load,a,h);
	  plantname(subtract,a,l);
	  xxretainreg(a);
	  plantname(multiply,b,areg);
	  plantname(base,d,1);
	  plantintconstant(subtract,a,1);
	  plantname(limit,d,0);
	  end
      else begin
	  plantintconstant(multiply,b,desc.size);
	  plantname(base,d,1);
	  plantintconstant(load,b,desc.size-1);
	  plantname(limit,d,0)
	  end
      else plantname(selel,d,0);
arrayentry^.desc := t^.elemtype^.desc;
stack(arrayentry)
end;

procedure indexedreference(lowbound, selfac : integer; elemdesc : descriptor);{6
1}
     var
	       indexentry, arrayentry : stackentry;
     begin
     indexentry := unstack;
     arrayentry := unstack;
     if entryusing[b] <> indexentry
	  then plantentry(load, b, indexentry);
     freestack(indexentry);
     if lowbound <> 0
	  then plantintconstant(add, b, - lowbound);
	plantentry(loadref, d, arrayentry);
     if selfac = 0 then
	plantname(selel,d,0)
     else begin
	plantintconstant(multiply,b,selfac);
	plantname(base,d,1);
	plantintconstant(load,b,selfac-1);
	plantname(limit,d,0)
	end;
     arrayentry^.desc := elemdesc;
     arrayentry^.boundedref := elemdesc.vector;
     stack(arrayentry)
     end;

procedure fieldreference(selectroot : fieldselentry; fielddesc : descriptor);{62
}
     var
	       selroot : fieldselentry;
	  opcode : integer;
     begin
     plantentry(loadref, d, topstackentry);
     while selectroot <> nil do
	  with selectroot^ do
	  begin
	  if kind = fld
	       then opcode := selfld
	  else opcode := selalt;
	  plantname(opcode, d, opd);
	  selectroot := next
	  end;
     topstackentry^.boundedref := fielddesc.vector;
     topstackentry^.desc := fielddesc
     end;

procedure pointerreference(recdesc : descriptor);{63}
     begin
     plantentry(load, d, topstackentry);
if recdesc.vector then
begin
plantintconstant(load,b,recdesc.size-1);
plantname(limit,d,0)
end;
     with topstackentry^ do
	  begin
	  desc := recdesc;
	  kind := reference;
	  refinreg := true
	  end
     end;

procedure withreference(withbase : stackentry; selectroot : fieldselentry; field
desc : descriptor);{64}
     var
	       fieldentry : stackentry;
     begin
     new(fieldentry);
     fieldentry^ := withbase^;
     stack(fieldentry);
     fieldreference(selectroot, fielddesc)
     end;

procedure forcepointer(typename : integer);{65}
     begin
     if entryusing[d] <> topstackentry then
       releaseregister(d,false)
;     if entryusing[a] <> topstackentry then
	releaseregister(a,false);
     xxsetaregmode(typename);
     plantname(loadref,a,operandtlname(topstackentry));
     with topstackentry^ do
	  begin
	  kind := data;
	  datainreg := true;
	  register := a
	  end
     end;

procedure openwithstatement;{66}
var mtlname : mutlname;
     begin
     releaseregister(a,true);
     xxsetaregmode(topstackentry^.desc.typename + ccunboundeditempointer);
     plantname(loadref,a,operandtlname(topstackentry));
     xxstaticstoreallocation(nullsymbname,topstackentry^.desc.typename
	+ ccunboundeditempointer,0,mtlname);
     plantname(store,a,mtlname);
     with topstackentry^ do
	begin
	kind := reference;
	refinreg := false;
	refonstack := false;
	selvartlname := mtlname
	end;
     end;

procedure closewithstatement;{67}
     var
	       withbase : stackentry;
     begin
     withbase := unstack;
     freestack(withbase)
     end;

function cardinality(entry : typentry) : integer; forward;

function comptypes(t1,t2 : typentry):boolean; forward;
procedure getdescriptor(entry : typentry; symbname : identry);{68}
     type
	       declarentry = ^declarerec;
	  declarerec = record
	       depth : integer;
	       next : declarentry;
	       case addition : boolean of
	       true : (symbname : identry;
	       typename, dimension : integer)
	       end;
     var
	       selectentry : fieldselentry;
	  decltail : declarentry;
	  fldselhead, fldseltail : fieldselentry;
	  noels, i, dimension, typname, siz, bitsize : integer;
	  idroot : identry;
	  level : integer;
	
     procedure newfieldselentry(k : fldselkind; val : integer);{69}
	  begin
	  new(selectentry);
	  with selectentry^ do
	       begin
	       next := nil;
	       kind := k;
	       opd := val
	       end
	  end;

     procedure newadddeclarentry(symname : identry; typname, dimen : integer);{7
0}
	  var
		    entry : declarentry;
	  begin
	  new(entry);
	  with entry^ do
	       begin
	       depth := level;
	       next := decltail;
	       addition := true;
	       symbname := symname;
	       typename := typname;
	       dimension := dimen;
	       end;
	  decltail := entry
	  end;

     procedure newenddeclarentry;{71}
	  var
		    entry : declarentry;
	  begin
	  new(entry);
	  with entry^ do
	       begin
	       depth := level;
	       next := decltail;
	       addition := false
	       end;
	  decltail := entry
	  end;

     procedure breakdeclarentry(symbnm : identry; var newtypename : mutlname);{7
2}
	  var
		    thislevel : boolean;
	       entry : declarentry;
	  begin
	  thislevel := false;
	  if decltail <> nil then thislevel := decltail^.depth = level;
	  xxstarttypedefinition(symbnm, 0, newtypename);
	  while thislevel do
	       begin
	       entry := decltail;
	       with decltail^ do
		    begin
		    if addition
			 then begin
			 with idrecs[symbname] do
			 tltypecomp(typename, dimension, addbound(idarray[iindex+1],length))
			end
		    else tlendtype(1);
		    decltail := next
		    end;
	       dispose(entry);
	       if decltail <> nil then thislevel := decltail^.depth = level
	       else thislevel := false
	       end;
	  tlendtype(0)
	  end;

     procedure  fielddeclaration(idroot : identry; packdec : boolean);{73}
	
	  procedure getselectroot(id : identry; packroot : boolean);{74}
	       var
		tname : mutlname;
			 newselhead, newseltail, newentry, entry : fieldselentry;
	       begin
	       newfieldselentry(fld, idrecs[id].serial);
	       if fldselhead <> nil
		    then begin
		    newseltail := nil;
		    entry := fldselhead;
		    while entry <> nil do
			 begin
			 new(newentry);
			 newentry^ := entry^;
			 if newseltail = nil
			      then newselhead := newentry
			 else newseltail^.next := newentry;
			 newseltail := newentry;
			 entry := entry^.next
			 end;
		    newseltail^.next := selectentry
		    end
	       else newselhead := selectentry;
	       with idrecs[id] do
		    begin
		    selectroot := newselhead;
		    if idtype <> nil
			 then with idtype^ do
			begin
			if packroot then tname := desc.packname
			else tname := desc.typename;
			if form = arrays then
		  	newadddeclarentry(id,tname,desc.size)
			 else newadddeclarentry(id, tname, 0)
			end
		    end
	       end; {get select root}
	
	  begin { fielddeclaration }
	  while idroot <> -1 do
	       begin
	       getselectroot(idroot, packdec);
	       idroot := idrecs[idroot].next
	       end
	  end; { fielddeclaration }

        procedure disposeselentry(markedentry : fieldselentry);{75}
	  var
		    thisentry, entry : fieldselentry;
	  begin
	  if markedentry = nil
	       then if fldseltail <> nil
	       then begin
	       dispose(fldseltail);
	       fldseltail := nil;
	       fldselhead := nil
	       end
	  else
	  else if markedentry <> fldseltail
	       then begin
	       entry := markedentry^.next;
	       while entry <> nil do
		    begin
		    thisentry := entry;
		    entry := entry^.next;
		    dispose(thisentry)
		    end;
	       fldseltail := markedentry;
	       if fldseltail = nil
		    then fldselhead := nil
	       else fldseltail^.next := nil
	       end
	  end;

     procedure variantdeclaration(varntrt : typentry; packvar : boolean); forwar
d;

     procedure varpartdeclaration(varpartroot : typentry; packtag : boolean);{76
}
	  var
		    thistail : fieldselentry;
	  begin
	  thistail := fldseltail;
	  with varpartroot^ do
	       begin
	       newfieldselentry(fld, serial);
	       if fldselhead = nil
		    then fldselhead := selectentry
	       else fldseltail^.next := selectentry;
	       fldseltail := selectentry;
	       if variantroot <> nil
		    then variantdeclaration(variantroot, packtag);
	       disposeselentry(thistail);
	       if tagfield <> -1
		    then fielddeclaration(tagfield, packtag);
	       end
	  end;

     procedure variantdeclaration;{77}
	  var
		    newtypename : mutlname;
	       thistail : fieldselentry;
	  begin
	  level := level + 1;

	  thistail := fldseltail;
	  while varntrt <> nil do {while more variants}
	       begin
	       with varntrt^ do
		    begin
		    if not aslastvariant
			 then begin
			 if distinctvariantcount <> 0
			      then begin
			      newfieldselentry(alt, distinctvariantcount);
			      if fldselhead = nil
				   then fldselhead := selectentry
			      else fldseltail^.next := selectentry;
			      fldseltail := selectentry
			      end;
			 if subvarpart <> nil
			      then varpartdeclaration(subvarpart, packvar);
			 if varfieldroot <> -1
			      then fielddeclaration(varfieldroot,packvar)
			 end;

		    varntrt := nextvariant;
		    end;
	
	       if varntrt <> nil
		    then if not varntrt^.aslastvariant
		    then newenddeclarentry;
	       disposeselentry(thistail)
	       end; {while more variants}
	  {declare variants to mutl}
	  breakdeclarentry(nullsymbname, newtypename);
	  level := level - 1;
	  newadddeclarentry(nullsymbname, newtypename, 0)
	  end;
(*kvrm *)
**in -1
