program pascal_pass1_RSX;
{N B S    P a s c a l - N     c o m p i l e r}
{Modified to accept upper or lower case identifiers
 and to accept comments enclosed in (* *).    JBH\780415}
 
				{constants}
				{*********}
const
  NL = chr(10); {ascii new line (line feed)}
  HT = chr(9);  {ascii horz tab}
  FF = chr(12);	{ascii form feed}
  alfaleng = 15; {max length of identifier}
  strlen = 80; {max length of string}
  filsiz = 522;		{size of file variable}

				{addressing characteristics}
				{**************************}
const
  maxlevel = 15;		{maximum lex level}
type
  lltype = 0..maxlevel;
  addrrange = integer;		{address type}

				{value information}
				{*****************}
type
  stndset = set of 0..15; { ***TEMP Restriction*** }
  realoverlay = array[0..3] of integer;
  cstclass = (lit,data,reel,setc);
  valu = record case kind: cstclass of
    lit: (ival: integer);
    data: (daddr: integer);
    reel: (case boolean of	{ caution: equivalence }
      false: (rval: @longreal);
      true: (xval: @realoverlay));
    setc: (sval: @stndset)
  end;

				{lexical information}
				{*******************}
				{basic symbols}
				{*************}
type
  symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,
            relop,lparen,rparen,lbrack,rbrack,comma,semicolon,
            period,atsign,colon,becomes,constsy,typesy,varsy,
            programsy,proceduresy,functionsy,setsy,packedsy,arraysy,
            recordsy,filesy,forwardsy,beginsy,ifsy,casesy,repeatsy,
            whilesy,forsy,withsy,loopsy,gotosy,exitsy,endsy,elsesy,
            untilsy,ofsy,dosy,tosy,downtosy,thensy,externalsy,
            eofsy,othersy);
  operator = (mul,andop,idiv,imod,plus,minus,orop,ltop,leop,
              geop,gtop,neop,eqop,inop,maxop,minop,ceilop,
	      floorop,noop);
  symtype = record
              sy: symbol;
              op: operator
            end;
  idtype = record
	     l: char;	{length of identifier}
	     s: array[1..alfaleng] of char
	   end;

				{returned by insymbol}
				{********************}
var
  sym: symtype;			{symbol type and classification}
  val: valu;			{value of constant}
  lgth: integer;		{length of string}
  string: array[0..strlen-1] of char;	{value of string}
  id: idtype;			{last identifier}
  ch: char;			{last character}
  chcnt: 0..75;			{character counter}
  linenr: integer;		{line counter}
  
  
                               {option switches:}
                               {****************}
  option: array ['A'..'Z'] of boolean;
 
                               {files}
                               {*****}
var
  src,                         {source}
  lst: text;                   {listing}

                               {error messages:}
                               {***************}
var
  errtot: integer;             {total number of errors}
  errinx: 0..7;                {number of errors in current line}
  errlist: array [1..7] of record pos: 1..75; nmr: 1..400 end;

function match(var s1: array[1..255] of char; l1: integer;
	       var s2: array[1..255] of char; l2: integer): integer;
var
  i, n: integer;
begin
n := min(l1, l2);
i := 1;
while (i <= n) and (s1[i] = s2[i]) do i := succ(i);
if i > n then
  match := l2 - l1
else
  match := ord(s2[i]) - ord(s1[i])
end;

procedure error(n: integer);
begin {error}
  if errinx < 7 then begin
    errinx := succ(errinx);
    with errlist[errinx] do begin
      pos := chcnt; nmr := n
      end
    end
end {error};

procedure endofline;
var k: integer;
begin {endofline}
  if errinx > 0 then begin
    for k := 1 to errinx do
      with errlist[k] do
	write(lst,'**',nmr:3,HT,' ':pos,'^',NL);
    errtot := errtot + errinx;
    errinx := 0
    end
end {endofline};

procedure insymbol;
type
  chartype = (ctl,oth,dig,let,quo,db0,db1,db2,db3,eos,s00,s01,s02,s03,
    s04,s05,s06,s07,s08,s09,s10,s11,s12,s13);
  chartabtype = array[chr(0)..chr(127)] of chartype;
const
  chartab = chartabtype(
  eos,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,
  ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,ctl,
  oth,oth,quo,s00,oth,oth,oth,quo,s01,s02,s03,s04,s05,s06,db3,s07,
  dig,dig,dig,dig,dig,dig,dig,dig,dig,dig,db0,s08,db1,s09,db2,oth,
  s10,let,let,let,let,let,let,let,let,let,let,let,let,let,let,let,
  let,let,let,let,let,let,let,let,let,let,let,s11,oth,s12,s13,let,
  oth,let,let,let,let,let,let,let,let,let,let,let,let,let,let,let,
  let,let,let,let,let,let,let,let,let,let,let,oth,oth,oth,oth,ctl);
type
  chartoktab = array[s00..s13] of symtype;
const
  chartok = chartoktab(
    (relop,neop),	{s00: '#'}
    (lparen,noop),	{s01: '('}
    (rparen,noop),	{s02: ')'}
    (mulop,mul),	{s03: '*'}
    (addop,plus),	{s04: '+'}
    (comma,noop),	{s05: ','}
    (addop,minus),	{s06: '-'}
    (mulop,idiv),	{s07: '/'}
    (semicolon,noop),	{s08: ';'}
    (relop,eqop),	{s09: '='}
    (atsign,noop),	{s10: '@'}
    (lbrack,noop),	{s11: '['}
    (rbrack,noop),	{s12: ']'}
    (atsign,noop));	{s13: '^'}

const
  NrKeywords = 36;
type
  keywords = array[1..NrKeywords] of record
    id: idtype;
    sym: symtype
  end;
const
  keyword = keywords(
    ((chr(3),'end            '),(endsy,noop)),
    ((chr(5),'begin          '),(beginsy,noop)),
    ((chr(2),'if             '),(ifsy,noop)),
    ((chr(4),'then           '),(thensy,noop)),
    ((chr(4),'else           '),(elsesy,noop)),
    ((chr(3),'div            '),(mulop,idiv)),
    ((chr(3),'mod            '),(mulop,imod)),
    ((chr(2),'do             '),(dosy,noop)),
    ((chr(5),'while          '),(whilesy,noop)),
    ((chr(6),'repeat         '),(repeatsy,noop)),
    ((chr(5),'until          '),(untilsy,noop)),
    ((chr(4),'with           '),(withsy,noop)),
    ((chr(4),'case           '),(casesy,noop)),
    ((chr(4),'loop           '),(loopsy,noop)),
    ((chr(4),'exit           '),(exitsy,noop)),
    ((chr(3),'not            '),(notsy,noop)),
    ((chr(2),'or             '),(addop,orop)),
    ((chr(3),'and            '),(mulop,andop)),
    ((chr(2),'to             '),(tosy,noop)),
    ((chr(2),'in             '),(relop,inop)),
    ((chr(3),'for            '),(forsy,noop)),
    ((chr(2),'of             '),(ofsy,noop)),
    ((chr(5),'array          '),(arraysy,noop)),
    ((chr(5),'const          '),(constsy,noop)),
    ((chr(4),'file           '),(filesy,noop)),
    ((chr(6),'packed         '),(packedsy,noop)),
    ((chr(6),'record         '),(recordsy,noop)),
    ((chr(3),'set            '),(setsy,noop)),
    ((chr(4),'type           '),(typesy,noop)),
    ((chr(3),'var            '),(varsy,noop)),
    ((chr(6),'downto         '),(downtosy,noop)),
    ((chr(9),'procedure      '),(proceduresy,noop)),
    ((chr(8),'function       '),(functionsy,noop)),
    ((chr(7),'forward        '),(forwardsy,noop)),
    ((chr(8),'external       '),(externalsy,noop)),
    ((chr(7),'program        '),(programsy,noop))
  );

procedure nextch;
begin {nextch}
  ch := chr(0);
  while (ch = chr(0)) and not eof(src) do read(src,ch);
  if option['L'] then begin
    if chcnt = 0 then write(lst,linenr:5,HT);
    write(lst,ch)
    end;
  if ch >= ' ' then chcnt := succ(chcnt)
  else if (ch = NL) or (ch = FF) then begin
    endofline;
    linenr := succ(linenr);
    chcnt := 0
    end
  else if ch = HT then
    repeat chcnt := succ(chcnt)
    until chcnt mod 8 = 0
end {nextch};
 
procedure options;
var lch: char;
begin {options}
  repeat
    nextch;
    if (ch >= 'a') and (ch <= 'z')
      then ch := chr(ord(ch)-32); {convert l.c. option to u.c.}
    if (ch >= 'A') and (ch <= 'Z') then begin
      lch := ch;
      nextch;
      option[lch] := (ch = '+');
      nextch
      end
  until ch <> ','
end {options};

const
  digmax = 9;
  zero = float(0);  {***TEMP***}
  one = float(1);  {***TEMP***}
 ten = float(10);  {***TEMP***}
var
  i, j, k, n, scale, radix: integer;
  r, sf, fac: longreal;
  digits: array[1..digmax] of 0..9;
  terminator: char;
  getnuchar, maxstr, found, sign, useful: boolean;
begin {insymbol}
repeat
  loop
    while (ch <= ' ') and (ch <> chr(0)) do	{skip over blanks and controls}
      nextch;
  exit if ch <> '{';
    nextch;
    if ch = '$' then options;
    while (ch <> '}') and (ch <> chr(0)) do	{ gobble up comment }
      nextch;
    nextch
  end;
  getnuchar := true;
  useful := true;
  case chartab[ch] of
    dig:begin
      sym.sy := intconst; {assume integer until shown otherwise}
      i := 0;
      repeat
	i := i + 1;
	if i <= digmax then digits[i] := ord(ch) - ord('0');
	nextch
      until chartab[ch] <> dig;
      if i > digmax then begin error(203); i := digmax end;
      n := 0; radix := 10;
      if (ch = 'b') or (ch = 'B') then begin
	nextch;
	radix := 8
	end
      else begin
	scale := 0;
	if ch = '.' then begin
	  nextch;
	  if ch = '.' then
	    ch := ':'
	  else begin
	    sym.sy := realconst;
	    while chartab[ch] = dig do begin
	      i := i + 1;
	      if i <= digmax then digits[i] := ord(ch) - ord('0');
	      scale := scale - 1;
	      nextch
	      end
	    end
	  end;
	if (ch = 'e') or (ch = 'E') then begin
	  nextch;
	  sign := false;
	  if ch = '+' then nextch
	  else if ch = '-' then begin
	    sign := true;
	    nextch
	    end;
	  while chartab[ch] = dig do begin
	    n := n*10 + (ord(ch) - ord('0'));
	    nextch
	    end;
	  if sign then scale := scale - n else scale := scale + n
	  end;
	end;
      if sym.sy = intconst then begin
	for k := 1 to i do
	  n := n*radix + digits[k];
	val.kind := lit; val.ival := n
	end
      else begin	{ realconst }
	r := zero;
	for k := 1 to i do
	  r := r*ten + float(digits[k]);
	sf := one; fac := ten;
	if scale < 0 then begin
	  scale := -scale; fac := 1.0/fac;
	  end;
	while scale > 0 do begin
	  if odd(scale) then sf := sf*fac;
	  fac := fac*fac;
	  scale := scale div 2
	  end;
	val.kind := reel;
	new(val.rval);
	val.rval@ := r * sf
	end;
      getnuchar := false
      end;
    let: begin
      k := 0;
      repeat
	if k < alfaleng then begin
	  if option['U'] then {convert u.c. identifier to l.c.}
	    if (ch >= 'A') and (ch <= 'Z') then ch := chr(ord(ch)+32);
	  k := succ(k); id.s[k] := ch;
	  end;
	nextch
      until (chartab[ch] <> let) and (chartab[ch] <> dig);
      id.l := chr(k);
      j := 0;
      repeat
	found := true;
	j := succ(j);
	if keyword[j].id.l = id.l then begin
	  i := 1;
	  while found and (i <= k) do
	    if keyword[j].id.s[i] <> id.s[i] then found := false
	    else i := succ(i)
	  end
	else found := false
      until found or (j >= NrKeywords);
      if found then sym := keyword[j].sym
      else sym := symtype(ident,noop);
      getnuchar := false
      end;
    quo: begin
      terminator := ch;
      sym.sy := stringconst;
      k := 0; maxstr := false;
      repeat
	repeat
	  nextch;
	  if maxstr = false then
	    if k < strlen then begin
	      string[k] := ch; k := succ(k)
	      end
	    else begin
	      error(205);
	      maxstr := true
	      end
	until (ch = terminator) or (ch = chr(0));
	nextch
      until ch <> terminator;
      if terminator = '"' then begin
	string[k-1] := chr(0); lgth := k
	end
      else lgth := pred(k);
      getnuchar := false;
      end;
    db0: begin {':' or ':='}
      nextch;
      if ch = '=' then sym := symtype(becomes,noop)
      else begin
	sym := symtype(colon,noop);
	getnuchar := false
	end
      end;
    db1: begin {'<' or '<=' or '<>'}
      nextch;
      if ch = '=' then sym := symtype(relop,leop)
      else if ch = '>' then sym := symtype(relop,neop)
      else begin
	sym := symtype(relop,ltop);
	getnuchar := false
	end
      end;
    db2: begin {'>' or '>='}
      nextch;
      if ch = '=' then sym := symtype(relop,geop)
      else begin
	sym := symtype(relop,gtop);
	getnuchar := false
	end
      end;
    db3: begin {'..' or '.'; '..' is changed to ':'}
      nextch;
      if ch = '.' then sym := symtype(colon,noop)
      else begin
	sym := symtype(period,noop);
	getnuchar := false
	end
      end;
    s00,s02,s03,s04,s05,s06,s07,s08,s09,s10,s11,s12,s13:
      sym := chartok[chartab[ch]];
    s01: begin {'(', check for (* *) comment}
      nextch;
      if ch <> '*' then
      begin
        sym := chartok[s01];
        getnuchar := false
      end
      else begin
        nextch;
        if ch = '$' then options;
        repeat
          while (ch <> '*') and (ch <> chr(0)) do nextch;
          nextch
        until (ch = ')') or (ch = chr(0));
        useful := false
      end;
      end;
    oth: begin
      error(396);
      sym := symtype(othersy, noop)
      end;
    eos: begin
      sym := symtype(eofsy,noop);
      getnuchar := false
      end
  end;
  if getnuchar then nextch;
{ write(output,'sym.sy=',ord(sym.sy),NL); break(output)	{***DEBUG***}
  until useful
end {insymbol};

procedure skip(tosymbol: symbol);
begin
  while (sym.sy <> tosymbol) and (sym.sy <> eofsy) do insymbol
end;

				{type and identifier information}
				{*******************************}
type
  itp = @idents;		{pointer to identifier information}
  stp = @struct;		{pointer to type information}
				{form of types:}
				{**************}
  forms = (scalar, booleant, chart, integert, longintt, realt, longrealt,
	   pointer, sett, arrayt, recordt, filet, tagfield, variant);
				{type information:}
				{*****************}
  struct = record
    size: integer;
    marked: boolean;	{used by printtables}
    case form: forms of
    scalar, booleant, chart, integert, longintt, realt, longrealt: (
      maxconst: itp;
      case subrange: boolean of
      true: (maxvalue, minvalue: integer));
    pointer: (
      eltype: stp);
    sett: (
      settyp: stp);
    arrayt: (
      aeltyp,
      inxtyp: stp);
    recordt: (
      fstfld: itp;
      recvar: stp);
    filet: (
      filtyp: stp);
    tagfield: (
      fstvar: stp;
      tagfld: itp;
      tagtyp: stp);
    variant: (
      varval: integer;
      nxtvar,
      subvar: stp)
  end;
				{pointers to builtin types:}
				{**************************}
var
  boolptr, charptr, intptr, realptr, textptr, nilptr: stp;

				{identifier classes:}
				{*******************}
type
  classes = (types, konst, vars, field, proc);
				{kinds of variables:}
				{*******************}
  varkinds = (local, param, formal);
				{kinds of procedures:}
				{********************}
  pkinds = (decl, stnd, forw, extn);
				{identifier information:}
				{***********************}
  idents = record
    name: @idtype;	{address of identifier string}
    llink, rlink: itp;	{pointers to build binary tree}
    itype: stp;	{pointer to type information}
    next: itp;	{used to build lists of identifiers}
    case class: classes of
    konst: (value: valu);
    vars:(
      vkind: varkinds;
      vlev: lltype;
      vaddr: addrrange);
    field:(
      case ispacked: boolean of
      false: (fdisp: addrrange);
      true: (bdisp: integer));
    proc:(
      case pkind: pkinds of
      decl: (
	plev: lltype;
	paddr: addrrange);
      stnd: (
	psinx: integer);
      extn: (
	pxinx: integer))
  end;
				{dummy identifiers for undeclareds:}
				{**********************************}
var
  udptrs: array[classes] of itp;

				{lex level display:}
				{******************}
const
  maxdis = 32;	{maximum depth of display (lexlev + with)}
type
  disprange = 0..maxdis-1;	{display index range}
  dtype = (blck, vrec, crec);	{display entry type}
var
  display: array[disprange] of record
    fname: itp;		{root of identifier tree}
    case occur: dtype of
    crec: (
      dlev: lltype;
      daddr: addrrange);
    vrec: (
      tnum: integer)
    end;
  top, disx, level: disprange;	{indices into display}
  pin,			{procedure number}
  maxpin,		{highest number procedure seen so far}
  ac,			{parameter address counter}
  dc,			{fixed data address counter}
  lc,			{local variable address counter}
  tc: integer;		{temporary (with ...) variable counter}
  prterr: boolean;	{print error if ident is undefined}

function searchlevel(fp: itp): itp;
var
  p: itp;
  i: integer;
  found: boolean;
begin
p := fp;
found := false;
while not found and (p <> nil) do with p@.name@ do begin
  i := match(s, ord(l), id.s, ord(id.l));
  if i = 0 then
    found := true
  else if i > 0
    then p := p@.llink
    else p := p@.rlink
  end;
searchlevel := p
end;

function searchid(fs: set of classes): itp;
var
  p: itp;
begin
disx := top;
repeat
  p := searchlevel(display[disx].fname);
  if p <> nil then begin
    if not (p@.class in fs) then begin
      if prterr then error(103);
      p := nil;
      disx := pred(disx)
      end
    end
  else disx := pred(disx)
until (p <> nil) or (disx < 0);
if (p = nil) and prterr then begin
  error(104);
  p := udptrs[any(fs)]
  end;
searchid := p
end;

procedure newid(fc: classes; fq: stp; fn: itp; var fp: itp);
var
  f: forms; c: classes;
  p, p1, p2: itp;
  i: integer;
  lleft: boolean;
begin {newid}
case fc of
types: new(p,types);
konst: new(p,konst);
vars:  new(p,vars);
field: new(p,field);
proc:  new(p,proc)
end;
with p@ do begin
  class := fc;
  new(name,ord(id.l));
  with name@ do begin
    l := id.l;
    for i := 1 to id.l do s[i] := id.s[i]
    end;
  llink := nil; rlink := nil;
  itype := fq; next := fn
  end;
p2 := display[top].fname;
if p2 = nil then display[top].fname := p
else begin
  repeat
    p1 := p2;
    with p2@.name@ do begin
      i := match(s, ord(l), id.s, ord(id.l));
      if i <= 0 then begin
	if i = 0 then error(101);
	p2 := p2@.rlink;
	lleft := false
	end
      else begin
	p2 := p2@.llink;
	lleft := true
	end
      end
  until p2 = nil;
  if lleft then p1@.llink := p else p1@.rlink := p
  end;
fp := p
end {newid};

procedure inittables; {initialized symbol tables with standard
                      and predeclared identifiers and types}
const
  nrbuiltin = 39; {number of builtin procedures and functions}
type
  nametab = array[0..nrbuiltin-1] of idtype;
const
  names = nametab(
    (chr(3),'get            '),
    (chr(3),'put            '),
    (chr(5),'break          '),
    (chr(8),'position       '),
    (chr(5),'reset          '),
    (chr(7),'rewrite        '),
    (chr(6),'update         '),
    (chr(4),'read           '),
    (chr(6),'readln         '),
    (chr(5),'write          '),
    (chr(7),'writeln        '),
    (chr(3),'eof            '),
    (chr(3),'eoln           '),
    (chr(3),'new            '),
    (chr(4),'free           '),
    (chr(4),'mark           '),
    (chr(7),'release        '),
    (chr(4),'pred           '),
    (chr(4),'succ           '),
    (chr(3),'any            '),
    (chr(3),'all            '),
    (chr(3),'odd            '),
    (chr(3),'ord            '),
    (chr(3),'chr            '),
    (chr(5),'float          '),
    (chr(5),'trunc          '),
    (chr(5),'round          '),
    (chr(3),'max            '),
    (chr(3),'min            '),
    (chr(4),'ceil           '),
    (chr(5),'floor          '),
    (chr(3),'abs            '),
    (chr(3),'sqr            '),
    (chr(4),'sqrt           '),
    (chr(2),'ln             '),
    (chr(3),'exp            '),
    (chr(3),'sin            '),
    (chr(3),'cos            '),
    (chr(6),'arctan         '));

var
  p, p1: itp;
  q: stp;
  i,j,k,l: integer;
begin {inittables}
  {Initialize display}
  level := 0;  top := 0;
  with display[0] do begin
    fname := nil;  occur := blck
    end;
  {***integer***}
  new(intptr,integert);
  with intptr@ do begin form := integert; size := 2; subrange := false end;
  id := idtype(chr(7),'integer        ');
  newid(types,intptr,nil,p);
  {***real***}
  new(realptr,longrealt);
  with realptr@ do begin form := longrealt; size := 8; subrange := false end;
  id := idtype(chr(8),'longreal       ');
  newid(types,realptr,nil,p);
  new(realptr,realt);
  with realptr@ do begin form := realt; size := 4; subrange := false end;
  id := idtype(chr(4),'real           ');
  newid(types,realptr,nil,p);
  {***char***}
  new(charptr,chart);
  with charptr@ do begin form := chart; size := 1; subrange := false end;
  id := idtype(chr(4),'char           ');
  newid(types,charptr,nil,p);
  {***false,true,boolean***}
  new(boolptr,booleant);
  with boolptr@ do begin form := booleant; size := 1; subrange := false end;
  id := idtype(chr(5),'false          ');
  newid(konst,boolptr,nil,p);
  p@.value.ival := 0;
  id := idtype(chr(4),'true           ');
  newid(konst,boolptr,p,p);
  p@.value.ival := 1;
  boolptr@.maxconst := p;
  id := idtype(chr(7),'boolean        ');
  newid(types,boolptr,nil,p);
  {***text***}
  new(textptr,filet);
  with textptr@ do begin form := filet; size := 1; filtyp := charptr end;
  id := idtype(chr(4),'text           ');
  newid(types,textptr,nil,p);
  {***nil***}
  new(nilptr,pointer);
  with nilptr@ do begin form := pointer; size := 2; eltype := nil end;
  id := idtype(chr(3),'nil            ');
  newid(konst,nilptr,nil,p);
  p@.value.ival := 0;
  {***builtin procedures and functions***}
  for i := 0 to nrbuiltin-1 do begin
    id := names[i];
    newid(proc,nil,nil,p);
    with p@ do begin
      pkind := stnd; psinx := i
      end
    end;
  {***enter undeclared identifiers***}
  id.l := chr(3); id.s[1] := '.'; id.s[2] := 'u'; id.s[3] := 't';
  newid(types,nil,nil,udptrs[types]);
  id.s[3] := 'c';
  newid(konst,nil,nil,udptrs[konst]);
  id.s[3] := 'v';
  newid(vars,nil,nil,udptrs[vars]);
  udptrs[vars]@.vkind := local;
  id.s[3] := 'f';
  newid(field,nil,nil,udptrs[field]);
  id.s[3] := 'p';
  newid(proc,nil,nil,udptrs[proc]);
  udptrs[proc]@.pkind := decl
end {inittables};

procedure printtables(fb: boolean);
var i,lim: disprange; i1: integer;

procedure markctp(fp: itp); forward;

procedure markstp(fp: stp);
  begin
    if  fp <> nil then with fp@ do begin
{     write(output,"s:",fp:8,NL); break(output); {DEBUG}
      marked := false;
      case form of
        sett: markstp(settyp);
        arrayt: begin markstp(aeltyp); markstp(inxtyp) end;
        recordt: begin markctp(fstfld); markstp(recvar) end;
        filet: markstp(filtyp);
        tagfield: 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
{   write(output,"c:",fp:8,llink:8,rlink:8,itype:8,NL); break(output); {DEBUG}
    markctp(llink);
    markctp(rlink);
    markstp(itype)
    end {with}
end {markctp};

procedure followctp(fp: itp); forward;

procedure followstp(fp: stp);
type
  typenamtab = array[forms] of array[0..7] of char;
const
  typename = typenamtab(
    'scalar  ','boolean ','char    ','integer ',
    'longint ','real    ','longreal','pointer ',
    'set     ','array   ','record  ','file    ',
    'tagfield','variant ');
begin
  if fp <> nil then with fp@ do begin
    write(lst,'  ',typename[form]);
    if marked then begin
      marked := false;
      case form of
	pointer: begin
	  write(lst,' to');
	  followstp(eltype)
	  end;
        sett:begin
          followstp(settyp)
          end;
        arrayt:begin
	  write(lst,' [');
          followstp(inxtyp);
	  write(lst,'] of');
          followstp(aeltyp)
          end;
        recordt:begin
	  write(lst,' of',NL);
          followctp(fstfld);
          followstp(recvar)
          end;
        filet:begin
          followstp(filtyp)
          end;
        tagfield:begin
          followstp(fstvar)
          end;
        variant:begin
          followstp(nxtvar);
          followstp(subvar)
          end
	end {case}
      end {if marked}
  end {if <> nil}
end {followstp};

  procedure followctp;
  var ch:char; i:integer;
  begin
    if  fp <> nil then with fp@ do begin
      followctp(llink);
      if name@.l <> chr(0) then
	write(lst,name@.s:ord(name@.l));
      write(lst,' ':16-ord(name@.l),llink:10,rlink:10,itype:10,next:10,' ':4);
      case class of
        types:write(lst,'type');
        konst:begin
          write(lst,'constant':13);
          end;
        vars:begin
	  case vkind of
	    formal: write(lst, 'parm by ref':13);
	    param: write(lst, 'parm by val':13);
	    local: write(lst, 'variable':13)
	  end;
          write(lst,vlev:6,vaddr:10)
          end;
        field:write(lst,'field':13,fdisp:10);
        proc:begin
          write(lst,'procedure':13);
          end
      end; {case}
      followstp(itype);
      write(lst,NL);
      followctp(rlink)
    end {with}
  end {followctp};

begin {printtables}
  write(lst,NL,NL,NL);
  if fb then lim:=0 else begin lim:=top; write(lst,'local ') end;
  write(lst,'tables',NL);
  for i:=top downto lim do markctp(display[i].fname);
  for i:=top downto lim do followctp(display[i].fname);
  write(lst,NL);
  if ch <> NL then write(lst,' ':chcnt+8)
end {printtables};

type
  attributestates = (cst, ref, exp);
  accessmodes = (direct, byvalue, offset, indirect, indexed);
  attr = record		{ attributes of expressions }
    atype: stp;
    case akind: attributestates of
      cst: (
	avalue: valu);
      ref: (
	access: accessmodes;
	alevel: lltype;
	addr: integer)
    end;
var
  gattr: attr;		{ attributes of current expression }
  int,			{intermediate code}
  dat: text;		{intermediate data}


procedure getbounds(fq: stp; var fmin, fmax: integer);
begin
fmin := 0; fmax := 0;	{ until shown otherwise }
if fq <> nil then with fq@ do
  if subrange
  then begin fmin := minvalue; fmax := maxvalue end
  else case form of
    scalar, booleant: fmax := maxconst@.value.ival;
    chart: fmax := 255
    end
end;

procedure block(fp: itp);

function floor(fa, fb: integer): integer;	{***THIS SHOULD BE BUILT-IN}
begin
floor := fa div fb * fb
end;


function ceil(fa, fb: integer): integer;	{***ALSO SHOULD BE BUILT-IN?}
begin
ceil := (fa + (fb - 1)) div fb * fb
end;

{************TARGET MACHINE DEPENDENT STUFF FOLLOWS:**************}
type
  sizetables = array[forms] of integer;
const
  bitsau = 8;	{ bits in addressable unit }
  auword = 2;	{ addressable units in a 'preferred' size word }
  bitswd = bitsau*auword;	{ bits in a 'preferred' size word }
  maxlit = bitswd;		{ bits in largest literal }
  usize = sizetables(	{ size of forms in addressable units }
    1 {scalar}, 1 {boolean}, 1 {char}, 2 {int}, 4 {longint},
    4 {real}, 8 {longreal}, 2 {pointer}, 0 {set},
    0 {array}, 0 {record}, 522 {file}, 0 {tagfield}, 0 {variant} );
  ualign = sizetables(	{ required alignment of forms in addressable units }
    1 {scalar}, 1 {boolean}, 1 {char}, 2 {int}, 2 {longint},
    2 {real},  2 {longreal}, 2 {pointer}, 0 {set},
    0 {array}, 0 {record}, 2 {file}, 0 {tagfield}, 0 {variant});
type
  litshfttab = array[0..maxlit/bitsau] of integer;
const
  shfttab = litshfttab(	{ use to "shift" au's into a literal }
    1, 256);


function typsize(fq: stp): integer; forward;


function typalign(fq: stp): integer;
begin
if fq <> nil then with fq@ do case form of
  scalar, booleant, chart, integert, longintt, realt, longrealt,
  pointer, filet, tagfield, variant:
    typalign := ualign[form];
  sett, recordt:
    if typsize(fq) < auword then typalign := 1
    else typalign := 2;
  arrayt:
    typalign := typalign(aeltyp)
  end
else typalign := 1
end;

function setsize(fq: stp): integer;
begin
if fq <> nil then with fq@ do
  if (form < pointer) and subrange then
    if (minvalue >= 0) and (maxvalue <= 255) then
      setsize := maxvalue
    else begin error(115); setsize := 0 end
  else case form of
    scalar, booleant:
      setsize := maxconst@.value.ival + 1;
    chart:
      setsize := 128;	{ why not 256 ? }
    integert:
      setsize := 256;	{ arbitrary decision? }
    longintt, realt, longrealt, pointer, sett, arrayt,
    recordt, filet, tagfield, variant: {default}
      begin error(115); setsize := 0 end
    end
else setsize := 0
end;


function typsize{(fq: stp): integer};
begin
if fq <> nil then with fq@ do case form of
  scalar, booleant, chart, integert, longintt, realt, longrealt, pointer, filet:
    typsize := usize[form];
  sett:
    if size < bitswd then typsize := (size + (bitsau-1))/bitsau
    else typsize := ((size + (bitswd-1))/bitswd)*auword;
  arrayt:
    typsize := ceil(typsize(aeltyp), typalign(aeltyp)) * size;	{ round-up }
  recordt, tagfield, variant:
    typsize := size
  end
else typsize := 0
end;

procedure genbyte(fi: integer);
begin
if not option['S'] then begin
  int@ := chr(fi);  put(int)
  end
end;

procedure genword(fi: integer);
begin
if not option['S'] then begin
  int@ := chr(fi/256);  put(int);
  int@ := chr(fi);  put(int)
  end
end;

procedure genlit(fi: integer);
begin
genbyte(162); genword(fi)
end;


procedure gendat(var fattr: attr);
var
  i, j, n: integer;
begin
if (fattr.akind = cst) and (fattr.avalue.kind = setc) then
  if fattr.atype <> nil then with fattr.atype@ do begin
    if size <= maxlit then begin
      n := 0;
      j := 1;
      for i := 0 to size-1 do begin
        if i in fattr.avalue.sval@ then n := n + j;
        j := j * 2
        end;
      fattr.avalue.kind := lit;
      fattr.avalue.ival := n
      end
    else begin
      if odd(dc) then dc := succ(dc);
      for i := 0 to size div bitswd do
        { do a gendword on each word of set };
      fattr.avalue.kind := data;
      fattr.avalue.daddr := dc
      end
    end
end;

procedure gencon(var fattr: attr);
var
  i: integer;
begin
gendat(fattr);
case fattr.avalue.kind of
  lit: genlit(fattr.avalue.ival);
  reel: begin
    genbyte(164 {LITD});
    with fattr.avalue do for i:=0 to 3 do
      genword(xval@[i])
    end;
  data: begin
    genbyte(163 {RDATA});
    genword(fattr.addr)
    end
  end;
fattr.akind := exp
end;


procedure gendif(fi: integer);
begin
if fi <> 0 then if fi > 0
  then begin genlit(fi); genbyte(32 {IADD}) end
  else begin genlit(-fi); genbyte(33 {ISUB}) end
end;


procedure gendbyte(fi: integer);
begin
if not option['S'] then begin
  dat@ := chr(fi);  put(dat)
  end;
dc := succ(dc)
end;


procedure gendword(fi: integer);
begin
if not option['S'] then begin
  dat@ := chr(fi);  put(dat);
  dat@ := chr(fi/256);  put(dat)
  end;
dc := dc + 2
end;

procedure genid(fid: @idtype);
var
  i: integer;
begin
if fid <> nil then with fid@ do begin
  genbyte(ord(l));
  for i := 1 to ord(l) do genbyte(ord(s[i]))
  end
end;

function comptypes(fq1, fq2: stp): boolean;
var
  form2: forms;
begin
comptypes := true;	{ until shown otherwise }
if (fq1 <> fq2) and (fq1 <> nil) and (fq2 <> nil) then begin
  form2 := fq2@.form;
  with fq1@ do begin
    case form of
      scalar:		{ to handle subranges, identifier list must be same }
	{P-compiler note: "indentical scalars declared on different
	 levels are not recognized to be compatible"}
	comptypes := (form2 = scalar) and (maxconst = fq2@.maxconst);
      booleant, chart:
	comptypes := (form2 = form);
      integert, longintt:
	comptypes := (form2 = integert) or (form2 = longintt);
      realt, longrealt:
	comptypes := (form2 = realt) or (form2 = longrealt);
      pointer:
	{P-compiler note: code is much different here}
	comptypes := (form2 = pointer) and comptypes(eltype, fq2@.eltype);
      sett:
	comptypes := (form2 = sett) and comptypes(settyp, fq2@.settyp);
      arrayt:
	comptypes := (form2 = arrayt) and comptypes(aeltyp, fq2@.aeltyp);
	{P-compiler note: sizes must also be equal}
	{P-compiler note: "alternatives:
	 ... indextype must be compatible.
	 ... lowbounds must be the same."}
      recordt:
	comptypes := false;
	{P-compiler note:"identical records are recognized
	 to be compatible iff no variants occur"}
      filet:
	comptypes := (form2 = filet) and comptypes(filtyp, fq2@.filtyp)
      end
    end
  end
end;

procedure expression; forward;


procedure valueexpression;
begin
expression;
if gattr.akind = cst then begin
  gencon(gattr);
  gattr.akind := exp
  end
end;


procedure setcoerce(fq: stp);
begin
if (gattr.atype = nil) or (gattr.atype@.form <> sett) or
 (gattr.atype@.settyp = nil) then
  gattr.atype := fq
else if gattr.atype@.settyp@.subrange then
  { check for inclusion }
end;


procedure selector(fp: itp);


procedure genload;
begin
case gattr.akind of
  cst: case gattr.avalue.kind of
    data: begin
      genbyte(163 {RDATA});
      genword(gattr.avalue.daddr);
      gattr.akind := ref
      end;
    reel: { coming attraction };
    setc: { coming attraction }
    end;
  ref: begin
    case gattr.access of
      direct:
	genbyte(176 {VARBL} + gattr.alevel);
      byvalue:
	genbyte(192 {PARAM} + gattr.alevel);
      offset:
	genbyte(132 {OFSET});
      indirect:
	genbyte(133 {INDIR});
      indexed:
	genbyte(134 {INDEX})
      end;
    genbyte(typsize(gattr.atype));
    genword(gattr.addr)
    end
  end
end;

var
  lattr: attr;
  p: itp;
  q: stp;
  loffset: integer;
  more: boolean;
begin {selector}
with fp@ do begin
  gattr.atype := itype;
  case class of
    konst: begin
      gattr.akind := cst;
      gattr.avalue := value;
      end;
    vars: begin
      gattr.akind := ref;
      if vkind = local then
	gattr.access := direct
      else
	gattr.access := byvalue;
      gattr.alevel := vlev;
      gattr.addr := vaddr;
      if vkind = formal then begin
	genload;
	gattr.access := indirect;
	gattr.addr := 0
	end
      end;
    field: begin
      with display[disx] do begin
	gattr.akind := ref;  { doesn't work with record structured constants }
	if occur = crec
	then begin { direct reference }
	  gattr.access := direct;
	  gattr.alevel := dlev;
	  gattr.addr := daddr
	  end
	else begin { indirect reference }
	  genbyte(140 {RTEMP}); genbyte(tnum);
	  gattr.access := indirect;
	  gattr.addr := 0
	  end;
	gattr.addr := gattr.addr + fdisp
	end
      end
    end {case}
  end; {with}
repeat
  more := false;
  if sym.sy = atsign then begin
    if gattr.atype <> nil then begin
      if gattr.atype@.form = pointer then
	gattr.atype := gattr.atype@.eltype
      else if gattr.atype@.form = filet then
	gattr.atype := gattr.atype@.filtyp
      else error(141);
      genload;
      gattr.access := indirect;
      gattr.addr := 0
      end;
    insymbol;
    more := true
    end
  else if sym.sy = period then begin
    if gattr.access = indexed then begin
      genload;
      gattr.access := offset;
      gattr.addr := 0
      end;
    if (gattr.atype <> nil) and (gattr.atype@.form <> recordt) then
      begin error(140); gattr.atype := nil end;
    insymbol;
    if sym.sy = ident then begin
      if gattr.atype <> nil then begin
	p := searchlevel(gattr.atype@.fstfld);
	if p <> nil then begin
	  gattr.atype := p@.itype;
	  gattr.addr := gattr.addr + p@.fdisp
	  end
	else begin
	  error(152);
	  gattr.atype := nil
	  end
	end;
      insymbol
      end
    else error(2);
    more := true
    end
  else if sym.sy = lbrack then begin
    repeat
      if (gattr.atype <> nil) and (gattr.atype@.form <> arrayt) then
	begin error(138); gattr.atype := nil end;
      insymbol;
      genload;
      lattr := gattr;
      expression;
      if lattr.atype <> nil then with lattr.atype@ do begin
	if (inxtyp <> nil) and inxtyp@.subrange then
	  loffset := - inxtyp@.minvalue
	else
	  loffset := 0;
	if not comptypes(gattr.atype, inxtyp) then error(139);
	if gattr.akind = cst then begin
	  gattr.avalue.ival := gattr.avalue.ival + loffset;
	  gencon(gattr);
	  gattr.akind := exp
	  end
	else
	  gendif(loffset);
	if aeltyp <> nil then
	  if aeltyp@.form = arrayt then
	    gattr.addr := aeltyp@.size	{ index multiplier }
	  else
	    gattr.addr := ceil(typsize(aeltyp), typalign(aeltyp));
	gattr.atype := aeltyp;
	gattr.akind := lattr.akind;
	gattr.access := indexed
	end
    until sym.sy <> comma;
    if sym.sy = rbrack then insymbol else error(12);
    more := true
    end
until not more;
genload
end;

procedure binop(fop: operator; var fattr: attr);
type
  binoptab = array[forms,operator] of 0..255;
const
  binopcodes = binoptab (
{ *  and  /  mod  +   -   or  <   <=  >=  >   <>  =   in max min cei flo nop }
(  0,  0,  0,  0, 16, 17,  0, 29, 27, 28, 26, 25, 24,  0, 30, 31,  0,  0,  0),
(  0,111,  0,  0,  0,  0,110,109,107,108,106,105,104,  0,  0,  0,  0,  0,  0),
(  0,  0,  0,  0, 16, 17,  0, 29, 27, 28, 26, 25, 24,  0, 30, 31,  0,  0,  0),
( 34,  0, 35, 36, 32, 33,  0, 61, 59, 60, 58, 57, 56,  0, 62, 63, 44, 45,  0),
( 34,  0, 35, 36, 32, 33,  0, 61, 59, 60, 58, 57, 56,  0, 62, 63, 44, 45,  0),
( 66,  0, 67,  0, 64, 65,  0, 93, 91, 92, 90, 89, 88,  0, 94, 95,  0,  0,  0),
( 66,  0, 67,  0, 64, 65,  0, 93, 91, 92, 90, 89, 88,  0, 94, 95,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 25, 24,  0,  0,  0,  0,  0,  0),
(114,  0,  0,  0,113,115,  0,  0,123,124,  0,121,120,126,  0,  0,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,173,171,172,170,169,168,  0,  0,  0,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0));
var
  q: stp;
  s: @stndset;
  r: @longreal;
  opcode: 0..255;
begin
if (fop = inop) and (gattr.atype <> nil) then
  if gattr.atype@.form = sett then
    q := gattr.atype@.settyp
  else
    begin error(134); q := nil end
else
  q := gattr.atype;
if not comptypes(q, fattr.atype) then error(134);
if gattr.atype <> nil then begin
  opcode := binopcodes[gattr.atype@.form][fop];
  if opcode = 0 then
    error(134)
  else if gattr.atype@.form = arrayt then begin
    if not comptypes(gattr.atype@.aeltyp, charptr) then error(134);
    if fattr.akind = cst then gencon(fattr);
    if gattr.akind = cst then
      gencon(gattr)
    else
      if fattr.akind = cst then genbyte(1 {XCH});
    genbyte(opcode); genbyte(1);
    genword(min(gattr.atype@.size, fattr.atype@.size))
    end
  else begin
    if fattr.akind <> cst then begin		{ <expr> <op> ?? }
      if gattr.akind = cst then			{ <expr> <op> <const> }
	gencon(gattr);
      genbyte(opcode)
      end
    else					{ <const> <op> ?? }
      if gattr.akind <> cst then begin		{ <const> <op> <expr> }
	gencon(fattr);
	genbyte(1 {XCH});
	genbyte(opcode)
	end
      else					{ <const> <op> <const> }
	case gattr.atype@.form of
	  scalar, booleant, chart, integert:
	    case fop of
	      plus:
		gattr.avalue.ival := fattr.avalue.ival + gattr.avalue.ival;
	      minus:
		gattr.avalue.ival := fattr.avalue.ival - gattr.avalue.ival;
	      mul:
		gattr.avalue.ival := fattr.avalue.ival * gattr.avalue.ival;
	      idiv:
		gattr.avalue.ival := fattr.avalue.ival div gattr.avalue.ival;
	      imod:
		gattr.avalue.ival := fattr.avalue.ival mod gattr.avalue.ival;
	      ltop:
		gattr.avalue.ival := ord(fattr.avalue.ival < gattr.avalue.ival);
	      leop:
		gattr.avalue.ival := ord(fattr.avalue.ival <= gattr.avalue.ival);
	      geop:
		gattr.avalue.ival := ord(fattr.avalue.ival >= gattr.avalue.ival);
	      gtop:
		gattr.avalue.ival := ord(fattr.avalue.ival > gattr.avalue.ival);
	      neop:
		gattr.avalue.ival := ord(fattr.avalue.ival <> gattr.avalue.ival);
	      eqop:
		gattr.avalue.ival := ord(fattr.avalue.ival = gattr.avalue.ival);
	      maxop:
		if fattr.avalue.ival > gattr.avalue.ival then
		  gattr.avalue.ival := fattr.avalue.ival;
	      minop:
		if fattr.avalue.ival < gattr.avalue.ival then
		  gattr.avalue.ival := fattr.avalue.ival;
	      ceilop:
		;
	      floorop:
		;
	      andop:
		if (fattr.avalue.ival <> 0) and (gattr.avalue.ival <> 0) then
		  gattr.avalue.ival := 1
		else
		  gattr.avalue.ival := 0;
	      orop:
		if (fattr.avalue.ival <> 0) or (gattr.avalue.ival <> 0) then
		  gattr.avalue.ival := 1
		else
		  gattr.avalue.ival := 0
	      end; {case fop}
	  realt, longrealt: begin
	    if fop <= minus then begin
	      new(r);
	      r@ := gattr.avalue.rval@;
	      gattr.avalue.rval := r
	      end;
	    case fop of
	      plus:
		gattr.avalue.rval@ := fattr.avalue.rval@ + gattr.avalue.rval@;
	      minus:
		gattr.avalue.rval@ := fattr.avalue.rval@ - gattr.avalue.rval@;
	      mul:
		gattr.avalue.rval@ := fattr.avalue.rval@ * gattr.avalue.rval@;
	      idiv:
		gattr.avalue.rval@ := fattr.avalue.rval@ / gattr.avalue.rval@
	    end
	  end;
	  sett: begin
	    if fop <= orop then begin
	      new(s);
	      s@ := gattr.avalue.sval@;
	      gattr.avalue.sval := s
	      end;
	    case fop of
	      plus:
		gattr.avalue.sval@ := fattr.avalue.sval@ + gattr.avalue.sval@;
	      minus:
		gattr.avalue.sval@ := fattr.avalue.sval@ - gattr.avalue.sval@;
	      mul:
		gattr.avalue.sval@ := fattr.avalue.sval@ * gattr.avalue.sval@;
	      inop:
		gattr.avalue.ival :=
		  ord(fattr.avalue.ival in gattr.avalue.sval@);
	      ltop:
		;
	      leop:
		;
	      geop:
		;
	      gtop:
		;
	      neop:
		;
	      eqop:
	      end
	    end
	end {case form}
    end {else opcode # 0}
  end {not nil}
end;

procedure call(fp: itp);


procedure calluser(fp: itp);
var
  p: itp;
  q: stp;
  nrofparm, retvsize: integer;
begin
nrofparm := 0;
p := fp@.next;	{ head of formal parameter list }
if fp@.itype <> nil then begin	{ its a function }
  retvsize := typsize(p@.itype);
  p := p@.next		{ skip over returned value dummy }
  end
else retvsize := 0;
if sym.sy = lparen then begin	{ parse actual parameter list }
  repeat
    insymbol;
    valueexpression;
    if p <> nil then begin
      q := p@.itype;	{ type of formal parameter }
      if q <> nil then
	if not comptypes(gattr.atype, q) then
	  error(142)
	else if q@.form = sett then
	  setcoerce(q);	{ make empty sets behave }
      if p@.vkind = formal then begin
	if gattr.akind <> ref then error(154);
	genbyte(9 {REFER})
	end;
      p := p@.next
      end
    else error(126);	{ nr actuals > nr formals }
    nrofparm := succ(nrofparm)
  until sym.sy <> comma;
  if sym.sy = rparen then insymbol else error(4)
  end;
if p <> nil then error(126);	{ nr formals > nr actuals }
genbyte(208 + fp@.plev {CALL});
genbyte(retvsize);
genbyte(fp@.paddr);
genbyte(nrofparm);
gattr.atype := fp@.itype
end;

procedure callnew;
var
  q, q1: stp;
  n, m: integer;
  hasvariablepart: boolean;
begin
q := nil; n := 0; hasvariablepart := false;
if gattr.atype <> nil then
  if gattr.atype@.form = pointer then begin
    q1 := gattr.atype@.eltype;
    if q1 <> nil then begin
      n := typsize(q1);
      if q1@.form = recordt then q := q1@.recvar
      end
    end
  else error(116);
while sym.sy = comma do begin
  insymbol;
  expression;
  if q<> nil then begin
    if q@.form = tagfield then begin
      if not comptypes(gattr.atype, q@.tagtyp) then error(116);
      n := typsize(q);
      if gattr.akind = cst then begin
	q1 := q@.fstvar;
	while (q1 <> nil) and (q1@.varval <> gattr.avalue.ival) do
	  q1 := q1@.nxtvar;
	if q1 <> nil then begin
	  n := q1@.size;
	  q := q1@.subvar
	  end
	end
      else error(50)
      end
    else if q@.form = arrayt then begin
      m := typsize(q@.aeltyp);
      n := n - (m * q@.size);
      if gattr.akind = cst then
	n := n + (gattr.avalue.ival * m)
      else begin
	genlit(m);
	genbyte(34 {IMUL});
	hasvariablepart := true
	end;
      q := nil
      end
    end
  end;
genlit(n);
if hasvariablepart then genbyte(32 {IADD});
genbyte(138 {INVOK}); genbyte(1); genbyte(4 {new});
genbyte(10 {STOL})
end;

procedure fileproc(apsinx: integer);
type
  rwtab = array[forms] of integer;
const
  readcode  = rwtab( 0, 0,24,30, 0,34,36, 0, 0, 0, 0, 0, 0, 0);
  writecode = rwtab( 0,29,25,31, 0,35,37,39, 0,27, 0, 0, 0, 0);
var
  code, lastcode, nrcalls, nrparm: integer;
begin
if sym.sy = ident then begin
  expression;
  if (gattr.atype <> nil) and (gattr.atype@.form <> filet) then error(168);
  if apsinx > 10 then begin	{ eof or eoln function }
    if apsinx = 11 then begin		{ eof }
      genbyte(132 {OFSET}); genbyte(1 {size}); genword(2 {offset of eof flag})
      end
    else begin				{ eoln }
      error(398) { not yet implemented }
      end;
    gattr.atype := boolptr
    end
  else begin			{ file procedure }
    genbyte(9 {REFER});
    case apsinx of
      0, 1: begin		{ get - put }
	genlit(typsize(gattr.atype@.filtyp));
	genbyte(138 {INVOK}); genbyte(2); genbyte(apsinx+21)
	end;
      2: begin			{ break }
	genbyte(138 {INVOK}); genbyte(1); genbyte(23)
	end;
      3: begin			{ [position] }
	end;
      4, 5, 6: begin		{ reset, rewrite, [update] }
	if sym.sy = comma then insymbol else error(20);
	valueexpression;
	if gattr.atype <> nil then
	  if (gattr.atype@.form <> arrayt) or (gattr.atype@.aeltyp <> charptr)
	  then error(116);
        genbyte(9 {REFER});
	if sym.sy=comma then begin
	  insymbol;
	  valueexpression;
	  end
	else genlit(0);
	genlit(apsinx - 4);	{0=>reset, 1=>rewrite, [2=>update]}
	genbyte(138 {INVOK}); genbyte(4); genbyte(17)
	end;
      7, 8, 9, 10: begin		{ read, readln, write, writeln }
	if gattr.atype <> textptr then error(169);
	if sym.sy = comma then insymbol else error(20);
	genbyte(177 {VARBL}); genbyte(2); genword(0);
	genbyte(1 {XCH});
	genbyte(10 {STOL});
	nrcalls := 0; lastcode := 0;
	if apsinx < 9 then begin	{ read or readln }
	  if apsinx = 8 then lastcode := 44;	{ readln }
	  loop
	    nrcalls := succ(nrcalls);
	    expression;
	    if gattr.atype <> nil then begin
	      code := readcode[gattr.atype@.form];
	      if code = 0 then error(116)
	      end
	    else code := 0;
	    genbyte(9 {REFER});
	    genbyte(138 {INVOK}); genbyte(2); genbyte(code);
	  exit if sym.sy <> comma;
	    insymbol;
	    genbyte(177 {VARBL}); genbyte(2); genword(0)
	  end {loop}
	  end {if...then}
	else begin			{ write or writeln }
	  if apsinx = 10 then lastcode := 45;	{ writeln }
	  loop
	    nrcalls := succ(nrcalls);
	    nrparm := 3;	{ until proven otherwise }
	    valueexpression;
	    if gattr.atype <> nil then begin
	      code := writecode[gattr.atype@.form];
	      if code = 27 then
	        if gattr.atype@.aeltyp = charptr then begin
		  genbyte(9 {REFER});
		  genlit(gattr.atype@.size);
		  nrparm := 4
		  end
	        else code := 0;
	      if code = 0 then error(116)
	      end
	    else code := 0;
	    if sym.sy = colon then begin
	      insymbol;
	      valueexpression;
	      if not comptypes(gattr.atype, intptr) then error(116)
	      end
	    else genlit(0);	{ default field width }
	    if (code=35) or (code=37) then	{write real/longreal}
	      if sym.sy = colon then begin
		insymbol;
		valueexpression;
		if not comptypes(gattr.atype, intptr) then error(116);
		nrparm:=4
	      end else code:=code+6;	{use e-style output}
	    genbyte(138 {INVOK}); genbyte(nrparm); genbyte(code);
	  exit if sym.sy <> comma;
	    insymbol;
	    genbyte(177 {VARBL}); genbyte(2); genword(0)
	  end {loop}
	  end; {if...else}
	if lastcode <> 0 then begin
	  genbyte(177 {VARBL}); genbyte(2); genword(0);
	  genbyte(138 {INVOK}); genbyte(1); genbyte(lastcode);
	  nrcalls := succ(nrcalls)
	  end;
	genbyte(152 {SEQ}); genbyte(nrcalls-1)
	end
      end {case}
    end {else}
  end {then}
else error(2);
if sym.sy = rparen then insymbol else error(4)
end;

var
  lattr: attr;
  i: integer;
const
  nrbuiltin = 39;
type
  doargtab = array[0..nrbuiltin-1] of set of (hasarg, getarg);
const
  doarg = doargtab(
  [hasarg], [hasarg], [hasarg], [hasarg],	{ get - position }
  [hasarg], [hasarg], [hasarg],			{ reset - update }
  [hasarg], [hasarg], [hasarg], [hasarg],	{ read - writeln }
  [hasarg], [hasarg],				{ eof - eoln }
  [hasarg,getarg], [hasarg,getarg], [], [],	{ new - release }
  [hasarg,getarg], [hasarg,getarg],		{ pred - succ }
  [hasarg,getarg], [hasarg,getarg],		{ any - all }
  [hasarg,getarg], [hasarg,getarg],		{ odd - ord }
  [hasarg,getarg], [hasarg,getarg],		{ chr - float }
  [hasarg,getarg], [hasarg,getarg],		{ trunc - round }
  [hasarg,getarg], [hasarg,getarg],		{ max - min }
  [hasarg,getarg], [hasarg,getarg],		{ ceil - floor }
  [hasarg,getarg],				{ abs }
  [hasarg,getarg], [hasarg,getarg],		{ sqr - sqrt }
  [hasarg,getarg], [hasarg,getarg],		{ ln - exp }
  [hasarg,getarg], [hasarg,getarg],		{ sin - cos }
  [hasarg,getarg]);				{ arctan }
begin
with fp@ do begin
  if pkind = stnd then begin
    if hasarg in doarg[psinx] then begin
      if sym.sy = lparen then begin
	insymbol;
	if getarg in doarg[psinx] then expression
	end
      else error(9)
      end;
    case psinx of
      0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12:	{ get - eoln }
	fileproc(psinx);
      13: callnew;			{ new }
      15, 16: begin			{ mark - release }
	genbyte(138 {INVOK});
	genbyte(0 {nr of args});
	genbyte(psinx-9)
	end;
      17: 				{ pred }
	if gattr.akind = cst then
	  gattr.avalue.ival := pred(gattr.avalue.ival)
	else
	  genbyte(17 {PRED});
      18:				{ succ }
	if gattr.akind = cst then
	  gattr.avalue.ival := succ(gattr.avalue.ival)
	else
	  genbyte(16 {SUCC});
      19:				{ any }
	if gattr.atype@.form = sett then begin
	  if gattr.akind = cst then
	    gattr.avalue.ival := any(gattr.avalue.sval@)
	  else
	    genbyte(127 {SANY});
	  gattr.atype := gattr.atype@.settyp
	  end
	else error(125);
      20:				{ all }
	;
      21: begin				{ odd }
	if comptypes(gattr.atype, intptr) then
	  if gattr.akind = cst then
	    gattr.avalue.ival := ord(odd(gattr.avalue.ival))
	  else
	    genbyte(42 {IODD})
	else error(125);
	gattr.atype := boolptr
	end;
      22: begin				{ ord }
	if (gattr.atype <> nil) and (gattr.atype@.form > integert) then
	  error(125);
	gattr.atype := intptr
	end;
      23: begin				{ chr }
	if not comptypes(gattr.atype, intptr) then error(125);
	gattr.atype := charptr
	end;
      24: begin				{ float }
	if not comptypes(gattr.atype, intptr) then error(125);
	if gattr.akind = cst then begin
	  i := gattr.avalue.ival;
	  new(gattr.avalue.rval);
	  gattr.avalue.rval@ := float(i);
	  gattr.avalue.kind := reel
	  end
	else
	  genbyte(74 {FLOAT});
	gattr.atype := realptr
	end;
      25: begin				{ trunc }
	if not comptypes(gattr.atype, realptr) then error(125);
	if gattr.akind = cst then begin
	  gattr.avalue.ival := trunc(gattr.avalue.rval@);
	  gattr.avalue.kind := lit
	  end
	else
	  genbyte(75 {TRUNC});
	gattr.atype := intptr
	end;
      26: begin				{ round }
	if not comptypes(gattr.atype, realptr) then error(125);
	gattr.atype := intptr
	end;
      27, 28: begin			{ max - min }
	lattr := gattr;
	if sym.sy = comma then insymbol else error(20);
	expression;
	if psinx = 27 then binop(maxop, lattr) else binop(minop, lattr)
	end;
      31:				{ abs }
	if gattr.atype <> nil then
	  if comptypes(gattr.atype, intptr) then
	    if gattr.akind = cst then
	      gattr.avalue.ival := abs(gattr.avalue.ival)
	    else
	      genbyte(41 {IABS})
	  else if comptypes(gattr.atype, realptr) then
	    if gattr.akind = cst then
	      gattr.avalue.rval@ := abs(gattr.avalue.rval@)
	    else
	      genbyte(73 {FABS})
	  else error(125)
      end; {case}
    if getarg in doarg[psinx] then begin
      if sym.sy = rparen then insymbol
      else error(4)
      end
    end {pkind = stnd}
  else
    calluser(fp)
  end {with}
end;

procedure expression;


procedure simpleexpression;


procedure term;


procedure factor;
var
  coffset: addrrange;
  cvalue: integer;


procedure structconst(fq: stp);
var
  nxtfld: itp;
  caddr, loffset: addrrange;
  nrelts, eltsiz: integer;
begin
if fq <> nil then begin
  case fq@.form of
    scalar, booleant, chart, integert, longintt, realt, longrealt, sett: begin
      expression;
      if not comptypes(gattr.atype, fq) then error(134)
      end;
    arrayt: begin
      if coffset > 0 then begin	{ flush out accumulated literal }
	if coffset = 1 then
	  gendbyte(cvalue)
	else { never use this else ? }
	  gendword(cvalue);
	coffset := 0; cvalue := 0
	end;
      nrelts := fq@.size;		{ nr elts in array }
      eltsiz := typsize(fq@.aeltyp);	{ size of array elt }
      if odd(dc) and (typalign(fq) > 1) then gendbyte(0);
      caddr := dc;
      if sym.sy = lparen then begin
	repeat
	  insymbol;
	  structconst(fq@.aeltyp);
	  if nrelts > 0 then begin
	    gendat(gattr);
	    if gattr.avalue.kind = lit then
	      if eltsiz = 1 then gendbyte(gattr.avalue.ival)
	      else gendword(gattr.avalue.ival);
	    nrelts := pred(nrelts)
	    end
	until sym.sy <> comma;
	if sym.sy = rparen then insymbol else error(4);
	gattr.atype := fq;
	gattr.akind := cst;
	gattr.avalue.kind := data;
	gattr.avalue.daddr := caddr
	end
      else if sym.sy = stringconst then begin
	expression;
	if (fq@.aeltyp <> nil) and (fq@.aeltyp@.form <> chart) then error(134)
	end
      else error(9)
      end;
    recordt: begin
      eltsiz := typsize(fq);
      if odd(dc) and (eltsiz >= auword) then gendbyte(0);
      caddr := dc;
      nxtfld := fq@.fstfld;
      if sym.sy = lparen then begin
	repeat
	  insymbol;
	  if nxtfld <> nil then begin
	    loffset := nxtfld@.fdisp mod auword; {proposed offset into literal}
	    if loffset < coffset then begin
	      gendword(cvalue);		{ flush literal }
	      cvalue := 0; coffset := 0
	      end;
	    structconst(nxtfld@.itype);
	    gendat(gattr);
	    if gattr.avalue.kind = lit then begin
	      cvalue := cvalue + (gattr.avalue.ival * shfttab[loffset]);
	      coffset := loffset + 1
	      end
	    else coffset := 0;
	    nxtfld := nxtfld@.next
	    end
	until sym.sy <> comma;
	if sym.sy = rparen then insymbol else error(4);
	gattr.atype := fq;
	gattr.akind := cst;
	if eltsiz > auword then begin
	  if coffset > 0 then gendword(cvalue); { flush accumulated literal }
	  gattr.avalue.kind := data;
	  gattr.avalue.daddr := caddr
	  end
	else begin	{ carry along as literal }
	  gattr.avalue.kind := lit;
	  gattr.avalue.ival := cvalue
	  end;
	coffset := 0; cvalue := 0
	end
      else error(9)
      end
    end
  end
end;

var
  p: itp;
  q, q1: stp;
  n: integer;
  s: @stndset;
  cstpart, varpart: boolean;
begin {factor}
case sym.sy of
  ident: begin
    p := searchid([types,konst,vars,field,proc]);
    insymbol;
    if p = udptrs[types] then { ident was not declared }
      if (sym.sy = lparen) or (sym.sy = semicolon) then
	p := udptrs[proc]	{ just for better error recovery }
      else
	p := udptrs[vars];
    case p@.class of
      types: begin
	{if sym.sy = lparen then insymbol else error(9);}
	coffset := 0; cvalue := 0;
	structconst(p@.itype);
	{if sym.sy = rparen then insymbol else error(4);}
	gattr.akind := cst;
	gattr.atype := p@.itype
	end;
      vars, field, konst:
	selector(p);
      proc:
	call(p)
      end
    end;
  intconst: begin
    gattr.akind := cst;
    gattr.atype := intptr;
    gattr.avalue.kind := lit;
    gattr.avalue.ival := val.ival;
    insymbol
    end;
  realconst: begin
    gattr.akind := cst;
    gattr.atype := realptr;
    gattr.avalue.kind := reel;
    gattr.avalue.rval := val.rval;
    insymbol
    end;
  stringconst: begin
    gattr.akind := cst;
    if lgth = 1 then begin {character constant}
      gattr.atype := charptr;
      gattr.avalue.kind := lit;
      gattr.avalue.ival := ord(string[0])
      end
    else begin {string constant}
      new(gattr.atype, arrayt);
      with gattr.atype@ do begin
	form := arrayt; size := lgth;
	aeltyp := charptr;  inxtyp := nil
	end;
      gattr.avalue.kind := data;
      gattr.avalue.daddr := dc;
      for n := 0 to lgth-1 do
	gendbyte(ord(string[n]))
      end;
    insymbol
    end;
  lparen: begin
    insymbol;
    expression;
    if sym.sy = rparen then insymbol else error(4)
    end;
  notsy: begin
    insymbol;
    factor;
    if gattr.atype = boolptr then
      genbyte(96 {NOT})
    else
      error(134)
    end;
  lbrack: begin
    insymbol;
    q := nil;  n := 0;
    varpart := false;  cstpart := false;
    new(s);  s@ := [];	{ place to store constant part }
    if sym.sy <> rbrack then begin
      loop
	expression;
	if gattr.atype <> nil then begin
	  if comptypes(gattr.atype, q) then begin
	    n := setsize(gattr.atype);
	    if n > 0 then begin
	      if gattr.akind = cst then { constant element }
		if (gattr.avalue.ival >= 0) and (gattr.avalue.ival <= 255)
		then begin
		  s@ := s@ + [gattr.avalue.ival];
		  cstpart := true
		  end
		else error(137)
	      else { variable element }
		if varpart then
		  genbyte(118 {SADEL})
		else begin
		  genbyte(117 {SGENS});
		  varpart := true
		  end;
	      q := gattr.atype
	      end
	    else error(136)
	    end
	  else error(137)
	end;
      exit if sym.sy <> comma;
	insymbol
      end
    end;
    if sym.sy = rbrack then insymbol else error(12);
    new(gattr.atype, sett);
    with gattr.atype@ do begin
      form := sett;  size := n;  settyp := q
      end;
    gattr.akind := cst;
    gattr.avalue.kind := setc;
    gattr.avalue.sval := s;
    if varpart then begin
      if cstpart then begin
	gencon(gattr);
	genbyte(113 {UNION})
	end;
      gattr.akind := exp
      end
    end
  end
end; {factor}

var
  lattr: attr;
  lop: operator;
begin {term}
factor;
while sym.sy = mulop do begin
  lattr := gattr;
  lop := sym.op;
  insymbol;
  factor;
  binop(lop, lattr)
  end
end; {term}


var
  lattr: attr;
  lop: operator;
  issigned: boolean;
begin {simpleexpression}
issigned := false;
if (sym.sy = addop) and ((sym.op = plus) or (sym.op = minus)) then
  begin issigned := sym.op = minus; insymbol end;
term;
if issigned and (gattr.atype <> nil) then
  case gattr.atype@.form of
    integert:
      if gattr.akind = cst then
	gattr.avalue.ival := - gattr.avalue.ival
      else
	genbyte(40 {INEG});
    longintt:
      if gattr.akind = cst then
	{ coming attraction }
      else
	genbyte(40 {INEG});
    realt:
      if gattr.akind = cst then
	{ coming attraction }
      else
	genbyte(72 {FNEG});
    longrealt:
      if gattr.akind = cst then
	{ coming attraction }
      else
	genbyte(72 {FNEG});
    scalar, booleant, chart, pointer, sett,
    arrayt, recordt, filet:
      error(134)
    end;
while sym.sy = addop do begin
  lattr := gattr;
  lop := sym.op;
  insymbol;
  term;
  binop(lop, lattr)
  end
end; {simpleexpression}

var
  lattr: attr;
  lop: operator;
begin {expression}
simpleexpression;
if sym.sy = relop then begin
  lattr := gattr;
  lop := sym.op;
  insymbol;
  simpleexpression;
  binop(lop, lattr);
  gattr.atype := boolptr
  end
end; {expression}

var
  fwptr, varlst: itp;

procedure typ(var fq: stp);	{ parse type definitions }

procedure subrange(var fq: stp);
var
  q, q1: stp;
  lmin: integer;
begin
expression;
if gattr.akind <> cst then error(106);
q1 := gattr.atype;
lmin := gattr.avalue.ival;
if sym.sy = colon then insymbol else error(5);
expression;
if gattr.akind <> cst then error(106);
if gattr.avalue.ival < lmin then error(102);
q := nil;
if (q1 <> nil) and (gattr.atype <> nil) then begin
  if comptypes(q1, gattr.atype) then begin
    case gattr.atype@.form of
      scalar: begin
        new(q, scalar, true);
        q@.maxconst := gattr.atype@.maxconst
        end;
      booleant: new(q, booleant, true);
      chart: new(q, chart, true);
      integert: new(q, integert, true);
      longintt: new(q, longintt, true)
    end;
    if q <> nil then with q@ do begin
      size := typsize(q1);  form := q1@.form;
      subrange := true;
      maxvalue := gattr.avalue.ival;
      minvalue := lmin
      end
    else error(148)
    end
  else error(107)
  end;
fq := q
end;

var fldoffset: integer;

procedure fieldlist(var fq: stp);

procedure fieldaddr(fp: itp);
begin
if fp <> nil then with fp@ do begin
  fldoffset := ceil(fldoffset , typalign(itype));
  fdisp := fldoffset;
  fldoffset := fldoffset + typsize(itype)
  end
end;

var
  p, p1, p2, p3: itp;
  q, q1, q2, q3, q4, q5: stp;
  maxsize, minsize: integer;
  lid: idtype;
begin
p3 := nil;
while sym.sy = ident do begin
  p2 := p3;
  loop
    if sym.sy = ident
    then begin newid(field,nil,p2,p2); insymbol end
    else error(2);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = colon then insymbol else error(5);
  typ(q);
  p := p2;
  while p2 <> p3 do begin
    p2@.itype := q;
    p2 := p2@.next
    end;
  p3 := p;
  if sym.sy = semicolon then insymbol
  end;
p2 := nil;
while p3 <> nil do begin	{ reverse links }
  p := p3@.next;
  p3@.next := p2;
  p2 := p3; p3 := p
  end;
p := p2;
while p <> nil do begin		{ assign offsets of fields }
  fieldaddr(p);
  p := p@.next
  end;
if sym.sy = casesy then begin
  insymbol;
  new(q, tagfield);
  with q@ do begin
    form := tagfield; fstvar := nil; tagfld := nil; tagtyp := nil;
    if sym.sy = ident then begin
      lid := id;
      insymbol;
      if sym.sy = colon then begin
	newid(field, nil, nil, p);
	tagfld := p;
	insymbol;
	if sym.sy = ident then begin
	  lid := id;
	  insymbol
	  end
	else error(2)
	end
      else p := nil;
      id := lid;
      p1 := searchid([types]);
      q5 := p1@.itype;
      if q5@.form > longintt then begin error(110); q5 := nil end;
      tagtyp := q5
      end
    else error(2);
    if p <> nil then begin
      p@.itype := q5;
      fieldaddr(p)
      end;
    size := fldoffset		{ min size of variants }
    end;
  if sym.sy = ofsy then insymbol else error(8);
  q1 := nil;
  minsize := fldoffset; maxsize := fldoffset;
  loop		{ parse variants }
    q2 := nil;
    loop
      expression;
      if not comptypes(gattr.atype, q5) then error(115);
      new(q3, variant);
      with q3@ do begin
	form := variant; nxtvar := q1; subvar := q2;
	varval := gattr.avalue.ival
	end;
      q1 := q3; q2 := q3;
    exit if sym.sy <> comma;
      insymbol
    end;
    if sym.sy = colon then insymbol else error(5);
    if sym.sy = lparen then insymbol else error(9);
    fieldlist(q2);
    if fldoffset > maxsize then maxsize := fldoffset;
    while q3 <> nil do begin
      q4 := q3@.subvar;
      q3@.subvar := q2;
      q3@.size := fldoffset;
      q3 := q4
      end;
    if sym.sy = rparen then insymbol else error(4);
  exit if sym.sy <> semicolon;
    insymbol;
    fldoffset := minsize
  end;
  fldoffset := maxsize;
  q@.fstvar := q1;
  fq := q
  end
else if (q <> nil) and (q@.form = arrayt)
  then fq := q
  else fq := nil
end;

var
  p: itp;
  q, q1, q2 : stp;
  oldtop, n, lmin, lmax: integer;
begin
if sym.sy = packedsy then insymbol;	{ 'packed' is ignored }
case sym.sy of
ident: begin
  p := searchid([types,konst,proc]);
  if p@.class = types then begin
    q := p@.itype;  insymbol
    end
  else subrange(q)
  end;
addop, intconst, realconst, stringconst:
  subrange(q);
lparen: begin
  oldtop := top;  top := level;
  new(q, scalar);
  with q@ do begin
    size := usize[scalar];  form := scalar;  subrange := false;
    p := nil;  n := 0;
    repeat
      insymbol;	{ gobble up leading '(' or ',' }
      if sym.sy = ident then begin
	newid(konst,q,p,p);
	with p@ do begin
	  value.kind := lit;  value.ival := n
	  end;
	n := succ(n);
	insymbol	{ gobble up ident }
	end
      else error(2)
    until sym.sy <> comma;
    maxconst := p
    end;
  top := oldtop;
  if sym.sy = rparen then insymbol else error(4)
  end;
atsign: begin
  insymbol;	{ gobble up '^' }
  new(q, pointer);
  with q@ do begin
    size := usize[pointer];  form := pointer;
    eltype := nil;
    if sym.sy = ident then begin
      prterr := false;	{ suppress error for forward declaration }
      p := searchid([types]);
      prterr := true;
      if p = nil then	{ referenced before declared }
        newid(types,q,fwptr,fwptr)
      else begin
	eltype := p@.itype;
	if (eltype <> nil) and (eltype@.form = filet) then error(108)
	end;
      insymbol	{ gobble up ident }
      end
    else error(2)
    end
  end;
arraysy: begin
  insymbol;	{ gobble up 'array' }
  if sym.sy = lbrack then insymbol else error(11);
  q1 := nil;
  loop
    new(q, arrayt);
    with q@ do
      begin form := arrayt; aeltyp := q1; inxtyp := nil end;
    q1 := q;
    typ(q2);
    if (q2 <> nil) and (q2@.form >= integert) and not q2@.subrange
    then begin
      if q2@.form = integert then error(149)
      else if q2@.form = realt then error(109)
      else error(113);
      q2 := nil
      end
    else q@.inxtyp := q2;
  exit if sym.sy <> comma;
    insymbol		{ gobble up ',' }
  end;	{loop}
  if sym.sy = rbrack then insymbol else error(12);
  if sym.sy = ofsy then insymbol else error(8);
  typ(q);	{ parse base type of array }
  repeat
    with q1@ do begin
      q2 := aeltyp; aeltyp := q;
      getbounds(inxtyp, lmin, lmax);
      size := lmax - lmin + 1
      end;
    q := q1; q1 := q2
  until q1 = nil
  end;
recordsy: begin
  insymbol;	{ gobble up 'record' }
  oldtop := top;
  if top < maxdis then begin
    top := succ(top);
    display[top].fname := nil
    end
  else error(250);
  fldoffset := 0;
  fieldlist(q1);
  new(q, recordt);
  with q@ do begin
    size := fldoffset;	{ maximum size of record }
    form := recordt;
    fstfld := display[top].fname;
    recvar := q1
    end;
  top := oldtop;
  if sym.sy = endsy then insymbol else error(13)
  end;
setsy: begin
  insymbol;	{ gobble up 'set' }
  if sym.sy = ofsy then insymbol else error(8);	{ gobble up 'of' }
  typ(q1);
  new(q, sett);
  with q@ do begin
    size := setsize(q1);  form := sett;  settyp := q1
    end
  end;
filesy: begin
  insymbol;	{ gobble up 'file' }
  if sym.sy = ofsy then insymbol else error(8); { gobble up 'of' }
  typ(q1);
  if q1 <> nil then
    if q1@.form > recordt then begin
      error(108);  q1 := nil
      end;
  new(q, filet);
  with q@ do begin
    size := 0; {??} form := filet;  filtyp := q1
    end
  end;
notsy, mulop, relop, rparen, lbrack, rbrack, comma, semicolon,
period, colon, becomes, constsy, typesy, varsy, programsy,
proceduresy, functionsy,  forwardsy, beginsy, ifsy, casesy,
repeatsy, whilesy, forsy, withsy, loopsy, gotosy, exitsy,
endsy, elsesy, untilsy, ofsy, dosy, tosy, downtosy, thensy,
externalsy, othersy: {... in other words - default } begin
  error(10);
  q := nil
  end
end;
fq := q
end;

procedure constdecl;
var
  p: itp;
begin
while sym.sy = ident do begin
  newid(konst,nil,nil,p);
  insymbol;
  if (sym.sy = relop) and (sym.op = eqop) then insymbol else error(16);
  expression;
  if (gattr.akind <> cst) then error(106);
  with p@ do begin
    itype := gattr.atype;  value := gattr.avalue
    end;
  if sym.sy = semicolon then insymbol else error(14)
  end
end;


procedure typedecl;
var
  p1, p2, p3: itp;
  q1, q2: stp;
begin
while sym.sy = ident do begin
  p1 := fwptr;  p3 := nil;  { p3 will point to a forward pointer id (if any) }
  while p1 <> nil do begin  { search current forward list }
    if match(p1@.name@.s, ord(p1@.name@.l), id.s, ord(id.l)) = 0 then begin
      p3 := p1;		{ got one, save it in p3 }
      if p1 = fwptr then fwptr := fwptr@.next else p2@.next := p1@.next
      end;
    p2 := p1;  p1 := p1@.next
    end;
  if p3 = nil then begin	{ if not a forward pointer, then enter it }
    newid(types,nil,nil,p3);
    q1 := nil
    end
  else q1 := p3@.itype;		{ q1 is the type of the forward pointer }
  insymbol;	{ gobble up the ident }
  if (sym.sy = relop) and (sym.op = eqop) then insymbol else error(16);
  typ(q2);	{ parse type field and return pointer to struct in q2 }
  p3@.itype := q2;
  if q1 <> nil then q1@.eltype := q2;	{ resolve forward pointer }
  if sym.sy = semicolon then insymbol else error(14)
  end
end;

procedure vardecl;

procedure varaddr(fp: itp);
begin
with fp@ do begin
  if level = 1 then begin
    lc := ceil(lc, typalign(itype));	{round-up}
    vaddr := lc;
    lc := lc + typsize(itype)
    end
  else begin
    lc := lc - typsize(itype);
    lc := -ceil(-lc, typalign(itype));	{round-down}
    vaddr := lc
    end
  end
end;

var
  p1, p2, p3, p4: itp;
  q: stp;
begin
p3 := nil;
while sym.sy = ident do begin
  loop
    if sym.sy = ident then begin
      newid(vars,nil,p3,p3);
      with p3@ do begin
	vkind := local;  vlev := level
	end;
      insymbol		{ gobble up the ident }
      end
    else error(2);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = colon then insymbol else error(5);
  typ(q);		{ parse type }
  if p3 <> nil then begin
    p4 := p3;  p2 := nil;	{ after reversing, p4 is tail, p2 is head }
    repeat	{ assign type and reverse list }
      p3@.itype := q;
      p1 := p3@.next;
      p3@.next := p2;
      p2 := p3;  p3 := p1
    until p3 = nil;
    p3 := p2;
    repeat	{ assign addresses }
      varaddr(p3);
      p3 := p3@.next
    until p3 = nil;
    p4@.next := varlst;  varlst := p2;	{ add to list of all variables }
    end;
  if sym.sy = semicolon then insymbol else error(14)
  end
end;

procedure procdecl(isfunction: boolean);

procedure parmlist(var fp: itp);
var
  p1, p2, p3, p4: itp;
  q: stp;
  lvkind: varkinds;
begin
p1 := nil;
if sym.sy = lparen then begin
  insymbol;	{ gobble up '(' }
  loop
    if sym.sy = varsy then begin
      insymbol; lvkind := formal
      end
    else lvkind := param;
    p2 := nil;
    loop
      if sym.sy = ident then begin
	newid(vars,nil,p2,p4);
	with p4@ do begin
	  vkind := lvkind;  vlev := level
	  end;
	p2 := p4;
	insymbol
	end
      else error(2);
    exit if sym.sy <> comma;
      insymbol
    end;
    if sym.sy = colon then begin
      insymbol;
      typ(q);	{ parse type }
      p3 := p2;
      while p2 <> nil do begin	{ assign type }
        p2@.itype := q;
        p4 := p2;  p2 := p2@.next
        end;
      p4@.next := p1;  p1 := p3
      end
    else error(5);
  exit if sym.sy <> semicolon;
    insymbol
  end;
  if sym.sy = rparen then insymbol else error(4)
  end;
fp := p1
end;

procedure parmaddr(fp: itp);
begin
if odd(ac) then ac := succ(ac);
with fp@ do begin
  vaddr := ac;
  if vkind = formal then
    ac := ac + usize[pointer]
  else
    ac := ac + typsize(itype)
  end
end;

var
  p1, p2, p3, p4: itp;
  oldfwptr, oldvarlst: itp;
  oldac, olddc, oldlc, oldpin: integer;
  oldlevel, oldtop: disprange;
  wasforward: boolean;
begin
{ preserve state of current procedure }
oldfwptr := fwptr;  oldvarlst := varlst;
oldlc := lc;  lc := 0;
oldac := ac;  ac := 0;
{ olddc := dc;  dc := 0; ***anticipating version 3 int code*** }
oldpin := pin;
p4 := nil;  p2 := nil;  p3 := nil;
wasforward := false;		{ assume its not until shown otherwise }
if sym.sy = ident then begin
  p4 := searchlevel(display[top].fname);
  if p4 <> nil then begin	{ check to see if previous declared forward }
    if (p4@.class = proc) and (p4@.pkind = forw) then wasforward := true
    else error(160)		{ ident has already been used }
    end;
  if not wasforward then begin	{ enter ident }
    newid(proc,nil,nil,p4);
    maxpin := succ(maxpin);  pin := maxpin;
    with p4@ do begin
      plev := level;  paddr := pin
      end
    end
  else begin	{ must restore parameter list to p2 }
    p1 := p4@.next;
    if (p4@.itype <> nil) then
      p2 := p1@.next	{ skip over dummy variable for returned value }
    else
      p2 := p1
    end;
  insymbol		{ gobble up the ident }
  end
else error(2);
oldlevel := level;
if level < maxlevel then level := succ(level) else error(251);
oldtop := top;
if top < maxdis then begin
  top := succ(top);
  with display[top] do begin
    occur := blck;  fname := p2
    end
  end
else error(250);
if wasforward then begin	{ param list and func type already avaiable }
  p3 := p4@.next;  p1 := nil;
  while p3 <> nil do begin	{ reverse links }
    p2 := p3@.next;
    p3@.next := p1;
    p1 := p3;  p3 := p2
    end
  end
else parmlist(p1);		{ must parse paramter list and function type }
p3 := nil;
while p1 <> nil do begin	{ reverse order and assign addresses }
  p2 := p1@.next;  p1@.next := p3;
  parmaddr(p1);
  p3 := p1;  p1 := p2
  end;
if not wasforward then begin
  p4@.next := p3;		{ in a proc, next points to parameter list }
  p4@.itype := nil;		{ assume its not a function }
  if isfunction then begin	{ parse function type }
    if sym.sy = colon then begin
      insymbol;		{ gobble up the colon }
      typ(p4@.itype)	{ parse the function type }
      end
    else error(5);
    if p4@.itype <> nil then begin
      if p4@.itype@.form > pointer then begin
	error(120);
	p4@.itype := nil
	end;
      id := idtype(chr(3),'.rv');  { enter dummy ident for returned value }
      newid(vars, p4@.itype, p3, p2);
      with p2@ do begin
	vkind := param;  vlev := level
	end;
      p4@.next := p2;
      parmaddr(p2)
      end
    else error(123)
    end
  end;
if sym.sy = semicolon then insymbol else error(14);
if sym.sy = forwardsy then begin
  if wasforward then error(161) else p4@.pkind := forw;
  insymbol	{ gobble up 'forward' }
  end
else if sym.sy = externalsy then begin
  p4@.pkind := extn;
  insymbol	{ gobble up 'external' }
  end
else begin	{ parse procedure definition }
  p4@.pkind := decl;
  block(p4)
  end;
if sym.sy = semicolon then insymbol else error(14);
level := oldlevel;  top := oldtop;
lc := oldlc;  ac := oldac;  {dc := olddc;}
pin := oldpin;
fwptr := oldfwptr;  varlst := oldvarlst
end;

procedure body;


procedure statelist(stopper: symbol);


procedure statement;


procedure assignment(fp: itp);
var
  q: stp;
begin
if (fp@.class = proc) and (fp@.itype <> nil) then
  fp := fp@.next;	{ dummy variable for returned value }
selector(fp);
q := gattr.atype;
if sym.sy = becomes then begin
  insymbol;
  valueexpression;
  if q <> nil then with q@ do begin
    if not comptypes(gattr.atype, q) then
      error(129)
    else
      if form = sett then setcoerce(q);		{ to make empty sets behave }
    if form = arrayt then begin
      genbyte(135 {MOVEM});
      if typsize(aeltyp) < 2 then genbyte(1) else genbyte(2);
      genword(size)
      end
    else if form = recordt then begin
      if size <= 2 then
	genbyte(10 {STOL})
      else begin
  	genbyte(135 {MOVEM});
  	if odd(size)
  	then begin genbyte(1); genword(size) end
  	else begin genbyte(2); genword(size div 2) end
  	end
      end
    else if (form = realt) or (form = longrealt) then
      genbyte(12 {STOF})
    else
      genbyte(10 {STOL})
    end
  end
else error(51)
end;

procedure ifstatement;
begin
valueexpression;
if not comptypes(gattr.atype, boolptr) then error(135);
if sym.sy = thensy then insymbol else error(52);
statement;
if sym.sy = elsesy
then begin insymbol; statement end
else genbyte(8 {NULL});
genbyte(144 {IF})
end;


procedure casestatement;
var
  q: stp;
  lmin, lmax, nrent, nrval: integer;
begin
valueexpression;
q := gattr.atype;
getbounds(q, lmin, lmax);
if sym.sy = ofsy then insymbol else error(8);
nrent := 1;
loop
  nrval := 0;
  loop
    expression;
    if gattr.akind = cst
    then begin
      if q <> nil
      then begin
	if not comptypes(gattr.atype, q) then error(147);
	genlit(gattr.avalue.ival - lmin);
	lmax := max(lmax, gattr.avalue.ival);
	nrval := succ(nrval)
	end
      end
    else error(106);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = colon then insymbol else error(5);
  statement;
  genbyte(146 {ENTRY});
  genbyte(nrval);
  nrent := succ(nrent);
exit if sym.sy <> semicolon;
  insymbol
end;
if sym.sy = endsy then insymbol else error(13);
lmax := lmax - lmin;
if lmax > 255 then error(173);
genbyte(145 {CASE});
genbyte(nrent);
genbyte(lmax)
end;

procedure repeatstatement;
begin
statelist(untilsy);
if sym.sy = untilsy
then begin
  insymbol;
  valueexpression;
  if not comptypes(gattr.atype, boolptr) then error(135);
  genbyte(8 {NULL});	{ no exit stub }
  genbyte(148 {EXIT})
  end
else error(53);
genbyte(8 {NULL});	{ no code after exit }
genbyte(147 {LOOP});
genbyte(2)		{ arg count - 2 }
end;


procedure whilestatement;
begin
genbyte(8 {NULL});	{ no code before exit }
valueexpression;
if not comptypes(gattr.atype, boolptr) then error(135);
if sym.sy = dosy then insymbol else error(54);
genbyte(96 {NOT});
genbyte(8 {NULL});	{ no exit stub }
genbyte(148 {EXIT});
statement;
genbyte(147 {LOOP});
genbyte(2)		{ arg count - 2 }
end;


procedure loopstatement;
var
  nrexits: integer;
begin
nrexits := 0;
loop
  statelist(exitsy);
exit if (sym.sy = endsy) or (sym.sy = eofsy);
  if sym.sy = exitsy then begin
    insymbol;
    if sym.sy = ifsy then insymbol else error(56);
    valueexpression;
    if not comptypes(gattr.atype, boolptr) then error(135);
    if sym.sy = thensy then begin
      insymbol;
      statement
      end
    else
      genbyte(8 {NULL});	{ no exit stub }
    genbyte(148 {EXIT});
    nrexits := succ(nrexits);
    if sym.sy = semicolon then insymbol else error(14)
    end
  else error(57)
end;
if sym.sy = endsy then insymbol else error(13);
genbyte(147 {LOOP});
genbyte(nrexits*2)	{ builds bad tree if exit missing! }
end;

procedure forstatement;
var
  p: itp;
  lsy: symbol;
begin
if sym.sy = ident
then begin
  p := searchid([vars]);
  selector(p);
  insymbol
  end
else error(2);
if sym.sy = becomes
then begin insymbol; valueexpression end
else error(51);
if (sym.sy = tosy) or (sym.sy = downtosy)
then begin
  lsy := sym.sy;
  insymbol;
  valueexpression;
  if lsy = tosy then genlit(1) else genlit(-1)
  end
else error(55);
if sym.sy = dosy then insymbol else error(54);
statement;
genbyte(149 {FOR})
end;

procedure withstatement;
var
  p: itp;
  nrwiths: integer;
begin
nrwiths := 0;
loop
  if sym.sy = ident
  then begin
    p := searchid([vars,field,konst]);
    insymbol
    end
  else begin
    error(2);
    p := udptrs[vars]
    end;
  selector(p);
  if gattr.atype <> nil
  then if gattr.atype@.form = recordt
    then begin
      if top < maxdis
      then begin
	top := succ(top); nrwiths := succ(nrwiths);
	with display[top] do begin
	  fname := gattr.atype@.fstfld;
	  if gattr.access = direct
	  then begin
	    occur := crec;
	    dlev := gattr.alevel;
	    daddr := gattr.addr;
	    genbyte(2 {DEL})	{ don't need the reference we already gen'ed }
	    end
	  else begin
	    occur := vrec;
	    tc := succ(tc);	{ need new temp to store 'with' pointer }
	    tnum := tc;
	    genbyte(9 {REFER})
	    end
	  end { of with }
	end
      else error(250)
      end
    else error(140);
exit if sym.sy <> comma;
  insymbol
end;
if sym.sy = dosy then insymbol else error(54);
statement;
for nrwiths := nrwiths downto 1 do begin
  if display[top].occur = vrec
  then begin
    genbyte(141 {DTEMP}); genbyte(tc);
    tc := pred(tc)
    end;
  top := pred(top)
  end
end;

var
  p: itp;
begin {statement}
{ check for labels and put out error message: }
if sym.sy = intconst then begin
  error(398);
  insymbol;
  if sym.sy = colon then insymbol else error(5)
  end;
case sym.sy of
  ident: begin
    p := searchid([vars,field,proc]);
    insymbol;
    if (p@.class = proc) and (p@.itype = nil)
    then call(p)	{ procedure call }
    else assignment(p)
    end;
  beginsy:
    begin insymbol; body end;
  ifsy:
    begin insymbol; ifstatement end;
  casesy:
    begin insymbol; casestatement end;
  whilesy:
    begin insymbol; whilestatement end;
  repeatsy:
    begin insymbol; repeatstatement end;
  loopsy:
    begin insymbol; loopstatement end;
  forsy:
    begin insymbol; forstatement end;
  withsy:
    begin insymbol; withstatement end;
  semicolon, endsy, elsesy, exitsy, untilsy:
    genbyte(8 {NULL});
  intconst, realconst, stringconst, notsy, mulop, addop, relop,
  lparen, rparen, lbrack, rbrack, comma,
  period, atsign, colon, becomes, constsy, typesy, varsy,
  programsy, proceduresy, functionsy, setsy, packedsy, arraysy,
  recordsy, filesy, forwardsy,
  ofsy, dosy, tosy, downtosy, thensy, externalsy, othersy:
    begin error(6); insymbol end
  end
end; {statement}

var
  scnt: integer;
begin {statelist}
scnt := 0;
statement;
while (sym.sy <> stopper) and (sym.sy <> endsy) and (sym.sy <> eofsy) do
  if sym.sy = semicolon
  then begin
    insymbol;	{ gobble up ';' }
    if scnt >= 255 then begin	{ already 256 statements, do a SEQ }
      genbyte(152 {SEQ});
      genbyte(255);
      scnt := 0
      end;
    statement;
    scnt := succ(scnt)
    end
  else begin
    error(14);
    skip(stopper)
    end;
genbyte(152 {SEQ});
genbyte(scnt)
end; {statelist}

begin {body}
statelist(endsy);
if sym.sy = endsy
then insymbol	{ gobble up 'end' }
else error(13)
end;

procedure checkfiles(isclose: boolean; var filecount: integer);
var
  p: itp;
  n: integer;
begin
n := 0;
p := varlst;
while p <> nil do with p@ do begin
  if itype <> nil then with itype@ do begin
    if form = filet then begin
      n := succ(n);
      genbyte(176 + vlev {VARBL});
      genbyte(typsize(itype));
      genword(vaddr);
      genbyte(9 {REFER});
      if isclose then begin
	genbyte(138 {INVOK});
	genbyte(1);
	genbyte(20) {close}
	end
      else begin
	genlit(typsize(itype@.filtyp));
	genbyte(138 {INVOK});
	genbyte(2);
	genbyte(16) {finit}
	end
      end
    end;
  p := p@.next
  end;
filecount := n
end;

var
  p: itp;
  q1, q2, q3: stp;
  rvsize, filecount: integer;
begin {block}
mark;
lc := 0; tc := 0;
genbyte(6 {proc});
if level = 1 then begin		{ declare implicit globals }
  lc := 2;
  id := idtype(chr(6),'output');
  newid(vars,textptr,nil,p);
  with p@ do begin
    vkind := local;  vlev := 1;  vaddr := lc
    end;
  lc := lc + filsiz;
  id := idtype(chr(5),'input');
  newid(vars,textptr,nil,p);
  with p@ do begin
    vkind := local;  vlev := 1;  vaddr := lc
    end;
  lc := lc + filsiz;
  { definition of argc and argv for UNIX: }
  new(q1, integert);
  with q1@ do begin
    size := 2;  form := integert;
    subrange := true;  minvalue := 0;  maxvalue := 255
    end;
  new(q2, arrayt);
  with q2@ do begin
    size := 256;  form := arrayt;
    aeltyp := charptr;  inxtyp := q1
    end;
  new(q3, pointer);
  with q3@ do begin
    size := 2;  form := pointer;
    eltype := q2
    end;
  new(q2, arrayt);
  with q2@ do begin
    size := 256;  form := arrayt;
    aeltyp := q3;  inxtyp := q1
    end;
  id := idtype(chr(4),'argv');
  newid(vars,q2,nil,p);
  with p@ do begin
    vkind := formal;  vlev := 1;  vaddr := 0
    end;
  id := idtype(chr(4),'argc');
  newid(vars,intptr,nil,p);
  with p@ do begin
    vkind := param;  vlev := 1;  vaddr := 2
    end;
  ac := 4
  { end of UNIX stuff }
  end;
fwptr := nil;  varlst := nil;
while (sym.sy <> beginsy) and (sym.sy <> eofsy) do
  if sym.sy = constsy then begin
    insymbol;  constdecl
    end
  else if sym.sy = typesy then begin
    insymbol;  typedecl
    end
  else if sym.sy = varsy then begin
    insymbol;  vardecl
    end
  else if sym.sy = proceduresy then begin
    insymbol;  procdecl(false)
    end
  else if sym.sy = functionsy then begin
    insymbol;  procdecl(true)
    end
  else begin
    error(18);  skip(semicolon);  insymbol
    end;
insymbol;	{ gobble the 'begin' }
genbyte(5 {ident});  genid(fp@.name);
checkfiles(false, filecount);
body;		{ parse the body of this block }
checkfiles(true, filecount);
if filecount > 0 then begin
  genbyte(152 {seq});  genbyte(filecount*2)
  end;
if odd(dc) then gendbyte(0);	{ round dc to word boundary }
genbyte(7 {end});  genbyte(fp@.paddr);
rvsize := typsize(fp@.itype);
genbyte(rvsize);
genword(lc);  genword(ac - rvsize);  genword(dc);
if option['T'] then printtables(false);
release
end; 

var
  lcp: itp;		{points to main procedure ident structure}
  c: char;

begin {main program of compiler}
reset(src,argv[2]@);
rewrite(int,argv[3]@);
rewrite(dat,argv[4]@);
rewrite(lst,argv[5]@, 2 {fd.cr attribute});
for c := 'A' to 'Z' do option[c] := false;
option['L'] := true;	{ get the listing for now }
prterr := true;
errtot := 0; errinx := 0; linenr := 1; maxpin := 0; dc := 0;
chcnt := 0; ch := NL;
level := 0; top := 0;
inittables;
lcp := nil;
insymbol;
if sym.sy = programsy then begin
  insymbol;
  if sym.sy = ident then begin
    newid(proc,nil,nil,lcp);
    insymbol
    end
  else error(2);
  if sym.sy = semicolon then insymbol else error(14)
  end;
if lcp = nil then begin
  id := idtype(chr(6),'.main.');
  newid(proc,nil,nil,lcp)
  end;
with lcp@ do begin
  pkind := decl;
  plev := 0;
  paddr := 0
  end;
level := 1; top := 1;
with display[1] do begin
  fname := nil;
  occur := blck
  end;
block(lcp);
if sym.sy <> period then error(21);
if ch <> NL then write(lst,NL);
endofline;
if errtot > 0 then write(output, NL, 'Pass1 errors: ', errtot, NL)
end {pascal}.