(*$c+,t-,d-,l-*)
 (***********************************************
  *						*
  *	 Portable Pascal compiler		*
  *	 ************************		*
  *						*
  *		Pascal P4			*
  *						*
  *     Authors:				*
  *	      Urs Ammann			*
  *	      Kesav Nori			*
  *	      Christian Jacobi			*
  *     Address:				*
  *	  Institut Fuer Informatik		*
  *	  Eidg. Technische Hochschule		*
  *	  CH-8096 Zuerich			*
  *						*
  *  This code is fully documented in the book	*
  *	   "Pascal Implementation"		*
  *   by Steven Pemberton and Martin Daniels	*
  * published by Ellis Horwood, Chichester, UK	*
  *	    ISBN: 0-13-653-0311			*
  *       (also available in Japanese)		*
  *						*
  * Steven Pemberton, CWI/AA,			*
  * Kruislaan 413, 1098 SJ Amsterdam, NL	*
  * Steven.Pemberton@cwi.nl			*
  *						*
  ***********************************************)

program pascalcompiler(input,output,prr);

const displimit = 20; maxlevel = 10;
   intsize     =      1;
   intal       =      1;
   realsize    =      1;
   realal      =      1;
   charsize    =      1;
   charal      =      1;
   charmax     =      1;
   boolsize    =      1;
   boolal      =      1;
   ptrsize     =      1;
   adral       =      1;
   setsize     =      1;
   setal       =      1;
   stackal     =      1;
   stackelsize =      1;
   strglgth    =     16;
   sethigh     =     47;
   setlow      =      0;
   ordmaxchar  =     63;
   ordminchar  =      0;
   maxint      =  32767;
   lcaftermarkstack = 5;
   fileal      = charal;
   (* stackelsize = minimum size for 1 stackelement
		  = k*stackal
      stackal     = scm(all other al-constants)
      charmax     = scm(charsize,charal)
		    scm = smallest common multiple
      lcaftermarkstack >= 4*ptrsize+max(x-size)
			= k1*stackelsize	  *)
   maxstack   =       1;
   parmal     = stackal;
   parmsize   = stackelsize;
   recal      = stackal;
   filebuffer =       4;
   maxaddr    =  maxint;



type							(*describing:*)
							    (*************)

     marktype= ^integer;
							    (*basic symbols*)
							    (***************)

     symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
	       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;
     chtp = (letter,number,special,illegal,
	     chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);

							    (*constants*)
							    (***********)
     setty = set of setlow..sethigh;
     cstclass = (reel,pset,strg);
     csp = ^ constant;
     constant = record case cclass: cstclass of
			 reel: (rval: packed array [1..strglgth] of char);
			 pset: (pval: setty);
			 strg: (slgth: 0..strglgth;
				sval: packed array [1..strglgth] of char)
		       end;

     valu = record case intval: boolean of  (*intval never set nor tested*)
		     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
		   marked: boolean;   (*for test phase only*)
		   size: addrrange;
		   case form: structform of
		     scalar:   (case scalkind: declkind of
				  declared: (fconst: ctp); standard: ());
		     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:   (tagfieldp: ctp; 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
		     types: ();
		     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, externl: boolean);
					   formal: ()))
		   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:   (cval: valu);
		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;

     extfilep = ^filerec;
     filerec = record filename:alpha; nextfile:extfilep end;

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

var
    prr: text; (* comment this out when compiling with pcom *)
				    (*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*)


				    (*counters:*)
				    (***********)

    chcnt: integer;		 (*character counter*)
    lc,ic: addrrange;	       (*data location and instruction counter*)
    linecount: integer;


				    (*switches:*)
				    (***********)

    dp,			     (*declaration part*)
    prterr,			 (*to allow forward references in pointer type
				      declaration by suppressing error message*)
    list,prcode,prtables: boolean;  (*output options for
					-- source program listing
					-- printing symbolic code
					-- displaying ident and struct tables
					--> procedure option*)
    debug: boolean;


				    (*pointers:*)
				    (***********)
    parmptr,
    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*)
    fextfilep: extfilep;	    (*head of chain of external files*)
    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 id in record with*)
	  case occur: where of      (*	 constant address*)
	    crec: (clev: levrange;  (*=vrec:   id is field id in record with*)
		  cdspl: addrrange);(*	 variable address*)
	    vrec: (vdspl: addrrange)
	  end;		      (* --> procedure withstatement*)


				    (*error messages:*)
				    (*****************)

    errinx: 0..10;		  (*nr of errors in current source line*)
    errlist:
      array [1..10] of
	packed record pos: integer;
		      nmr: 1..400
	       end;



				    (*expression compilation:*)
				    (*************************)

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


				    (*structured constants:*)
				    (***********************)

    constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
    statbegsys,typedels: setofsys;
    chartp : array[char] of chtp;
    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 [char] of operator;
    na:  array [1..35] of alpha;
    mn:  array [0..60] of packed array [1..4] of char;
    sna: array [1..23] of packed array [1..4] of char;
    cdx: array [0..60] of -4..+4;
    pdx: array [1..23] of -7..+7;
    ordint: array [char] of integer;

    intlabel,mxint10,digmax: integer;
(*-------------------------------------------------------------------------*)
  procedure mark(var p: marktype); begin end;
  procedure release(p: marktype); begin end;

  procedure endofline;
    var lastpos,freepos,currpos,currnmr,f,k: integer;
  begin
    if errinx > 0 then   (*output error messages*)
      begin write(output,linecount:6,' ****  ':9);
	lastpos := 0; freepos := 1;
	for k := 1 to errinx do
	  begin
	    with errlist[k] do
	      begin currpos := pos; currnmr := nmr end;
	    if currpos = lastpos then write(output,',')
	    else
	      begin
		while freepos < currpos do
		  begin write(output,' '); freepos := freepos + 1 end;
		write(output,'^');
		lastpos := currpos
	      end;
	    if currnmr < 10 then f := 1
	    else if currnmr < 100 then f := 2
	      else f := 3;
	    write(output,currnmr:f);
	    freepos := freepos + f + 1
	  end;
	writeln(output); errinx := 0
      end;
    linecount := linecount + 1;
    if list and (not eof(input)) then
      begin write(output,linecount:6,'  ':2);
	if dp then write(output,lc:7) else write(output,ic:7);
	write(output,' ')
      end;
    chcnt := 0
  end  (*endofline*) ;

  procedure error(ferrnr: integer);
  begin
    if errinx >= 9 then
      begin errlist[10].nmr := 255; errinx := 10 end
    else
      begin errinx := errinx + 1;
	errlist[errinx].nmr := ferrnr
      end;
    errlist[errinx].pos := chcnt
  end (*error*) ;

  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..strglgth] of char;
	string: packed array [1..strglgth] of char;
	lvp: csp; test: boolean;

    procedure nextch;
    begin if eol then
      begin if list then writeln(output); endofline
      end;
      if not eof(input) then
       begin eol := eoln(input); read(input,ch);
	if list then write(output,ch);
	chcnt := chcnt + 1
       end
      else
	begin writeln(output,'   *** eof ','encountered');
	  test := false
	end
    end;

    procedure options;
    begin
      repeat nextch;
	if ch <> '*' then
	  begin
	    if ch = 't' then
	      begin nextch; prtables := ch = '+' end
	    else
	      if ch = 'l' then
		begin nextch; list := ch = '+';
		  if not list then writeln(output)
		end
	      else
	     if ch = 'd' then
	       begin nextch; debug := ch = '+' end
	     else
		if ch = 'c' then
		  begin nextch; prcode := ch = '+' end;
	    nextch
	  end
      until ch <> ','
    end (*options*) ;

  begin (*insymbol*)
  1:
    repeat while ((ch = ' ') or (ch = '	')) and not eol do nextch;
      test := eol;
      if test then nextch
    until not test;
    if chartp[ch] = illegal then
      begin sy := othersy; op := noop;
	error(399); nextch
      end
    else
    case chartp[ch] of
      letter:
	begin k := 0;
	  repeat
	    if k < 8 then
	     begin k := k + 1; id[k] := ch end ;
	    nextch
	  until chartp[ch] in [special,illegal,chstrquo,chcolon,
				chperiod,chlt,chgt,chlparen,chspace];
	  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;
      number:
	begin op := noop; i := 0;
	  repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
	  until chartp[ch] <> number;
	  if ((ch = '.') and (input^ <> '.')) 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 chartp[ch] <> number then error(201)
		      else
			repeat k := k + 1;
			  if k <= digmax then digit[k] := ch; nextch
			until chartp[ch] <>  number
		    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 chartp[ch] <> number then error(201)
		      else
			repeat k := k+1;
			  if k <= digmax then digit[k] := ch; nextch
			until chartp[ch] <> number
		     end;
		   new(lvp,reel); sy:= realconst; lvp^.cclass := reel;
		   with lvp^ do
		     begin for i := 1 to strglgth 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+ordint[digit[k]]
			else begin error(203); ival := 0 end
		      end;
		    sy := intconst
		  end
	    end
	end;
      chstrquo:
	begin lgth := 0; sy := stringconst;  op := noop;
	  repeat
	    repeat nextch; lgth := lgth + 1;
		   if lgth <= strglgth 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 = 0 then error(205) else
	  if lgth = 1 then val.ival := ord(string[1])
	  else
	    begin new(lvp,strg); lvp^.cclass:=strg;
	      if lgth > strglgth then
		begin error(399); lgth := strglgth end;
	      with lvp^ do
		begin slgth := lgth;
		  for i := 1 to lgth do sval[i] := string[i]
		end;
	      val.valp := lvp
	    end
	end;
      chcolon:
	begin op := noop; nextch;
	  if ch = '=' then
	    begin sy := becomes; nextch end
	  else sy := colon
	end;
      chperiod:
	begin op := noop; nextch;
	  if ch = '.' then
	    begin sy := colon; nextch end
	  else sy := period
	end;
      chlt:
	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;
      chgt:
	begin nextch; sy := relop;
	  if ch = '=' then
	    begin op := geop; nextch end
	  else op := gtop
	end;
      chlparen:
       begin nextch;
	 if ch = '*' then
	   begin nextch;
	     if ch = '$' then options;
	     repeat
	       while (ch <> '*') and not eof(input) do nextch;
	       nextch
	     until (ch = ')') or eof(input);
	     nextch; goto 1
	   end;
	 sy := lparent; op := noop
       end;
      special:
	begin sy := ssy[ch]; op := sop[ch];
	  nextch
	end;
      chspace: sy := othersy
    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 successful; 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<>intptr and fsp<>realptr*)
  begin
    fmin := 0; fmax := 0;
    if fsp <> nil then
    with fsp^ do
      if form = subrange then
	begin fmin := min.ival; fmax := max.ival end
      else
	  if fsp = charptr then
	    begin fmin := ordminchar; fmax := ordmaxchar
	    end
	  else
	    if fconst <> nil then
	      fmax := fconst^.values.ival
  end (*getbounds*) ;

  function alignquot(fsp: stp): integer;
  begin
    alignquot := 1;
    if fsp <> nil then
      with fsp^ do
	case form of
	  scalar:   if fsp=intptr then alignquot := intal
		    else if fsp=boolptr then alignquot := boolal
		    else if scalkind=declared then alignquot := intal
		    else if fsp=charptr then alignquot := charal
		    else if fsp=realptr then alignquot := realal
		    else (*parmptr*) alignquot := parmal;
	  subrange: alignquot := alignquot(rangetype);
	  pointer:  alignquot := adral;
	  power:    alignquot := setal;
	  files:    alignquot := fileal;
	  arrays:   alignquot := alignquot(aeltype);
	  records:  alignquot := recal;
	  variant,tagfld: error(501)
	end
  end (*alignquot*);

  procedure align(fsp: stp; var flc: addrrange);
    var k,l: integer;
  begin
    k := alignquot(fsp);
    l := flc-1;
    flc := l + k  -  (k+l) mod k
  end (*align*);

  procedure printtables(fb: boolean);
    (*print data structure and name table*)
    var i, lim: disprange;

    procedure marker;
      (*mark data structure entries to avoid multiple printout*)
      var i: integer;

      procedure markctp(fp: ctp); forward;

      procedure markstp(fp: stp);
	(*mark data structures, prevent cycles*)
      begin
	if fp <> nil then
	  with fp^ do
	    begin marked := true;
	      case form of
	      scalar:   ;
	      subrange: markstp(rangetype);
	      pointer:  (*don't mark eltype: cycle possible; will be marked
			anyway, if fp = true*) ;
	      power:    markstp(elset) ;
	      arrays:   begin markstp(aeltype); markstp(inxtype) end;
	      records:  begin markctp(fstfld); markstp(recvar) end;
	      files:    markstp(filtype);
	      tagfld:   markstp(fstvar);
	      variant:  begin markstp(nxtvar); markstp(subvar) end
	      end (*case*)
	    end (*with*)
      end (*markstp*);

      procedure markctp;
      begin
	if fp <> nil then
	  with fp^ do
	    begin markctp(llink); markctp(rlink);
	      markstp(idtype)
	    end
      end (*markctp*);

    begin (*marker*)
      for i := top downto lim do
	markctp(display[i].fname)
    end (*marker*);

    procedure followctp(fp: ctp); forward;

    procedure followstp(fp: stp);
    begin
      if fp <> nil then
	with fp^ do
	  if marked then
	    begin marked := false; write(output,' ':4,ord(fp):6,size:10);
	      case form of
	      scalar:   begin write(output,'scalar':10);
			  if scalkind = standard then
			    write(output,'standard':10)
			  else write(output,'declared':10,' ':4,ord(fconst):6);
			  writeln(output)
			end;
	      subrange: begin
			  write(output,'subrange':10,' ':4,ord(rangetype):6);
			  if rangetype <> realptr then
			    write(output,min.ival,max.ival)
			  else
			    if (min.valp <> nil) and (max.valp <> nil) then
			      write(output,' ',min.valp^.rval:9,
				    ' ',max.valp^.rval:9);
			  writeln(output); followstp(rangetype);
			end;
	      pointer:  writeln(output,'pointer':10,' ':4,ord(eltype):6);
	      power:    begin writeln(output,'set':10,' ':4,ord(elset):6);
			  followstp(elset)
			end;
	      arrays:   begin
			  writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
			    ord(inxtype):6);
			  followstp(aeltype); followstp(inxtype)
			end;
	      records:  begin
			  writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
			    ord(recvar):6); followctp(fstfld);
			  followstp(recvar)
			end;
	      files:    begin write(output,'file':10,' ':4,ord(filtype):6);
			  followstp(filtype)
			end;
	      tagfld:   begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
			    ' ':4,ord(fstvar):6);
			  followstp(fstvar)
			end;
	      variant:  begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
			    ' ':4,ord(subvar):6,varval.ival);
			  followstp(nxtvar); followstp(subvar)
			end
	      end (*case*)
	    end (*if marked*)
    end (*followstp*);

    procedure followctp;
      var i: integer;
    begin
      if fp <> nil then
	with fp^ do
	  begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
	    ' ':4,ord(rlink):6,' ':4,ord(idtype):6);
	    case klass of
	      types: write(output,'type':10);
	      konst: begin write(output,'constant':10,' ':4,ord(next):6);
		       if idtype <> nil then
			 if idtype = realptr then
			   begin
			     if values.valp <> nil then
			       write(output,' ',values.valp^.rval:9)
			   end
			 else
			   if idtype^.form = arrays then  (*stringconst*)
			     begin
			       if values.valp <> nil then
				 begin write(output,' ');
				   with values.valp^ do
				     for i := 1 to slgth do
				       write(output,sval[i])
				 end
			     end
			   else write(output,values.ival)
		     end;
	      vars:  begin write(output,'variable':10);
		       if vkind = actual then write(output,'actual':10)
		       else write(output,'formal':10);
		       write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
		     end;
	      field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
	      proc,
	      func:  begin
		       if klass = proc then write(output,'procedure':10)
		       else write(output,'function':10);
		       if pfdeckind = standard then
			 write(output,'standard':10, key:10)
		       else
			 begin write(output,'declared':10,' ':4,ord(next):6);
			   write(output,pflev,' ':4,pfname:6);
			   if pfkind = actual then
			     begin write(output,'actual':10);
			       if forwdecl then write(output,'forward':10)
			       else write(output,'notforward':10);
			       if externl then write(output,'extern':10)
			       else write(output,'not extern':10);
			     end
			   else write(output,'formal':10)
			 end
		     end
	    end (*case*);
	    writeln(output);
	    followctp(llink); followctp(rlink);
	    followstp(idtype)
	  end (*with*)
    end (*followctp*);

  begin (*printtables*)
    writeln(output); writeln(output); writeln(output);
    if fb then lim := 0
    else begin lim := top; write(output,' local') end;
    writeln(output,' tables '); writeln(output);
    marker;
    for i := top downto lim do
      followctp(display[i].fname);
    writeln(output);
    if not eol then write(output,' ':chcnt+16)
  end (*printtables*);

  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 skip(fsys: setofsys);
      (*skip input string until relevant symbol found*)
    begin
      if not eof(input) then
	begin while not(sy in fsys) and (not eof(input)) do insymbol;
	  if not (sy in fsys) then insymbol
	end
    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..strglgth;
    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 then
	    begin
	      if lgth = 1 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 strglgth 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 equalbounds(fsp1,fsp2: stp): boolean;
      var lmin1,lmin2,lmax1,lmax2: integer;
    begin
      if (fsp1=nil) or (fsp2=nil) then equalbounds := true
      else
	begin
	  getbounds(fsp1,lmin1,lmax1);
	  getbounds(fsp2,lmin2,lmax2);
	  equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
	end
    end (*equalbounds*) ;

    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:
		begin
		  comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
		      and comptypes(fsp1^.inxtype,fsp2^.inxtype);
		  comptypes := comp and (fsp1^.size = fsp2^.size) and
		      equalbounds(fsp1^.inxtype,fsp2^.inxtype)
		end;
	      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 fsize:addrrange);
	var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
	    lcnt: integer; lvalu: valu;
      begin fsize := 1;
	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;
		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
		      begin lsp := lcp^.idtype;
			if lsp <> nil then fsize := lsp^.size
		      end
		  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: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
	if not (sy in (fsys+[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 align(lsp,displ);
		  idtype := lsp; fldaddr := displ;
		  nxt := next; displ := displ + lsize
		end;
	    nxt1 := lcp;
	    while sy = semicolon do
	      begin insymbol;
		if not (sy in fsys + [ident,casesy,semicolon]) 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);
	    with lsp^ do
	      begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
	    frecvar := lsp;
	    insymbol;
	    if sy = ident then
	      begin new(lcp,field);
		with lcp^ do
		  begin name := id; idtype := nil; klass:=field;
		    next := nil; fldaddr := displ
		  end;
		enterid(lcp);
		insymbol;
		if sy = colon then insymbol else error(5);
		if sy = ident then
		  begin searchid([types],lcp1);
		    lsp1 := lcp1^.idtype;
		    if lsp1 <> nil then
		      begin align(lsp1,displ);
			lcp^.fldaddr := displ;
			displ := displ+lsp1^.size;
			if (lsp1^.form <= subrange) or string(lsp1) then
			  begin if comptypes(realptr,lsp1) then error(109)
			    else if string(lsp1) then error(399);
			    lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
			  end
			else error(110);
		      end;
		    insymbol;
		  end
		else begin error(2); skip(fsys + [ofsy,lparent]) 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;
	      if not (sy in fsys + [semicolon]) then
	      begin
		repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
		  if lsp^.tagfieldp <> nil then
		   if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
		  new(lsp3,variant);
		  with lsp3^ do
		    begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
		      form := variant
		    end;
		  lsp4 := lsp1;
		  while lsp4 <> nil do
		    with lsp4^ do
		      begin
			if varval.ival = lvalu.ival then error(178);
			lsp4 := nxtvar
		      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);
	      end;
	      test := sy <> semicolon;
	      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,fsize)
	  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,lsize);
		      lsp1^.size := lsize;
		      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);
			      align(lsp,lsize);
			      lsize := lsize*(lmax - lmin + 1);
			      size := lsize
			    end
			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,lsize);
			if lsp1 <> nil then
			  if lsp1^.form > subrange then
			    begin error(115); lsp1 := nil end
			  else
			    if lsp1 = realptr then
			      begin error(114); lsp1 := nil end
			    else if lsp1 = intptr then
			      begin error(169); lsp1 := nil end
			    else
			      begin getbounds(lsp1,lmin,lmax);
				if (lmin < setlow) or (lmax > sethigh)
				  then error(169);
			      end;
			new(lsp,power);
			with lsp^ do
			  begin elset:=lsp1; size:=setsize; form:=power end;
		      end
		    else
    (*file*)	    if sy = filesy then
			  begin insymbol;
			    error(399); skip(fsys); lsp := 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
	      else 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
	begin error(117); writeln(output);
	  repeat writeln(output,' type-id ',fwptr^.name);
	    fwptr := fwptr^.next
	  until fwptr = nil;
	  if not eol then write(output,' ': chcnt+16)
	end
    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 align(lsp,lc);
	      idtype := lsp; vaddr := lc;
	      lc := lc + lsize; nxt := 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)
      until (sy <> ident) and not (sy in typedels);
      if fwptr <> nil then
	begin error(117); writeln(output);
	  repeat writeln(output,' type-id ',fwptr^.name);
	    fwptr := fwptr^.next
	  until fwptr = nil;
	  if not eol then write(output,' ': chcnt+16)
	end
    end (*vardeclaration*) ;

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

      procedure parameterlist(fsy: setofsys; var fpar: ctp);
	var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
	  llc,lsize: 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;
			  align(parmptr,lc);
			  (*lc := lc + some size *)
			  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;
			     align(parmptr,lc);
			     (*lc := lc + some size*)
			      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;
				lsize := ptrsize;
				if lsp <> nil then
				  if lkind=actual then
				    if lsp^.form<=power then lsize := lsp^.size
				    else if lsp^.form=files then error(121);
				align(parmptr,lsize);
				lcp3 := lcp2;
				align(parmptr,lc);
				lc := lc+count*lsize;
				llc := lc;
				while lcp2 <> nil do
				  begin lcp := lcp2;
				    with lcp2^ do
				      begin idtype := lsp;
					llc := llc-lsize;
					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^.form>power) then
			begin align(idtype,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; forw := false;
      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;
	  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;
		  externl := 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
	begin error(2); lcp := ufctptr end;
      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);
	  repeat block(fsys,semicolon,lcp);
	    if sy = semicolon then
	      begin if prtables then printtables(false); 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 eof(input);
	  release(markp); (* return local entries on runtime heap *)
	end;
      level := oldlev; top := oldtop; lc := llc;
    end (*procdeclaration*) ;

    procedure body(fsys: setofsys);
      const cstoccmax=65; cixmax=1000;
      type oprange = 0..63;
      var
	  llcp:ctp; saveid:alpha;
	  cstptr: array [1..cstoccmax] of csp;
	  cstptrix: 0..cstoccmax;
	  (*allows referencing of noninteger constants by an index
	   (instead of a pointer), which can be stored in the p2-field
	   of the instruction record until writeout.
	   --> procedure load, procedure writeout*)
	  entname, segsize: integer;
	  stacktop, topnew, topmax: integer;
	  lcmax,llc1: addrrange; lcp: ctp;
	  llp: lbp;


      procedure mes(i: integer);
      begin topnew := topnew + cdx[i]*maxstack;
	if topnew > topmax then topmax := topnew
      end;

      procedure putic;
      begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;

      procedure gen0(fop: oprange);
      begin
	if prcode then begin putic; writeln(prr,mn[fop]:4) end;
	ic := ic + 1; mes(fop)
      end (*gen0*) ;

      procedure gen1(fop: oprange; fp2: integer);
	var k: integer;
      begin
	if prcode then
	  begin putic; write(prr,mn[fop]:4);
	    if fop = 30 then
	      begin writeln(prr,sna[fp2]:12);
		topnew := topnew + pdx[fp2]*maxstack;
		if topnew > topmax then topmax := topnew
	      end
	    else
	      begin
		if fop = 38 then
		   begin write(prr,'''');
		     with cstptr[fp2]^ do
		     begin
		       for k := 1 to slgth do write(prr,sval[k]:1);
		       for k := slgth+1 to strglgth do write(prr,' ');
		     end;
		     writeln(prr,'''')
		   end
		else if fop = 42 then writeln(prr,chr(fp2))
		     else writeln(prr,fp2:12);
		mes(fop)
	      end
	  end;
	ic := ic + 1
      end (*gen1*) ;

      procedure gen2(fop: oprange; fp1,fp2: integer);
	var k : integer;
      begin
	if prcode then
	  begin putic; write(prr,mn[fop]:4);
	    case fop of
	      45,50,54,56:
		writeln(prr,' ',fp1:3,fp2:8);
	      47,48,49,52,53,55:
		begin write(prr,chr(fp1));
		  if chr(fp1) = 'm' then write(prr,fp2:11);
		  writeln(prr)
		end;
	      51:
		case fp1 of
		  1: writeln(prr,'i ',fp2);
		  2: begin write(prr,'r ');
		       with cstptr[fp2]^ do
			 for k := 1 to strglgth do write(prr,rval[k]);
		       writeln(prr)
		     end;
		  3: writeln(prr,'b ',fp2);
		  4: writeln(prr,'n');
		  6: writeln(prr,'c ''':3,chr(fp2),'''');
		  5: begin write(prr,'(');
		       with cstptr[fp2]^ do
			 for k := setlow to sethigh do
			   if k in pval then write(prr,k:3);
		       writeln(prr,')')
		     end
		end
	    end;
	  end;
	ic := ic + 1; mes(fop)
      end (*gen2*) ;

      procedure gentypindicator(fsp: stp);
      begin
	if fsp<>nil then
	  with fsp^ do
	    case form of
	     scalar: if fsp=intptr then write(prr,'i')
		     else
		       if fsp=boolptr then write(prr,'b')
		       else
			 if fsp=charptr then write(prr,'c')
			 else
			   if scalkind = declared then write(prr,'i')
			   else write(prr,'r');
	     subrange: gentypindicator(rangetype);
	     pointer:  write(prr,'a');
	     power:    write(prr,'s');
	     records,arrays: write(prr,'m');
	     files,tagfld,variant: error(500)
	    end
      end (*typindicator*);

      procedure gen0t(fop: oprange; fsp: stp);
      begin
	if prcode then
	  begin putic;
	    write(prr,mn[fop]:4);
	    gentypindicator(fsp);
	    writeln(prr);
	  end;
	ic := ic + 1; mes(fop)
      end (*gen0t*);

      procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
      begin
	if prcode then
	  begin putic;
	    write(prr,mn[fop]:4);
	    gentypindicator(fsp);
	    writeln(prr,fp2:11)
	  end;
	ic := ic + 1; mes(fop)
      end (*gen1t*);

      procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
      begin
	if prcode then
	  begin putic;
	    write(prr,mn[fop]: 4);
	    gentypindicator(fsp);
	    writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:8);
	  end;
	ic := ic + 1; mes(fop)
      end (*gen2t*);

      procedure load;
      begin
	with gattr do
	  if typtr <> nil then
	    begin
	      case kind of
		cst:   if (typtr^.form = scalar) and (typtr <> realptr) then
			 if typtr = boolptr then gen2(51(*ldc*),3,cval.ival)
			 else
			   if typtr=charptr then
			     gen2(51(*ldc*),6,cval.ival)
			   else gen2(51(*ldc*),1,cval.ival)
		       else
			 if typtr = nilptr then gen2(51(*ldc*),4,0)
			 else
			   if cstptrix >= cstoccmax then error(254)
			   else
			     begin cstptrix := cstptrix + 1;
			       cstptr[cstptrix] := cval.valp;
			       if typtr = realptr then
				 gen2(51(*ldc*),2,cstptrix)
			       else
				 gen2(51(*ldc*),5,cstptrix)
			     end;
		varbl: case access of
			 drct:   if vlevel<=1 then
				   gen1t(39(*ldo*),dplmt,typtr)
				 else gen2t(54(*lod*),level-vlevel,dplmt,typtr);
			 indrct: gen1t(35(*ind*),idplmt,typtr);
			 inxd:   error(400)
		       end;
		expr:
	      end;
	      kind := expr
	    end
      end (*load*) ;

      procedure store(var fattr: attr);
      begin
	with fattr do
	  if typtr <> nil then
	    case access of
	      drct:   if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr)
		      else gen2t(56(*str*),level-vlevel,dplmt,typtr);
	      indrct: if idplmt <> 0 then error(400)
		      else gen0t(26(*sto*),typtr);
	      inxd:   error(400)
	    end
      end (*store*) ;

      procedure loadaddress;
      begin
	with gattr do
	  if typtr <> nil then
	    begin
	      case kind of
		cst:   if string(typtr) then
			 if cstptrix >= cstoccmax then error(254)
			 else
			   begin cstptrix := cstptrix + 1;
			     cstptr[cstptrix] := cval.valp;
			     gen1(38(*lca*),cstptrix)
			   end
		       else error(400);
		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
				   gen1t(34(*inc*),idplmt,nilptr);
			 inxd:   error(400)
		       end;
		expr:  error(400)
	      end;
	      kind := varbl; access := indrct; idplmt := 0
	    end
      end (*loadaddress*) ;


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

      procedure genujpxjp(fop: oprange; fp2: integer);
      begin
       if prcode then
	  begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
	ic := ic + 1; mes(fop)
      end (*genujpxjp*);


      procedure gencupent(fop: oprange; fp1,fp2: integer);
      begin
	if prcode then
	  begin putic;
	    writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
	  end;
	ic := ic + 1; mes(fop)
      end;


      procedure checkbnds(fsp: stp);
	var lmin,lmax: integer;
      begin
	if fsp <> nil then
	  if fsp <> intptr then
	    if fsp <> realptr then
	      if fsp^.form <= subrange then
		begin
		  getbounds(fsp,lmin,lmax);
		  gen2t(45(*chk*),lmin,lmax,fsp)
		end
      end (*checkbnds*);


      procedure putlabel(labname: integer);
      begin if prcode then writeln(prr, 'l', labname:4)
      end (*putlabel*);

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

	procedure expression(fsys: setofsys); forward;

	procedure selector(fsys: setofsys; fcp: ctp);
	var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: 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 gen2t(54(*lod*),level-vlev,vaddr,nilptr);
		      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 gen1t(39(*ldo*),vdspl,nilptr)
			else gen2t(54(*lod*),0,vdspl,nilptr);
			access := indrct; idplmt := fldaddr
		      end;
		func:
		  if pfdeckind = standard then
		    begin error(150); typtr := nil end
		  else
		    begin
		      if pfkind = formal then error(151)
		      else
			if (pflev+1<>level)or(fprocp<>fcp) then error(177);
			begin access := drct; vlevel := pflev + 1;
			  dplmt := 0   (*impl. relat. addr. of fct. result*)
			end
		    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)
		      else if not comptypes(gattr.typtr,intptr) then
			     gen0t(58(*ord*),gattr.typtr);
		    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 debug then
				    gen2t(45(*chk*),lmin,lmax,intptr);
				  if lmin>0 then gen1t(31(*dec*),lmin,intptr)
				  else if lmin<0 then
				    gen1t(34(*inc*),-lmin,intptr);
				  (*or simply gen1(31,lmin)*)
				end
			    end
			  else error(139);
			  with gattr do
			    begin typtr := aeltype; kind := varbl;
			      access := indrct; idplmt := 0
			    end;
			  if gattr.typtr <> nil then
			    begin
			      lsize := gattr.typtr^.size;
			      align(gattr.typtr,lsize);
			      gen1(36(*ixa*),lsize)
			    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;
			    if debug then gen2t(45(*chk*),1,maxaddr,nilptr);
			    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 error(399)
	  end (*getputresetrewrite*) ;

	  procedure read;
	    var llev:levrange; laddr:addrrange;
		lsp : stp;
	  begin
	    llev := 1; laddr := lcaftermarkstack;
	    if sy = lparent then
	      begin insymbol;
		variable(fsys + [comma,rparent]);
		lsp := gattr.typtr; test := false;
		if lsp <> nil then
		  if lsp^.form = files then
		    with gattr, lsp^ do
		      begin
			if filtype = charptr then
			  begin llev := vlevel; laddr := dplmt end
			else error(399);
			if sy = rparent then
			  begin if lkey = 5 then error(116);
			    test := true
			  end
			else
			  if sy <> comma then
			    begin error(116); skip(fsys + [comma,rparent]) end;
			if sy = comma then
			  begin insymbol; variable(fsys + [comma,rparent])
			  end
			else test := true
		      end;
	       if not test then
		repeat loadaddress;
		  gen2(50(*lda*),level-llev,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
		    begin insymbol; variable(fsys + [comma,rparent])
		    end
		until test;
		if sy = rparent then insymbol else error(4)
	      end
	    else if lkey = 5 then error(116);
	    if lkey = 11 then
	      begin gen2(50(*lda*),level-llev,laddr);
		gen1(30(*csp*),21(*rln*))
	      end
	  end (*read*) ;

	  procedure write;
	    var lsp: stp; default : boolean; llkey: 1..15;
		llev:levrange; laddr,len:addrrange;
	  begin llkey := lkey;
	    llev := 1; laddr := lcaftermarkstack + charmax;
	    if sy = lparent then
	    begin insymbol;
	    expression(fsys + [comma,colon,rparent]);
	    lsp := gattr.typtr; test := false;
	    if lsp <> nil then
	      if lsp^.form = files then
		with gattr, lsp^ do
		  begin
		    if filtype = charptr then
		      begin llev := vlevel; laddr := dplmt end
		    else error(399);
		    if sy = rparent then
		      begin if llkey = 6 then error(116);
			test := true
		      end
		    else
		      if sy <> comma then
			begin error(116); skip(fsys+[comma,rparent]) end;
		    if sy = comma then
		      begin insymbol; expression(fsys+[comma,colon,rparent])
		      end
		    else test := true
		  end;
	   if not test then
	    repeat
	      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*),1,10);
		    gen2(50(*lda*),level-llev,laddr);
		    gen1(30(*csp*),6(*wri*))
		  end
		else
		  if lsp = realptr then
		    begin if default then gen2(51(*ldc*),1,20);
		      gen2(50(*lda*),level-llev,laddr);
		      gen1(30(*csp*),8(*wrr*))
		    end
		  else
		    if lsp = charptr then
		      begin if default then gen2(51(*ldc*),1,1);
			gen2(50(*lda*),level-llev,laddr);
			gen1(30(*csp*),9(*wrc*))
		      end
		    else
		      if lsp <> nil then
			begin
			  if lsp^.form = scalar then error(399)
			  else
			    if string(lsp) then
			      begin len := lsp^.size div charmax;
				if default then
				      gen2(51(*ldc*),1,len);
				gen2(51(*ldc*),1,len);
				gen2(50(*lda*),level-llev,laddr);
				gen1(30(*csp*),10(*wrs*))
			      end
			    else error(116)
			end;
	      test := sy <> comma;
	      if not test then
		begin insymbol; expression(fsys + [comma,colon,rparent])
		end
	    until test;
	    if sy = rparent then insymbol else error(4)
	    end
	      else if lkey = 6 then error(116);
	    if llkey = 12 then (*writeln*)
	      begin gen2(50(*lda*),level-llev,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: 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 lsp^.tagfieldp <> nil then
		      if string(lsp1) or (lsp1 = realptr) then error(159)
		      else
			if comptypes(lsp^.tagfieldp^.idtype,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*),1,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(116)
	  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(116)
	  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);
	    gen0t(58(*ord*),gattr.typtr);
	    gattr.typtr := intptr
	  end (*ord*) ;

	  procedure chr;
	  begin
	    if gattr.typtr <> nil then
	      if gattr.typtr <> intptr then error(125);
	    gen0(59(*chr*));
	    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 gen1t(31(*dec*),1,gattr.typtr)
	    else gen1t(34(*inc*),1,gattr.typtr)
	  end (*predsucc*) ;

	  procedure eof;
	  begin
	    if sy = lparent then
	      begin insymbol; variable(fsys + [rparent]);
		if sy = rparent then insymbol else error(4)
	      end
	    else
	      with gattr do
		begin typtr := textptr; kind := varbl; access := drct;
		  vlevel := 1; dplmt := lcaftermarkstack
		end;
	    loadaddress;
	    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;
	  begin locpar := 0;
	    with fcp^ do
	      begin nxt := next; lkind := pfkind;
		if not externl 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 always 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^.form <= power then
					begin load;
					  if debug then checkbnds(lsp);
					  if comptypes(realptr,lsp)
					     and (gattr.typtr = intptr) then
					    begin gen0(10(*flt*));
					      gattr.typtr := realptr
					    end;
					  locpar := locpar+lsp^.size;
					  align(parmptr,locpar);
					end
				      else
					begin
					  loadaddress;
					  locpar := locpar+ptrsize;
					  align(parmptr,locpar)
					end
				    else
				      if gattr.kind = varbl then
					begin loadaddress;
					  locpar := locpar+ptrsize;
					  align(parmptr,locpar);
					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 externl then gen1(30(*csp*),pfname)
		    else gencupent(46(*cup*),locpar,pfname);
		  end
	      end;
	    gattr.typtr := fcp^.idtype
	  end (*callnonstandard*) ;

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

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

	  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: setty; 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;
			  if lcp^.klass = func then
			    begin call(fsys,lcp);
			      with gattr do
				begin kind := expr;
				  if typtr <> nil then
				    if typtr^.form=subrange then
				      typtr := typtr^.rangetype
				end
			    end
			  else
			    if lcp^.klass = konst then
			      with gattr, lcp^ do
				begin typtr := idtype; kind := cst;
				  cval := values
				end
			    else
			      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
			end;
	      (*cst*)   intconst:
			begin
			  with gattr do
			    begin typtr := intptr; kind := cst;
			      cval := val
			    end;
			  insymbol
			end;
		      realconst:
			begin
			  with gattr do
			    begin typtr := realptr; kind := cst;
			      cval := val
			    end;
			  insymbol
			end;
		      stringconst:
			begin
			  with gattr do
			    begin
			      if lgth = 1 then typtr := charptr
			      else
				begin new(lsp,arrays);
				  with lsp^ do
				    begin aeltype := charptr; form:=arrays;
				      inxtype := nil; size := lgth*charsize
				    end;
				  typtr := lsp
				end;
			      kind := cst; cval := val
			    end;
			  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
					  if (gattr.cval.ival < setlow) or
					    (gattr.cval.ival > sethigh) then
					    error(304)
					  else
					    cstpart := cstpart+[gattr.cval.ival]
					else
					  begin load;
					    if not comptypes(gattr.typtr,intptr)
					    then gen0t(58(*ord*),gattr.typtr);
					    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 new(lvp,pset); lvp^.pval := cstpart;
				  lvp^.cclass := pset;
				  if cstptrix = cstoccmax then error(254)
				  else
				    begin cstptrix := cstptrix + 1;
				      cstptr[cstptrix] := lvp;
				      gen2(51(*ldc*),5,cstptrix);
				      gen0(28(*uni*)); gattr.kind := expr
				    end
				end
			    end
			  else
			    begin new(lvp,pset); lvp^.pval := cstpart;
			      lvp^.cclass := pset;
			      gattr.cval.valp := lvp
			    end
			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
			      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;
	      if lop = inop then
		if not comptypes(gattr.typtr,intptr) then
		  gen0t(58(*ord*),gattr.typtr);
	      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 := 'r'
			    else
			      if lattr.typtr = boolptr then typind := 'b'
			      else
				if lattr.typtr = charptr then typind := 'c'
				else typind := 'i';
			  pointer:
			    begin
			      if lop in [ltop,leop,gtop,geop] then error(131);
			      typind := 'a'
			    end;
			  power:
			    begin if lop in [ltop,gtop] then error(132);
			      typind := 's'
			    end;
			  arrays:
			    begin
			      if not string(lattr.typtr)
				then error(134);
			      typind := 'm'
			    end;
			  records:
			    begin
			      error(134);
			      typind := 'm'
			    end;
			  files:
			    begin error(133); typind := 'f' end
			end;
			case lop of
			  ltop: gen2(53(*les*),ord(typind),lsize);
			  leop: gen2(52(*leq*),ord(typind),lsize);
			  gtop: gen2(49(*grt*),ord(typind),lsize);
			  geop: gen2(48(*geq*),ord(typind),lsize);
			  neop: gen2(55(*neq*),ord(typind),lsize);
			  eqop: gen2(47(*equ*),ord(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: begin
				  if debug then checkbnds(lattr.typtr);
				  store(lattr)
				end;
		      pointer: begin
				 if debug then
				   gen2t(45(*chk*),0,maxaddr,nilptr);
				 store(lattr)
			       end;
		      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,ttop1: disprange;
	begin
	  if sy = intconst then
	    begin
	      found := false;
	      ttop := top;
	      while display[ttop].occur <> blck do ttop := ttop - 1;
	      ttop1 := ttop;
	      repeat
		llp := display[ttop].flabel;
		while (llp <> nil) and not found do
		  with llp^ do
		    if labval = val.ival then
		      begin found := true;
			if ttop = ttop1 then
			  genujpxjp(57(*ujp*),labname)
			else (*goto leads out of procedure*) error(399)
		      end
		    else llp := nextlab;
		ttop := ttop - 1
	      until found or (ttop = 0);
	      if not found then 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;
	    if not test then insymbol
	  until test;
	  if sy = endsy then insymbol else error(13)
	end (*compoundstatemenet*) ;

	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); genujpxjp(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);
	  lsp := gattr.typtr;
	  if lsp <> nil then
	    if (lsp^.form <> scalar) or (lsp = realptr) then
	      begin error(144); lsp := nil end
	    else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp);
	  genujpxjp(57(*ujp*),lcix);
	  if sy = ofsy then insymbol else error(8);
	  fstptr := nil; genlabel(laddr);
	  repeat
	    lpt3 := nil; genlabel(lcix1);
	    if not(sy in [semicolon,endsy]) then
	      begin
		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
		  genujpxjp(57(*ujp*),laddr);
	      end;
	    test := sy <> semicolon;
	    if not test then insymbol
	  until test;
	  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
		  gen2t(45(*chk*),lmin,lmax,intptr);
		  gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix);
		  genujpxjp(44(*xjp*),lcix); putlabel(lcix);
		  repeat
		    with fstptr^ do
		      begin
			while cslab > lmin do
			   begin gen0(60(*ujc error*));
			     lmin := lmin+1
			   end;
			genujpxjp(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 statement(fsys + [semicolon,untilsy]);
	    if sy in statbegsys then error(14)
	  until not(sy in statbegsys);
	  while sy = semicolon do
	    begin insymbol;
	      repeat statement(fsys + [semicolon,untilsy]);
		if sy in statbegsys then error(14)
	      until not (sy in statbegsys);
	    end;
	  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); genujpxjp(57(*ujp*),laddr); putlabel(lcix)
	end (*whilestatement*) ;

	procedure forstatement;
	  var lattr: attr;  lsy: symbol;
	      lcix, laddr: integer;
		    llc: addrrange;
	begin llc := lc;
	  with lattr do
	    begin typtr := nil; kind := varbl;
	      access := drct; vlevel := level; dplmt := 0
	    end;
	  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;
		      if not comptypes(lattr.typtr,intptr) then
			gen0t(58(*ord*),gattr.typtr);
		      align(intptr,lc);
		      gen2t(56(*str*),0,lc,intptr);
		      genlabel(laddr); putlabel(laddr);
		      gattr := lattr; load;
		      if not comptypes(gattr.typtr,intptr) then
			gen0t(58(*ord*),gattr.typtr);
		      gen2t(54(*lod*),0,lc,intptr);
		      lc := lc + intsize;
		      if lc > lcmax then lcmax := lc;
		      if lsy = tosy then gen2(52(*leq*),ord('i'),1)
		      else gen2(48(*geq*),ord('i'),1);
		    end
		  else error(145)
	    end
	  else begin error(55); skip(fsys + [dosy]) end;
	  genlabel(lcix); genujpxjp(33(*fjp*),lcix);
	  if sy = dosy then insymbol else error(54);
	  statement(fsys);
	  gattr := lattr; load;
	  if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr)
	  else  gen1t(31(*dec*),1,gattr.typtr);
	  store(lattr); genujpxjp(57(*ujp*),laddr); putlabel(lcix);
	  lc := llc;
	end (*forstatement*) ;


	procedure withstatement;
	  var lcp: ctp; lcnt1: disprange; llc: addrrange;
	begin lcnt1 := 0; llc := lc;
	  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;
			align(nilptr,lc);
			gen2t(56(*str*),0,lc,nilptr);
			with display[top] do
			  begin occur := vrec; vdspl := lc end;
			lc := lc+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 := llc;
	end (*withstatement*) ;

      begin (*statement*)
	if sy = intconst then (*label*)
	  begin llp := display[level].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 genlabel(entname);
      cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack;
      putlabel(entname); genlabel(segsize); genlabel(stacktop);
      gencupent(32(*ent1*),1,segsize); gencupent(32(*ent2*),2,stacktop);
      if fprocp <> nil then (*copy multiple values into local cells*)
	begin llc1 := lcaftermarkstack;
	  lcp := fprocp^.next;
	  while lcp <> nil do
	    with lcp^ do
	      begin
		align(parmptr,llc1);
		if klass = vars then
		  if idtype <> nil then
		    if idtype^.form > power then
		      begin
			if vkind = actual then
			  begin
			    gen2(50(*lda*),0,vaddr);
			    gen2t(54(*lod*),0,llc1,nilptr);
			    gen1(40(*mov*),idtype^.size);
			  end;
			llc1 := llc1 + ptrsize
		      end
		    else llc1 := llc1 + idtype^.size;
		lcp := lcp^.next;
	      end;
	end;
      lcmax := lc;
      repeat
	repeat statement(fsys + [semicolon,endsy])
	until not (sy in statbegsys);
	test := sy <> semicolon;
	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
	with llp^ do
	  begin
	    if not defined then
	      begin error(168);
		writeln(output); writeln(output,' label ',labval);
		write(output,' ':chcnt+16)
	      end;
	    llp := nextlab
	  end;
      if fprocp <> nil then
	begin
	  if fprocp^.idtype = nil then gen1(42(*ret*),ord('p'))
	  else gen0t(42(*ret*),fprocp^.idtype);
	  align(parmptr,lcmax);
	  if prcode then
	    begin writeln(prr,'l',segsize:4,'=',lcmax);
	      writeln(prr,'l',stacktop:4,'=',topmax)
	    end
	end
      else
	begin gen1(42(*ret*),ord('p'));
	  align(parmptr,lcmax);
	  if prcode then
	    begin writeln(prr,'l',segsize:4,'=',lcmax);
	      writeln(prr,'l',stacktop:4,'=',topmax);
	      writeln(prr,'q')
	    end;
	  ic := 0;
	  (*generate call of main program; note that this call must be loaded
	    at absolute address zero*)
	  gen1(41(*mst*),0); gencupent(46(*cup*),0,entname); gen0(29(*stp*));
	  if prcode then
	    writeln(prr,'q');
	  saveid := id;
	  while fextfilep <> nil do
	    begin
	      with fextfilep^ do
		if not ((filename = 'input   ') or (filename = 'output  ') or
			(filename = 'prd     ') or (filename = 'prr     '))
		then begin id := filename;
		       searchid([vars],llcp);
		       if llcp^.idtype<>nil then
			 if llcp^.idtype^.form<>files then
			   begin writeln(output);
			     writeln(output,' ':8,'undeclared ','external ',
				   'file',fextfilep^.filename:8);
			     write(output,' ':chcnt+16)
			   end
		     end;
		fextfilep := fextfilep^.nextfile
	    end;
	  id := saveid;
	  if prtables then
	    begin writeln(output); printtables(true)
	    end
	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 eof(input);
    dp := false;
    if sy = beginsy then insymbol else error(17);
    repeat body(fsys + [casesy]);
      if sy <> fsy then
	begin error(6); skip(fsys) end
    until ((sy = fsy) or (sy in blockbegsys)) or eof(input);
  end (*block*) ;

  procedure programme(fsys:setofsys);
    var extfp:extfilep;
  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 new(extfp);
		  with extfp^ do
		    begin filename := id; nextfile := fextfilep end;
		  fextfilep := extfp;
		  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;
    repeat block(fsys,period,nil);
      if sy <> period then error(21)
    until (sy = period) or eof(input);
    if list then writeln(output);
    if errinx <> 0 then
      begin list := false; endofline end
  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] := 'abs     '; na[18] := 'sqr     '; na[19] := 'trunc   ';
    na[20] := 'odd     '; na[21] := 'ord     '; na[22] := 'chr     ';
    na[23] := 'pred    '; na[24] := 'succ    '; na[25] := 'eof     ';
    na[26] := 'eoln    ';
    na[27] := 'sin     '; na[28] := 'cos     '; na[29] := 'exp     ';
    na[30] := 'sqrt    '; na[31] := 'ln      '; na[32] := 'arctan  ';
    na[33] := 'prd     '; na[34] := 'prr     '; na[35] := 'mark    ';
  end (*stdnames*) ;

  procedure enterstdtypes;

  begin						 (*type underlying:*)
							(******************)

    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(parmptr,scalar,standard); (*for alignment of parameters*)
    with parmptr^ do
      begin size := parmsize; form := scalar; scalkind := standard end ;
    new(textptr,files);				       (*text*)
    with textptr^ do
      begin filtype := charptr; size := charsize; form := files end
  end (*enterstdtypes*) ;

  procedure entstdnames;
    var cp,cp1: ctp; i: integer;
  begin						       (*name:*)
							      (*******)

    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)*charmax;
	  end;
	enterid(cp)
      end;
    for i:=33 to 34 do
      begin new(cp,vars);				     (*prd,prr files*)
	 with cp^ do
	   begin name := na[i]; idtype := textptr; klass := vars;
	      vkind := actual; next := nil; vlev := 1;
	      vaddr := lcaftermarkstack+(i-31)*charmax;
	   end;
	 enterid(cp)
      end;
    for i := 5 to 16 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
	  end;
	enterid(cp)
      end;
    new(cp,proc,standard);
    with cp^ do
      begin name:=na[35]; idtype:=nil;
	    next:= nil; key:=13;
	    klass:=proc; pfdeckind:= standard
      end; enterid(cp);
    for i := 17 to 26 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 - 16;
	    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 := 27 to 32 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; externl := true; pflev := 0; pfname := i - 12;
	    klass := func; pfdeckind := declared; pfkind := actual
	  end;
	enterid(cp1)
      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; externl := 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; externl := false; pflev := 0; genlabel(pfname);
	klass := func; pfdeckind := declared; pfkind := actual
      end
  end (*enterundecl*) ;

  procedure initscalars;
  begin fwptr := nil;
    prtables := false; list := true; prcode := true; debug := true;
    dp := true; prterr := true; errinx := 0;
    intlabel := 0; kk := 8; fextfilep := nil;
    lc := lcaftermarkstack+filebuffer*charmax;
    (* note in the above reservation of buffer store for 2 text files *)
    ic := 3; eol := true; linecount := 0;
    ch := ' '; chcnt := 0;
    globtestp := nil;
    mxint10 := maxint div 10; digmax := strglgth - 1;
  end (*initscalars*) ;

  procedure initsets;
  begin
    constbegsys := [addop,intconst,realconst,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];
    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;
    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;
      ssy['+'] := addop ;   ssy['-'] := addop;    ssy['*'] := mulop;
      ssy['/'] := mulop ;   ssy['('] := lparent;  ssy[')'] := rparent;
      ssy['$'] := othersy ; ssy['='] := relop;    ssy[' '] := othersy;
      ssy[','] := comma ;   ssy['.'] := period;   ssy['''']:= othersy;
      ssy['['] := lbrack ;  ssy[']'] := rbrack;   ssy[':'] := colon;
      ssy['^'] := arrow ;   ssy['<'] := relop;    ssy['>'] := relop;
      ssy[';'] := semicolon;
    end (*symbols*) ;

    procedure rators;
      var i: integer;
    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 i := ordminchar to ordmaxchar do sop[chr(i)] := 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] :=' wro'; 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';
    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'; mn[58] :=' ord'; mn[59] :=' chr';
      mn[60] :=' ujc';
    end (*instrmnemonics*) ;

    procedure chartypes;
    var i : integer;
    begin
      for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
      chartp['a'] := letter  ;
      chartp['b'] := letter  ; chartp['c'] := letter  ;
      chartp['d'] := letter  ; chartp['e'] := letter  ;
      chartp['f'] := letter  ; chartp['g'] := letter  ;
      chartp['h'] := letter  ; chartp['i'] := letter  ;
      chartp['j'] := letter  ; chartp['k'] := letter  ;
      chartp['l'] := letter  ; chartp['m'] := letter  ;
      chartp['n'] := letter  ; chartp['o'] := letter  ;
      chartp['p'] := letter  ; chartp['q'] := letter  ;
      chartp['r'] := letter  ; chartp['s'] := letter  ;
      chartp['t'] := letter  ; chartp['u'] := letter  ;
      chartp['v'] := letter  ; chartp['w'] := letter  ;
      chartp['x'] := letter  ; chartp['y'] := letter  ;
      chartp['z'] := letter  ; chartp['0'] := number  ;
      chartp['1'] := number  ; chartp['2'] := number  ;
      chartp['3'] := number  ; chartp['4'] := number  ;
      chartp['5'] := number  ; chartp['6'] := number  ;
      chartp['7'] := number  ; chartp['8'] := number  ;
      chartp['9'] := number  ; chartp['+'] := special ;
      chartp['-'] := special ; chartp['*'] := special ;
      chartp['/'] := special ; chartp['('] := chlparen;
      chartp[')'] := special ; chartp['$'] := special ;
      chartp['='] := special ; chartp[' '] := chspace ;
      chartp[','] := special ; chartp['.'] := chperiod;
      chartp['''']:= chstrquo; chartp['['] := special ;
      chartp[']'] := special ; chartp[':'] := chcolon ;
      chartp['^'] := special ; chartp[';'] := special ;
      chartp['<'] := chlt    ; chartp['>'] := chgt    ;
      ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
      ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
      ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
      ordint['9'] := 9;
    end;

    procedure initdx;
    begin
      cdx[ 0] :=  0; cdx[ 1] :=  0; cdx[ 2] := -1; cdx[ 3] := -1;
      cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1;
      cdx[ 8] :=  0; cdx[ 9] :=  0; cdx[10] :=  0; cdx[11] := -1;
      cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1;
      cdx[16] := -1; cdx[17] :=  0; cdx[18] :=  0; cdx[19] :=  0;
      cdx[20] :=  0; cdx[21] := -1; cdx[22] := -1; cdx[23] :=  0;
      cdx[24] :=  0; cdx[25] :=  0; cdx[26] := -2; cdx[27] :=  0;
      cdx[28] := -1; cdx[29] :=  0; cdx[30] :=  0; cdx[31] :=  0;
      cdx[32] :=  0; cdx[33] := -1; cdx[34] :=  0; cdx[35] :=  0;
      cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1;
      cdx[40] := -2; cdx[41] :=  0; cdx[42] :=  0; cdx[43] := -1;
      cdx[44] := -1; cdx[45] :=  0; cdx[46] :=  0; cdx[47] := -1;
      cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1;
      cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1;
      cdx[56] := -1; cdx[57] :=  0; cdx[58] :=  0; cdx[59] :=  0;
      cdx[60] :=  0;
      pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2;
      pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3;
      pdx[ 9] := -3; pdx[10] := -4; pdx[11] :=  0; pdx[12] := -2;
      pdx[13] := -1; pdx[14] :=  0; pdx[15] :=  0; pdx[16] :=  0;
      pdx[17] :=  0; pdx[18] :=  0; pdx[19] :=  0; pdx[20] :=  0;
      pdx[21] := -1; pdx[22] := -1; pdx[23] := -1;
    end;

  begin (*inittables*)
    reswords; symbols; rators;
    instrmnemonics; procmnemonics;
    chartypes; initdx;
  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:*) rewrite(prr); (*comment this out when compiling with pcom *)
  (**********)
  insymbol;
  programme(blockbegsys+statbegsys-[casesy]);

end.