(*version: 004		date: 1-5-77*)
(*--------------------------------------------------------------
|								|
|		P A S C A L   C O M P I L E R			|
|		-----------------------------			|
|								|
|	This compiler processes PASCAL-U1, a subset of		|
|   of standard PASCAL and has been written in this subset.	|
|   It is a modified version of the PASCAL-P2 compiler as	|
|   distributed by the ETH at Zuerich.				|
|								|
|	Authors:						|
|	   Urs Amann, Kesav Nori, Christian Jacobi		|
|								|
|	Authors of modification:				|
|	   Rudolf van Bottenburg, Johan Stevenson		|
|		Vakgroep Informatica				|
|		Wiskundig Seminarium				|
|		Vrije Universiteit				|
|		A M S T E R D A M				|
|								|
---------------------------------------------------------------*)


program pascalcompiler(input,output,prr);



const displimit = 20; maxlevel = 10; maxaddr = 32767; maxint=32767;
      maxchord = 127; tab = '	';
      intsize = 2; realsize = 4;
      charsize = 1; boolsize = 1; setsize =8; ptrsize = 2;
      len0=10; len1=20; len2=40; len3=80; digmax=13;
      lcaftermarkstack = 10; maxfiles = 8;
      (*  3*ptrsize+max of standard scalar sizes and ptrsize  *)



type
(*basic symbols*)

     symbol = (underline,letters,digits,  (*they must be the first three*)
		ident,intconst,charconst,realconst,stringconst,notsy,mulop,
	       addop,relop,layout,quote,less,greater,lbrace,
	       lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
	       colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
	       procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
	       beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
	       gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
	       thensy,othersy);
     operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
		 neop,eqop,inop,noop);
     setofsys = set of symbol;

(*constants*)

     cstclass = (reel,strg);
     strtype = (t0,t1,t2,t3);
     maxset = set of 0..63;
     csp = ^ constant;
     constant = record case cstclass of
			 reel: (rval: array [1..digmax] of char);
			 strg: (slgth: 1..len3;
				case strtype of
				  t0:(sval0:array [1..len0] of char);
				  t1:(sval1:array [1..len1] of char);
				  t2:(sval2:array [1..len2] of char);
				  t3:(sval3:array [1..len3] of char)
			       )
		       end;

     valu = record case boolean of
		     true:  (ival: integer);
		     false: (valp: csp)
		   end;

(*data structures*)
     levrange = 0..maxlevel; addrrange = 0..maxaddr;
     structform = (scalar,subrange,pointer,power,arrays,records,files,
		   tagfld,variant);
     declkind = (standard,declared);
     stp = ^ structure; ctp = ^ identifier;

     structure = packed record
		   size: addrrange;
		   case form: structform of
		     scalar:   (case scalkind: declkind of
				  declared: (fconst: ctp));
		     subrange: (rangetype: stp; min,max: valu);
		     pointer:  (eltype: stp);
		     power:    (elset: stp);
		     arrays:   (aeltype,inxtype: stp);
		     records:  (fstfld: ctp; recvar: stp);
		     files:    (filtype: stp);
		     tagfld:   (tagstp: stp; fstvar: stp);
		     variant:  (nxtvar,subvar: stp; varval: valu)
		   end;

(*names*)

     idclass = (types,konst,vars,field,proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);
     alpha = packed array [1..8] of char;

     identifier = packed record
		   name: alpha; llink, rlink: ctp;
		   idtype: stp; next: ctp;
		   case klass: idclass of
		     konst: (values: valu);
		     vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
		     field: (fldaddr: addrrange);
		     proc,
		     func:  (case pfdeckind: declkind of
			      standard: (key: 1..15);
			      declared: (pflev: levrange; pfname: integer;
					  case pfkind: idkind of
					   actual: (forwdecl, extrn:
						    boolean)))
		   end;


     disprange = 0..displimit;
     where = (blck,crec,vrec,rec);

(*expressions*)
     attrkind = (cst,varbl,expr);
     vaccess = (drct,indrct,inxd);

     attr = record typtr: stp;
	      case kind: attrkind of
		cst:   (intval:integer);
		varbl: (case access: vaccess of
			  drct: (vlevel: levrange; dplmt: addrrange);
			  indrct: (idplmt: addrrange))
	      end;

     testp = ^ testpointer;
     testpointer = packed record
		     elt1,elt2 : stp;
		     lasttestp : testp
		   end;

(*labels*)
     lbp = ^ labl;
     labl = record nextlab: lbp; defined: boolean;
		   labval, labname: integer
	    end;


(*-------------------------------------------------------------------------*)


var
(*returned by source program scanner insymbol *)

    sy: symbol;				(*last symbol*)
    op: operator;			(*classification of last symbol*)
    val: valu;				(*value of last constant*)
    lgth: integer;			(*length of last string constant*)
    id: alpha;				(*last identifier(possibly truncated)*)
    kk: 1..8;				(*nr of chars in last identifier*)
    ch: char;				(*last character*)
    eol: boolean;			(*end of line flag*)
     endoffile: boolean;		(*end of file flag*)

(*counters:*)

     chcnt: integer;			(*character counter*)
    lc: addrrange;			(*instruction counter*)
    linecount: integer;


(*switches:*)

    dp,				(*declaration part*)
    prterr:boolean;		(*to allow forward references in pointer type
				  declaration by suppressing error message*)


(*pointers:*)
    intptr,realptr,charptr,
    boolptr,nilptr,textptr
			  : stp;    (*pointers to entries of standard ids*)
    utypptr,ucstptr,uvarptr,
    ufldptr,uprcptr,ufctptr,	(*pointers to entries for undeclared ids*)
    fwptr: ctp;			(*head of chain of forw decl type ids*)
    globtestp: testp;		(*last testpointer*)


(*bookkeeping of declaration levels:*)

    level: levrange;		(*current static level*)
    disx,			(*level of last id searched by searchid*)
    top: disprange;		(*top of display*)

    display:				(*where:   means:*)
      array [disprange] of
	packed record			(*=blck:   id is variable id*)
	  fname: ctp; flabel: lbp;	(*=crec:   id is field in record with*)
	  case occur: where of		(*	   constant address*)
	    crec: (clev: levrange;	(*=vrec:   id is field in record with*)
		  cdspl: addrrange);	(*	   variable address*)
	    vrec: (vdspl: addrrange)
	  end;				(* --> procedure withstatement*)


(*expression compilation:*)

    gattr: attr;		(*describes the expr currently compiled*)


(*structured constants:*)

    constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
    statbegsys,typedels: setofsys;
    rw:  array [1..35(*nr. of res. words*)] of alpha;
    frw: array [1..9] of 1..36(*nr. of res. words + 1*);
    rsy: array [1..35(*nr. of res. words*)] of symbol;
    ssy: array [char] of symbol;
    rop: array [1..35(*nr. of res. words*)] of operator;
    sop: array [')'..'^'] of operator;
    na:  array [1..38] of alpha;
    mn:  array [0..57] of packed array [1..4] of char;
    sna: array [1..30] of packed array [1..4] of char;
    intlabel,mxint10 : integer;

(*-------------------------------------------------------------------------*)

  procedure error(ferrnr: integer);
  begin writeln(output,ferrnr,linecount,chcnt) end;

  procedure insymbol;
    (*read next basic symbol of source program and return its
    description in the global variables sy, op, id, val and lgth*)
    label 1,2,3;
    var i,k: integer;
	digit: packed array [1..digmax] of char;
	string: packed array [1..len3] of char;
	lvp: csp;test: boolean;

    procedure nextch;
    begin
      if eol then begin linecount:=linecount+1; chcnt:=0 end;
      if not eof(input) then
       begin eol := eoln(input); read(input,ch);
	if ch = tab
	 then chcnt := chcnt - chcnt mod 8 + 8
	 else chcnt := chcnt + 1
       end
      else
	if not endoffile then
	  begin error(0);
	    endoffile := true; eol := false; ch := ';';
	  end
    end;

    procedure options;
    begin end;

  begin (*insymbol*)
  1:
     while ssy[ch]= layout do nextch;
    case ssy[ch] of
      letters:
	begin k := 0;
	  repeat
	    if k < 8 then
	     begin k := k + 1; id[k] := ch end ;
	    nextch
	  until ssy[ch]>digits;  (*ugly, but fast*)
	  if k >= kk then kk := k
	  else
	    repeat id[kk] := ' '; kk := kk - 1
	    until kk = k;
	  for i := frw[k] to frw[k+1] - 1 do
	    if rw[i] = id then
	      begin sy := rsy[i]; op := rop[i]; goto 2 end;
	    sy := ident; op := noop;
  2:    end;
      digits:
	begin op := noop; i := 0;
	  repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
	  until (ord(ch)<ord('0')) or (ord(ch)>ord('9'));
	  if (ch = '.') or (ch = 'e') then
	    begin
		  k := i;
		  if ch = '.' then
		    begin k := k+1; if k <= digmax then digit[k] := ch;
		      nextch; if ch = '.' then begin ch := ':'; goto 3 end;
		      if (ord(ch)<ord('0')) or (ord(ch)>ord('9')) then
			error(201)
		      else
			repeat k := k + 1;
			  if k <= digmax then digit[k] := ch; nextch
			until (ord(ch)<ord('0')) or (ord(ch)>ord('9'))
		    end;
		  if ch = 'e' then
		    begin k := k+1; if k <= digmax then digit[k] := ch;
		      nextch;
		      if (ch = '+') or (ch ='-') then
			begin k := k+1; if k <= digmax then digit[k] := ch;
			  nextch
			end;
		      if (ord(ch)<ord('0')) or (ord(ch)>ord('9')) then
			error(201)
		      else
			repeat k := k+1;
			  if k <= digmax then digit[k] := ch; nextch
			until (ord(ch)<ord('0')) or (ord(ch)>ord('9'))
		     end;
		   new(lvp,reel); sy:= realconst;
		   with lvp^ do
		     begin for i := 1 to digmax do rval[i] := ' ';
		       if k <= digmax then
			 for i := 2 to k + 1 do rval[i] := digit[i-1]
		       else begin error(203); rval[2] := '0';
			      rval[3] := '.'; rval[4] := '0'
			    end
		     end;
		   val.valp := lvp
	    end
	  else
  3:	begin
	      if i > digmax then begin error(203); val.ival := 0 end
	      else
		with val do
		  begin ival := 0;
		    for k := 1 to i do
		      begin
			if ival <= mxint10 then
			  ival := ival*10 + (ord(digit[k])-ord('0'))
			else begin error(203); ival := 0 end
		      end;
		    sy := intconst
		 end
	    end
	end;
      quote:
	begin lgth := 0;  op := noop;
	  repeat
	    repeat nextch; lgth := lgth + 1;
		   if lgth <= len3 then string[lgth] := ch
	    until (eol) or (ch = '''');
	    if eol then error(202) else nextch
	  until ch <> '''';
	  lgth := lgth - 1;   (*now lgth = nr of chars in string*)
	  if lgth = 1 then
	    begin sy:=charconst; val.ival:=ord(string[1]) end
	  else
	    begin sy:=stringconst; if lgth=0 then error(397);
	      if lgth <= len0 then new(lvp,strg,t0) else
	      if lgth <= len1 then new(lvp,strg,t1) else
	      if lgth <= len2 then new(lvp,strg,t2) else
		begin new(lvp,strg,t3);
		  if lgth>len3 then begin error(397); lgth:=len3 end
		end;
	      lvp^.slgth:=lgth; val.valp:=lvp;
	      for i:=1 to lgth do lvp^.sval3[i]:=string[i]
	    end
	end;
      colon:
	begin op := noop; nextch;
	  if ch = '=' then
	    begin sy := becomes; nextch end
	  else sy := colon
	end;
      period:
	begin op := noop; nextch;
	  if ch = '.' then
	    begin sy := colon; nextch end
	  else sy := period
	end;
      less:
	begin nextch; sy := relop;
	  if ch = '=' then
	    begin op := leop; nextch end
	  else
	    if ch = '>' then
	      begin op := neop; nextch end
	    else op := ltop
	end;
      greater:
	begin nextch; sy := relop;
	  if ch = '=' then
	    begin op := geop; nextch end
	  else op := gtop
	end;
      lparent:
       begin nextch;
	 if ch = '*' then
	   begin nextch;
	     if ch = '$' then options;
	     repeat
	       while (ch <> '*') or endoffile  do nextch;
	       nextch
	     until (ch = ')') or endoffile;
	     nextch; goto 1
	   end;
	 sy := lparent; op := noop
       end;
      lbrace:
	begin repeat nextch until (ch='}') or endoffile;
	  nextch; goto 1;
	end;
      mulop,addop,relop,rparent,lbrack,rbrack,comma,semicolon,arrow:
	begin sy := ssy[ch]; op := sop[ch];
	  nextch
	end;
      underline,othersy:
	begin sy := othersy; op := noop; error(396); nextch end
    end (*case*)
  end (*insymbol*) ;

  procedure enterid(fcp: ctp);
    (*enter id pointed at by fcp into the name-table,
     which on each declaration level is organised as
     an unbalanced binary tree*)
    var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
  begin nam := fcp^.name;
    lcp := display[top].fname;
    if lcp = nil then
      display[top].fname := fcp
    else
      begin
	repeat lcp1 := lcp;
	  if lcp^.name = nam then   (*name conflict, follow right link*)
	    begin error(101); lcp := lcp^.rlink; lleft := false end
	  else
	    if lcp^.name < nam then
	      begin lcp := lcp^.rlink; lleft := false end
	    else begin lcp := lcp^.llink; lleft := true end
	until lcp = nil;
	if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
      end;
    fcp^.llink := nil; fcp^.rlink := nil
  end (*enterid*) ;

  procedure searchsection(fcp: ctp; var fcp1: ctp);
    (*to find record fields and forward declared procedure id's
     --> procedure proceduredeclaration
     --> procedure selector*)
     label 1;
  begin
    while fcp <> nil do
      if fcp^.name = id then goto 1
      else if fcp^.name < id then fcp := fcp^.rlink
	else fcp := fcp^.llink;
1:  fcp1 := fcp
  end (*searchsection*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
  begin
    for disx := top downto 0 do
      begin lcp := display[disx].fname;
	while lcp <> nil do
	  if lcp^.name = id then
	    if lcp^.klass in fidcls then goto 1
	    else
	      begin if prterr then error(103);
		lcp := lcp^.rlink
	      end
	  else
	    if lcp^.name < id then
	      lcp := lcp^.rlink
	    else lcp := lcp^.llink
      end;
    (*search not successfull; suppress error message in case
     of forward referenced type id in pointer type definition
     --> procedure simpletype*)
    if prterr then
      begin error(104);
	(*to avoid returning nil, reference an entry
	 for an undeclared id of appropriate class
	 --> procedure enterundecl*)
	if types in fidcls then lcp := utypptr
	else
	  if vars in fidcls then lcp := uvarptr
	  else
	    if field in fidcls then lcp := ufldptr
	    else
	      if konst in fidcls then lcp := ucstptr
	      else
		if proc in fidcls then lcp := uprcptr
		else lcp := ufctptr;
      end;
1:  fcp := lcp
  end (*searchid*) ;

  procedure getbounds(fsp: stp; var fmin,fmax: integer);
    (*get internal bounds of subrange or scalar type*)
    (*assume (fsp <> nil) and (fsp^.form <= subrange) and (fsp <> intptr)
     and not comptypes(realptr,fsp)*)
  begin
    with fsp^ do
      if form = subrange then
	begin fmin := min.ival; fmax := max.ival end
      else
	begin fmin := 0;
	  if fsp = charptr then fmax := maxchord
	  else
	    if fsp^.fconst <> nil then
	      fmax := fsp^.fconst^.values.ival
	    else fmax := 0
	end
  end (*getbounds*) ;

  procedure genlabel(var nxtlab: integer);
  begin intlabel := intlabel + 1;
    nxtlab := intlabel
  end (*genlabel*);

  procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
    var lsy: symbol; test: boolean;

    procedure even (var cnt : addrrange );
    begin if odd(cnt) then cnt:= cnt + 1 end;

    procedure skip(fsys: setofsys);
      (*skip input string until relevant symbol found*)
     begin while not((sy in fsys) or endoffile) do insymbol
    end (*skip*) ;

    procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
      var lsp: stp; lcp: ctp; sign: (none,pos,neg);
	  lvp: csp; i: 2..len3;
    begin lsp := nil; fvalu.ival := 0;
      if not(sy in constbegsys) then
	begin error(50); skip(fsys+constbegsys) end;
      if sy in constbegsys then
	begin
	  if (sy=stringconst) or (sy=charconst) then
	    begin
	      if sy=charconst then lsp:=charptr
	      else
		begin
		  new(lsp,arrays);
		  with lsp^ do
		    begin aeltype := charptr; inxtype := nil;
		       size := lgth*charsize; form := arrays
		    end
		end;
	      fvalu := val; insymbol
	    end
	  else
	    begin
	      sign := none;
	      if (sy = addop) and (op in [plus,minus]) then
		begin if op = plus then sign := pos else sign := neg;
		  insymbol
		end;
	      if sy = ident then
		begin searchid([konst],lcp);
		  with lcp^ do
		    begin lsp := idtype; fvalu := values end;
		  if sign <> none then
		    if lsp = intptr then
		      begin if sign = neg then fvalu.ival := -fvalu.ival end
		    else
		      if lsp = realptr then
			begin
			  if sign = neg then
			    begin new(lvp,reel);
			      if fvalu.valp^.rval[1] = '-' then
				lvp^.rval[1] := '+'
			      else lvp^.rval[1] := '-';
			      for i := 2 to len3 do
				lvp^.rval[i] := fvalu.valp^.rval[i];
			      fvalu.valp := lvp;
			    end
			  end
			else error(105);
		  insymbol;
		end
	      else
		if sy = intconst then
		  begin if sign = neg then val.ival := -val.ival;
		    lsp := intptr; fvalu := val; insymbol
		  end
		else
		  if sy = realconst then
		    begin if sign = neg then val.valp^.rval[1] := '-';
		      lsp := realptr; fvalu := val; insymbol
		    end
		  else
		    begin error(106); skip(fsys) end
	    end;
	  if not (sy in fsys) then
	    begin error(6); skip(fsys) end
	  end;
      fsp := lsp
    end (*constant*) ;

    function comptypes(fsp1,fsp2: stp) : boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
      var nxt1,nxt2: ctp; comp: boolean;
	ltestp1,ltestp2 : testp;
    begin
      if fsp1 = fsp2 then comptypes := true
      else
	if (fsp1 <> nil) and (fsp2 <> nil) then
	  if fsp1^.form = fsp2^.form then
	    case fsp1^.form of
	      scalar:
		comptypes := false;
		(* identical scalars declared on different levels are
		 not recognized to be compatible*)
	      subrange:
		comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
	      pointer:
		  begin
		    comp := false; ltestp1 := globtestp;
		    ltestp2 := globtestp;
		    while ltestp1 <> nil do
		      with ltestp1^ do
			begin
			  if (elt1 = fsp1^.eltype) and
			    (elt2 = fsp2^.eltype) then comp := true;
			  ltestp1 := lasttestp
			end;
		    if not comp then
		      begin new(ltestp1);
			with ltestp1^ do
			  begin elt1 := fsp1^.eltype;
			    elt2 := fsp2^.eltype;
			    lasttestp := globtestp
			  end;
			globtestp := ltestp1;
			comp := comptypes(fsp1^.eltype,fsp2^.eltype)
		      end;
		    comptypes := comp; globtestp := ltestp2
		  end;
	      power:
		comptypes := comptypes(fsp1^.elset,fsp2^.elset);
	      arrays:
		comptypes := comptypes(fsp1^.aeltype,fsp2^.aeltype)
			     and (fsp1^.size = fsp2^.size);
		(*alternatives: -- add a third boolean term: indextype must
				  be compatible.
			       -- add a fourth boolean term: lowbounds must
				  be the same*)
	      records:
		begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
		  while (nxt1 <> nil) and (nxt2 <> nil) do
		    begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
		      nxt1 := nxt1^.next; nxt2 := nxt2^.next
		    end;
		  comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
			      and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
		end;
		(*identical records are recognized to be compatible
		 iff no variants occur*)
	      files:
		comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
	    end (*case*)
	  else (*fsp1^.form <> fsp2^.form*)
	    if fsp1^.form = subrange then
	      comptypes := comptypes(fsp1^.rangetype,fsp2)
	    else
	      if fsp2^.form = subrange then
		comptypes := comptypes(fsp1,fsp2^.rangetype)
	      else comptypes := false
	else comptypes := true
    end (*comptypes*) ;

    function string(fsp: stp) : boolean;
    begin string := false;
      if fsp <> nil then
	if fsp^.form = arrays then
	  if comptypes(fsp^.aeltype,charptr) then string := true
    end (*string*) ;

    procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
      var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
	  lsize,displ: addrrange; lmin,lmax: integer;

      procedure simpletype(fsys:setofsys; var fsp:stp);
	var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
	    lcnt: integer; lvalu: valu;
      begin
	if not (sy in simptypebegsys) then
	  begin error(1); skip(fsys + simptypebegsys) end;
	if sy in simptypebegsys then
	  begin
	    if sy = lparent then
	      begin ttop := top;   (*decl. consts local to innermost block*)
		while display[top].occur <> blck do top := top - 1;
		new(lsp,scalar,declared);
		with lsp^ do
		  begin size := intsize; form := scalar;
		    scalkind := declared
		  end;
		lcp1 := nil; lcnt := 0;
		repeat insymbol;
		  if sy = ident then
		    begin new(lcp,konst);
		      with lcp^ do
			begin name := id; idtype := lsp; next := lcp1;
			  values.ival := lcnt; klass := konst
			end;
		      enterid(lcp);
		      lcnt := lcnt + 1;
		      lcp1 := lcp; insymbol
		    end
		  else error(2);
		  if not (sy in fsys + [comma,rparent]) then
		    begin error(6); skip(fsys + [comma,rparent]) end
		until sy <> comma;
		(*if lcnt<=256 then lsp^.size:=charsize;*)
		lsp^.fconst := lcp1; top := ttop;
		if sy = rparent then insymbol else error(4)
	      end
	    else
	      begin
		if sy = ident then
		  begin searchid([types,konst],lcp);
		    insymbol;
		    if lcp^.klass = konst then
		      begin new(lsp,subrange);
			with lsp^, lcp^ do
			  begin rangetype := idtype; form := subrange;
			    if string(rangetype) then
			      begin error(148); rangetype := nil end;
			    min := values; size := intsize
			  end;
			if sy = colon then insymbol else error(5);
			constant(fsys,lsp1,lvalu);
			lsp^.max := lvalu;
			if lsp^.rangetype <> lsp1 then error(107)
		      end
		    else lsp:=lcp^.idtype;
		  end (*sy = ident*)
		else
		  begin new(lsp,subrange); lsp^.form := subrange;
		    constant(fsys + [colon],lsp1,lvalu);
		    if string(lsp1) then
		      begin error(148); lsp1 := nil end;
		    with lsp^ do
		      begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
		    if sy = colon then insymbol else error(5);
		    constant(fsys,lsp1,lvalu);
		    lsp^.max := lvalu;
		    if lsp^.rangetype <> lsp1 then error(107)
		  end;
		if lsp <> nil then
		  with lsp^ do
		    if form = subrange then
		      if rangetype <> nil then
			if rangetype = realptr then error(399)
			else
			  if min.ival > max.ival then error(102)
	      end;
	    fsp := lsp;
	    if not (sy in fsys) then
	      begin error(6); skip(fsys) end
	  end
	    else fsp := nil
      end (*simpletype*) ;

      procedure fieldlist(fsys: setofsys; var frecvar: stp);
	var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
	    minsize,maxsize,lsize,sz: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
	if not (sy in [ident,casesy]) then
	  begin error(19); skip(fsys + [ident,casesy]) end;
	while sy = ident do
	  begin nxt := nxt1;
	    repeat
	      if sy = ident then
		begin new(lcp,field);
		  with lcp^ do
		    begin name := id; idtype := nil; next := nxt;
		      klass := field
		    end;
		  nxt := lcp;
		  enterid(lcp);
		  insymbol
		end
	      else error(2);
	      if not (sy in [comma,colon]) then
		begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
		end;
	    test := sy <> comma;
	      if not test  then insymbol
	    until test;
	    if sy = colon then insymbol else error(5);
	    typ(fsys + [casesy,semicolon],lsp,lsize);
	    while nxt <> nxt1 do
	      with nxt^ do
		begin idtype := lsp; nxt := next;
		  if lsize>1 then even(displ);
		  fldaddr := displ; displ := displ + lsize
		end;
	    nxt1 := lcp;
	    if sy = semicolon then
	      begin insymbol;
		if not (sy in [ident,casesy]) then
		  begin error(19); skip(fsys + [ident,casesy]) end
	      end
	  end (*while*);
	nxt := nil;
	while nxt1 <> nil do
	  with nxt1^ do
	    begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
	if sy = casesy then
	  begin new(lsp,tagfld); lcp:=nil;
	    with lsp^ do
	      begin tagstp := nil; fstvar := nil; form:=tagfld end;
	    frecvar := lsp;
	    insymbol;
	    if sy = ident then
	      begin prterr:=false; searchid([types],lcp1); prterr:=true;
		if lcp1=nil then
		  begin new(lcp,field);
		    with lcp^ do begin name:=id; klass:=field; next:=nil end;
		    enterid(lcp); insymbol;
		    if sy = colon then insymbol else error(5);
		    if sy = ident then
		      begin searchid([types],lcp1); insymbol end
		    else
		      begin error(2); skip(fsys + [ofsy,lparent]) end;
		  end
		else insymbol;
		lsp1:=lcp1^.idtype; lsp^.tagstp:=lsp1; sz:=intsize;
		if lsp1 <> nil then
		  if lsp1^.form > subrange then error(110) else
		    if lsp1=realptr then error(109) else sz:=lsp1^.size;
		if lcp<>nil then  (*explicit tag*)
		  begin if sz>1 then even(displ); lcp^.fldaddr:=displ;
		    displ:=displ+sz; lcp^.idtype:=lsp1
		  end;
	      end
	    else begin error(2); skip(fsys + [ofsy,lparent]) end;
	    lsp^.size := displ;
	    if sy = ofsy then insymbol else error(8);
	    lsp1 := nil; minsize := displ; maxsize := displ;
	    repeat lsp2 := nil;
	      repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
		if not comptypes(lsp^.tagstp,lsp3)then error(111);
		new(lsp3,variant);
		with lsp3^ do
		  begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
		    form := variant
		  end;
		lsp1 := lsp3; lsp2 := lsp3;
		test := sy <> comma;
		if not test then insymbol
	      until test;
	      if sy = colon then insymbol else error(5);
	      if sy = lparent then insymbol else error(9);
	      fieldlist(fsys + [rparent,semicolon],lsp2);
	      if displ > maxsize then maxsize := displ;
	      while lsp3 <> nil do
		begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
		  lsp3^.size := displ;
		  lsp3 := lsp4
		end;
	      if sy = rparent then
		begin insymbol;
		  if not (sy in fsys + [semicolon]) then
		    begin error(6); skip(fsys + [semicolon]) end
		end
	      else error(4);
	      test := (sy <> semicolon) or endoffile;
	      if not test then
		begin displ := minsize;
		      insymbol
		end
	    until test;
	    displ := maxsize;
	    lsp^.fstvar := lsp1;
	  end
	else frecvar := nil
      end (*fieldlist*) ;

    begin (*typ*)
      if not (sy in typebegsys) then
	 begin error(10); skip(fsys + typebegsys) end;
      if sy in typebegsys then
	begin
	  if sy in simptypebegsys then simpletype(fsys,fsp)
	  else
    (*^*)     if sy = arrow then
	      begin new(lsp,pointer); fsp := lsp;
		with lsp^ do
		  begin eltype := nil; size := ptrsize; form:=pointer end;
		insymbol;
		if sy = ident then
		  begin prterr := false; (*no error if search not successful*)
		    searchid([types],lcp); prterr := true;
		    if lcp = nil then   (*forward referenced type id*)
		      begin new(lcp,types);
			with lcp^ do
			  begin name := id; idtype := lsp;
			    next := fwptr; klass := types
			  end;
			fwptr := lcp
		      end
		    else
		      begin
			if lcp^.idtype <> nil then
			  if lcp^.idtype^.form = files then error(108)
			  else lsp^.eltype := lcp^.idtype
		      end;
		    insymbol;
		  end
		else error(2);
	      end
	    else
	      begin
		if sy = packedsy then
		  begin insymbol;
		    if not (sy in typedels) then
		      begin
			error(10); skip(fsys + typedels)
		      end
		  end;
    (*array*)     if sy = arraysy then
		  begin insymbol;
		    if sy = lbrack then insymbol else error(11);
		    lsp1 := nil;
		    repeat new(lsp,arrays);
		      with lsp^ do
			begin aeltype := lsp1; inxtype := nil; form:=arrays end;
		      lsp1 := lsp;
		      simpletype(fsys + [comma,rbrack,ofsy],lsp2);
		      if lsp2 <> nil then
			if lsp2^.form <= subrange then
			  begin
			    if lsp2 = realptr then
			      begin error(109); lsp2 := nil end
			    else
			      if lsp2 = intptr then
				begin error(149); lsp2 := nil end;
			    lsp^.inxtype := lsp2
			  end
			else begin error(113); lsp2 := nil end;
		      test := sy <> comma;
		      if not test then insymbol
		    until test;
		    if sy = rbrack then insymbol else error(12);
		    if sy = ofsy then insymbol else error(8);
		    typ(fsys,lsp,lsize);
		    repeat
		      with lsp1^ do
			begin lsp2 := aeltype; aeltype := lsp;
			  if inxtype <> nil then
			    begin getbounds(inxtype,lmin,lmax);
			      if odd(lsize) and (lsize>1) then
				lsize:=(lsize+1)*(lmax-lmin+1)-1
			      else      lsize := lsize*(lmax - lmin + 1);
			    end;
			  size := lsize
			end;
		      lsp := lsp1; lsp1 := lsp2
		    until lsp1 = nil
		  end
		else
    (*record*)      if sy = recordsy then
		    begin insymbol;
		      oldtop := top;
		      if top < displimit then
			begin top := top + 1;
			  with display[top] do
			    begin fname := nil;
			      flabel := nil;
				  occur := rec
			    end
			end
		      else error(250);
		      displ := 0;
		      fieldlist(fsys-[semicolon]+[endsy],lsp1);
		      new(lsp,records);
		      with lsp^ do
			begin fstfld := display[top].fname;
			  recvar := lsp1; size := displ; form := records
			end;
		      top := oldtop;
		      if sy = endsy then insymbol else error(13)
		    end
		  else
    (*set*)	   if sy = setsy then
		      begin insymbol;
			if sy = ofsy then insymbol else error(8);
			simpletype(fsys,lsp1);
			if lsp1 <> nil then
			  if lsp1^.form > subrange then
			    begin error(115); lsp1 := nil end
			  else
			    if lsp1 = realptr then error(114);
			new(lsp,power);
			with lsp^ do
			  begin elset:=lsp1; size:=setsize; form:=power end;
		      end
		    else
    (*file*)	    if sy = filesy then
			begin error(399); insymbol; skip(fsys); fsp:= nil end;
		fsp := lsp
	      end;
	  if not (sy in fsys) then
	    begin error(6); skip(fsys) end
	end
      else fsp := nil;
      if fsp = nil then fsize := 1 else fsize := fsp^.size
    end (*typ*) ;

    procedure labeldeclaration;
      var llp: lbp; redef: boolean; lbname: integer;
    begin
      repeat
	if sy = intconst then
	  with display[top] do
	    begin llp := flabel; redef := false;
	      while (llp <> nil) and not redef do
		if llp^.labval <> val.ival then
		  llp := llp^.nextlab
		else begin redef := true; error(166) end;
	      if not redef then
		begin new(llp);
		  with llp^ do
		    begin labval := val.ival; genlabel(lbname);
		      defined := false; nextlab := flabel; labname := lbname
		    end;
		  flabel := llp
		end;
	      insymbol
	    end
	else error(15);
	if not ( sy in fsys + [comma, semicolon] ) then
	  begin error(6); skip(fsys+[comma,semicolon]) end;
	test := sy <> comma;
	if not test then insymbol
      until test;
      if sy = semicolon then insymbol else error(14)
    end (* labeldeclaration *) ;

    procedure constdeclaration;
      var lcp: ctp; lsp: stp; lvalu: valu;
    begin
      if sy <> ident then
	begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
	begin new(lcp,konst);
	  with lcp^ do
	    begin name := id; idtype := nil; next := nil; klass:=konst end;
	  insymbol;
	  if (sy = relop) and (op = eqop) then insymbol else error(16);
	  constant(fsys + [semicolon],lsp,lvalu);
	  enterid(lcp);
	  lcp^.idtype := lsp; lcp^.values := lvalu;
	  if sy = semicolon then
	    begin insymbol;
	      if not (sy in fsys + [ident]) then
		begin error(6); skip(fsys + [ident]) end
	    end
	  else error(14)
	end
    end (*constdeclaration*) ;

    procedure typedeclaration;
      var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
    begin
      if sy <> ident then
	begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
	begin new(lcp,types);
	  with lcp^ do
	    begin name := id; idtype := nil; klass := types end;
	  insymbol;
	  if (sy = relop) and (op = eqop) then insymbol else error(16);
	  typ(fsys + [semicolon],lsp,lsize);
	  enterid(lcp);
	  lcp^.idtype := lsp;
	  (*has any forward reference been satisfied:*)
	  lcp1 := fwptr;
	  while lcp1 <> nil do
	    begin
	      if lcp1^.name = lcp^.name then
		begin lcp1^.idtype^.eltype := lcp^.idtype;
		  if lcp1 <> fwptr then
		    lcp2^.next := lcp1^.next
		  else fwptr := lcp1^.next;
		end;
	      lcp2 := lcp1; lcp1 := lcp1^.next
	    end;
	  if sy = semicolon then
	    begin insymbol;
	      if not (sy in fsys + [ident]) then
		begin error(6); skip(fsys + [ident]) end
	    end
	  else error(14)
	end;
      if fwptr <> nil then error(117);
    end (*typedeclaration*) ;

    procedure vardeclaration;
      var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
    begin nxt := nil;
      repeat
	repeat
	  if sy = ident then
	    begin new(lcp,vars);
	      with lcp^ do
	       begin name := id; next := nxt; klass := vars;
		  idtype := nil; vkind := actual; vlev := level
		end;
	      enterid(lcp);
	      nxt := lcp;
	      insymbol;
	    end
	  else error(2);
	  if not (sy in fsys + [comma,colon] + typedels) then
	    begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
	  test := sy <> comma;
	  if not test then insymbol
	until test;
	if sy = colon then insymbol else error(5);
	typ(fsys + [semicolon] + typedels,lsp,lsize);
	while nxt <> nil do
	  with  nxt^ do
	    begin idtype := lsp; nxt := next;
	      if lsize>1 then even(lc);
	      vaddr := lc; lc := lc + lsize
	    end;
	if sy = semicolon then
	  begin insymbol;
	    if not (sy in fsys + [ident]) then
	      begin error(6); skip(fsys + [ident]) end
	  end
	else error(14)
      until (sy <> ident) and not (sy in typedels);
      if fwptr <> nil then error(117);
    end (*vardeclaration*) ;

    procedure procdeclaration(fsy: symbol);
      var oldlev: 0..maxlevel; lsy: symbol; lcp,lcp1: ctp; lsp: stp;
	  forw: boolean; oldtop: disprange;
	  llc,lcm: addrrange; lbname: integer; markp: ^integer;

      procedure parameterlist(fsy: setofsys; var fpar: ctp);
	var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
	  llc  : addrrange; count : integer;
      begin lcp1 := nil;
	if not (sy in fsy + [lparent]) then
	  begin error(7); skip(fsys + fsy + [lparent]) end;
	if sy = lparent then
	  begin if forw then error(119);
	    insymbol;
	    if not (sy in [ident,varsy,procsy,funcsy]) then
	      begin error(7); skip(fsys + [ident,rparent]) end;
	    while sy in [ident,varsy,procsy,funcsy] do
	      begin
		if sy = procsy then
		  begin error(399);
		    repeat insymbol;
		      if sy = ident then
		      begin new(lcp,proc,declared,formal);
			  with lcp^ do
			    begin name := id; idtype := nil; next := lcp1;
			      pflev := level (*beware of parameter procedures*);
			      klass:=proc;pfdeckind:=declared;pfkind:=formal
			    end;
			  enterid(lcp);
			  lcp1 := lcp; lc := lc + ptrsize;
			  insymbol
			end
		      else error(2);
		      if not (sy in fsys + [comma,semicolon,rparent]) then
			begin error(7);skip(fsys+[comma,semicolon,rparent])end
		    until sy <> comma
		  end
		else
		  begin
		    if sy = funcsy then
		      begin error(399); lcp2 := nil;
			repeat insymbol;
			  if sy = ident then
			    begin new(lcp,func,declared,formal);
			      with lcp^ do
				begin name := id; idtype := nil; next := lcp2;
				  pflev := level (*beware param funcs*);
				  klass:=func;pfdeckind:=declared;
				  pfkind:=formal
				end;
			      enterid(lcp);
			      lcp2 := lcp; lc := lc + ptrsize;
			      insymbol;
			    end;
			  if not (sy in [comma,colon] + fsys) then
			   begin error(7);skip(fsys+[comma,semicolon,rparent])
			    end
			until sy <> comma;
			if sy = colon then
			  begin insymbol;
			    if sy = ident then
			      begin searchid([types],lcp);
				lsp := lcp^.idtype;
				if lsp <> nil then
				 if not(lsp^.form in[scalar,subrange,pointer])
				    then begin error(120); lsp := nil end;
				lcp3 := lcp2;
				while lcp2 <> nil do
				  begin lcp2^.idtype := lsp; lcp := lcp2;
				    lcp2 := lcp2^.next
				  end;
				lcp^.next := lcp1; lcp1 := lcp3;
				insymbol
			      end
			    else error(2);
			    if not (sy in fsys + [semicolon,rparent]) then
			      begin error(7);skip(fsys+[semicolon,rparent])end
			  end
			else error(5)
		      end
		    else
		      begin
			if sy = varsy then
			  begin lkind := formal; insymbol end
			else lkind := actual;
			lcp2 := nil;
			count := 0;
			repeat
			  if sy = ident then
			    begin new(lcp,vars);
			      with lcp^ do
				begin name:=id; idtype:=nil; klass:=vars;
				  vkind := lkind; next := lcp2; vlev := level;
				end;
			      enterid(lcp);
			      lcp2 := lcp; count := count+1;
			      insymbol;
			    end;
			  if not (sy in [comma,colon] + fsys) then
			   begin error(7);skip(fsys+[comma,semicolon,rparent])
			    end;
			  test := sy <> comma;
			  if not test then insymbol
			until test;
			if sy = colon then
			  begin insymbol;
			    if sy = ident then
			      begin searchid([types],lcp);
				lsp := lcp^.idtype;
				if lsp <> nil then
				  if (lkind=actual)and(lsp^.form=files) then
				    error(121);
				lcp3 := lcp2;
				lc := lc+count*    ptrsize    ;
				llc := lc;
				while lcp2 <> nil do
				  begin lcp := lcp2;
				    with lcp2^ do
				      begin idtype := lsp;
					llc:=llc-ptrsize;
					vaddr := llc;
				      end;
				    lcp2 := lcp2^.next
				  end;
				lcp^.next := lcp1; lcp1 := lcp3;
				insymbol
			      end
			    else error(2);
			    if not (sy in fsys + [semicolon,rparent]) then
			      begin error(7);skip(fsys+[semicolon,rparent])end
			  end
			else error(5);
		      end;
		  end;
		if sy = semicolon then
		  begin insymbol;
		    if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
		      begin error(7); skip(fsys + [ident,rparent]) end
		  end
	      end (*while*) ;
	    if sy = rparent then
	      begin insymbol;
		if not (sy in fsy + fsys) then
		  begin error(6); skip(fsy + fsys) end
	      end
	    else error(4);
	    lcp3 := nil;
	    (*reverse pointers and reserve local cells for copies of multiple
	     values*)
	    while lcp1 <> nil do
	      with lcp1^ do
		begin lcp2 := next; next := lcp3;
		  if klass = vars then
		    if idtype <> nil then
		      if (vkind = actual) and (idtype^.size > ptrsize) then
			begin      even(lc);
			  vaddr := lc; lc := lc + idtype^.size
			end;
		  lcp3 := lcp1; lcp1 := lcp2
		end;
	    fpar := lcp3
	  end
	    else fpar := nil
    end (*parameterlist*) ;

    begin (*procdeclaration*)
      llc := lc; lc := lcaftermarkstack;
      if sy = ident then
	begin searchsection(display[top].fname,lcp); (*decide whether forw.*)
	  if lcp <> nil then
	  begin
	    if lcp^.klass = proc then
	      forw := lcp^.forwdecl and(fsy = procsy)and(lcp^.pfkind = actual)
	    else
	      if lcp^.klass = func then
		forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
	      else forw := false;
	    if not forw then error(160)
	  end
	  else forw := false;
	  if not forw then
	    begin
	      if fsy = procsy then new(lcp,proc,declared,actual)
	      else new(lcp,func,declared,actual);
	      with lcp^ do
		begin name := id; idtype := nil;
		  extrn := false; pflev := level; genlabel(lbname);
		  pfdeckind := declared; pfkind := actual; pfname := lbname;
		  if fsy = procsy then klass := proc
		  else klass := func
		end;
	      enterid(lcp)
	    end
	  else
	    begin lcp1 := lcp^.next;
	      while lcp1 <> nil do
		begin
		  with lcp1^ do
		    if klass = vars then
		      if idtype <> nil then
			begin lcm := vaddr + idtype^.size;
			  if lcm > lc then lc := lcm
			end;
		  lcp1 := lcp1^.next
		end
	      end;
	  insymbol
	end
      else error(2);
      oldlev := level; oldtop := top;
      if level < maxlevel then level := level + 1 else error(251);
      if top < displimit then
	begin top := top + 1;
	  with display[top] do
	    begin
	      if forw then fname := lcp^.next
	      else fname := nil;
	      flabel := nil;
	      occur := blck
	    end
	end
      else error(250);
      if fsy = procsy then
	begin parameterlist([semicolon],lcp1);
	  if not forw then lcp^.next := lcp1
	end
      else
	begin parameterlist([semicolon,colon],lcp1);
	  if not forw then lcp^.next := lcp1;
	  if sy = colon then
	    begin insymbol;
	      if sy = ident then
		begin if forw then error(122);
		  searchid([types],lcp1);
		  lsp := lcp1^.idtype;
		  lcp^.idtype := lsp;
		  if lsp <> nil then
		    if not (lsp^.form in [scalar,subrange,pointer]) then
		      begin error(120); lcp^.idtype := nil end;
		  insymbol
		end
	      else begin error(2); skip(fsys + [semicolon]) end
	    end
	  else
	    if not forw then error(123)
	end;
      if sy = semicolon then insymbol else error(14);
      if sy = forwardsy then
	begin
	  if forw then error(161)
	  else lcp^.forwdecl := true;
	  insymbol;
	  if sy = semicolon then insymbol else error(14);
	  if not (sy in fsys) then
	    begin error(6); skip(fsys) end
	end
      else
	begin lcp^.forwdecl := false; mark(markp); (* mark heap *)
	  repeat block(fsys,semicolon,lcp);
	    if sy = semicolon then
	      begin insymbol;
		if not (sy in [beginsy,procsy,funcsy]) then
		  begin error(6); skip(fsys) end
	      end
	    else error(14)
	  until (sy in [beginsy,procsy,funcsy]) or endoffile;
	  release(markp); (* return local entries on runtime heap *)
	end;
      level := oldlev; top := oldtop; lc := llc;
    end (*procdeclaration*) ;

    procedure body(fsys: setofsys);
      const cixmax = 256;
      type oprange = 0..63;
      var
	  i, entname, segsize: integer;
	  lcmax,llc1: addrrange; lcp: ctp;
	  llp: lbp;

      function length (fsp:stp):integer;
      begin with fsp^ do
	      if size = 2 then length:=0
	      else if size= 1 then length:=1
		   else if size = 4 then length:=2
			else if size = 8 then length:=3
			     else begin error(177);length:=0 end
      end (* length *)  ;

      procedure gen0(fop: oprange);
      begin writeln(prr,mn[fop]:4) end;

      procedure gen1(fop: oprange; fp2: integer);
      begin
	write(prr,mn[fop]:4);
	    if fop = 30 then writeln(prr,sna[fp2]:4)
	    else writeln(prr,' ',fp2:1)
      end (*gen1*) ;

      procedure gen2(fop: oprange; fp1,fp2: integer);
	var k : integer;
      begin
	write(prr,mn[fop]:4);
	    case fop of
	      35,39,43,45,50,54,56,51:
		writeln(prr,' ',fp1:1,' ',fp2:1);
	      47,48,49,52,53,55:
		begin write(prr,    ' ',fp1:1,' '      );
		  if fp1 = 5 (*multiple*) then write(prr,fp2:1);
		  writeln(prr)
		end;
	    end;
      end (*gen2*) ;

      procedure load;
	var l: integer;
      begin
	with gattr do
	  if typtr <> nil then
	    begin
	      case kind of
		cst:   gen2(51(*ldc*),0,intval);	(*only 1-word values*)
		varbl: begin l:= length (typtr);
			 case access of
			   drct:  if vlevel <= 1 then gen2(39,l,dplmt)
				  else gen2(54,l*16+level-vlevel,dplmt);
			   indrct:gen2(35(*ind*),l,idplmt);
			   inxd:  error(400)
			 end;
		       end;
		expr:
	      end;
	      kind := expr
	    end
      end (*load*) ;

      procedure store(var fattr: attr);
	var l: integer;
      begin
	with fattr do
	  if typtr <> nil then
	    begin l:=length(typtr);
	      case access of
		drct:  if vlevel<=1 then gen2(43,l,dplmt)
		       else gen2(56,l*16+level-vlevel,dplmt);
		indrct:if idplmt <>0 then error(400)
		       else gen1(26(*sto*),l);
		inxd:  error(400)
	      end
	    end
      end (*store*) ;

      procedure loadaddress;
      begin
	with gattr do
	  if typtr <> nil then
	    begin
	      case kind of
		varbl: case access of
			 drct:   if vlevel <= 1 then gen1(37(*lao*),dplmt)
				 else gen2(50(*lda*),level-vlevel,dplmt);
			 indrct: if idplmt <> 0 then gen1(34(*inc*),idplmt);
			 inxd:   error(400)
		       end;
		expr,cst:  error(400)
	      end;
	      kind := varbl; access := indrct; idplmt := 0
	    end
      end (*loadaddress*) ;


      procedure loadset(s:maxset);
	var k:integer;
      begin write(prr,mn[51]:4,' 5 (' );
	for k:=0 to 63 do
	  if k in s then write(prr,k:3);
	writeln(prr,')'); gattr.kind:=expr
      end;

      procedure loadreal(p:csp);
	var k:integer;
      begin write(prr,mn[51]:4,' 4 ');
	for k:=1 to digmax do write(prr,p^.rval[k]);
	writeln(prr); gattr.kind:=expr
      end;

      procedure loadstring(p:csp);
	var k:integer;
      begin write(prr,mn[38]:4,'#');
	for k:=1 to p^.slgth do write(prr,p^.sval3[k]);
	writeln(prr,'#'); gattr.kind:=varbl; gattr.access:=indrct;
	gattr.idplmt:=0
      end;

      procedure genfjp(faddr: integer);
      begin load;
	if gattr.typtr <> nil then
	  if gattr.typtr <> boolptr then error(144);
	writeln(prr,mn[33]:1,' ','l',faddr:1)
      end (*genfjp*) ;

      procedure genujpent(fop: oprange; fp2: integer);
     begin
	writeln(prr, mn[fop]:4,' ','l',fp2:1)
      end (*genujpent*);


      procedure gencup(fp1, fp2: integer);
     begin
	writeln(prr, mn[46]:4,' ',fp1:1,' ','l', fp2:1)
      end (*gencup*);


      procedure putlabel(labname: integer);
      begin writeln(prr, 'l', labname:1)
      end (*putlabel*);

      procedure statement(fsys: setofsys);
	label 1;
	var lcp: ctp; llp: lbp; ttop: disprange;

	procedure expression(fsys: setofsys); forward;

	procedure selector(fsys: setofsys; fcp: ctp);
	  var lattr: attr; lcp: ctp; lmin,lmax,aelsize: integer;
	begin
	  with fcp^, gattr do
	    begin typtr := idtype; kind := varbl;
	      case klass of
		vars:
		  if vkind = actual then
		    begin access := drct; vlevel := vlev;
		      dplmt := vaddr
		    end
		  else
		    begin gen2(54,level-vlev,vaddr);
		      access := indrct; idplmt := 0
		    end;
		field:
		  with display[disx] do
		    if occur = crec then
		      begin access := drct; vlevel := clev;
			dplmt := cdspl + fldaddr
		      end
		    else
		      begin
			if level = 1 then gen2(39(*ldo*),0,vdspl)
			else gen2(54(*lod*),0,vdspl);
			access := indrct; idplmt := fldaddr
		      end;
		func:
		  if pfdeckind = standard then error(150)
		  else
		    if pflev = 0 then error(150)   (*external fct*)
		    else
		      if pfkind = formal then error(151)
		      else
			begin access := drct; vlevel := pflev + 1;
			  dplmt := 0   (*impl. relat. addr. of fct. result*)
			end
	      end (*case*)
	    end (*with*);
	  if not (sy in selectsys + fsys) then
	    begin error(59); skip(selectsys + fsys) end;
	  while sy in selectsys do
	    begin
	(*[*)   if sy = lbrack then
		begin
		  repeat lattr := gattr;
		    with lattr do
		      if typtr <> nil then
			if typtr^.form <> arrays then
			  begin error(138); typtr := nil end;
		    loadaddress;
		    insymbol; expression(fsys + [comma,rbrack]);
		    load;
		    if gattr.typtr <> nil then
		      if gattr.typtr^.form <> scalar then error(113);
		    if lattr.typtr <> nil then
		      with lattr.typtr^ do
			begin
			  if comptypes(inxtype,gattr.typtr) then
			    begin
			      if inxtype <> nil then
				begin getbounds(inxtype,lmin,lmax);
				  if lmin > 0 then gen1(31(*dec*),lmin)
				  else if lmin < 0 then gen1(34(*inc*),-lmin)
				  (*or simply gen1(31,lmin)*)
				end
			    end
			  else error(139);
			  with gattr do
			    begin typtr := aeltype; kind := varbl;
			      access := indrct; idplmt := 0;
			      if typtr <> nil then
				begin aelsize := typtr^.size;
				  if aelsize > 2 then even(aelsize);
				  gen1(36(*ixa*),aelsize)
				end
			    end
			end
		  until sy <> comma;
		  if sy = rbrack then insymbol else error(12)
		end (*if sy = lbrack*)
	      else
	(*.*)     if sy = period then
		  begin
		    with gattr do
		      begin
			if typtr <> nil then
			  if typtr^.form <> records then
			    begin error(140); typtr := nil end;
			insymbol;
			if sy = ident then
			  begin
			    if typtr <> nil then
			      begin searchsection(typtr^.fstfld,lcp);
				if lcp = nil then
				  begin error(152); typtr := nil end
				else
				  with lcp^ do
				    begin typtr := idtype;
				      case access of
					drct:   dplmt := dplmt + fldaddr;
					indrct: idplmt := idplmt + fldaddr;
					inxd:   error(400)
				      end
				    end
			      end;
			    insymbol
			  end (*sy = ident*)
			else error(2)
		      end (*with gattr*)
		  end (*if sy = period*)
		else
	(*^*)       begin
		    if gattr.typtr <> nil then
		      with gattr,typtr^ do
			if form = pointer then
			  begin     load;    typtr := eltype;
			    with gattr do
			      begin kind := varbl; access := indrct;
				idplmt := 0
			      end
			  end
			else
			  if form = files then typtr := filtype
			  else error(141);
		    insymbol
		  end;
	      if not (sy in fsys + selectsys) then
		begin error(6); skip(fsys + selectsys) end
	    end (*while*)
	end (*selector*) ;

	procedure call(fsys: setofsys; fcp: ctp);
	  var lkey: 1..15;

	  procedure variable(fsys: setofsys);
	    var lcp: ctp;
	  begin
	    if sy = ident then
	      begin searchid([vars,field],lcp); insymbol end
	    else begin error(2); lcp := uvarptr end;
	    selector(fsys,lcp)
	  end (*variable*) ;

	  procedure getputresetrewrite;
	  begin variable(fsys + [rparent]); loadaddress;
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form <> files then error(116);
	    if lkey <= 2 then gen1(30(*csp*),lkey(*get,put*))
	    else     gen1(30,lkey+23)
	  end (*getputresetrewrite*) ;

	  procedure read;
	    var lcp:ctp; llev:levrange; laddr:addrrange;
	  begin
	    llev := 1; laddr := lcaftermarkstack;
	    if sy = ident then
	      begin searchid([vars,field],lcp);
		if lcp <> nil then
		  with lcp^ do
		    if idtype <> nil then
		      if idtype^.form = files then
		      begin
			if idtype^.filtype = charptr then
			  begin llev := vlev; laddr := vaddr end
			else error(399);
			insymbol;
			if not (sy in [comma,rparent]) then error(20)
		      end
	      end
	    else begin error(2);
		   insymbol
		 end;
	   if sy = comma then insymbol;
	   if lkey= 14 then
	   begin variable(fsys + [comma]); loadaddress;
	     if not string(gattr.typtr) then error(116);
	     if sy=comma then insymbol;
	     variable(fsys + [rparent]); loadaddress;
	     gen1(37,laddr); gen1(30,24)
	   end else
	   if sy = ident then
	   begin
	    repeat variable(fsys + [comma,rparent]); loadaddress;
		  gen1(37,laddr);
	      if gattr.typtr <> nil then
		if gattr.typtr^.form <= subrange then
		  if comptypes(intptr,gattr.typtr) then
		    gen1(30(*csp*),3(*rdi*))
		  else
		    if comptypes(realptr,gattr.typtr) then
		      gen1(30(*csp*),4(*rdr*))
		    else
		      if comptypes(charptr,gattr.typtr) then
			gen1(30(*csp*),5(*rdc*))
		      else error(399)
		else error(116);
	      test := sy <> comma;
	      if not test then insymbol
	    until test
	   end;
	   if lkey = 11 then
	     begin
		    gen1(37,laddr);
	       gen1(30(*csp*),21(*rln*))
	     end
	  end (*read*) ;

	  procedure write;
	    var lsp: stp; default : boolean; llkey: 1..15;
		lcp:ctp; llev:levrange; laddr,len:addrrange;
	  begin llkey := lkey;
	    llev := 1; laddr := lcaftermarkstack+2;
	    if sy = ident then
	      begin searchid([konst,vars,field,func],lcp);
		if lcp <> nil then
		  with lcp^ do
		    if idtype <> nil then
		      if idtype^.form = files then
		      begin
			if idtype^.filtype = charptr then
			  begin llev := vlev; laddr := vaddr end
			else error(399);
			insymbol;
			if not (sy in [comma,rparent]) then error(20)
		      end
	      end;
	   if sy = comma then insymbol;
	   if llkey=15 then
	   begin expression(fsys + [comma]);
	     if string(gattr.typtr) then loadaddress else error(116);
	     if sy=comma then insymbol;
	     expression(fsys + [rparent]);
	     if gattr.typtr=intptr then load else error(116);
	     gen1(37,laddr); gen1(30,25)
	   end
	   else
	    if sy in facbegsys then
	    repeat expression(fsys + [comma,colon,rparent]);
	      lsp := gattr.typtr;
	      if lsp <> nil then
		if lsp^.form <= subrange then load else loadaddress;
	      if sy = colon then
		begin insymbol; expression(fsys + [comma,colon,rparent]);
		  if gattr.typtr <> nil then
		    if gattr.typtr <> intptr then error(116);
		  load; default := false
		end
	      else default := true;
	      if sy = colon then
		begin insymbol; expression(fsys + [comma,rparent]);
		  if gattr.typtr <> nil then
		    if gattr.typtr <> intptr then error(116);
		  if lsp <> realptr then error(124);
		  load; error(399);
		end
	      else
		if lsp = intptr then
		  begin if default then gen2(51(*ldc*), 0 , 6);
			gen1(37,laddr);
		    gen1(30(*csp*),6(*wri*))
		  end
		else
		  if lsp = realptr then
		    begin if default then gen2(51(*ldc*),0,13);
			  gen1(37,laddr);
		      gen1(30(*csp*),8(*wrr*))
		    end
		  else
		    if lsp = charptr then
		      begin if default then gen2(51(*ldc*),0,1);
			    gen1(37,laddr);
			gen1(30(*csp*),9(*wrc*))
		      end
		    else
		     if lsp=boolptr then
		       begin if default then gen2(51,0,1);
			 gen1(37,laddr);
			 gen1(30,7(*wrb*))
		       end
		     else
		      if lsp <> nil then
			begin
			  if lsp^.form = scalar then error(399)
			  else
			    if string(lsp) then
			      begin len := lsp^.size div charsize;
				if default then
				      gen2(51(*ldc*),0,len);
				gen2(51(*ldc*),0,len);
				    gen1(37,laddr);
				gen1(30(*csp*),10(*wrs*))
			      end
			    else error(116)
			end;
	      test := sy <> comma;
	      if not test then insymbol
	    until test;
	    if llkey = 12 then (*writeln*)
	      begin
		    gen1(37,laddr);
		gen1(30(*csp*),22(*wln*))
	      end
	  end (*write*) ;

	  procedure pack;
	    var lsp,lsp1: stp;
	  begin error(399); variable(fsys + [comma,rparent]);
	    lsp := nil; lsp1 := nil;
	    if gattr.typtr <> nil then
	      with gattr.typtr^ do
		if form = arrays then
		  begin lsp := inxtype; lsp1 := aeltype end
		else error(116);
	    if sy = comma then insymbol else error(20);
	    expression(fsys + [comma,rparent]);
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form <> scalar then error(116)
	      else
		if not comptypes(lsp,gattr.typtr) then error(116);
	    if sy = comma then insymbol else error(20);
	    variable(fsys + [rparent]);
	    if gattr.typtr <> nil then
	      with gattr.typtr^ do
		if form = arrays then
		  begin
		    if not comptypes(aeltype,lsp1)
		      or not comptypes(inxtype,lsp) then
		      error(116)
		  end
		else error(116)
	  end (*pack*) ;

	  procedure unpack;
	    var lsp,lsp1: stp;
	  begin error(399); variable(fsys + [comma,rparent]);
	    lsp := nil; lsp1 := nil;
	    if gattr.typtr <> nil then
	      with gattr.typtr^ do
		if form = arrays then
		  begin lsp := inxtype; lsp1 := aeltype end
		else error(116);
	    if sy = comma then insymbol else error(20);
	    variable(fsys + [comma,rparent]);
	    if gattr.typtr <> nil then
	      with gattr.typtr^ do
		if form = arrays then
		  begin
		    if not comptypes(aeltype,lsp1)
		      or not comptypes(inxtype,lsp) then
		      error(116)
		  end
		else error(116);
	    if sy = comma then insymbol else error(20);
	    expression(fsys + [rparent]);
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form <> scalar then error(116)
	      else
		if not comptypes(lsp,gattr.typtr) then error(116);
	  end (*unpack*) ;

	  procedure new;
	    label 1;
	    var lsp,lsp1: stp; varts,lmin,lmax: integer;
		lsize: addrrange; lval: valu;
	  begin variable(fsys + [comma,rparent]); loadaddress;
	    lsp := nil; varts := 0; lsize := 0;
	    if gattr.typtr <> nil then
	      with gattr.typtr^ do
		if form = pointer then
		  begin
		    if eltype <> nil then
		      begin lsize := eltype^.size;
			if eltype^.form = records then lsp := eltype^.recvar
		      end
		  end
		else error(116);
	    while sy = comma do
	      begin insymbol;constant(fsys + [comma,rparent],lsp1,lval);
		varts := varts + 1;
		(*check to insert here: is constant in tagfieldtype range*)
		if lsp = nil then error(158)
		else
		  if lsp^.form <> tagfld then error(162)
		  else
		      if string(lsp1) or (lsp1 = realptr) then error(159)
		      else
			if comptypes(lsp^.tagstp,lsp1) then
			  begin
			    lsp1 := lsp^.fstvar;
			    while lsp1 <> nil do
			      with lsp1^ do
				if varval.ival = lval.ival then
				  begin lsize := size; lsp := subvar;
				    goto 1
				  end
				else lsp1 := nxtvar;
			    lsize := lsp^.size; lsp := nil;
			  end
			else error(116);
	  1:  end (*while*) ;
	    gen2(51(*ldc*),0,lsize);
	    gen1(30(*csp*),12(*new*));
	  end (*new*) ;

	  procedure mark;
	  begin variable(fsys+[rparent]);
	     if gattr.typtr <> nil then
	       if gattr.typtr^.form = pointer then
		 begin loadaddress; gen1(30(*csp*),23(*sav*)) end
	       else error(125)
	  end(*mark*);

	  procedure release;
	  begin variable(fsys+[rparent]);
		if gattr.typtr <> nil then
		   if gattr.typtr^.form = pointer then
		      begin load; gen1(30(*csp*),13(*rst*)) end
		   else error(125)
	  end (*release*);



	  procedure abs;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr = intptr then gen0(0(*abi*))
	      else
		if gattr.typtr = realptr then gen0(1(*abr*))
		else begin error(125); gattr.typtr := intptr end
	  end (*abs*) ;

	  procedure sqr;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr = intptr then gen0(24(*sqi*))
	      else
		if gattr.typtr = realptr then gen0(25(*sqr*))
		else begin error(125); gattr.typtr := intptr end
	  end (*sqr*) ;

	  procedure trunc;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr <> realptr then error(125);
	    gen0(27(*trc*));
	    gattr.typtr := intptr
	  end (*trunc*) ;

	  procedure odd;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr <> intptr then error(125);
	    gen0(20(*odd*));
	    gattr.typtr := boolptr
	  end (*odd*) ;

	  procedure ord;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form >= power then error(125);
	    gattr.typtr := intptr
	  end (*ord*) ;

	  procedure chr;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr <> intptr then error(125);
	    gattr.typtr := charptr
	  end (*chr*) ;



	  procedure predsucc;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form <> scalar then error(125);
	      if lkey=7 then gen1(31(*dec*),1)
			else gen1(34(*inc*),1)
	  end (*predsucc*) ;

	  procedure eof;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form <> files then error(125);
	    if lkey = 9 then gen0(8(*eof*)) else gen1(30(*csp*),14(*eln*));
	      gattr.typtr := boolptr
	  end (*eof*) ;

	  procedure callnonstandard;
	    var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean;
		locpar, llc: addrrange;     l:integer;
	  begin locpar := 0;
	    with fcp^ do
	      begin nxt := next; lkind := pfkind;
		if not extrn then gen1(41(*mst*),level-pflev)
	      end;
	    if sy = lparent then
	      begin llc := lc;
		repeat lb := false; (*decide whether proc/func must be passed*)
		  if lkind = actual then
		    begin
		      if nxt = nil then error(126)
		      else lb := nxt^.klass in [proc,func]
		    end else error(399);
		  (*for formal proc/func lb is false and expression
		   will be called, which will allways interpret a proc/func id
		  at its beginning as a call rather than a parameter passing.
		  in this implementation, parameter procedures/functions
		  are therefore not allowed to have procedure/function
		  parameters*)
		  insymbol;
		  if lb then   (*pass function or procedure*)
		    begin error(399);
		      if sy <> ident then
			begin error(2); skip(fsys + [comma,rparent]) end
		      else
			begin
			  if nxt^.klass = proc then searchid([proc],lcp)
			  else
			    begin searchid([func],lcp);
			      if not comptypes(lcp^.idtype,nxt^.idtype) then
				error(128)
			    end;
			  insymbol;
			  if not (sy in fsys + [comma,rparent]) then
			    begin error(6); skip(fsys + [comma,rparent]) end
			end
		    end (*if lb*)
		  else
		    begin expression(fsys + [comma,rparent]);
		      if gattr.typtr <> nil then
			if lkind = actual then
			  begin
			    if nxt <> nil then
			      begin lsp := nxt^.idtype;
				if lsp <> nil then
				  begin
				    if (nxt^.vkind = actual) then
				      if lsp^.size <= ptrsize then
				      begin load;
					if comptypes(realptr,lsp)
					   and (gattr.typtr = intptr) then
					  begin gen0(10);
					    gattr.typtr := realptr
					  end;
					locpar := locpar + ptrsize
				      end
				      else
				      begin
					if (gattr.kind = expr) or
					 ((gattr.kind = cst) and
					   not string(gattr.typtr)) then
					begin load;
					  if comptypes(realptr,lsp)
					     and (gattr.typtr = intptr) then
					    begin gen0(10(*flt*));
					      gattr.typtr := realptr
					    end;
					  even(lc);
					  l:=length(gattr.typtr);
					  gen2(56(*str*),l*16,lc);
					  gen2(50(*lda*),0,lc);
					  lc := lc + gattr.typtr^.size;
					  if lcmax < lc then lcmax := lc
					end
					else
					  if comptypes(realptr,lsp)
					   and (gattr.typtr = intptr) then
					  begin load;
					    gen0(10(*flt*));
					    even(lc);
					    gen2(56,32(*real*),lc);
					    gen2(50(*lda*),0,lc);
					    gattr.typtr := realptr;
					    lc := lc + gattr.typtr^.size;
					    if lcmax < lc then lcmax := lc
					  end
					  else loadaddress;
					locpar := locpar + ptrsize
				      end
				    else
				      if gattr.kind = varbl then
					begin loadaddress;
					  locpar:=locpar + ptrsize
					end
				      else error(154);
				    if not comptypes(lsp,gattr.typtr) then
				      error(142)
				  end
			      end
			  end
		      else (*lkind = formal*)
			begin (*pass formal param*)
			end
		    end;
		  if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next
		until sy <> comma;
		lc := llc;
	      if sy = rparent then insymbol else error(4)
	    end (*if lparent*);
	    if lkind = actual then
	      begin if nxt <> nil then error(126);
		with fcp^ do
		  begin
		    if extrn then gen1(30(*csp*),pfname)
		    else gencup(locpar, pfname);
		  end
	      end;
	    gattr.typtr := fcp^.idtype
	  end (*callnonstandard*) ;

	begin (*call*)
	  if fcp^.pfdeckind = standard then
	    begin if sy = lparent then insymbol else error(9);
	      lkey := fcp^.key;
	      if fcp^.klass = proc then
		case lkey of
		  1,2,
		  3,4:  getputresetrewrite;
		  5,11    ,14    :    read;
		  6,12    ,15    :    write;
		  7:    pack;
		  8:    unpack;
		  9:    new;
		  10:   release;
		  13:   mark
		end
	      else
		begin expression(fsys + [rparent]);
		      if lkey <= 8 then load else loadaddress;
		  case lkey of
		    1:    abs;
		    2:    sqr;
		    3:    trunc;
		    4:    odd;
		    5:    ord;
		    6:    chr;
		    7,8:  predsucc;
		    9,10:    eof
		  end
		end;
	      if sy = rparent then insymbol else error(4)
	    end (*standard procedures and functions*)
	  else callnonstandard
	end (*call*) ;

	procedure expression;
	  var lattr: attr; lop: operator; lsize: addrrange;
	      typind:     integer    ;

	  procedure simpleexpression(fsys: setofsys);
	    var lattr: attr; lop: operator; signed: boolean;

	    procedure term(fsys: setofsys);
	      var lattr: attr; lop: operator;

	      procedure factor(fsys: setofsys);
		var lcp: ctp; lvp: csp; varpart: boolean;
		    cstpart: maxset; lsp: stp;
	      begin
		if not (sy in facbegsys) then
		  begin error(58); skip(fsys + facbegsys);
		    gattr.typtr := nil
		  end;
		while sy in facbegsys do
		  begin
		    case sy of
	      (*id*)  ident:
			begin searchid([konst,vars,field,func],lcp);
			  insymbol;
			  case lcp^.klass of
			    func:begin call(fsys,lcp); gattr.kind := expr end;
			    field,vars:
			      begin selector(fsys,lcp);
				if gattr.typtr<>nil then(*elim.subr.types to*)
				  with gattr,typtr^ do(*simplify later tests*)
				    if form = subrange then
				      typtr := rangetype
			      end;
			    konst:
			      with gattr,lcp^ do
				begin typtr:=idtype;
				  if typtr^.form=scalar then
				    if typtr=realptr then
				      loadreal(values.valp)
				    else
				      begin kind:=cst; intval:=values.ival end
				  else
				    if typtr=nilptr then
				      begin gen1(51(*ldc*),3); kind:=expr end
				    else
				      loadstring(values.valp)
				end;
			  end;  (*case*)
			end;  (*ident*)
	      (*cst*) intconst:
			with gattr do
			  begin typtr:=intptr; kind:=cst; intval:=val.ival;
			    insymbol
			  end;
		      charconst:
			with gattr do
			  begin typtr:=charptr; kind:=cst; intval:=val.ival;
			    insymbol
			  end;
		      realconst:
			with gattr do
			  begin typtr:=realptr; loadreal(val.valp);
			    insymbol
			  end;
		      stringconst:
			with gattr do
			  begin new(lsp,arrays);
			    with lsp^ do
			      begin aeltype := charptr; form:=arrays;
				inxtype := nil; size := lgth*charsize
			      end;
			    typtr := lsp;
			    loadstring(val.valp); insymbol;
			  end;
	      (*(*)   lparent:
			begin insymbol; expression(fsys + [rparent]);
			  if sy = rparent then insymbol else error(4)
			end;
	      (*not*) notsy:
			begin insymbol; factor(fsys);
			  load; gen0(19(*not*));
			  if gattr.typtr <> nil then
			    if gattr.typtr <> boolptr then
			      begin error(135); gattr.typtr := nil end;
			end;
	      (*[*)   lbrack:
			begin insymbol; cstpart := [ ]; varpart := false;
			  new(lsp,power);
			  with lsp^ do
			    begin elset:=nil;size:=setsize;form:=power end;
			  if sy = rbrack then
			    begin
			      with gattr do
				begin typtr := lsp; kind := cst end;
			      insymbol
			    end
			  else
			    begin
			      repeat expression(fsys + [comma,rbrack]);
				if gattr.typtr <> nil then
				  if gattr.typtr^.form <> scalar then
				    begin error(136); gattr.typtr := nil end
				  else
				    if comptypes(lsp^.elset,gattr.typtr) then
				      begin
					if gattr.kind = cst then
					  cstpart := cstpart+[gattr.intval]
					else
					  begin load; gen0(23(*sgs*));
					    if varpart then gen0(28(*uni*))
					    else varpart := true
					  end;
					lsp^.elset := gattr.typtr;
					gattr.typtr := lsp
				      end
				    else error(137);
				test := sy <> comma;
				if not test then insymbol
			      until test;
			      if sy = rbrack then insymbol else error(12)
			    end;
			  if varpart then
			    begin
			      if cstpart <> [ ] then
				begin loadset(cstpart); gen0(28(*uni*)) end
			    end
			  else loadset(cstpart)
			end
		    end (*case*) ;
		    if not (sy in fsys) then
		      begin error(6); skip(fsys + facbegsys) end
		  end (*while*)
	      end (*factor*) ;

	    begin (*term*)
	      factor(fsys + [mulop]);
	      while sy = mulop do
		begin load; lattr := gattr; lop := op;
		  insymbol; factor(fsys + [mulop]); load;
		  if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
		    case lop of
	    (***)       mul:  if (lattr.typtr=intptr)and(gattr.typtr=intptr)
			      then gen0(15(*mpi*))
			    else
			      begin
				if lattr.typtr = intptr then
				  begin gen0(9(*flo*));
				    lattr.typtr := realptr
				  end
				else
				  if gattr.typtr = intptr then
				    begin gen0(10(*flt*));
				      gattr.typtr := realptr
				    end;
				if (lattr.typtr = realptr)
				  and(gattr.typtr=realptr)then gen0(16(*mpr*))
				else
				  if(lattr.typtr^.form=power)
				    and comptypes(lattr.typtr,gattr.typtr)then
				    gen0(12(*int*))
				  else begin error(134);gattr.typtr:=nil end
			      end;
	    (*/*)       rdiv: begin (*note: order flt,flo for 2 int.s*)
			      if gattr.typtr = intptr then
				begin gen0(10(*flt*));
				  gattr.typtr := realptr
				end;
			      if lattr.typtr = intptr then
				begin gen0(9(*flo*));
				  lattr.typtr := realptr
				end;
			      if (lattr.typtr = realptr)
				and (gattr.typtr=realptr)then gen0(7(*dvr*))
			      else begin error(134); gattr.typtr := nil end
			    end;
	    (*div*)     idiv: if (lattr.typtr = intptr)
			      and (gattr.typtr = intptr) then gen0(6(*dvi*))
			    else begin error(134); gattr.typtr := nil end;
	    (*mod*)     imod: if (lattr.typtr = intptr)
			      and (gattr.typtr = intptr) then gen0(14(*mod*))
			    else begin error(134); gattr.typtr := nil end;
	    (*and*)     andop:if (lattr.typtr = boolptr)
			      and (gattr.typtr = boolptr) then gen0(4(*and*))
			    else begin error(134); gattr.typtr := nil end
		    end (*case*)
		  else gattr.typtr := nil
		end (*while*)
	    end (*term*) ;

	  begin (*simpleexpression*)
	    signed := false;
	    if (sy = addop) and (op in [plus,minus]) then
	      begin signed := op = minus; insymbol end;
	    term(fsys + [addop]);
	    if signed then
	      begin load;
		if gattr.typtr = intptr then gen0(17(*ngi*))
		else
		  if gattr.typtr = realptr then gen0(18(*ngr*))
		  else begin error(134); gattr.typtr := nil end
	      end;
	    while sy = addop do
	      begin load; lattr := gattr; lop := op;
		insymbol; term(fsys + [addop]); load;
		if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
		  case lop of
	  (*+*)       plus:
		      if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
			gen0(2(*adi*))
		      else
			begin
			  if lattr.typtr = intptr then
			    begin gen0(9(*flo*));
			      lattr.typtr := realptr
			    end
			  else
			    if gattr.typtr = intptr then
			      begin gen0(10(*flt*));
				gattr.typtr := realptr
			      end;
			  if (lattr.typtr = realptr)and(gattr.typtr = realptr)
			    then gen0(3(*adr*))
			  else if(lattr.typtr^.form=power)
				 and comptypes(lattr.typtr,gattr.typtr) then
				 gen0(28(*uni*))
			       else begin error(134);gattr.typtr:=nil end
			end;
	  (*-*)       minus:
		      if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
			gen0(21(*sbi*))
		      else
			begin
			  if lattr.typtr = intptr then
			    begin gen0(9(*flo*));
			      lattr.typtr := realptr
			    end
			  else
			    if gattr.typtr = intptr then
			    begin gen0(10(*flt*));
				gattr.typtr := realptr
			      end;
			  if (lattr.typtr = realptr)and(gattr.typtr = realptr)
			    then gen0(22(*sbr*))
			  else
			    if (lattr.typtr^.form = power)
			      and comptypes(lattr.typtr,gattr.typtr) then
			      gen0(5(*dif*))
			    else begin error(134); gattr.typtr := nil end
			end;
	  (*or*)      orop:
		      if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then
			gen0(13(*ior*))
		      else begin error(134); gattr.typtr := nil end
		  end (*case*)
		else gattr.typtr := nil
	      end (*while*)
	  end (*simpleexpression*) ;

	begin (*expression*)
	  simpleexpression(fsys + [relop]);
	  if sy = relop then
	    begin
	      if gattr.typtr <> nil then
		if gattr.typtr^.form <= power then load
		else loadaddress;
		lattr := gattr; lop := op;
	      insymbol; simpleexpression(fsys);
	      if gattr.typtr <> nil then
		if gattr.typtr^.form <= power then load
		else loadaddress;
	      if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
		if lop = inop then
		  if gattr.typtr^.form = power then
		    if comptypes(lattr.typtr,gattr.typtr^.elset) then
		      gen0(11(*inn*))
		    else begin error(129); gattr.typtr := nil end
		  else begin error(130); gattr.typtr := nil end
		else
		  begin
		    if lattr.typtr <> gattr.typtr then
		      if lattr.typtr = intptr then
			begin gen0(9(*flo*));
			  lattr.typtr := realptr
			end
		      else
			if gattr.typtr = intptr then
			  begin gen0(10(*flt*));
			    gattr.typtr := realptr
			  end;
		    if comptypes(lattr.typtr,gattr.typtr) then
		      begin lsize := lattr.typtr^.size;
			case lattr.typtr^.form of
			  scalar:
			    if lattr.typtr = realptr
			     then typind :=     2
			    else
			      if lattr.typtr = boolptr
			       then typind :=     3
			      else typind := 1 ;
			  pointer:
			    begin
			      if lop in [ltop,leop,gtop,geop] then error(131);
			      typind :=     0
			    end;
			  power:
			    begin if lop in [ltop,gtop] then error(132);
			      typind :=     4
			  end;
			  arrays:
			    begin
			      if not string(lattr.typtr)
			      and(lop in[ltop,leop,gtop,geop])then error(131);
			      if lattr.typtr^.aeltype^.size >2
				 then error(399);(*because of holes*)
			      typind :=     5
			    end;
			  records:
			    begin
			      if lop in [ltop,leop,gtop,geop] then error(131);
			      typind :=     5 ; error(399)
			    end;
			  files:
			    begin error(133);typind:=6 end
			end;
			case lop of
			  ltop: gen2(53(*les*),typind,lsize);
			  leop: gen2(52(*leq*),typind,lsize);
			  gtop: gen2(49(*grt*),typind,lsize);
			  geop: gen2(48(*geq*),typind,lsize);
			  neop: gen2(55(*neq*),typind,lsize);
			  eqop: gen2(47(*equ*),typind,lsize)
			end
		      end
		    else error(129)
		  end;
	      gattr.typtr := boolptr; gattr.kind := expr
	    end (*sy = relop*)
	end (*expression*) ;

	procedure assignment(fcp: ctp);
	  var lattr: attr;
	begin selector(fsys + [becomes],fcp);
	  if sy = becomes then
	    begin
	      if gattr.typtr <> nil then
		if (gattr.access<>drct) or (gattr.typtr^.form>power) then
		  loadaddress;
	      lattr := gattr;
	      insymbol; expression(fsys);
	      if gattr.typtr <> nil then
		if gattr.typtr^.form <= power then load
		else loadaddress;
	      if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
		begin
		  if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then
		    begin gen0(10(*flt*));
		      gattr.typtr := realptr
		    end;
		  if comptypes(lattr.typtr,gattr.typtr) then
		    case lattr.typtr^.form of
		      scalar,
		      subrange,
		      pointer,
		      power:   store(lattr);
		      arrays,
		      records: gen1(40(*mov*),lattr.typtr^.size);
		      files: error(146)
		    end
		  else error(129)
		end
	    end (*sy = becomes*)
	  else error(51)
	end (*assignment*) ;

	procedure gotostatement;
	  var llp: lbp; found: boolean; ttop: disprange;
	begin
	  if sy = intconst then
	    begin ttop:=top; found:=false;
	      while display[ttop].occur <> blck do ttop := ttop - 1;
	      llp := display[ttop].flabel;
	      while (llp <> nil) and not found do
		if llp^.labval<>val.ival then llp:=llp^.nextlab
		else found:=true;
	      if found then genujpent(57(*ujp*),llp^.labname) else error(167);
	      insymbol
	    end
	  else error(15)
	end (*gotostatement*) ;

	procedure compoundstatement;
	begin
	  repeat
	    repeat statement(fsys + [semicolon,endsy])
	    until not (sy in statbegsys);
	    test := (sy <> semicolon) or endoffile;
	    if not test then insymbol
	  until test;
	  if sy = endsy then insymbol else error(13)
	end (*compoundstatement*) ;

	procedure ifstatement;
	  var lcix1,lcix2: integer;
	begin expression(fsys + [thensy]);
	  genlabel(lcix1); genfjp(lcix1);
	  if sy = thensy then insymbol else error(52);

	  statement(fsys + [elsesy]);
	  if sy = elsesy then
	    begin genlabel(lcix2); genujpent(57(*ujp*),lcix2);
	      putlabel(lcix1);
	      insymbol; statement(fsys);
	      putlabel(lcix2)
	    end
	  else putlabel(lcix1)
	end (*ifstatement*) ;

	procedure casestatement;
	  label 1;
	  type cip = ^caseinfo;
	       caseinfo = packed
			  record next: cip;
			    csstart: integer;
			    cslab: integer
			  end;
	  var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
	      laddr, lcix, lcix1, lmin, lmax: integer;
	begin expression(fsys + [ofsy,comma,colon]);
	  load; genlabel(lcix); genujpent(57(*ujp*),lcix);
	  lsp := gattr.typtr;
	  if lsp <> nil then
	    if (lsp^.form <> scalar) or (lsp = realptr) then
	      begin error(144); lsp := nil end;
	  if sy = ofsy then insymbol else error(8);
	  fstptr := nil; genlabel(laddr);
	  repeat
	    lpt3 := nil; genlabel(lcix1);
	    repeat constant(fsys + [comma,colon],lsp1,lval);
	      if lsp <> nil then
		if comptypes(lsp,lsp1) then
		  begin lpt1 := fstptr; lpt2 := nil;
		    while lpt1 <> nil do
		      with lpt1^ do
			begin
			  if cslab <= lval.ival then
			    begin if cslab = lval.ival then error(156);
			      goto 1
			    end;
			  lpt2 := lpt1; lpt1 := next
			end;
	1:	  new(lpt3);
		    with lpt3^ do
		      begin next := lpt1; cslab := lval.ival;
			csstart := lcix1
		      end;
		    if lpt2 = nil then fstptr := lpt3
		    else lpt2^.next := lpt3
		  end
		else error(147);
	      test := sy <> comma;
	      if not test then insymbol
	    until test;
	    if sy = colon then insymbol else error(5);
	    putlabel(lcix1);
	    repeat statement(fsys + [semicolon])
	    until not (sy in statbegsys);
	    if lpt3 <> nil then
	      genujpent(57(*ujp*),laddr);
	    test := (sy <> semicolon) or endoffile;
	    if not test then insymbol
	  until test or (sy = endsy);
	  putlabel(lcix);
	  if fstptr <> nil then
	    begin lmax := fstptr^.cslab;
	      (*reverse pointers*)
	      lpt1 := fstptr; fstptr := nil;
	      repeat lpt2 := lpt1^.next; lpt1^.next := fstptr;
		fstptr := lpt1; lpt1 := lpt2
	      until lpt1 = nil;
	      lmin := fstptr^.cslab;
	      if lmax - lmin < cixmax then
		begin      even(lc);
		  if lc+intsize > lcmax then lcmax := lc + intsize;
		  gen2(56(*str*),0,lc); gen2(54(*lod*),0,lc);
		  gen2(51(*ldc*),0,lmin);
		  gen2(48(*geq*),1,0);
		  genujpent(33(*fjp*),laddr); gen2(54(*lod*),0,lc);
		  gen2(51(*ldc*),0,lmax);
		  gen2(52(*leqi*),1,0);
		  genujpent(33(*fjp*),laddr); gen2(54(*lod*),0,lc);
		  gen2(51(*ldc*),0,lmin);
		  gen0(21(*sbi*)); genlabel(lcix);
		  genujpent(44(*xjp*),lcix); putlabel(lcix);
		  repeat
		    with fstptr^ do
		      begin
			while cslab > lmin do
			  begin genujpent(57(*ujp*),laddr); lmin:=lmin+1 end;
			genujpent(57(*ujp*),csstart);
			fstptr := next; lmin := lmin + 1
		      end
		  until fstptr = nil;
		  putlabel(laddr)
		end
	      else error(157)
	    end;
	    if sy = endsy then insymbol else error(13)
	end (*casestatement*) ;

	procedure repeatstatement;
	  var laddr: integer;
	begin genlabel(laddr); putlabel(laddr);
	  repeat
	    repeat statement(fsys + [semicolon,untilsy])
	    until not (sy in statbegsys);
	    test := (sy <> semicolon) or endoffile;
	    if not test then insymbol
	  until test;
	  if sy = untilsy then
	    begin insymbol; expression(fsys); genfjp(laddr)
	    end
	  else error(53)
	end (*repeatstatement*) ;

	procedure whilestatement;
	  var laddr, lcix: integer;
	begin genlabel(laddr); putlabel(laddr);
	  expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix);
	  if sy = dosy then insymbol else error(54);
	  statement(fsys); genujpent(57(*ujp*),laddr); putlabel(lcix)
	end (*whilestatement*) ;

	procedure forstatement;
	  var lattr: attr; lsp: stp;  lsy: symbol;
	      lcix, laddr: integer;
	begin
	  if sy = ident then
	    begin searchid([vars],lcp);
	      with lcp^, lattr do
		begin typtr := idtype; kind := varbl;
		  if vkind = actual then
		    begin access := drct; vlevel := vlev;
		      dplmt := vaddr
		    end
		  else begin error(155); typtr := nil end
		end;
	      if lattr.typtr <> nil then
		if (lattr.typtr^.form > subrange)
		   or comptypes(realptr,lattr.typtr) then
		  begin error(143); lattr.typtr := nil end;
	      insymbol
	    end
	  else
	    begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;
	  if sy = becomes then
	    begin insymbol; expression(fsys + [tosy,downtosy,dosy]);
	      if gattr.typtr <> nil then
		  if gattr.typtr^.form <> scalar then error(144)
		  else
		    if comptypes(lattr.typtr,gattr.typtr) then
		      begin load; store(lattr) end
		    else error(145)
	    end
	  else
	    begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
	  if sy in [tosy,downtosy] then
	    begin lsy := sy; insymbol; expression(fsys + [dosy]);
	      if gattr.typtr <> nil then
	      if gattr.typtr^.form <> scalar then error(144)
		else
		  if comptypes(lattr.typtr,gattr.typtr) then
		    begin load;    even(lc);      gen2(56(*str*),0,lc);
		      genlabel(laddr); putlabel(laddr);
		      gattr := lattr; load; gen2(54(*lod*),0,lc);
		      lc := lc + intsize;
		      if lc > lcmax then lcmax := lc;
		      if lsy = tosy
			then gen2(52(*leq*),1,1)
		      else gen2(48(*geq*),1,1);
		    end
		  else error(145)
	    end
	  else begin error(55); skip(fsys + [dosy]) end;
	  genlabel(lcix); genujpent(33(*fjp*),lcix);
	  if sy = dosy then insymbol else error(54);
	  statement(fsys);
	  gattr := lattr; load;
	  if lsy = tosy then gen1(34(*inc*),1) else gen1(31(*dec*),1);
	  store(lattr); genujpent(57(*ujp*),laddr); putlabel(lcix);
	  lc := lc - intsize
	end (*forstatement*) ;


	procedure withstatement;
	  var lcp: ctp; lcnt1,lcnt2: disprange;
	begin lcnt1 := 0; lcnt2 := 0;
	  repeat
	    if sy = ident then
	      begin searchid([vars,field],lcp); insymbol end
	    else begin error(2); lcp := uvarptr end;
	    selector(fsys + [comma,dosy],lcp);
	    if gattr.typtr <> nil then
	      if gattr.typtr^.form = records then
		if top < displimit then
		  begin top := top + 1; lcnt1 := lcnt1 + 1;
		    with display[top] do
		      begin fname := gattr.typtr^.fstfld;
			flabel := nil
		      end;
		    if gattr.access = drct then
		      with display[top] do
			begin occur := crec; clev := gattr.vlevel;
			  cdspl := gattr.dplmt
			end
		    else
		      begin loadaddress;    even(lc);    gen2(56(*str*),0,lc);
			with display[top] do
			  begin occur := vrec; vdspl := lc end;
			lc := lc + ptrsize; lcnt2 := lcnt2 + ptrsize;
			if lc > lcmax then lcmax := lc
		      end
		  end
		else error(250)
	      else error(140);
	    test := sy <> comma;
	    if not test then insymbol
	  until test;
	  if sy = dosy then insymbol else error(54);
	  statement(fsys);
	  top := top - lcnt1; lc := lc - lcnt2;
	end (*withstatement*) ;

      begin (*statement*)
	if sy = intconst then (*label*)
	  begin ttop:=top;
	    while display[ttop].occur<>blck do ttop:=ttop-1;
	    llp:=display[ttop].flabel;
	    while llp <> nil do
	      with llp^ do
		if labval = val.ival then
		  begin if defined then error(165);
		    putlabel(labname); defined := true;
		    goto 1
		  end
		else llp := nextlab;
	    error(167);
      1:    insymbol;
	    if sy = colon then insymbol else error(5)
	  end;
	if not (sy in fsys + [ident]) then
	  begin error(6); skip(fsys) end;
	if sy in statbegsys + [ident] then
	  begin
	    case sy of
	      ident:    begin searchid([vars,field,func,proc],lcp); insymbol;
			  if lcp^.klass = proc then call(fsys,lcp)
			  else assignment(lcp)
			end;
	      beginsy:  begin insymbol; compoundstatement end;
	      gotosy:   begin insymbol; gotostatement end;
	      ifsy:     begin insymbol; ifstatement end;
	      casesy:   begin insymbol; casestatement end;
	      whilesy:  begin insymbol; whilestatement end;
	      repeatsy: begin insymbol; repeatstatement end;
	      forsy:    begin insymbol; forstatement end;
	      withsy:   begin insymbol; withstatement end
	    end;
	    if not (sy in [semicolon,endsy,elsesy,untilsy]) then
	      begin error(6); skip(fsys) end
	  end
      end (*statement*) ;

    begin (*body*)
      if fprocp <> nil then entname := fprocp^.pfname
      else  entname := 1;
      putlabel(entname); genlabel(segsize);
      genujpent(32(*ent*),segsize);
      if fprocp <> nil then (*copy multiple values into local cells*)
	begin llc1 := lcaftermarkstack;
	  lcp := fprocp^.next;
	  while lcp <> nil do
	    with lcp^ do
	      begin
		if klass = vars then
		  if idtype <> nil then
		   begin
		    if (vkind = actual) and (idtype^.size > ptrsize) then
		      begin
			gen2(50(*lda*),0,vaddr);
			gen2(54(*lod*),0,llc1);
			gen1(40(*mov*),idtype^.size);
		      end      ;
		    llc1:=llc1 + ptrsize
		   end;
		lcp := lcp^.next;
	      end;
	end;
      lcmax := lc;
      repeat
	repeat statement(fsys + [semicolon,endsy])
	until not (sy in statbegsys);
	test := (sy <> semicolon) or endoffile;
	if not test then insymbol
      until test;
      if sy = endsy then insymbol else error(13);
      llp := display[top].flabel; (*test for undefined labels*)
      while llp <> nil do
	if llp^.defined then llp:=llp^.nextlab else
	  begin error(168); llp:=nil end;
      even(lcmax);
      if fprocp <> nil then
	begin
	  if fprocp^.idtype = nil
	   then gen1(42(*ret*),0)
	  else
	    with fprocp^ do
	      if idtype = realptr
	       then gen1(42(*ret*),1)
	      else if idtype = boolptr
		     then gen1(42(*ret*),4)
		   else if idtype^.form = pointer then
			  gen1(42(*ret*),5)
			else if (idtype = charptr)
				or ((idtype^.form = subrange)
				    and (idtype^.rangetype = charptr)) then
			       gen1(42(*ret*),3)
			     else gen1(42(*ret*),2);
	  writeln(prr,'l',segsize:1,'=',lcmax)
	end
      else
	begin gen1(42(*ret*),0);
	  writeln(prr,'l',segsize:1,'=',lcmax);
	     writeln(prr) (*simulates eor*);
	end;
    end (*body*) ;

  begin (*block*)
    dp := true;
    repeat
      if sy = labelsy then
	begin insymbol; labeldeclaration end;
      if sy = constsy then
	begin insymbol; constdeclaration end;
      if sy = typesy then
	begin insymbol; typedeclaration end;
      if sy = varsy then
	begin insymbol; vardeclaration end;
      while sy in [procsy,funcsy] do
	begin lsy := sy; insymbol; procdeclaration(lsy) end;
      if sy <> beginsy then
	begin error(18); skip(fsys) end
     until (sy in statbegsys) or endoffile;
    dp := false;
    if sy = beginsy then insymbol else error(17);
    repeat body(fsys + [casesy]);
      if sy <> fsy then
	begin error(6); skip(fsys + [fsy]) end
     until (sy = fsy) or (sy in blockbegsys) or endoffile;
  end (*block*) ;

  procedure programme(fsys:setofsys);
    var lcp:ctp;
  begin
    if sy = progsy then
      begin insymbol; if sy <> ident then error(2); insymbol;
	if not (sy in [lparent,semicolon]) then error(14);
	if sy = lparent  then
	  begin
	    repeat insymbol;
	      if sy = ident then
		begin
		  if (id<>'input   ') and (id<>'output  ') then
		  begin new(lcp,vars);
		    with lcp^ do
		    begin name:= id; klass:= vars; idtype:= textptr;
		      vaddr:= lc; vkind:= actual; vlev:= 1; next:= nil
		    end;
		    enterid(lcp); lc:= lc + 2;
		    if lc > lcaftermarkstack + maxfiles*2 then error(399)
		  end;
		  insymbol;
		  if not ( sy in [comma,rparent]) then error(20);
		end
	      else error(2)
	    until sy <> comma;
	    if sy <> rparent then error(4);
	    insymbol
	  end;
	if sy <> semicolon then error(14)
	else insymbol;
      end;
     writeln(prr,mn[41]:4,' ',0:1);
     writeln(prr,mn[46]:4,0:2,' ','l',1:1); writeln(prr,mn[29]:4);
    repeat block(fsys,period,nil);
      if sy <> period then error(21)
    until (sy = period) or endoffile;
  end (*programme*) ;


  procedure stdnames;
  begin
    na[ 1] := 'false   '; na[ 2] := 'true    '; na[ 3] := 'input   ';
    na[ 4] := 'output  '; na[ 5] := 'get     '; na[ 6] := 'put     ';
    na[ 7] := 'reset   '; na[ 8] := 'rewrite '; na[ 9] := 'read    ';
    na[10] := 'write   '; na[11] := 'pack    '; na[12] := 'unpack  ';
    na[13] := 'new     '; na[14] := 'release '; na[15] := 'readln  ';
    na[16] := 'writeln ';
    na[17] := 'mark    '; na[18] := 'getline '; na[19] := 'putline ';
    na[20] := 'abs     '; na[21] := 'sqr     '; na[22] := 'trunc   ';
    na[23] := 'odd     '; na[24] := 'ord     '; na[25] := 'chr     ';
    na[26] := 'pred    '; na[27] := 'succ    '; na[28] := 'eof     ';
    na[29] := 'eoln    ';
    na[30] := 'sin     '; na[31] := 'cos     '; na[32] := 'exp     ';
    na[33] := 'sqrt    '; na[34] := 'ln      '; na[35] := 'arctan  ';
     na[36]:= 'aborted '; na[37] := 'avail   '; na[38] := 'clock   ';
  end (*stdnames*) ;

  procedure enterstdtypes;
  begin
    new(intptr,scalar,standard);			(*integer*)
    with intptr^ do
      begin size := intsize; form := scalar; scalkind := standard end;
    new(realptr,scalar,standard);			(*real*)
    with realptr^ do
      begin size := realsize; form := scalar; scalkind := standard end;
    new(charptr,scalar,standard);			(*char*)
    with charptr^ do
      begin size := charsize; form := scalar; scalkind := standard end;
    new(boolptr,scalar,declared);			(*boolean*)
    with boolptr^ do
      begin size := boolsize; form := scalar; scalkind := declared end;
    new(nilptr,pointer);				(*nil*)
    with nilptr^ do
      begin eltype := nil; size := ptrsize; form := pointer end;
    new(textptr,files);
    with textptr^ do
      begin filtype := charptr; size := charsize; form := files end;
  end (*enterstdtypes*) ;

  procedure entstdnames;
    var cp,cp1: ctp; i: integer;
  begin
    new(cp,types);					(*integer*)
    with cp^ do
      begin name := 'integer '; idtype := intptr; klass := types end;
    enterid(cp);
    new(cp,types);					(*real*)
    with cp^ do
      begin name := 'real    '; idtype := realptr; klass := types end;
    enterid(cp);
    new(cp,types);					(*char*)
    with cp^ do
      begin name := 'char    '; idtype := charptr; klass := types end;
    enterid(cp);
    new(cp,types);					(*boolean*)
    with cp^ do
      begin name := 'boolean '; idtype := boolptr; klass := types end;
    enterid(cp);
    cp1 := nil;
    for i := 1 to 2 do
      begin new(cp,konst);				(*false,true*)
	with cp^ do
	  begin name := na[i]; idtype := boolptr;
	    next := cp1; values.ival := i - 1; klass := konst
	  end;
	enterid(cp); cp1 := cp
      end;
    boolptr^.fconst := cp;
    new(cp,konst);					(*nil*)
    with cp^ do
      begin name := 'nil     '; idtype := nilptr;
	next := nil; values.ival := 0; klass := konst
      end;
    enterid(cp);
    for i := 3 to 4 do
      begin new(cp,vars);				(*input,output*)
	with cp^ do
	  begin name := na[i]; idtype := textptr; klass := vars;
	    vkind := actual; next := nil; vlev := 1;
	    vaddr :=    lcaftermarkstack    + (i-3)*2
	  end;
	enterid(cp)
      end;
    for i := 5 to     19     do
      begin new(cp,proc,standard);			(*get,put,reset*)
	with cp^ do					(*rewrite,read*)
	  begin name := na[i]; idtype := nil;		(*write,pack*)
	    next := nil; key := i - 4;			(*unpack,pack*)
	    klass := proc; pfdeckind := standard
					(*mark,getline,putline*)
	  end;
	enterid(cp)
      end;
    for i := 20 to 29 do
      begin new(cp,func,standard);			(*abs,sqr,trunc*)
	with cp^ do					(*odd,ord,chr*)
	  begin name := na[i]; idtype := nil;		(*pred,succ,eof*)
	    next := nil; key := i -     19    ;
	    klass := func; pfdeckind := standard
	  end;
	enterid(cp)
      end;
    new(cp,vars);		(*parameter of predeclared functions*)
    with cp^ do
      begin name := '        '; idtype := realptr; klass := vars;
	vkind := actual; next := nil; vlev := 1; vaddr := 0
      end;
    for i := 30 to    35     do
      begin new(cp1,func,declared,actual);		(*sin,cos,exp*)
	with cp1^ do					(*sqrt,ln,arctan*)
	  begin name := na[i]; idtype := realptr; next := cp;
	    forwdecl := false; extrn := true; pflev := 0; pfname := i - 15;
	    klass := func; pfdeckind := declared; pfkind := actual
	  end;
	enterid(cp1)
      end;
     for i := 36 to 38 do
      begin new(cp,func,declared,actual);		(*aborted,avail,clock*)
	with cp^ do
	  begin name := na[i]; next := nil; forwdecl := false;
	    if i=36 then idtype := boolptr else idtype := intptr;
	    extrn := true; pflev := 0; pfname := i - 8;
	    klass := func; pfdeckind := declared; pfkind := actual
	  end;
	enterid(cp)
      end
  end (*entstdnames*) ;

  procedure enterundecl;
  begin
    new(utypptr,types);
    with utypptr^ do
      begin name := '        '; idtype := nil; klass := types end;
    new(ucstptr,konst);
    with ucstptr^ do
      begin name := '        '; idtype := nil; next := nil;
	values.ival := 0; klass := konst
      end;
    new(uvarptr,vars);
    with uvarptr^ do
      begin name := '        '; idtype := nil; vkind := actual;
	next := nil; vlev := 0; vaddr := 0; klass := vars
      end;
    new(ufldptr,field);
    with ufldptr^ do
      begin name := '        '; idtype := nil; next := nil; fldaddr := 0;
	klass := field
      end;
    new(uprcptr,proc,declared,actual);
    with uprcptr^ do
      begin name := '        '; idtype := nil; forwdecl := false;
	next := nil; extrn := false; pflev := 0; genlabel(pfname);
	klass := proc; pfdeckind := declared; pfkind := actual
      end;
    new(ufctptr,func,declared,actual);
    with ufctptr^ do
      begin name := '        '; idtype := nil; next := nil;
	forwdecl := false; extrn := false; pflev := 0; genlabel(pfname);
	klass := func; pfdeckind := declared; pfkind := actual
      end
  end (*enterundecl*) ;

  procedure initscalars;
  begin fwptr := nil;
     get(input); rewrite(prr);
    dp := true; prterr := true;
    intlabel := 1 ; kk := 8;
    lc := lcaftermarkstack +  4 ;
    (* note in the above reservation of buffer store for 2 text files *)
     eol := true; endoffile := false; linecount := 0;
    ch := ' '; chcnt := 0;
    globtestp := nil;
    mxint10 := maxint div 10;
  end (*initscalars*) ;

  procedure initsets;
  begin
    constbegsys := [addop,intconst,realconst,charconst,stringconst,ident];
    simptypebegsys := [lparent] + constbegsys;
    typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
    typedels := [arraysy,recordsy,setsy,filesy];
    blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,
		    beginsy];
    selectsys := [arrow,period,lbrack];
    facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy,
			charconst];
    statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,
		   casesy];
  end (*initsets*) ;

  procedure inittables;
    procedure reswords;
    begin
      rw[ 1] := 'if      '; rw[ 2] := 'do      '; rw[ 3] := 'of      ';
      rw[ 4] := 'to      '; rw[ 5] := 'in      '; rw[ 6] := 'or      ';
      rw[ 7] := 'end     '; rw[ 8] := 'for     '; rw[ 9] := 'var     ';
      rw[10] := 'div     '; rw[11] := 'mod     '; rw[12] := 'set     ';
      rw[13] := 'and     '; rw[14] := 'not     '; rw[15] := 'then    ';
      rw[16] := 'else    '; rw[17] := 'with    '; rw[18] := 'goto    ';
      rw[19] := 'case    '; rw[20] := 'type    ';
      rw[21] := 'file    '; rw[22] := 'begin   ';
      rw[23] := 'until   '; rw[24] := 'while   '; rw[25] := 'array   ';
      rw[26] := 'const   '; rw[27] := 'label   ';
      rw[28] := 'repeat  '; rw[29] := 'record  '; rw[30] := 'downto  ';
      rw[31] := 'packed  '; rw[32] := 'forward '; rw[33] := 'program ';
      rw[34] := 'function'; rw[35] := 'procedur';
      frw[1] :=  1; frw[2] :=  1; frw[3] :=  7; frw[4] := 15; frw[5] := 22;
      frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36;
    end (*reswords*) ;

    procedure symbols;
     var i: integer; ch: char;
    begin
      rsy[1] := ifsy; rsy[2] := dosy; rsy[3] := ofsy; rsy[4] := tosy;
      rsy[5] := relop; rsy[6] := addop; rsy[7] := endsy; rsy[8] := forsy;
      rsy[9] := varsy; rsy[10] := mulop; rsy[11] := mulop; rsy[12] := setsy;
      rsy[13] := mulop; rsy[14] := notsy; rsy[15] := thensy;
      rsy[16] := elsesy; rsy[17] := withsy; rsy[18] := gotosy;
      rsy[19] := casesy; rsy[20] := typesy;
      rsy[21] := filesy; rsy[22] := beginsy;
      rsy[23] := untilsy; rsy[24] := whilesy; rsy[25] := arraysy;
      rsy[26] := constsy; rsy[27] := labelsy;
      rsy[28] := repeatsy; rsy[29] := recordsy; rsy[30] := downtosy;
      rsy[31] := packedsy; rsy[32] := forwardsy; rsy[33] := progsy;
      rsy[34] := funcsy; rsy[35] := procsy;
      for ch := chr(0) to chr(maxchord) do ssy[ch] := othersy;
      for ch := '0' to '9' do ssy[ch] := digits;
      for ch := chr(65) to chr(90) do ssy[ch] := letters;
      for ch := chr(97) to chr(122) do ssy[ch] := letters;
      for ch := chr(9) to chr(13) do ssy[ch] := layout;
      ssy['+'] := addop; ssy['-'] := addop; ssy['*'] := mulop;
      ssy['/'] := mulop; ssy['('] := lparent; ssy[')'] := rparent;
      ssy['_'] := underline; ssy['='] := relop; ssy[' '] := layout;
      ssy[','] := comma; ssy['.'] := period; ssy['{'] := lbrace;
      ssy['['] := lbrack; ssy[']'] := rbrack; ssy[':'] := colon;
      ssy['^'] := arrow;
      ssy['<'] := less; ssy['>'] := greater; ssy[''''] := quote;
      ssy[';'] := semicolon;
    end (*symbols*) ;

    procedure rators;
      var i: integer; ch: char;
    begin
      for i := 1 to 35 (*nr of res words*) do rop[i] := noop;
      rop[5] := inop; rop[10] := idiv; rop[11] := imod;
      rop[6] := orop; rop[13] := andop;
      for ch := ')' to '^' do sop[ch] := noop;
      sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
      sop['='] := eqop;
      sop['<'] := ltop; sop['>'] := gtop;
    end (*rators*) ;

    procedure procmnemonics;
    begin
      sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr';
      sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wrb'; sna[ 8] :=' wrr';
      sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new';
      sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos';
      sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn';
      sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav';
      sna[24] :=' gln'; sna[25] :=' pln'; sna[26] :=' orf'; sna[27] :=' cwf';
      sna[28] :=' abt'; sna[29] :=' avl'; sna[30] :=' clk';
    end (*procmnemonics*) ;

    procedure instrmnemonics;
    begin
      mn[0] :=' abi'; mn[1] :=' abr'; mn[2] :=' adi'; mn[3] :=' adr';
      mn[4] :=' and'; mn[5] :=' dif'; mn[6] :=' dvi'; mn[7] :=' dvr';
      mn[8] :=' eof'; mn[9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn';
      mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi';
      mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not';
      mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs';
      mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc';
      mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec';
      mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind';
      mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo';
      mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro';
      mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ';
      mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc';
      mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq';
      mn[56] :=' str'; mn[57] :=' ujp';
    end (*instrmnemonics*) ;

  begin (*inittables*)
    reswords; symbols; rators;
    instrmnemonics; procmnemonics;
  end (*inittables*) ;

begin
  (*initialize*)
  (************)
  initscalars; initsets; inittables;


  (*enter standard names and standard types:*)
  (******************************************)

  level := 0; top := 0;
  with display[0] do
    begin fname := nil; flabel := nil; occur := blck end;
  enterstdtypes;   stdnames; entstdnames;   enterundecl;
  top := 1; level := 1;
  with display[1] do
    begin fname := nil; flabel := nil; occur := blck end;


  (*compile:*)
  (**********)

  insymbol;
  programme(blockbegsys+statbegsys-[casesy]);

end.