{$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.
}
{Revision History:
 Current Revision code: I
 780812: Make nil a reserved word
	 Make upper & lower case indistinct
	 Add maxint
 
 780908: Add eoln (a la NBS)
	 Make default filenames work
	 Add readln
	 Fix readln, writeln for no args
}
 
{DEC OS versions maintained by DECUS Pascal SIG:
 Bill Heidebrecht - TRW DSSG
 John R. Barr     - University of Montana
 Brian Nelson     - University of Toledo
 
 RSX / IAS / RSTS revision history: }
 
{Modified to accept upper or lower case identifiers
 and to accept comments enclosed in (* *).	JBH\780415}
{Modified to print lex level.			JBH\780529}
{Temporary mods for real library functions.	JBH\780610}
{Add code to implement eoln.			JBH\780811}
{Modified to print tables in alfa order.	JBH\780826}
{Added error msgs for unimplemented features.	JBH\780831}
{Modified for extern procedures.		JBH\JRB\780909}
{Added error msg 401.				JBH\781110}
{Above NBS mods (780812 & 780908)
 applied to RSX/RSTS versions;
 eliminate U option.				JBH\781209}
{Implemented sqr.				JBH\790111}
{Fixed typ bug for arrays.			JBH\790118}
{Minor mod in insymbol for reals.		JBH\790224}
{Improve error handling in factor;
 add label and goto reserved words;
 partial implementation of round;
 add implied float for assignment of
 integer expression to real var.		JBH\790310}
{Check for duplicate case labels;
 allow integer args for std real functions.	JBH\790320}
{Add warning messages for nonstd features.	JBH\790609}
{Fixed p.2 subtreematch bug.			JBH\790712}
{Fixed readln/writeln arg error;
 added var size to output tables;
 improved factor error detection.		JBH\790818}
{Changed spelling of 'extern' to 'external';
 Increased size of reltab and symbol table
 in pass2; Added err msg 32 in pass2.		JBH\791006}
{Added external procedure capability for
 Pascal, C and Fortran.				JCW\JRB\791006}
{Fix factor bug for not <constant>.		JBH\791101}
{Fix real comparison bug in p2 genfpbinary.	JBH\791110}
{Add X option for separate compilation.		JRB\791201}
{Eliminate p1 'S' option;  fix p2 bugs;
 combine .ols & .lst files in p2.		JBH\791201}
{P1 and P2 error corrections.			JBH\800315}
{P1 and P2 error corrections.			JBH\800329}
{P1 and P2 error corrections.		JBH\SHK\BDN\801004}
{P1 and P2 error corrections.			JBH\801023}
{P1 and P2 error corrections.			JBH\810606}
{P1 and P2 error corrections.			JBH\JRB\811020}
 
 
				{constants}
				{*********}
const
  NL = chr(10); {ascii new line (line feed)}
  CR = chr(13); {ascii cr}
  BEL = chr(7); {ascii bell}
  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 = 528;		{size of file variable}
  pagesize = 58;	{length of printer page}
  compiler_version = ' Pascal-N  ';
  pass1id = "PASS1";
  counterperiod = 16;   {period of counter update}

		{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,beginsy,ifsy,casesy,repeatsy,
	    whilesy,nilsy,forsy,withsy,loopsy,gotosy,exitsy,endsy,
	    elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy,
            labelsy,eofsy,othersy);
 
  operator = (mul,rdiv,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: -1..75;		{character counter}
  pageno: integer;		{current page number}
  linesleft: integer;		{lines left on current page}
  linenr: integer;		{line counter}
  oldlinenr: integer;           {previous line counter value}
  
  
                               {option switches:}
                               {****************}
  option: array ['A'..'Z'] of boolean;
    runtimcheks:  integer;	{integer value of option 'R'}
    Ok_to_proceed: boolean;
 
  { Implemented pass1 options:
	C+, display line count on terminal; C-, don't display.
	E+, don't compile main program (for separate compilation).
        G+, trace program execution;  G-, don't trace.
        Z+, pause on error;  Z-, don't pause.
	L+, list source;  L-, no source list.
	Rn, runtime checks option. (not yet impl.)
	T+, print tables;  T-, no table printout.
	W+, print warnings;  W-, suppress warnings.
	Y+, enforce array size compatibility;  Y-, don't enforce.
 
    Implemented pass2 options:
        F+, generate profile data on execution;  F-, don't profile.
	I+, indefinite program execution; I-, execute once only.
        N+, don't prompt for command line;  N-, prompt for command line.
	O+, object code list file; O-, no obj code list.
	P+, procedure name/number cross ref.
	S+, stack dump list to user terminal.
	X+, use actual proc names for object code;
	    X-, use IIInnn proc names.
 
	default options:
	  $C+,E-,F-,G-,I-,L-,N-,O-,P-,R0,S-,T-,W+,X-,Y+
  }
 
                               {files}
                               {*****}
var
  src,                         {source}
  lst,                         {listing}
  int,                         {intermediate code}
  dat: text;                   {intermediate data}
 
                               {error messages:}
                               {***************}
const
  not_yet_impl = 398;          {error msg number}
  maxerrs = 10;			{max errors per source line}
var
  errtot: integer;             {total number of errors}
  warntot: integer;		{total number of warnings}
  errinx: 0..maxerrs;		{number of errors in current line}
  errlist: array [1..maxerrs] of
    record
      nmr: 1..999;
      pos: 1..132;
      errlevel: boolean
    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;}
 
 
{*******************************************************}

{*******************************************************}
{          Additional Declarations for RT-11            }

type
  versionstring = array [1..80] of char;

var
  nbsversion : @versionstring;

procedure error(prog, msg : array [1..80] of char); external;

procedure warn(prog, msg : array [1..80] of char); external;

function version:@versionstring; external;

{*******************************************************}
 
 
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 newpage;
begin
  if option['L'] then begin
    if pageno>0 then
      write(lst, FF);
    pageno := succ(pageno);
    writeln(lst, compiler_version, nbsversion@, 'Page':9, pageno:6, NL);
    linesleft := pagesize
  end
end;


procedure beginline;
begin
  chcnt := 0;
  linenr := linenr + 1;
  if linesleft=0 then
    newpage;
  if (linenr mod counterperiod = 0) and option['C'] then
    write(linenr:8, CR);
  if option['L'] then
    write(lst, linenr:8, level:6, HT)
end;


procedure msg (n: integer; errlev: boolean);
{ save error messages for this source line. }
begin {msg}
  if errinx < maxerrs then
  begin
    errinx := succ(errinx);
    with errlist[errinx] do
    begin
      pos := chcnt; nmr := n;
      errlevel := errlev
    end
  end;
end {msg};
 
procedure pass1error (n: integer);
begin {pass1error}
  errtot := errtot + 1;
  msg(n, true);
  genbyte(3 {OPTION});
  genbyte(2 {abort p2}); genword(0 {value unused})
end {pass1error};
 
procedure warning (n: integer);
begin {warning}
  if option['W'] then
  begin
    warntot := warntot + 1;
    msg(n, false)
  end
end {warning};
 
 
procedure endofline;
type
  flagtype = array [boolean] of 
	array [0..1] of char;
const
  flag = flagtype ('%W', '?F');
var
  k: integer;
begin {endofline}
  if (errinx > 0) and option['C'] then
    write(CR, linenr:8, CR);
  if option['L'] and (chcnt>=0) then begin
    writeln(lst);
    linesleft := pred(linesleft)
  end
  else if (errinx > 0) and option['C'] then
    writeln;
  for k := 1 to errinx do begin
    if linesleft=0 then
      newpage;
    with errlist[k] do
      writeln(lst, flag[errlevel], '*+*+*', nmr:4, HT, '^':pos+1);
    linesleft := pred(linesleft)
  end;
  if (errinx > 0) and option['Z'] then begin
    write(BEL);
    readln
  end;
  chcnt := -1;
  errinx := 0
end {endofline};
 
 
 
procedure insymbol;
type
  chartype = (ctl,oth,dig,let,quo,db0,db1,db2,db3,eos,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,oth,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 [s01..s13] of symtype;
const
  chartok = chartoktab(
    (lparen,noop),	{s01: '('}
    (rparen,noop),	{s02: ')'}
    (mulop,mul),	{s03: '*'}
    (addop,plus),	{s04: '+'}
    (comma,noop),	{s05: ','}
    (addop,minus),	{s06: '-'}
    (mulop,rdiv),	{s07: '/'}
    (semicolon,noop),	{s08: ';'}
    (relop,eqop),	{s09: '='}
    (atsign,noop),	{s10: '@'}
    (lbrack,noop),	{s11: '['}
    (rbrack,noop),	{s12: ']'}
    (atsign,noop));	{s13: '^'}
 
 
const
  NrKeywords = 37;
type
  keywords = array [1..153] of char;
  keyword_symbols=array [1..NrKeywords] of symtype;
  keyword_indices=array [2..10] of array [1..2] of char;
const
  keyword = keywords(
'i','f','d','o','o','r','t','o','i','n','o','f',
'e','n','d','d','i','v','m','o','d','n','o','t','a','n','d','n','i','l','f','o','r','s','e','t','v','a','r',
't','h','e','n','e','l','s','e','w','i','t','h','c','a','s','e','l','o','o','p','e','x','i','t','f','i','l','e','t','y','p','e','g','o','t','o',
'b','e','g','i','n','w','h','i','l','e','u','n','t','i','l','a','r','r','a','y','c','o','n','s','t','l','a','b','e','l',
'r','e','p','e','a','t','p','a','c','k','e','d','r','e','c','o','r','d','d','o','w','n','t','o',
'p','r','o','g','r','a','m',
'f','u','n','c','t','i','o','n',
'p','r','o','c','e','d','u','r','e'
  );
  keyword_sym=keyword_symbols(
(ifsy,noop),(dosy,noop),(addop,orop),(tosy,noop),(relop,inop),(ofsy,noop),
(endsy,noop),(mulop,idiv),(mulop,imod),(notsy,noop),(mulop,andop),(nilsy,noop),(forsy,noop),(setsy,noop),(varsy,noop),
(thensy,noop),(elsesy,noop),(withsy,noop),(casesy,noop),(loopsy,noop),(exitsy,noop),(filesy,noop),(typesy,noop),(gotosy,noop),
(beginsy,noop),(whilesy,noop),(untilsy,noop),(arraysy,noop),(constsy,noop),(labelsy,noop),
(repeatsy,noop),(packedsy,noop),(recordsy,noop),(downtosy,noop),
(programsy,noop),
(functionsy,noop),
(proceduresy,noop)
  );
  keyword_index=keyword_indices(
  (chr(001),chr(01)), {2}
  (chr(013),chr(07)), {3}
  (chr(040),chr(16)), {4}
  (chr(076),chr(25)), {5}
  (chr(106),chr(31)), {6}
  (chr(130),chr(35)), {7}
  (chr(137),chr(36)), {8}
  (chr(145),chr(37)), {9}
  (chr(154),chr(38)) {10}
  );
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 (chcnt < 0) and ((src@ = ' ') or (src@ = ht)) then begin
    beginline;
    repeat
      if option['L'] then begin
	write(lst, src@);
	chcnt := succ(chcnt);
	if src@ = ht then
	  chcnt := succ(chcnt div 8) * 8
      end;
      get(src)
    until (src@ <> ' ') and (src@ <> ht)
  end;
  if not eof(src) then begin
    if not eoln(src) then begin
      read(src, ch);
      if ch <> ff then begin
	if chcnt < 0 then
	  beginline;
	if option['L'] then begin
	  write(lst, ch);
	  chcnt := succ(chcnt);
	  if ch = ht then
	    chcnt := succ(chcnt div 8) * 8
	end
      end
      else begin
	endofline;
	linesleft := 0
      end
    end
    else begin
      if chcnt < 0 then
	beginline;
      endofline;
      readln(src);
      ch := nl
    end
  end
  else
    ch := chr(0)
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 pass1error(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 pass1error(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
      id.s := '               ';
      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);
      if (k<2) or (k>9) then
        found := false
      else begin
        i:=ord(keyword_index[k][1]);
        n:=ord(keyword_index[k+1][1]);
        radix:=ord(keyword_index[k][2]);
        loop
          scale:=1;
          j:=i;
          found:=true;
          while found and (scale<=k) do begin
            if keyword[j]<>id.s[scale] then
              found := false
            else begin
              scale:=succ(scale);
              j:=succ(j)
            end
          end;
        exit if found;
          i:=i+k;
        exit if i=n;
          radix:=succ(radix)
        end {loop}
      end;
      if found then sym := keyword_sym[radix]
      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
	      pass1error(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;
    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, ctl: begin
      pass1error(396);
      sym := symtype(othersy, noop)
      end;
    eos: begin
      sym := symtype(eofsy,noop);
      getnuchar := false;
      useful := true
      end
  end {case};
  if getnuchar then nextch;
{ write(output,'sym.sy=',ord(sym.sy),NL); 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 pass1error(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
  pass1error(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 pass1error(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[1..204] of char;
const
  names = nametab(
chr(3),'g','e','t',
chr(3),'p','u','t',
chr(5),'b','r','e','a','k',
chr(4),'s','e','e','k',
chr(5),'r','e','s','e','t',
chr(7),'r','e','w','r','i','t','e',
chr(6),'u','p','d','a','t','e',
chr(4),'r','e','a','d',
chr(6),'r','e','a','d','l','n',
chr(5),'w','r','i','t','e',
chr(7),'w','r','i','t','e','l','n',
chr(13),'e','o','f',
chr(14),'e','o','l','n',
chr(3),'n','e','w',
chr(4),'f','r','e','e',
chr(4),'m','a','r','k',
chr(7),'r','e','l','e','a','s','e',
chr(14),'p','r','e','d',
chr(14),'s','u','c','c',
chr(13),'a','n','y',
chr(3),'a','l','l',
chr(13),'o','d','d',
chr(13),'o','r','d',
chr(13),'c','h','r',
chr(15),'f','l','o','a','t',
chr(15),'t','r','u','n','c',
chr(15),'r','o','u','n','d',
chr(13),'m','a','x',
chr(13),'m','i','n',
chr(4),'c','e','i','l',
chr(5),'f','l','o','o','r',
chr(13),'a','b','s',
chr(13),'s','q','r',
chr(14),'s','q','r','t',
chr(12),'l','n',
chr(13),'e','x','p',
chr(13),'s','i','n',
chr(13),'c','o','s',
chr(16),'a','r','c','t','a','n',
chr(4),'p','a','g','e'
);
 
 
var
  p, p1: itp;
  q: stp;
  i,j,k,l: integer;
begin {inittables}
{$Y-}
{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 := 2; 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***}
  j := 1;
  for i := 0 to nrbuiltin-1 do begin
    with id do begin
      l := names[j];
      q := nil;
      if l > chr(10) then begin
	l := chr(ord(l) - 10);
	q := intptr		{anything will do as long as not nil}
      end;
      j := j + 1;
      for k := 1 to ord(l) do begin
        s[k] := names[j];
        j := j + 1
      end
    end;
    newid(proc,q,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
{$Y+}
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
{   write(output,"c:",fp:8,llink:8,rlink:8,itype:8,NL); break(output); {DEBUG}
    markctp(llink);
    markctp(rlink);
    markstp(itype)
  end {with}
end {markctp};
 
procedure followctp (fp: itp); forward;
 
procedure followstp (fp: stp);
type
  typenamtab = array[forms] of array[0..7] of char;
const
  typename = typenamtab(
    'scalar  ','boolean ','char    ','integer ',
    'longint ','real    ','longreal','pointer ',
    'set     ','array   ','record  ','file    ',
    'tagfield','variant ');
begin {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);
	  write(lst, '] of', NL, '		');
          followstp(aeltyp)
          end;
        recordt:begin
	  write(lst,' of',NL);
          followctp(fstfld);
          followstp(recvar)
          end;
        filet:begin
          followstp(filtyp)
          end;
        tagfield:begin
          followstp(fstvar)
          end;
        variant:begin
          followstp(nxtvar);
          followstp(subvar)
          end
	end {case}
      end {if marked}
  end {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}, filsiz {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)-1] 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 pass1error(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 pass1error(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);
      pass1error( 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.avalue.daddr)
    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};
 
 
procedure invoke (nrargs, procnr: integer);
{ invoke runtime library routine 'procnr' }
begin {invoke}
  genbyte(138 {INVOK});
  genbyte(nrargs);
  genword(procnr)
end {invoke};
 
 
 
 
 
function comptypes(fq1, fq2: stp): boolean;
var
  form2: forms;
{  compat: boolean;}
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
    comptypes := false;	{until shown otherwise}
    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"}
	if form2 = scalar then
	  if maxconst = fq2@.maxconst then
	    comptypes := true;
	{comptypes := (form2 = scalar) and (maxconst = fq2@.maxconst);}
      booleant, chart:
	if form2 = form then
	  comptypes := true;
	{comptypes := (form2 = form);}
      integert, longintt:
	if (form2 = integert) or (form2 = longintt) then
	  comptypes := true;
	{comptypes := (form2 = integert) or (form2 = longintt);}
      realt, longrealt:
	if (form2 = realt) or (form2 = longrealt) then
	  comptypes := true;
	{comptypes := (form2 = realt) or (form2 = longrealt);}
      pointer:
	{P-compiler note: code is much different here}
	if form2 = pointer then
	  if comptypes(eltype, fq2@.eltype) then
	    comptypes := true;
	{comptypes := (form2 = pointer) and comptypes(eltype, fq2@.eltype);}
      sett:
	if form2 = sett then
	  if comptypes(settyp, fq2@.settyp) then
	    comptypes := true;
	{comptypes := (form2 = sett) and comptypes(settyp, fq2@.settyp);}
      arrayt: {begin}
	if form2 = arrayt then
	  if comptypes(aeltyp, fq2@.aeltyp) then
	    if comptypes(inxtyp, fq2@.inxtyp) then
	      if not option['Y'] or (size = fq2@.size) then
		comptypes := true;
	{compat := (form2 = arrayt) and comptypes(aeltyp, fq2@.aeltyp)}
	{	and comptypes(inxtyp, fq2@.inxtyp);}
	{if option['Y'] then compat := compat and (size = fq2@.size);}
	{comptypes := compat;}
	{P-compiler note: sizes must also be equal}
	{P-compiler note: "alternatives:
	 ... indextype must be compatible.
	 ... lowbounds must be the same."}
	{end; }{arrayt}
      recordt: ;
	{comptypes := false;}
	{P-compiler note:"identical records are recognized
	 to be compatible iff no variants occur"}
      filet:
	if form2 =filet then
	  if comptypes(filtyp, fq2@.filtyp) then
	    comptypes := true
	{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.addr := gattr.avalue.daddr;
      gattr.akind := exp {ref}
      end;
    reel: { coming attraction };
    setc: { coming attraction }
    end;
  exp,	{kludge for structured constants}
  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 {exp}{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 pass1error(141);
      genload;
      gattr.access := indirect;
      gattr.addr := 0
      end;
    insymbol;
    more := true
    end { atsign }
  else if sym.sy = period then begin
    if (gattr.akind = cst) or (gattr.access = indexed) then begin
      genload;
      gattr.access := offset;
      gattr.addr := 0
      end;
    if (gattr.atype <> nil) and (gattr.atype@.form <> recordt) then
      begin pass1error(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
	  pass1error(152);
	  gattr.atype := nil
	  end
	end;
      insymbol
      end
    else pass1error(2);
    more := true
    end { period }
  else if sym.sy = lbrack then begin
    repeat
      if (gattr.atype <> nil) and (gattr.atype@.form <> arrayt) then
	begin pass1error(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 pass1error(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 pass1error(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 char {0..255};
const
  binopcodes = binoptab (
{ *         /        and       div 
 mod        +         -         or
  <         <=        >=        >
  <>        =         in       max 
 min       cei       flo       nop }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr( 29), chr( 27), chr( 28), chr( 26),
 chr( 25), chr( 24), chr(  0), chr( 30),
 chr( 31), chr(  0), chr(  0), chr(  0)),{ scalar }
(chr(  0), chr(  0), chr(111), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(110),
 chr(109), chr(107), chr(108), chr(106),
 chr(105), chr(104), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ booleant }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr( 29), chr( 27), chr( 28), chr( 26),
 chr( 25), chr( 24), chr(  0), chr( 30),
 chr( 31), chr(  0), chr(  0), chr(  0)),{ chart }
(chr( 34), chr(  0), chr(  0), chr( 35),
 chr( 36), chr( 32), chr( 33), chr(  0),
 chr( 61), chr( 59), chr( 60), chr( 58),
 chr( 57), chr( 56), chr(  0), chr( 62),
 chr( 63), chr( 44), chr( 45), chr(  0)),{ integert }
(chr( 34), chr(  0), chr(  0), chr( 35),
 chr( 36), chr( 32), chr( 33), chr(  0),
 chr( 61), chr( 59), chr( 60), chr( 58),
 chr( 57), chr( 56), chr(  0), chr( 62),
 chr( 63), chr( 44), chr( 45), chr(  0)),{ longintt }
(chr( 66), chr( 67), chr(  0), chr(  0),
 chr(  0), chr( 64), chr( 65), chr(  0),
 chr( 93), chr( 91), chr( 92), chr( 90),
 chr( 89), chr( 88), chr(  0), chr( 94),
 chr( 95), chr(  0), chr(  0), chr(  0)),{ realt }
(chr( 66), chr( 67), chr(  0), chr(  0),
 chr(  0), chr( 64), chr( 65), chr(  0),
 chr( 93), chr( 91), chr( 92), chr( 90),
 chr( 89), chr( 88), chr(  0), chr( 94),
 chr( 95), chr(  0), chr(  0), chr(  0)),{ longrealt }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr( 25), chr( 24), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0),chr(  0)),{ pointer }
(chr(114), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(113), chr(115), chr(  0),
 chr(  0), chr(123), chr(124), chr(  0),
 chr(121), chr(120), chr(126), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ sett }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(173), chr(171), chr(172), chr(170),
 chr(169), chr(168), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ arrayt }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ recordt }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ filet }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)),{ tagfield }
(chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0),
 chr(  0), chr(  0), chr(  0), chr(  0)));{variant }
var
  q: stp;
  s: @stndset;
  r: @longreal;
  opcode: 0..255;
  compat: boolean;
begin {binop}
compat := true;
if (fop = inop) and (gattr.atype <> nil) then
  if gattr.atype@.form = sett then
    q := gattr.atype@.settyp
  else begin
    pass1error(134);  compat := false;
    q := nil
  end
else
  q := gattr.atype;
if not comptypes(q, fattr.atype) then
  begin pass1error(134);  compat := false end;
if gattr.atype <> nil then begin
  opcode := ord(binopcodes[gattr.atype@.form][fop]);
  if opcode = 0 then
    begin pass1error(134);  compat := false end
  else if gattr.atype@.form = arrayt then begin
    if not comptypes(gattr.atype@.aeltyp, charptr) then
      begin pass1error(134);  compat := false end;
    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> }
	if compat then
	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: pass1error(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@;
	      rdiv:
		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:
		pass1error(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:
		pass1error(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
	  pass1error(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 pass1error(154);
	genbyte(9 {REFER})
      end {vkind = formal}
      else if vkind = largeparam then
      begin
	genbyte(9 {REFER})
      end {vkind = largeparam};
      p := p@.next
      end
    else pass1error(126);	{ nr actuals > nr formals }
    nrofparm := succ(nrofparm)
  until sym.sy <> comma;
  if sym.sy = rparen then insymbol else pass1error(4)
  end;
if p <> nil then pass1error(126);	{ nr formals > nr actuals }
if fp@.paddr = 0 then pass1error(401);	{ illegal call on main program }
genbyte(208 + fp@.plev {CALL});
genbyte(retvsize);
genword(fp@.paddr {proc nr});
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 pass1error(116);
while sym.sy = comma do begin
  insymbol;
  expression;
  if q = nil then
    pass1error(116)
  else begin
    if q@.form = tagfield then begin
      if not comptypes(gattr.atype, q@.tagtyp) then pass1error(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 pass1error(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});
invoke(1, 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,26, 0, 0, 0, 0);
    writecode = rwtab( 0,29,25,31, 0,41,43,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);
	  nrparm := 2;
	  expression;				{compute varble}
	  genbyte(9 {REFER});
	  if gattr.atype <> nil then begin
	    code := readcode[gattr.atype@.form];
	    if code = 26 {array} then
	      if gattr.atype@.aeltyp = charptr then begin
		genlit(gattr.atype@.size);
		nrparm := 3
	      end
	      else
		code := 0;
	    if code = 0 then pass1error(116)
	  end else code := 0;
	  invoke(nrparm, 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 pass1error(116)
	  end else code := 0;
	  if sym.sy = colon then begin		{field width}
	    insymbol;
	    valueexpression;
	    if not comptypes(gattr.atype, intptr) then pass1error(116);
	    if (code=41) or (code=43) then		{reals}
	      if sym.sy = colon then begin		{fraction width}
		insymbol;
		valueexpression;
		if not comptypes(gattr.atype, intptr) then pass1error(116);
		nrparm := 4;
		code := code - 6
	      end
	  end else
	    genlit(0);			{default field width}
	  invoke(nrparm, 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;
      invoke(1, 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, write or page} then pass1error(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 pass1error(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}
  if (apsinx >= 11) and (apsinx <> 39) then	{eof, eoln}
  begin
    if apsinx = 11 then begin   {eof}
      genbyte(132 {OFSET}); genbyte(1 {size}); genword(2 {offset to eof byte});
    end else begin              {eoln}
      if UNIX then begin
	if not comptypes(filetype,textptr) then pass1error(169)	{UNIX}
      end else begin
	if filetype <> textptr then pass1error(169)		{DEC OS}
      end;
      genbyte(132 {OFSET}); genbyte(1 {size}); genword(3 {offset to eoln byte})
    end;
    gattr.atype := boolptr
  end else begin
    genbyte(9 {REFER});	{Remaining procs REFER to fileblock}
    case apsinx of
      0,1: begin				{get - put}
{        genlit(typsize(gattr.atype@.filtyp));}
	invoke(1{2}, apsinx+21)
        end;
      2: begin				{break}
	invoke(1, 23)
        end;
      3: begin				{seek}
	  warning( 413 );
	  if sym.sy = comma then begin
	    insymbol;
	    valueexpression;
	    invoke(2, 18)
	    end
        end;
      4, 5, 6: begin				{reset, rewrite, [update]}
        {Rewritten to permit "anonymous" files, according to standard}
{	if apsinx = 6 }{update}{ then pass1error(not_yet_impl);}
        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 pass1error(116);
          genbyte(9 {REFER});
        end else begin
	  pass1error(126);	{ NBS Pascal requires at least two args - for now }
	  genlit(0 {nil - default filename});
	end;
	{ for DEC OS, check for 3rd arg, default extension (string): }
	{ for DEC OS, check for 4rd arg, file attribute (integer): }
	if not UNIX then
	begin
	  if sym.sy = comma then
	  begin
	    insymbol;
	    valueexpression;
	    if (gattr.atype <> nil) and ((gattr.atype@.form <> arrayt)
				or (gattr.atype@.aeltyp <> charptr))
	      then pass1error(116);
	    genbyte(9 {REFER})
	  end
	  else  genlit(0 {no default required});
	  if sym.sy = comma then
	  begin
	    insymbol;
	    valueexpression
	  end
	  else genlit(filetype@.size {default file attr})
	end;
	genlit(apsinx-3);		{mode: 1=>reset, 2=>rewrite, 3=>update}
	if UNIX then invoke(3, 17 {openfile})	{UNIX}
		else invoke(5, 17 {openfile})	{DEC OS}
        end;
      7, 9: begin			{read, write}
	if not comptypes(filetype,textptr) then pass1error(169);
	if not defaulted then
	  if sym.sy = comma then insymbol else pass1error(20);
        readwrite(false)
        end;
      8, 10: begin			{readln, writeln}
        if UNIX then begin
	  if not comptypes(filetype,textptr) then pass1error(169)	{UNIX}
        end else begin
	  if filetype <> textptr then pass1error(169)		{DEC OS}
        end;
	if (not defaulted) and (sym.sy = comma) then insymbol;
        readwrite(true)
	end;
      39: begin				{page}
	if not comptypes(filetype, textptr) then pass1error(169);
	invoke(1, 47 {page})
        end
    end {case}
  end {else case};
  if not noarg then if sym.sy = rparen then insymbol else pass1error(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 pass1error(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 }
	invoke(0, psinx-9);
	lkind := exp
	end;
      17: begin				{ pred }
	if (gattr.atype <> nil) and (gattr.atype@.form > integert)
	  then pass1error(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 pass1error(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 pass1error(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 pass1error(125);
	gattr.atype := boolptr
	end;
      22: begin				{ ord }
	if (gattr.atype <> nil) and (gattr.atype@.form > integert) then
	  pass1error(125);
	gattr.atype := intptr
	end;
      23: begin				{ chr }
	if comptypes(gattr.atype, intptr) then
	begin
	  if gattr.akind = cst then with gattr.avalue do
	    if (ival<0) or (ival>255) then pass1error(125)
	end
	  else pass1error(125);
	gattr.atype := charptr
	end;
      24: begin				{ float }
	if not comptypes(gattr.atype, intptr) then pass1error(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 pass1error(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 pass1error(125);
	if gattr.akind = cst then begin
	  pass1error(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 pass1error(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 pass1error(125);
 
      14,				{ free }
      20,				{ all }
      29,				{ ceil }
      30: pass1error(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 pass1error(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 pass1error(125);
	  invoke(1, 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 pass1error(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
  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;

procedure bigstructconst(fp:stp);

var
  i : integer;

begin
  structconst(fp);
  gendat(gattr);
  case gattr.avalue.kind of
    lit: if typsize(fp)<auword then
           gendbyte(gattr.avalue.ival)
         else
           gendword(gattr.avalue.ival);
    reel: for i := 0 to ((typsize(fp) div auword)-1) do
            gendword(gattr.avalue.xval@[i]);
    data, setc: ;
  end;
  gattr.atype := fq;
  gattr.akind := cst;
  gattr.avalue.kind := data;
  gattr.avalue.daddr := caddr
end;

begin {structconst}
if fq <> nil then begin
  case fq@.form of
    scalar, booleant, chart, integert, longintt, realt, longrealt, sett: begin
      expression;
      if gattr.akind <> cst then pass1error(106);
      if not comptypes(gattr.atype, fq) then pass1error(134)
      end;
    arrayt: begin
      nrelts := fq@.size;		{ nr elts in array }
      if odd(dc) and (typalign(fq) > 1) then gendbyte(0);
      caddr := dc;
      if sym.sy = lparen then begin
	repeat
	  insymbol;
	  bigstructconst(fq@.aeltyp);
          nrelts := pred(nrelts)
	until sym.sy <> comma;
        if nrelts <> 0 then pass1error(126);
	if sym.sy = rparen then insymbol else pass1error(4)
	end
      else if sym.sy = stringconst then begin
	expression;
        if not comptypes(gattr.atype, fq) then pass1error(134);
        eltsiz := nrelts - gattr.atype@.size;
        if eltsiz < 0 then
          pass1error(50)
        else
          for nrelts := 1 to eltsiz do
            gendbyte(0)
	end
      else pass1error(9)
      end;
    recordt: begin
      nxtfld := fq@.fstfld;
      if odd(dc) and (typalign(fq) > 1) then gendbyte(0);
      caddr := dc;
      if sym.sy = lparen then begin
	repeat
	  insymbol;
	  if nxtfld <> nil then begin
            for nrelts := 1 to nxtfld@.fdisp-(dc-caddr) do
              gendbyte(0);
	    bigstructconst(nxtfld@.itype);
	    nxtfld := nxtfld@.next
	    end
          else pass1error(126)
	until sym.sy <> comma;
	if sym.sy = rparen then insymbol else pass1error(4);
        for nrelts := 1 to fq@.size-(dc-caddr) do
          gendbyte(0)
	end
      else pass1error(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 pass1error(9);}
	if sym.sy <> lparen then pass1error(9);
	warning(414);
	structconst(p@.itype);
	{if sym.sy = rparen then insymbol else pass1error(4);}
	gattr.akind := cst;
	gattr.atype := p@.itype
	end;
      vars, field, konst:
	selector(p);
      proc: begin
	if p@.itype = nil then
	  pass1error(103);
	call(p)
        end
      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) and (string[0] <> chr(0)) 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 pass1error(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
      pass1error(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 pass1error(137)
	      else { variable element }
		if varpart then
		  genbyte(118 {SADEL})
		else begin
		  genbyte(117 {SGENS});
		  varpart := true
		  end;
	      q := gattr.atype
	      end
	    else pass1error(136)
	    end
	  else pass1error(137)
	end;
      exit if sym.sy <> comma;
	insymbol
      end
    end;
    if sym.sy = rbrack then insymbol else pass1error(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,beginsy,ifsy,casesy,repeatsy,whilesy,
  forsy,withsy,loopsy,gotosy,exitsy,endsy,elsesy,untilsy,
  ofsy,dosy,tosy,downtosy,thensy,
  labelsy,eofsy,othersy:
    begin
      pass1error(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 pass1error(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:
      pass1error(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 pass1error(106);
q1 := gattr.atype;
lmin := gattr.avalue.ival;
if sym.sy = colon then insymbol else pass1error(5);
expression;
if gattr.akind <> cst then pass1error(106);
if gattr.avalue.ival < lmin then pass1error(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 pass1error(148)
    end
  else pass1error(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 pass1error(2);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = colon then insymbol else pass1error(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 pass1error(2)
	end
      else p := nil;
      id := lid;
      p1 := searchid([types]);
      q5 := p1@.itype;
      if q5@.form > longintt then begin pass1error(110); q5 := nil end;
      tagtyp := q5
      end
    else pass1error(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 pass1error(8);
  q1 := nil;
  minsize := fldoffset; maxsize := fldoffset;
  loop		{ parse variants }
    q2 := nil;
    loop
      expression;
      if not comptypes(gattr.atype, q5) then pass1error(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 pass1error(5);
    if sym.sy = lparen then insymbol else pass1error(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 pass1error(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 pass1error(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 pass1error(2)
    until sym.sy <> comma;
    maxconst := p
    end;
  top := oldtop;
  if sym.sy = rparen then insymbol else pass1error(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 pass1error(108)
	end;
      insymbol	{ gobble up ident }
      end
    else pass1error(2)
    end
  end { atsign };
arraysy: begin
  insymbol;	{ gobble up 'array' }
  if sym.sy = lbrack then insymbol else pass1error(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 pass1error(113)
      else if (form=realt) or (form=longrealt) then pass1error(109)
      else if ((form=integert) or (form=longintt))
	and not subrange then pass1error(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 pass1error(12);
  if sym.sy = ofsy then insymbol else pass1error(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 pass1error(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 pass1error(13)
  end { recordsy };
setsy: begin
  insymbol;	{ gobble up 'set' }
  if sym.sy = ofsy then insymbol else pass1error(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 pass1error(8); { gobble up 'of' }
  typ(q1);
  if q1 <> nil then
    if q1@.form > recordt then begin
      pass1error(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, beginsy, ifsy, casesy,
repeatsy, whilesy, forsy, withsy, loopsy, gotosy, exitsy,
endsy, elsesy, untilsy, ofsy, dosy, tosy, downtosy, thensy,
othersy, packedsy, nilsy, eofsy, labelsy:
 {... in other words - default }
begin
  pass1error(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 pass1error(16);
  expression;
  if (gattr.akind <> cst) then pass1error(106);
  with p@ do begin
    itype := gattr.atype;  value := gattr.avalue
    end;
  if sym.sy = semicolon then insymbol else pass1error(14)
  end
end {constdecl};
 
 
procedure labeldecl;
begin {labeldecl}
  pass1error(not_yet_impl);
  loop
    if sym.sy = intconst then
    begin
      insymbol
    end
    else pass1error(15);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = semicolon then insymbol else pass1error(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 pass1error(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 pass1error(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 pass1error(2);
  exit if sym.sy <> comma;
    insymbol
  end;
  if sym.sy = colon then insymbol else pass1error(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 pass1error(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 pass1error(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 pass1error(5);
  exit if sym.sy <> semicolon;
    insymbol
  end;
  if sym.sy = rparen then insymbol else pass1error(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});  genword(pin);  genbyte(ord(langcode)-ord(extn)+1);
  genid(fp@.name);
  genbyte(5 {ident}); genid( fp@.name );
  genbyte(7 {end});   genword(pin {proc nr});
  if langcode = forw then
    rvsize := 255
  else
    rvsize := typsize( fp@.itype );
  genbyte( rvsize );  genword( lc ); genword( ac-rvsize );
  genword( dc );
end {externs};
 
 
procedure directive;
begin {directive}
  if id.s = 'forward        ' then
  begin
    if wasforward then pass1error(161)
    else begin
      p4@.pkind := forw;
      externs(p4, forw)
    end
  end
  else if id.s = 'external       ' then
  begin
    p4@.pkind := extn;  externs(p4, extn)
  end
  else if id.s = 'cext           ' then
  begin
    p4@.pkind := cee;   externs(p4, cee)
  end
  else if id.s = 'fortran        ' then
  begin
    if hasvalueparam then pass1error(182);
    p4@.pkind := fort;  externs(p4, fort)
  end
  else begin
    warning(420);				{ unknown directive }
    p4@.pkind := extn; externs(p4, extn);	{ assume external }
  end;
  insymbol	{ gobble up directive }
end {directive};
 
 
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 pass1error(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 pass1error(2);
oldlevel := level;
if level < maxlevel then level := succ(level) else pass1error(251);
oldtop := top;
if top < maxdis then begin
  top := succ(top);
  with display[top] do begin
    occur := blck;  fname := p2
    end
  end
else pass1error(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 pass1error(5);
    if p4@.itype <> nil then begin
      if p4@.itype@.form > pointer then begin
	pass1error(120);
	p4@.itype := nil
	end;
      {$Y-}
      id := idtype(chr(3),'.rv');  { enter dummy ident for returned value }
      {$Y+}
      newid(vars, p4@.itype, p3, p2);
      with p2@ do begin
	vkind := param;  vlev := level
	end;
      p4@.next := p2;
      parmaddr(p2)
      end
    else pass1error(123)
    end
  end;
if sym.sy = semicolon then insymbol else pass1error(14);
if sym.sy = ident then directive
else begin	{ parse procedure definition }
  p4@.pkind := decl;
  genbyte(6 {proc});
  genword(pin);			{proc nr}
  genbyte(0 {not extern});	{type}
  genid(p4@.name);		{id}
  block(p4)
  end;
if sym.sy = semicolon then insymbol else pass1error(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;
  newlinenr : boolean;
  genlinenr, savelinenr: integer;
 
 
procedure assignment(fp: itp);
var
  q: stp;
  s, t: integer;
begin {assignment}
with fp@ do
  if (class = proc) {and (itype <> nil)} then
    if (pkind = decl) and (plev + 1 = level) then
      fp := next	{ dummy variable for returned value }
    else begin
      if pkind = stnd then
	pass1error(150)
      else
	pass1error(177);
      fp := udptrs[proc]	{careful of sideeffects}
    end;
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 pass1error(129)
    else
      if form = sett then setcoerce(q);		{ to make empty sets behave }
    if form = arrayt then begin
      genbyte(135 {MOVEM});
      t := min(typsize(q), typsize(gattr.atype));
      s := 1;
      if not (odd(t) or odd(typalign(q))) then begin
	s := 2;  t := t div 2
      end;
      genbyte(s);
      genword(t)
      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 pass1error(51)
end {assignment};
 
 
procedure gotostatement;
begin {gotostatement}
  pass1error(not_yet_impl);
  genbyte(8 {NULL});	{ temporary, in place of goto op }
  if sym.sy = intconst then
  begin
    insymbol
  end
  else pass1error(15)
end {gotostatement};
 
 
procedure ifstatement;
begin {ifstatement}
  valueexpression;
  if not comptypes(gattr.atype, boolptr) then pass1error(135);
  if sym.sy = thensy then insymbol else pass1error(52);
  statement;
  if sym.sy = elsesy
  then begin insymbol; statement end
  else genbyte(8 {NULL});
  genbyte(144 {IF})
end {ifstatement};
 
 
procedure casestatement;
const
  minlab = -255;
  maxlab =  255;
var
  q: stp;
  lmin, lmax, nrent, nrval: integer;
  cslab, elm, ind, tmp: integer;
  fixedrange: boolean;
  usedlabels: array [0..31] of stndset;
  { Note: elm, ind, and the above array are artifacts
    of the small set size.  This will be changed when
    larger sets are implemented. }
begin {casestatement}
  for ind := 0 to 31 do usedlabels[ind] := [];
  valueexpression;
  q := gattr.atype;
  if q <> nil then
    if q@.form > integert then pass1error(173);
  getbounds(q, lmin, lmax);
  fixedrange := (lmin<>0) or (lmax<>0);
  if gattr.akind = exp then fixedrange := false;
  if sym.sy = ofsy then insymbol else pass1error(8);
  nrent := 1;
  loop
    nrval := 0;
    loop
      expression;
      if gattr.akind = cst
      then begin
        if q <> nil
        then begin
	  cslab := gattr.avalue.ival;
	  if comptypes(gattr.atype, q) then
	  begin
	    if fixedrange then
	      if ((cslab<lmin) or (cslab>lmax)) then pass1error(147);
	  end
	    else pass1error(147);
	  if (cslab>=minlab) and (cslab<=maxlab) then
	  begin
	    tmp := cslab - minlab;
	    ind := tmp div 16;
	    elm := tmp mod 16;
	    if elm in usedlabels[ind] then pass1error(156)
	      else usedlabels[ind] := [elm] + usedlabels[ind]
	  end;
	  genlit(cslab);
	  if not fixedrange then
	  begin
	    lmin := min(lmin, cslab);
	    lmax := max(lmax, cslab)
	  end;
	  nrval := succ(nrval)
	end
      end
      else pass1error(106);
    exit if sym.sy <> comma;
      insymbol
    end {loop};
    if sym.sy = colon then insymbol else pass1error(5);
    statement;
    genbyte(146 {ENTRY});
    genbyte(nrval);
    nrent := succ(nrent);
  exit if sym.sy <> semicolon;
    insymbol;
  exit if (sym.sy = endsy) or (sym.sy = elsesy);
  end {loop};
  if sym.sy <> elsesy then
    genbyte(8 {NULL})	{hook for future 'otherwise' extension}
  else begin
    warning(416);
    insymbol;
    statement;
    if sym.sy = semicolon then insymbol
  end;
  nrent := succ(nrent);
  if sym.sy = endsy then insymbol else pass1error(13);
  if (lmin < minlab) or (lmax > maxlab)
    or ((lmax-lmin)>255) or (nrent>253) then pass1error(157);
  genlit(lmin);		{min case label}
  genbyte(145 {CASE});
  genbyte(nrent+1);
  genbyte(lmax)		{max case label}
end {casestatement};
 
 
procedure repeatstatement;
begin {repeatstatement}
  statelist(nil, untilsy);
  if sym.sy = untilsy
  then begin
    insymbol;
    valueexpression;
    if not comptypes(gattr.atype, boolptr) then pass1error(135);
    genbyte(8 {NULL});	{ no exit stub }
    genbyte(148 {EXIT})
  end
  else pass1error(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 pass1error(135);
  if sym.sy = dosy then insymbol else pass1error(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 pass1error(56);
      valueexpression;
      if not comptypes(gattr.atype, boolptr) then pass1error(135);
      if sym.sy = thensy then begin
        insymbol;
        statement
      end
      else
        genbyte(8 {NULL});	{ no exit stub }
      genbyte(148 {EXIT});
      nrexits := succ(nrexits)
    end
    else pass1error(57);
  exit if sym.sy <> semicolon then genbyte(8 {NULL});
    insymbol
  end {loop};
  if sym.sy = endsy then insymbol else pass1error(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]);
  if p <> nil then		{ check that control var is a local }
  with p@ do			{ entire-variable of an ordinal-type: }
    if vkind <> local then pass1error(143)
      else if vlev <> level then pass1error(143)
      else if itype@.form > longintt then pass1error(143);
  selector(p);
  insymbol
  end
else pass1error(2);
if sym.sy = becomes
then begin insymbol; valueexpression end
else pass1error(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 pass1error(55);
if sym.sy = dosy then insymbol else pass1error(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}]);	{exclude structured constants}
    insymbol
    end
  else begin
    pass1error(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 pass1error(250)
      end
    else pass1error(140);
exit if sym.sy <> comma;
  insymbol
end;
if sym.sy = dosy then insymbol else pass1error(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: }
newlinenr := oldlinenr <> linenr;
genlinenr := linenr;
savelinenr := oldlinenr;
oldlinenr := linenr;
if sym.sy = intconst then begin
  pass1error(not_yet_impl);
  insymbol;
  if sym.sy = colon then insymbol else pass1error(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; newlinenr := false; oldlinenr := savelinenr; 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: begin
    newlinenr := false;
    oldlinenr := savelinenr;
    genbyte(8 {NULL})
  end;
  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, nilsy, labelsy,
  ofsy, dosy, tosy, downtosy, thensy,
  othersy, eofsy:
    begin pass1error(6); insymbol end
  end; {case}
if option['G'] and newlinenr then begin
  genbyte(255 {LINE});
  genword(genlinenr)
end
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;
  s, t: integer;
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});
	    t := typsize(q);
	    s := 1;
	    if not (odd(t) or odd(typalign(q))) then begin
	      s := 2;  t := t div 2
	    end;
	    genbyte(s);
	    genword(t)
	  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 pass1error (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
    pass1error(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 pass1error(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
	invoke(1, 20 {close})
	end
      else begin
	with itype@ do
	  genlit(ceil(typsize(filtyp), typalign(filtyp)));
	invoke(2, 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}
  { start allocating global vars at loc 2.
    loc 0:  temporary for read/write. }
  lc := 2;
  {$Y-}
  id := idtype(chr(6), 'output');
  {$Y+}
  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 - 512 + 2);
  {$Y-}
  id := idtype(chr(5), 'input');
  {$Y+}
  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 - 512 + 2);
  { 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;
  {$Y-}
  id := idtype(chr(4), 'argv');
  {$Y+}
  newid(vars, q2, nil, p);
  with p@ do begin
    vkind := formal;  vlev := 1;  vaddr := 0
  end;
  {$Y-}
  id := idtype(chr(4), 'argc');
  {$Y+}
  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
      pass1error(18);  skip(semicolon);  insymbol
    end;
  while fwptr <> nil do
  begin
    pass1error(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});	genword(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
  Ok_to_proceed := true;
  if argc = 2 then begin
    reset(src, argv[1]@, "PAS");
    rewrite(int, "I");
    rewrite(dat, "D");
    rewrite(lst, "TT:")
  end
  else if argc = 6 then begin
    reset (src, argv[2]@, "PAS", 2);	{ source input }
    rewrite (int, argv[3]@);	{ intermediate code output }
    rewrite (dat, argv[4]@);	{ intermediate data output }
    rewrite (lst, argv[5]@, "LST", 2)	{ list output }
  end
  else begin
    Ok_to_proceed := false;
    if argc = 1 then
      writeln(pass1id, compiler_version, nbsversion@)
    else
      {$Y-}
      error(pass1id, "Bad command")
      {$Y+}
  end
end {openfiles};
 
 
procedure initialize;
var
  c: char;
begin {initialize}
  nbsversion := version;
{  write(output, NL, compiler_version, nbsversion@); break(output);}
  openfiles;
  if Ok_to_proceed then
  begin
    for c := 'A' to 'Z' do option[c] := false;
{    option['L'] := true;}	{ get the listing for now }
    option['C'] := true;	{ line count display on }
{    option['W'] := true;}	{ warnings on }
    option['Y'] := true;	{ enforce array size compatibility }
    option['Z'] := true;	{ snooze on error enabled }
    runtimcheks := 0;		{ initial R option }
    if argv[1]@[0] = '-' then begin
      chcnt := 0;
      loop
        chcnt := chcnt + 1;
        c := argv[1]@[chcnt];
      exit if c = chr(0);
        if (c >= 'A') and (c <= 'Z') then
          option[c] := not option[c];
      end
    end;
    prterr := true;
    errtot := 0; errinx := 0; linenr := 0; oldlinenr := 0;
    warntot := 0;
    maxpin := 0; dc := 0;
    chcnt := -1; ch := NL;
    pageno := 0; linesleft := 0;
    level := 0; top := 0; pin := 0;
    gattr.atype := nil; gattr.akind := cst;
    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 pass1error(2);
      if sym.sy = lparen then
      begin { ignore program parameters }
	skip(rparen);
	insymbol
      end;
      if sym.sy = semicolon then insymbol else pass1error(14)
    end {sy = programsy};
    if lcp = nil then
    begin
      {$Y-}
      id := idtype(chr(6),'.main.');
      {$Y+}
      newid(proc,nil,nil,lcp)
    end;
    with lcp@ do
    begin
      pkind := decl;
      plev := 0;
      paddr := 0
    end;
    level := 1; top := 1;
    genbyte(6 {proc});		{subprogram}
    genword(0);			{main}
    genbyte(0);			{locally declared}
    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 pass1error(21);
    endofline;
    if option['C'] then
      write(CR, ' ':8, CR);
    if errtot > 0 then
    begin
      {$Y-}
      error(pass1id, "");
      {$Y+}
      writeln(output, 'Pass1 errors: ', errtot);
      writeln(lst, ' *+*+* Pass1 errors: ', errtot)
    end;
    if warntot > 0 then
    begin
      {$Y-}
      warn(pass1id, "");
      {$Y+}
      writeln(output, 'Pass1 warnings: ', warntot);
      writeln(lst, ' *+*+* Pass1 warnings: ', warntot);
    end
  end {Ok_to_proceed}
end {P1FP}.