{$W- }
program P1FP (output, src, lst, int, dat);
{N B S      P a s c a l      C o m p i l e r  --   P a s s   1}
 
{
 *Authors: Brian G. Lucas
 *         Justin C. Walker
 *Address comments to:
 *         Justin C. Walker
 *         Interactive Systems Corp
 *         1050 17th Street, N.W.
 *         Suite 580
 *         Washington, D.C.   20036
 * This software has been developed at the National Bureau of Standards.
 * As a product of the U.S. Government, it is in the public domain, and
 * should not be sold or otherwise used for profit.
}
{DEC OS versions maintained by DECUS Pascal SIG:
 Bill Heidebrecht - TRW DSSG
 John R. Barr     - University of Montana
 Brian Nelson     - University of Toledo }
 
{ RT11 version put together by:
	Paul Lustgraaf - Iowa State University
from v1.6e for RT-11 by John Barr
 and v1.6g for RSX }
 
				{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}
  pagesize = 58; { length of printer page }
  compiler_version = ' Pascal-NBS  V1.6g  7 Mar 83';
 
		{Operating system version:}
		{*************************}
const
	RSX11 = false;
	RSTS  = false;
	RT11  = true;
	UNIX  = false;
 
 
				{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,nilsy,forsy,withsy,loopsy,gotosy,exitsy,endsy,
	    elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy,externalsy,
            labelsy,eofsy,othersy,ceesy,fortransy);
 
  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}
  pageno: integer;		{page count}
  linesleft: integer;		{lines left on page}
  datestring: array[1..9] of char;	{current date}
  timestring: array[1..8] of char;	{current time}
  
  
                               {option switches:}
                               {****************}
  option: array ['A'..'Z'] of boolean;
    runtimcheks:  integer;	{integer value of option 'R'}
    Ok_to_proceed: boolean;
 
                               {files}
                               {*****}
var
  src,                         {source}
  lst,                         {listing}
  int,                         {intermediate code}
  dat: text;                   {intermediate data}
 
                               {error messages:}
                               {***************}
const
  not_yet_impl = 398;          {error msg number}
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..999
    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;
      fwid: @idtype);
    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, largeparam, formal);
 
				{kinds of procedures:}
				{********************}
  pkinds = (decl, stnd, forw, extn, cee, fort);
 
				{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
    types: ( );
    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,forw: (
	plev: lltype;
	paddr: addrrange);
      stnd: (
	psinx: integer);
      extn,cee,fort: (
	pxinx: integer))
  end;
 
				{dummy identifiers for undeclareds:}
				{**********************************}
var
  udptrs: array[classes] of itp;
 
				{pointers to names of input and output defaults}
				{**********************************************}
  inptr, outptr: 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}
 
 
 
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 }
  lcp: itp;		{ points to main program ident structure }
 
 
 
 
{*******************************************************}
{ Additional declarations for RSTS: ********************}
 
type
	datetime = packed array [1..9] of char;
 
{ External procedure declarations for RSTS: ************}
 
procedure paserr (ern: integer; var txt: array [1..64] of char;
		  var reterr: integer); external;
 
procedure dattim (var sysdate, systime: datetime); external;
 
function  jobnum: integer; external;
 
procedure defext (var ext: array [1..3] of char); external;
 
 
{*******************************************************}
 
procedure date(var dstrg:array[1..9] of char); fortran;
procedure time(var tstrg:array[1..8] of char); fortran;
procedure p2go; external;	{chain to pass 2}
 
procedure genbyte (fi: integer);
begin
  int@ := chr(fi);  put(int)
end {genbyte};
 
 
procedure genword(fi: integer);
begin
  int@ := chr(fi div 256);  put(int);
  int@ := chr(fi);  put(int)
end {genword};
 
 
function match(var s1: array[1..alfaleng] of char; l1: integer;
	       var s2: array[1..alfaleng] of char; l2: integer): integer;
var
  i, n: integer;
begin {match}
  n := min(l1, l2);
  i := 1;
  while (i <= n) and (s1[i] = s2[i]) do i := succ(i);
  if i > n then
    match := l1 - l2
  else
    match := ord(s1[i]) - ord(s2[i])
end {match};
 
 
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;
  genbyte(3 {OPTION});
  genbyte(2 {abort p2}); genword(0 {value unused})
end {error};
 
procedure warning (n: integer);
begin {warning}
  if option['W'] then error(n)
end {warning};
 
procedure newpage;
begin
  if option['L'] then begin
    pageno := pageno + 1;
    writeln(lst,FF,compiler_version,HT,datestring,'  ',timestring,HT,
    'Page ',pageno:5);
    writeln(lst);
    linesleft := pagesize;
  end;
end; {newpage}

procedure beginline;
begin
  if option['L'] then write(lst,linenr:8,level:6,'  ');
end; {beginline}

 
procedure endofline;
var k: integer;
begin {endofline}
if option['L'] then begin
  writeln(lst);
  linesleft := linesleft - 1;
  if linesleft <= 0 then newpage;
  if errinx > 0 then begin
    for k := 1 to errinx do
      with errlist[k] do begin
	writeln(lst, '*+*+*', nmr:4, HT, ' ':pos, '^');
	linesleft := linesleft - 1;
	if linesleft <= 0 then newpage;
      end;
    errtot := errtot + errinx;
    errinx := 0;
    end;
  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 = 41;
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),'nil            '),(nilsy,noop)),
    ((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(4),'cext           '),(ceesy,noop)),
    ((chr(7),'fortran        '),(fortransy,noop)),
    ((chr(7),'program        '),(programsy,noop)),
    ((chr(4),'goto           '),(gotosy,noop)),
    ((chr(5),'label          '),(labelsy,noop))
  );
const
  digmax = 9;
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;
 
 
procedure nextch;
begin {nextch}
  if eof(src) then ch := chr(0)
  else if eoln(src) then begin
    endofline;
    linenr := succ(linenr);
    beginline;
    chcnt := 0;
    readln(src);
    ch := NL;
  end
  else begin
    read(src,ch);
    if ch >= ' ' then begin
      chcnt := succ(chcnt);
      if option['L'] then write(lst,ch);
    end
    else if ch = HT then begin
      repeat chcnt := succ(chcnt)
      until chcnt mod 8 = 0;
      if option['L'] then write(lst,ch);
    end
    else if ch=FF then newpage
    else ch := chr(0);
  end;
end {nextch};
 
 
procedure options;
var
  lch: char;
  boolopt: boolean;
  intopt: integer;
 
function intoption: integer;
{ accept decimal integer in option string. }
var
  issigned: boolean;
  value:    integer;
begin {intoption}
  value := 0;
  issigned := false;
  if (ch = '+') or (ch = '-') then
  begin
    issigned := ch = '-';
    nextch
  end;
  while (ch >= '0') and (ch <= '9') do
  begin
    value := 10 * value + ord(ch) - ord('0');
    nextch
  end;
  if issigned then value := - value;
  intoption := value
end {intoption};
 
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;
      if lch = 'R' then
      begin
	intopt := intoption;
	runtimcheks := intopt;
      end
      else begin
	boolopt := (ch = '+');
	option[lch] := boolopt;
	intopt := ord(boolopt);
	nextch
      end;
      genbyte(3 {OPTION});  genbyte(ord(lch));
      genword(intopt)
    end
  until ch <> ','
end {options};
 
 
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;
	    if chartab[ch] <> dig then error(201)
	    else
	    while chartab[ch] = dig do begin
	      i := i + 1;
	      if i <= digmax then digits[i] := ord(ch) - ord('0');
	      scale := scale - 1;
	      nextch
	      end {while}
	    end
	  end;
	if (ch = 'e') or (ch = 'E') then begin
	  sym.sy := realconst;
	  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 := 0.0;
	for k := 1 to i do
	  r := r * 10.0 + float(digits[k]);
	sf  := 1.0;
	fac := 10.0;
	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
	  {Map to lower case in keywords and identifiers}
	  if (ch <= 'Z') and (ch >= 'A') 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 not maxstr 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;
      useful := true
      end
  end {case};
  if getnuchar then nextch;
{ writeln(output,'sym.sy=',ord(sym.sy)); break(output)	{***DEBUG***}
until useful
end {insymbol};
 
 
procedure skip(tosymbol: symbol);
begin {skip}
  while (sym.sy <> tosymbol) and (sym.sy <> eofsy) do insymbol
end {skip};
 
 
function searchlevel(fp: itp): itp;
var
  p: itp;
  i: integer;
  found: boolean;
begin {searchlevel}
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 {searchlevel};
 
 
function searchid(fs: set of classes): itp;
var
  p: itp;
begin {searchid}
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 {searchid};
 
 
procedure newid(fc: classes; fq: stp; fn: itp; var fp: itp);
var
  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; {initialize symbol tables with standard
                      and predeclared identifiers and types}
const
  nrbuiltin = 40; {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(4),'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         '),
    (chr(4),'page           '));
 
 
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);
  with p@.value do begin
    kind := lit;  ival := 0
  end;
  id := idtype(chr(4),'true           ');
  newid(konst,boolptr,p,p);
  with p@.value do begin
    kind := lit;  ival := 1
  end;
  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 (need nilptr for type)***}
  new(nilptr,pointer);
  with nilptr@ do begin form := pointer; size := 2; eltype := nil end;
{***maxint***}
  id := idtype(chr(6),'maxint         ');
  newid(konst,intptr,nil,p);
  with p@.value do begin
    kind := lit;  ival := 32767
  end;
{***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]);
  with udptrs[konst]@.value do begin
    kind := lit;  ival := 0
  end;
  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;
 
procedure markctp (fp: itp); forward;
 
procedure markstp (fp: stp);
  begin {markstp}
    if  fp <> nil then with fp@ do
    begin
      marked := true;
      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 { (fp: itp) };
begin {markctp}
  if  fp <> nil then with fp@ do
  begin
{   writeln(output,"c:",fp:8,llink:8,rlink:8,itype:8); 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 {followstp}
  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);
	  writeln(lst, '] of'); write(lst, '		');
          followstp(aeltyp)
          end;
        recordt:begin
	  writeln(lst,' of');
          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 {fp <> nil}
end {followstp};
 
  procedure followctp { (fp: itp) };
  var ch:char; i:integer;
  begin {followctp}
    if  fp <> nil then with fp@ do
    begin
      followctp(llink);
      write(lst, '  ');
      if name@.l <> chr(0) then
	write(lst, name@.s:ord(name@.l));
      write(lst, ' ':16-ord(name@.l), fp:8, llink:8, rlink:8, 
	itype:8, next:8, ' ':2);
      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);
	    largeparam,
	    param:  write(lst, 'parm by val':13);
	    local:  write(lst, 'variable':13)
	  end;
          write(lst, vlev:4, vaddr:6);
	  if itype <> nil
	    then write(lst, itype@.size:6, ':')
	    else write(lst, ' ':7);
          end;
        field:write(lst,'field':13,fdisp:10);
        proc:begin
          write(lst,'procedure');
          if pkind = extn      then write(lst, ' Ext')
	  else if pkind = cee  then write(lst, ' Cxt')
	  else if pkind = fort then write(lst, ' Ftn')
          else write(lst, '    ')
          end
      end; {case}
      followstp(itype);
      writeln(lst);
      followctp(rlink)
    end {with}
  end {followctp};
 
begin {printtables}
  writeln(lst);  writeln(lst, ' ');
  if fb then lim:=0 else begin lim:=top; write(lst,'Local ') end;
  writeln(lst,'Tables');
  for i:=top downto lim do markctp(display[i].fname);
  for i:=top downto lim do followctp(display[i].fname);
  writeln(lst);
  if ch <> NL then write(lst,' ':chcnt+8)
end {printtables};
 
 
 
procedure getbounds(fq: stp; var fmin, fmax: integer);
begin {getbounds}
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 {getbounds};
 
 
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 {genid};
 
 
procedure block (fp: itp);
 
type
  blockparts = (headpart, labelpart, constpart, typepart,
		varblpart, procpart);
 
{************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 div bitsau] of integer;
const
  shfttab = litshfttab(	{ use to "shift" au's into a literal }
    1, 256);
var
  fwptr: stp;
  varlst: itp;
  rvsize, filecount: integer;
  declstate: blockparts;
  lgparmallocated: boolean;
 
 
 
function floor(fa, fb: integer): integer;	{***THIS SHOULD BE BUILT-IN}
begin {floor}
  floor := fa div fb * fb
end {floor};
 
 
function ceil(fa, fb: integer): integer;	{***ALSO SHOULD BE BUILT-IN?}
begin {ceil}
  ceil := (fa + (fb - 1)) div fb * fb
end {ceil};
 
 
 
function typsize(fq: stp): integer; forward;
 
 
function typalign(fq: stp): integer;
begin {typalign}
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 {typalign};
 
 
 
function setsize(fq: stp): integer;
begin {setsize}
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 {setsize};
 
 
function typsize { (fq: stp): integer };
begin {typsize}
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)) div bitsau
    else typsize := ((size + (bitswd-1)) div bitswd)*auword;
  arrayt:
    typsize := ceil(typsize(aeltyp), typalign(aeltyp)) * size;	{ round-up }
  recordt, tagfield, variant:
    typsize := size
  end
else typsize := 0
end {typsize};
 
 
 
procedure genlit(fi: integer);
begin
  genbyte(162); genword(fi)
end {genlit};
 
 
procedure gendat(var fattr: attr);
var
  i, j, n: integer;
begin {gendat}
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);
      error( not_yet_impl );
      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 {gendat};
 
 
procedure gencon(var fattr: attr);
var
  i: integer;
begin {gencon}
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 {gencon};
 
 
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 {gendif};
 
 
procedure gendbyte(fi: integer);
begin
  dat@ := chr(fi);  put(dat);
  dc := succ(dc)
end {gendbyte};
 
 
procedure gendword(fi: integer);
begin
  dat@ := chr(fi);  put(dat);
  dat@ := chr(fi div 256);  put(dat);
  dc := dc + 2
end {gendword};
 
 
 
 
 
function comptypes(fq1, fq2: stp): boolean;
var
  form2: forms;
begin {comptypes}
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)
		and (size = fq2@.size) and comptypes(inxtyp, fq2@.inxtyp);
	{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 {comptypes};
 
 
procedure expression; forward;
 
 
procedure valueexpression;
begin {valueexpression}
expression;
if gattr.akind = cst then begin
  gencon(gattr);
  gattr.akind := exp
  end
end {valueexpression};
 
 
procedure setcoerce(fq: stp);
begin {setcoerce}
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 {setcoerce};
 
 
procedure selector (fp: itp);
var
  lattr: attr;
  p: itp;
  q: stp;
  loffset: integer;
  more: boolean;
 
 
procedure genload;
begin {genload}
case gattr.akind of
  cst: case gattr.avalue.kind of
    lit: { do nothing };
    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 {ref};
  exp: { do nothing }
  end {case}
end {genload};
 
 
 
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) or (vkind = largeparam) 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 { atsign }
  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 { period }
  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
	    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 { lbrack };
  if sym.sy = eofsy then more := false
until not more;
genload
end {selector};
 
 
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),{ scalar }
(  0,111,  0,  0,  0,  0,110,109,107,108,106,105,104,  0,  0,  0,  0,  0,  0),{ booleant }
(  0,  0,  0,  0, 16, 17,  0, 29, 27, 28, 26, 25, 24,  0, 30, 31,  0,  0,  0),{ chart }
( 34,  0, 35, 36, 32, 33,  0, 61, 59, 60, 58, 57, 56,  0, 62, 63, 44, 45,  0),{ integert }
( 34,  0, 35, 36, 32, 33,  0, 61, 59, 60, 58, 57, 56,  0, 62, 63, 44, 45,  0),{ longintt }
( 66,  0, 67,  0, 64, 65,  0, 93, 91, 92, 90, 89, 88,  0, 94, 95,  0,  0,  0),{ realt }
( 66,  0, 67,  0, 64, 65,  0, 93, 91, 92, 90, 89, 88,  0, 94, 95,  0,  0,  0),{ longrealt }
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 25, 24,  0,  0,  0,  0,  0,  0),{ pointer }
(114,  0,  0,  0,113,115,  0,  0,123,124,  0,121,120,126,  0,  0,  0,  0,  0),{ sett }
(  0,  0,  0,  0,  0,  0,  0,173,171,172,170,169,168,  0,  0,  0,  0,  0,  0),{ arrayt }
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),{ recordt }
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),{ filet }
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0),{ tagfield }
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0));{variant }
var
  q: stp;
  s: @stndset;
  r: @longreal;
  opcode: 0..255;
begin {binop}
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);
      gattr.akind := exp;
      genbyte(opcode)
      end
    else					{ <const> <op> ?? }
      if gattr.akind <> cst then begin		{ <const> <op> <expr> }
	gencon(fattr);
	genbyte(1 {XCH});
	gattr.akind := exp;
	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: error(not_yet_impl);
	      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, gtop:
		error(132);
	      eqop:
		gattr.avalue.ival :=
		  ord(fattr.avalue.sval@ = gattr.avalue.sval@);
	      neop:
		gattr.avalue.ival :=
		  ord(fattr.avalue.sval@ <> gattr.avalue.sval@);
	      leop, geop:
		error(not_yet_impl)
	      end
	    end
	end {case form}
    end {else opcode <> 0}
  end {not nil}
end {binop};
 
 
procedure call (fp: itp);
var
  lattr: attr;
  i: integer;
  lkind: attributestates;
const
  nrbuiltin = 40;
type
  doargtab = array[0..nrbuiltin-1] of set of (hasarg, getarg, dfltarg);
	{hasarg:  will be arg list}
	{getarg:  parse arg list here}
	{dfltarg: arg list may be incomplete or missing}
const
  doarg = doargtab(
  [hasarg],  [hasarg],  [hasarg],  [hasarg],    { get - position }
  [hasarg],  [hasarg],  [hasarg],               { reset - update }
  [dfltarg], [dfltarg], [dfltarg], [dfltarg],   { 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 }
  [dfltarg]);					{ page }
 
 
procedure calluser (fp: itp);
var
  p: itp;
  q: stp;
  nrofparm, retvsize: integer;
begin {calluser}
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 }
      with p@ do
      if vkind = formal then
      begin
	if gattr.akind <> ref then error(154);
	genbyte(9 {REFER})
      end {vkind = formal}
      else if vkind = largeparam then
      begin
	genbyte(9 {REFER})
      end {vkind = largeparam};
      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 }
if fp@.paddr = 0 then error(401);	{ illegal call on main program }
genbyte(208 + fp@.plev {CALL});
genbyte(retvsize);
genbyte(fp@.paddr);
genbyte(nrofparm);
gattr.atype := fp@.itype
end {calluser};
 
 
procedure callnew;
var
  q, q1: stp;
  n, m: integer;
  hasvariablepart: boolean;
begin {callnew}
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
      warning(415);	{ dynamic new is an extension }
      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 {callnew};
 
 
 
procedure fileproc (apsinx:integer; candefault:boolean);
{ call builtin file procedures }
 
var
  noarg,defaulted:boolean;
  p,fileptr: itp;
  filetype: stp;	{to retain type of file}
 
 
  procedure readwrite(doline:boolean);
  {implements the read, readln, write, and writeln calls.  doline
   tells whether to add the final call to complete a line}
 
  type
    rwtab = array[forms] of integer;	{for read/write proc codes}
 
  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, nrcalls, nrparm: integer;
    arglist: boolean;
 
  begin {readwrite}
    genbyte(177 {VARBL}); genbyte(2); genword(0);
    genbyte(1 {XCH});
    genbyte(10 {STOL});
    nrcalls := 0; arglist := false;
    {process arg list if present}
    if (not noarg) and
	(defaulted or not (sym.sy = rparen)) then
    begin	{has arg list}
      arglist := true;
      if apsinx < 9 then			{read/readln}
	loop
	  nrcalls := succ(nrcalls);
	  expression;				{compute varble}
	  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}
      else				{write/writeln}
	loop
	  nrcalls := succ(nrcalls);
	  nrparm := 3;			{until otherwise proven}
	  valueexpression;
	  if gattr.atype <> nil then begin
	    code := writecode[gattr.atype@.form];
	    if code = 27 {array} 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		{field width}
	    if not comptypes(filetype,textptr) then error(169);	{must be text-like}
	    insymbol;
	    valueexpression;
	    if not comptypes(gattr.atype, intptr) then error(116);
	    if (code=35) or (code=37) then		{reals}
	      if sym.sy = colon then begin		{fraction width}
		insymbol;
		valueexpression;
		if not comptypes(gattr.atype, intptr) then error(116);
		nrparm := 4
	      end else code := code+6;			{use e-stype output}
	  end else begin
	    genlit(0);			{default field width}
	    if (code = 35) or (code = 37) then begin	{default for reals}
	      genlit(0); nrparm := 4;
	    end
	  end;
	  genbyte(138 {INVOK}); genbyte(nrparm); genbyte(code);
	exit if sym.sy <> comma;
	  insymbol;
	  genbyte(177 {VARBL}); genbyte(2); genword(0)
	end{loop}
      end{arglist};
    if doline then 
    begin {readln/writeln}
      code := 44;	{readln until proven otherwise}
      if apsinx = 10 then code := succ(code);
      if nrcalls <> 0 then
      begin
	genbyte(177 {VARBLE}); genbyte(2); genword(0)
      end;
      genbyte(138 {INVOK}); genbyte(1); genbyte(code);
      nrcalls := succ(nrcalls)
    end{doline};
    genbyte(152 {SEQ}); genbyte(pred(nrcalls))
  end {readwrite};
 
 
begin {fileproc}
  {First, determine the state of the argument list and set up
   the environment so that subsequent processing will see things
   uniformly}
  noarg := false;	{Assume there is an arg list}
  defaulted := false;	{Assume there is a file name}
  filetype := textptr;		{an initial assumption}
  if candefault and (sym.sy <> lparen) then begin {No arglist}
    noarg := true;
    defaulted := true;
    if odd(apsinx) and (apsinx<>39) {read or write} then error(20)
  end else begin {arglist present}
    if candefault then insymbol;   {gobble up '('}
    if sym.sy = ident then begin	{may be file spec}
      p := searchid([types,konst,vars,field,proc]);
      if p@.class = proc then defaulted := true;
      if p@.itype <> nil then
	if (p@.itype@.form <> filet) or
		((ch = '^') or (ch = '@'))	{KLUDGE!!!} then defaulted := true
    end else defaulted := true
  end;
  if defaulted and not candefault then error(116)
  else if not defaulted then	{must be a file name} begin
    expression;
    filetype := gattr.atype
  end else begin		{defaulted file name}
    fileptr := inptr;		{Assume input}
    if apsinx > 8 then fileptr := outptr;	{It's output}
    selector(fileptr)		{Make the file available}
  end;
 
  {now, implement the specified procedure}
    genbyte(9 {REFER});	{Remaining procs REFER to fileblock}
    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] }
	  warning(413);
	  if sym.sy = comma then begin
	    insymbol;
	    valueexpression;
	    genbyte(138); genbyte(2); genbyte(18);
	  end;
        end;
      4, 5, 6: begin				{reset, rewrite, [update]}
        {Rewritten to permit "anonymous" files, according to standard}
	if apsinx = 6 {update} then warning(413);
        if sym.sy = comma then begin	{Assume filename}
	  insymbol;			{gobble up ','}
          valueexpression;		{parse it}
          if (gattr.atype <> nil) and ((gattr.atype@.form <> arrayt)
      				or (gattr.atype@.aeltyp <> charptr))
      		then error(116);
          genbyte(9 {REFER});
	  { For DEC OS, check for 3rd arg,
	    file attribute (integer): }
	  if sym.sy = comma then
	  begin
	    insymbol;
	    valueexpression
	  end
	  else genlit(0 {default file attr})
        end else genlit(0 {nil});
	genlit(apsinx-4);		{0=>reset, 1=>rewrite, [2=>update]}
        genbyte(138 {INVOK}); genbyte(4); genbyte(17)
        end;
      7, 9: begin			{read, write}
	if not defaulted then
	  if sym.sy = comma then insymbol else error(20);
        readwrite(false)
        end;
      8, 10: begin			{readln, writeln}
	if not comptypes(filetype,textptr) then error(169);
	if (not defaulted) and (sym.sy = comma) then insymbol;
        readwrite(true)
        end;
      11: begin				{eof}
	genbyte(138 {INVOK}); genbyte(1); genbyte(47);
	gattr.atype := boolptr;
	end;
      12: begin				{eoln}
	if filetype <> textptr then error(169);
	genbyte(138 {INVOK}); genbyte(1); genbyte(48);
	gattr.atype := boolptr;
	end;
      39: begin				{page}
	genbyte(138 {INVOK}); genbyte(1); genbyte(46);
	end;
    end; {case}
  if not noarg then if sym.sy = rparen then insymbol else error(4)
end {fileproc};
 
 
begin {call}
lkind := exp;
with fp@ do begin
  if pkind <> stnd then calluser(fp)
  else begin { pkind = stnd }
    if hasarg in doarg[psinx] then begin
      if sym.sy = lparen then begin
	insymbol;
	if getarg in doarg[psinx] then
	begin
	  expression;
	  { Initial assumption for standard functions:
	    if function has constant args, evaluate function
	    at compile-time.  Some functions are evaluated
	    at run-time only, so these are handled as
	    special cases. }
	  if gattr.akind = cst then lkind := cst
	end {getarg in doarg}
      end {sym.sy = lparen}
      else error(9)
      end;
    case psinx of
      0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 39:	{ get - eoln, page }
	begin
	fileproc(psinx, dfltarg in doarg[psinx]);
	  lkind := exp
	end;
      13: begin				{ new }
	  callnew;
	  lkind := exp
	end;
      15, 16: begin			{ mark - release }
	genbyte(138 {INVOK});
	genbyte(0 {nr of args});
	genbyte(psinx-9);
	lkind := exp
	end;
      17: begin				{ pred }
	if (gattr.atype <> nil) and (gattr.atype@.form > integert)
	  then error(125);
	if gattr.akind = cst then
	  gattr.avalue.ival := pred(gattr.avalue.ival)
	else
	  genbyte(17 {PRED})
	end;
      18: begin				{ succ }
	if (gattr.atype <> nil) and (gattr.atype@.form > integert)
	  then error(125);
	if gattr.akind = cst then
	  gattr.avalue.ival := succ(gattr.avalue.ival)
	else
	  genbyte(16 {SUCC})
	end;
      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);
      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;
	gattr.atype@.form := longrealt
	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);
	if gattr.akind = cst then begin
	  error(not_yet_impl);
	  {gattr.avalue.ival := round(gattr.avalue.rval@);}
	  {gattr.avalue.kind := lit}
	end else
	  genbyte(76 {ROUND});
	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);
	lkind := gattr.akind
	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);
 
      14,				{ free }
      20,				{ all }
      29,				{ ceil }
      30: error(not_yet_impl);		{ floor }
 
      32: 				{ sqr }
	if gattr.atype <> nil then
	  if comptypes(gattr.atype, intptr) then
	    if gattr.akind = cst then
	      gattr.avalue.ival := sqr(gattr.avalue.ival)
	    else
	      genbyte(37 {ISQR})
	  else if comptypes(gattr.atype, realptr) then
	    if gattr.akind = cst then
	      gattr.avalue.rval@ := sqr(gattr.avalue.rval@)
	    else
	      genbyte(69 {FSQR})
	else error(125);
 
      33,				{ sqrt }
      34,				{ ln }
      35,				{ exp }
      36,				{ sin }
      37,				{ cos }
      38:				{ arctan }
        begin
	  lkind := exp;
	  if gattr.akind = cst then gencon(gattr);
	  if not comptypes(gattr.atype, realptr) then
	    if comptypes(gattr.atype, intptr)
		then genbyte(74 {FLOAT})
		else error(125);
	  genbyte(138 {INVOK});
	  genbyte(1   {nr of args});
	  genbyte(psinx + 68);
	  gattr.atype := realptr;
	  gattr.atype@.form := longrealt
	end
      end {case};
    if getarg in doarg[psinx] then begin
      if sym.sy = rparen then insymbol
      else error(4)
      end
    end {pkind = stnd}
  end {with fp@};
  gattr.akind := lkind
end {call};
 
 
procedure expression;
var
  lattr: attr;
  lop: operator;
 
 
procedure simpleexpression;
var
  lattr: attr;
  lop: operator;
  issigned: boolean;
 
 
procedure term;
var
  lattr: attr;
  lop: operator;
 
 
procedure factor;
var
  coffset: addrrange;
  cvalue: integer;
  p: itp;
  q, q1: stp;
  n: integer;
  s: @stndset;
  cstpart, varpart: boolean;
 
 
procedure structconst(fq: stp);
var
  nxtfld: itp;
  caddr, loffset: addrrange;
  nrelts, eltsiz: integer;
begin {structconst}
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 {structconst};
 
 
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	{ structured constant }
	{if sym.sy = lparen then insymbol else error(9);}
	if sym.sy <> lparen then error(9);
	warning(414);
	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;
  nilsy: begin  {nil is reserved word; set up its value}
    gattr.akind := cst;
    gattr.atype := nilptr;
    gattr.avalue.kind := lit;
    gattr.avalue.ival := 0;
    insymbol
    end;
  notsy: begin
    insymbol;
    factor;
    if gattr.atype = boolptr then
      if gattr.akind = cst then
      begin { not <const> }
	if gattr.avalue.ival = 0	{false}
	  then gattr.avalue.ival := 1	{true}
	  else gattr.avalue.ival := 0	{false}
      end else
      begin
	genbyte(96 {NOT});
	gattr.akind := exp
      end
    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 { lbrack };
  mulop,addop,relop,rparen,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,
  ceesy,fortransy,labelsy,eofsy,othersy:
    begin
      error(58); gattr.atype := nil
    end
  end {case}
end {factor};
 
 
begin {term}
factor;
while sym.sy = mulop do begin
  lattr := gattr;
  lop := sym.op;
  insymbol;
  factor;
  binop(lop, lattr)
  end
end {term};
 
 
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 begin
	genbyte(40 {INEG});
	gattr.akind := exp
      end;
    longintt:
      if gattr.akind = cst then error(not_yet_impl)
	{ coming attraction }
      else begin
	genbyte(40 {INEG});
	gattr.akind := exp
      end;
    realt, longrealt:
      if gattr.akind = cst then
	gattr.avalue.rval@ := - gattr.avalue.rval@
      else begin
	genbyte(72 {FNEG});
	gattr.akind := exp
      end;
    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};
 
 
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};
 
 
 
procedure typ (var fq: stp);	{ parse type definitions }
var
  fldoffset: integer;
  i: integer;
  p: itp;
  q, q1, q2 : stp;
  oldtop, n, lmin, lmax: integer;
 
 
procedure subrange(var fq: stp);
var
  q, q1: stp;
  lmin: integer;
begin {subrange}
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 {subrange};
 
 
 
procedure fieldlist (var fq: stp);
var
  p, p1, p2, p3: itp;
  q, q1, q2, q3, q4, q5: stp;
  maxsize, minsize: integer;
  lid: idtype;
 
 
procedure fieldaddr(fp: itp);
begin {fieldaddr}
if fp <> nil then with fp@ do begin
  fldoffset := ceil(fldoffset , typalign(itype));
  fdisp := fldoffset;
  fldoffset := fldoffset + typsize(itype)
  end
end {fieldaddr};
 
 
begin {fieldlist}
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 {fieldlist};
 
 
begin {typ}
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;
    if q = nil then error(145)
    end
  else subrange(q)
  end { ident };
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 { lparen };
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) or ( (p<>nil) and (p@.itype = nil) ) then
      begin
        {referenced before declared}
        new(fwid, ord(id.l));
        fwid@.l := id.l;
        for i := 1 to ord(id.l) do
          fwid@.s[i] := id.s[i];
        eltype := fwptr;
        fwptr := q
      end
      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 { atsign };
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 then with q2@ do
      if form > longrealt then error(113)
      else if (form=realt) or (form=longrealt) then error(109)
      else if ((form=integert) or (form=longintt))
	and not subrange then error(149)
      else q@.inxtyp := q2 { valid index type };
  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 { arraysy };
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 { recordsy };
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 { setsy };
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 { filesy };
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, ceesy, fortransy,
othersy, packedsy, nilsy, eofsy, labelsy:
 {... in other words - default }
begin
  error(10);
  q := nil
  end
end {case sym.sy};
fq := q
end {typ};
 
 
 
procedure constdecl;
var
  p: itp;
begin {constdecl}
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 {constdecl};
 
 
procedure labeldecl;
begin {labeldecl}
  error(not_yet_impl);
  loop
    if sym.sy = intconst then
    begin
      insymbol
    end
    else error(15);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = semicolon then insymbol else error(14)
end {labeldecl};
 
 
procedure typedecl;
var
  p : itp;
  q, q1, q2, q3: stp;
begin {typedecl}
  while sym.sy = ident do
  begin
    newid(types, nil, nil, p);
    insymbol;	{ gobble up the ident }
    if (sym.sy = relop) and (sym.op = eqop) then insymbol else error(16);
    typ(q);	{ parse type field and return pointer to struct in q2 }
    p@.itype := q;
    { see if any forward pointers now resolved }
    q1 := fwptr; q2 := nil;
    while q1 <> nil do
    begin
      q3 := q1@.eltype; {pointer to next on forward list}
      if match(p@.name@.s,ord(p@.name@.l), q1@.fwid@.s,ord(q1@.fwid@.l)) = 0 then
      begin
	if q2 = nil then fwptr := q3
	  else q2@.eltype := q3;
        q1@.eltype := q; {resolve forward pointer type}
      end
      else q2 := q1;
      q1:= q3;
    end {while};
    if sym.sy = semicolon then insymbol else error(14)
  end {while}
end {typedecl};
 
 
procedure varaddr(fp: itp);
begin {varaddr}
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 {varaddr};
 
 
procedure vardecl;
var
  p1, p2, p3, p4: itp;
  q: stp;
begin {vardecl}
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 {vardecl};
 
 
procedure procdecl (isfunction: boolean);
var
  p1, p2, p3, p4: itp;
  oldfwptr: stp;
  oldvarlst: itp;
  oldac, olddc, oldlc, oldpin: integer;
  rvsize: integer;
  oldlevel, oldtop: disprange;
  wasforward, hasvalueparam: boolean;
 
 
procedure parmlist(var fp: itp);
{ Parmlist parses the parameterlist and determines
  how parameters are to be passed.  For large value-
  parameters (arrays, records), an implementation
  dependent decision is made. }
var
  p1, p2, p3, p4: itp;
  q: stp;
  lvkind: varkinds;
begin {parmlist}
p1 := nil;
if sym.sy = lparen then begin
  insymbol;	{ gobble up '(' }
  loop
    if sym.sy = varsy then begin
      insymbol; lvkind := formal
      end
    else begin
      lvkind := param;
      hasvalueparam := true
    end;
    p2 := nil;
    loop
      if sym.sy = ident then begin
	newid(vars,nil,p2,p4);
	p4@.vlev := level;
	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 }
      if lvkind = param then
      with q@ do
	if (form = arrayt) or (form = recordt)
	  then lvkind := largeparam;
      p3 := p2;
      while p2 <> nil do begin	{ assign type }
	with p2@ do
	begin
	  itype := q;  vkind := lvkind
	end;
        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 {parmlist};
 
 
procedure parmaddr(fp: itp);
begin {parmaddr}
if odd(ac) then ac := succ(ac);
with fp@ do begin
  vaddr := ac;
  if (vkind = formal) or (vkind = largeparam) then
    ac := ac + usize[pointer]
  else
    ac := ac + typsize(itype)
  end
end {parmaddr};
 
 
procedure externs (fp: itp; langcode: pkinds);
var rvsize: integer;
begin {externs}
  genbyte(6 {proc});  genbyte(ord(langcode)-ord(extn)+1);
  genbyte(5 {ident}); genid( fp@.name );
  genbyte(7 {end});   genbyte( pin {proc nr});
  rvsize := typsize( fp@.itype );
  genbyte( rvsize );  genword( lc ); genword( ac-rvsize );
  genword( dc );
  insymbol	{gobble up 'external','cext',or 'fortran'}
end {externs};
 
 
begin {procdecl}
{ 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 }
hasvalueparam := false;
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; externs( p4, extn )
end
else if sym.sy = ceesy then
begin
  p4@.pkind := cee; externs( p4, cee )
end
else if sym.sy = fortransy then
begin
  if hasvalueparam then error(182);
  p4@.pkind := fort; externs( p4, fort )
end
else begin	{ parse procedure definition }
  p4@.pkind := decl;
  genbyte(6 {proc});  genbyte(0 {not extern});
  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 {procdecl};
 
 
 
procedure body (fpb: itp);
{ fpb points to the procedure information if this
  is the outer compound-statement, otherwise nil. }
 
 
procedure statelist (fpl: itp; stopper: symbol);
{ fpl points to the procedure information if this
  is the outer statement-sequence, otherwise nil. }
var
  scnt: integer;
 
 
procedure checkscnt;
{ Insure that stmt count does not exceed maximum value. }
begin {checkscnt}
  if scnt >= 255 then {already 256 statements, do a SEQ}
  begin
    genbyte(152 {SEQ});
    genbyte(255);
    scnt := 0
  end
end {checkscnt};
 
 
procedure statement;
var
  p: itp;
 
 
procedure assignment(fp: itp);
var
  q: stp;
begin {assignment}
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
      if comptypes(q, realptr) and comptypes(gattr.atype, intptr)
	then genbyte(74 {FLOAT})
	else 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 {assignment};
 
 
procedure gotostatement;
begin {gotostatement}
  error(not_yet_impl);
  genbyte(8 {NULL});	{ temporary, in place of goto op }
  if sym.sy = intconst then
  begin
    insymbol
  end
  else error(15)
end {gotostatement};
 
 
procedure ifstatement;
begin {ifstatement}
  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 {ifstatement};
 
 
procedure casestatement;
var
  q: stp;
  lmin, lmax, nrent, nrval: integer;
  cslab, elm, ind: integer;
  usedlabels: array [0..15] of stndset;
  { Note: elm, ind, and the above array are artifacts
    of the small set size.  This will be changed when
    set of 0..255 is implemented. }
begin {casestatement}
  for ind := 0 to 15 do usedlabels[ind] := [];
  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);
	  cslab := gattr.avalue.ival - lmin;
	  if (cslab>=0) and (cslab<=255) then
	  begin
	    ind := cslab div 16; { temp }
	    elm := cslab mod 16; { temp }
	    if elm in usedlabels[ind] then error(156)
	      else usedlabels[ind] := [elm] + usedlabels[ind]
	  end;
	  genlit(cslab);
	  lmax := max(lmax, gattr.avalue.ival);
	  nrval := succ(nrval)
	end
      end
      else error(106);
    exit if sym.sy <> comma;
      insymbol
    end {loop};
    if sym.sy = colon then insymbol else error(5);
    statement;
    genbyte(146 {ENTRY});
    genbyte(nrval);
    nrent := succ(nrent);
  exit if sym.sy <> semicolon;
    insymbol;
  exit if sym.sy = endsy;
  end {loop};
  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 {casestatement};
 
 
procedure repeatstatement;
begin {repeatstatement}
  statelist(nil, 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 {repeatstatement};
 
 
procedure whilestatement;
begin {whilestatement}
  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 {whilestatement};
 
 
procedure loopstatement;
var
  nrexits: integer;
begin {loopstatement}
  warning(411);
  nrexits := 0;
  loop
    statelist(nil, exitsy);
  exit if (sym.sy = endsy) or (sym.sy = eofsy);
    if sym.sy = exitsy then begin
      warning(412);
      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 {loop};
  if sym.sy = endsy then insymbol else error(13);
  genbyte(147 {LOOP});
  genbyte(nrexits * 2)	{ builds bad tree if exit missing! }
end {loopstatement};
 
 
procedure forstatement;
var
  p: itp;
  lsy: symbol;
begin {forstatement}
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 {forstatement};
 
 
procedure withstatement;
var
  p: itp;
  nrwiths: integer;
begin {withstatement}
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 {withstatement};
 
 
begin {statement}
{ check for labels and put out error message: }
if sym.sy = intconst then begin
  error(not_yet_impl);
  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(nil) 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;
  gotosy:    begin insymbol; gotostatement 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, nilsy, labelsy,
  ofsy, dosy, tosy, downtosy, thensy, externalsy,
  ceesy, fortransy, othersy, eofsy:
    begin error(6); insymbol end
  end {case}
end {statement};
 
 
procedure copyparams (fp: itp);
{ Copy large value-parameters to local variables
  upon entry to a user procedure or function. }
var
  p: itp;
  q: stp;
  pac, tmpaddr, siz: addrrange;
  lsym: symbol;
begin {copyparams}
  lsym := sym.sy;	{ save current symbol }
  sym.sy := othersy;	{ so selector won't read source file }
  p := fp@.next;	{ head of param list }
  if fp@.itype <> nil	{ function }
    then p := p@.next;	{ skip over returned value }
  pac := ac - rvsize;	{ reconstruct param addr }
  while p <> nil do
  begin
    with p@ do
    begin
      if (vkind = formal) or (vkind = largeparam)
	then siz := usize[pointer]
	else siz := typsize(itype);
      pac := pac - siz;		{ addr of this param }
      if odd(pac) then pac := pred(pac);
      if vkind = largeparam then
      begin { copy parameter to local variable: }
	vkind := local;
	selector(p);		{destination - local var}
	tmpaddr := vaddr;	{save local addr}
	vaddr := pac;
	vkind := formal;
	selector(p);		{source - parameter}
	vaddr := tmpaddr;	{restore local addr}
	vkind := largeparam;
	q := p@.itype;
	with q@ do
	begin
	  if form = arrayt then
	  begin
	    genbyte(135 {MOVEM});
	    if typsize(aeltyp) < 2 then genbyte(1) else genbyte(2);
	    genword(size)
	  end {arrayt}
	  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 {recordt}
	  else error (400)		{* TEMP *}
	end {with q@};
	scnt := succ(scnt);
	checkscnt
      end {largeparam};
    end {with p@ do};
    p := p@.next
  end {while};
  sym.sy := lsym
end {copyparams};
 
 
begin {statelist}
scnt := 0;
if fpl <> nil then copyparams (fpl);
statement;
while (sym.sy <> stopper) and (sym.sy <> endsy) and (sym.sy <> eofsy) do
  if sym.sy = semicolon
  then begin
    insymbol;	{ gobble up ';' }
    checkscnt;
    statement;
    scnt := succ(scnt)
    end
  else begin
    error(14);
    skip(stopper)
    end;
genbyte(152 {SEQ});
genbyte(scnt)
end {statelist};
 
 
begin {body}
  statelist(fpb, endsy);
  if sym.sy = endsy
  then insymbol	{ gobble up 'end' }
  else error(13)
end {body};
 
 
procedure alloc_lgparms (fp: itp);
{ Allocate space on the local stack frame for large
 parameters passed by value.  The parameter address in
 the symbol table entry is replaced by the local variable
 address where the copy will be stored by copyparams. }
var
  p: itp;
begin {alloc_lgparms}
  lgparmallocated := true;
  p := fp@.next;	{ head of param list }
  if fp@.itype <> nil	{ function }
    then p := p@.next;	{ skip over returned value }
  while p <> nil do
  begin
    if p@.vkind = largeparam then varaddr(p);	{ assign local address }
    p := p@.next
  end {while}
end {alloc_lgparms};
 
 
 
procedure checkfiles(isclose: boolean; var filecount: integer);
var
  p: itp;
  n: integer;
begin {checkfiles}
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 {checkfiles};
 
 
procedure initstdnames;
{ Initialize the symbol table with lex level 1 declarations. }
var
  p: itp;
  q1, q2, q3: stp;
begin {initstdnames}
  genbyte(6 {proc - main program});  genbyte(0 {not extern});
  { start allocating global vars at loc 4.
    loc 0:  temporary for read/write.
    loc 2:  source prog line nr. for runtime checks. }
  lc := 4;
  id := idtype(chr(6), 'output');
  newid(vars, textptr, nil, p);
  outptr := p;			{retain in case of defaulted filename}
  with p@ do begin
    vkind := local;  vlev := 1;  vaddr := lc
  end;
  lc := lc + filsiz;
  id := idtype(chr(5), 'input');
  newid(vars, textptr, nil, p);
  inptr := p;			{retain in case of defaulted filename}
  with p@ do begin
    vkind := local;  vlev := 1;  vaddr := lc
  end;
  lc := lc + filsiz;
  { definition of argc and argv: }
  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 {initstdnames};
 
 
begin {block}
  mark;
  lc := 0;  tc := 0;
  if level = 1 then initstdnames;
  fwptr := nil;  varlst := nil;
  declstate := headpart;
  lgparmallocated := false;
  while (sym.sy <> beginsy) and (sym.sy <> eofsy) do
    if sym.sy = labelsy then begin
      if declstate > labelpart then warning(413);
      declstate := labelpart;
      insymbol;  labeldecl
      end
    else if sym.sy = constsy then begin
      if declstate > constpart then warning(413);
      declstate := constpart;
      insymbol;  constdecl
      end
    else if sym.sy = typesy then begin
      if declstate > typepart then warning(413);
      declstate := typepart;
      insymbol;  typedecl
      end
    else if sym.sy = varsy then begin
      if declstate > varblpart then warning(413);
      declstate := varblpart;
      insymbol;  vardecl
      end
    else if sym.sy = proceduresy then begin
      declstate := procpart;
      if not lgparmallocated then alloc_lgparms(fp);
      insymbol;  procdecl(false)
      end
    else if sym.sy = functionsy then begin
      declstate := procpart;
      if not lgparmallocated then alloc_lgparms(fp);
      insymbol;  procdecl(true)
      end
    else begin
      error(18);  skip(semicolon);  insymbol
    end;
  while fwptr <> nil do
  begin
    error(117); fwptr := fwptr@.eltype
  end;
  if not lgparmallocated then alloc_lgparms(fp);
  rvsize := typsize(fp@.itype);
  if (sym.sy = beginsy) and ((level>1) or not option['E']) then
  begin
    insymbol;	{ gobble the 'begin' }
    genbyte(5 {ident});  genid(fp@.name);
    checkfiles(false, filecount);
 
    body(fp);	{ 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 {proc nr});
    genbyte(rvsize);
    genword(lc);  genword(ac - rvsize);  genword(dc);
    if option['T'] then printtables(false)
  end;
  release
end {block}; 
 
 
procedure openfiles;
begin
  if (argc=5) or (argc=6) then
  begin
    Ok_to_proceed := true;
    reset (src, argv[2]@, 2);	{ source input }
    rewrite (int, "PASINT.TMP[100]");	{ intermediate code output }
    rewrite (dat, "PASDAT.TMP[20]");	{ intermediate data output }
    if (option['L'] or option['T']) then
      rewrite (lst, argv[3]@, 2)	{ list output }
  end
  else begin
    Ok_to_proceed := false;
    writeln(output,'PASS 1: command line error.')
  end
end {openfiles};

procedure initoptions;
var
  c: char;
  i: integer;
begin
  for c := 'A' to 'Z' do option[c] := false;
  runtimcheks := 0;		{ initial R option }
  if argc > 1 then begin
    if argv[1]@[0] = '-' then begin
      i := 1;
      loop
	c := argv[1]@[i];
	exit if c=chr(0);
	if (c>='A') and (c<='Z') then option[c] := true;
	i := i+1;
      end; {loop}
    end; {if}
  end; {if}
end; {initoptions}
 
 
procedure initialize;
begin {initialize}
  date(datestring); time(timestring);		{get the date and time}
  writeln(output);
  writeln(output, compiler_version);
  initoptions;		{get options from command string}
  openfiles;
  if Ok_to_proceed then
  begin
    pageno := 0;
    newpage;
    prterr := true;
    errtot := 0; errinx := 0; linenr := 1;
    maxpin := 0; dc := 0;
    chcnt := 0; ch := NL;
    level := 0; top := 0; pin := 0;
    gattr.atype := nil; gattr.akind := cst;
    beginline;
    insymbol;	{ get initial option stmt if any }
    inittables;
    lcp := nil;
    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 = lparen then
      begin { ignore program parameters }
	skip(rparen);
	insymbol
      end;
      if sym.sy = semicolon then insymbol else error(14)
    end {sy = programsy};
    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;
    genbyte(5 {ident});  genid(lcp@.name);	{output module name}
    with display[1] do
    begin
      fname := nil;
      occur := blck
    end
  end {Ok_to_proceed}
end {initialize};
 
 
 
 
begin {P1FP}
  initialize;
  if Ok_to_proceed then
  begin
 
    block(lcp);
 
    if sym.sy <> period then if not option['E'] then error(21);
    endofline;
    if errtot > 0 then
    begin
      writeln(output);
      writeln(output,'Pass1 errors: ', errtot);
      if option['L'] then begin
	writeln(lst);
	writeln(lst);
	writeln(lst,' *+*+* Pass1 errors: ', errtot)
      end
    end
    else p2go;	{chain to pass2 if no errors}
  end {Ok_to_proceed}
end {P1FP}.