{$W-}
program P2FP (output, int, dat, ols, obj);
 
{N B S      P a s c a l      C o m p i l e r  --   P a s s   2}
 
{
 *Authors: Brian G. Lucas
 *         Justin C. Walker
 *Address comments to:
 *         Justin C. Walker
 *         Interactive Systems Corp
 *         1050 17th Street, N.W.
 *         Suite 580
 *         Washington, D.C.   20036
 * This software has been developed at the National Bureau of Standards.
 * As a product of the U.S. Government, it is in the public domain, and
 * should not be sold or otherwise used for profit.
}
 
{DEC OS versions maintained by DECUS Pascal SIG:
 John R. Barr     - University of Montana
 Bill Heidebrecht - TRW DSSG
 Brian Nelson     - University of Toledo
 
put together by Paul Lustgraaf, Iowa State University
from v1.6e for RT11 by John Barr
 and v1.6g for RSX }
 
const ht=chr(9); nl=chr(10); ff=chr(12);
      compiler_version = ' Pascal-NBS  V1.6g  7 Mar 83';
 
		{Operating system version:}
		{*************************}
const
	RSX11 = false;
	RSTS  = false;
	RT11  = true;
	UNIX  = false;
		{floating point version}
		{**********************}
	FPU = true;
	FIS = false;
 
type byte = char;
 
			{Description of node}
			{*******************}
const maxarg=255; litcode=chr(162);
type
  fvalue = array [0..3] of integer;
  fvalptr = @fvalue;
  ptn = @node;		{description of tree nodes}
  node = record
 	code: byte;	{indicates node type}
 	size: byte;
 	dsp: record case boolean of
          false: (disp: integer);
          true:  (xval: fvalptr) end;
 	segnr: byte;
        nrarg: byte;
        arg: array[1..maxarg] of ptn
	end;
var tree,				{pointer to expression tree}
  target: ptn;			{pointer to subtree target of store}
  sideeffects: boolean;	{true if subtree just traversed has sideeffects}
		{Description of symbol table}
		{***************************}
const
  maxsym = 150;
  maxnamesize = 15;
type
  symbol_types = (localsy, externalsy, ceesy, fortransy);
  stab =  {packed} record
   sname: array [0..5] of char;
   stype: symbol_types;
   snum: 0..255;  {arg count for use by pdb}
   sval: integer  {unique symbol number for searching}
  end;
var stable: array[0..maxsym] of stab;
  s,lastid: -1..maxsym;
 
 
 
			{Description of relocation info}
			{******************************}
type
  reltypes = (absact,absrel,txtact,txtrel,datact,datrel,bssact,bssrel,
		uxtact,uxtrel);
  relpair = record
		segnr: byte;
		reltype: reltypes
	    end;
const	{commonly used kinds of relocation}
  ordinary = relpair(chr(0), absact);
  global = relpair(chr(0), uxtact);
			{Description of code buffer}
			{**************************}
const maxcode=2047;	{size of code buffer}
  workspace=54;		{size of workspace area in code buffer}
  maxlexlev=15;		{Max lexical nesting level}
  maxrel=511;		{size of relocation table}
type codeindex=0..maxcode+workspace;
  relindex=0..maxrel {associative table for relocation data};
  relent = record
        rs: relpair;
        cix: codeindex
        end;
var
  codebuf: array[codeindex] of integer;
  reltab: array[relindex] of relent;
  cp,					{first empty cell beyond instructions}
  rlp: relindex;			{current reloc tab index}
  dcnt: integer;                        {sizes of text(words) and data(bytes)}
 
 
 
			{Description of register resources}
			{*********************************}
type
  registers=(gr0,gr1,gr2,gr3,gr4,gr5,fr0,fr1,fr2,fr3,stk,gcc,mem,dbl);
  resources=set of registers;
const
  evenregs=[gr0,gr2];
  oddregs=[gr1,gr3];
  gregs=evenregs + oddregs;
  fregs=[fr0,fr1,fr2,fr3];
  tregs=[gr2,gr3];
  assignable=gregs + fregs;
  maxtmpregs=2 {use two regs for temps};
var
  avail,			{the set of free registers}
  usedregs,			{the set of regs in use}
  pushdesire: resources;	{the set of registers desired for next push}
  truecode: integer;		{code of the last setting of condition code}
 
 
 
			{Description of operand status}
			{*****************************}
{pass2 uses an operand stack to keep track of the state of code generation
 during the tree walk by gencode.  This is done to avoid modifying the tree.}
const maxopstk=127; {max stack depth}
{machine dependent data structure parameters:}
  bitsize=chr(0); bytesize=chr(7); wordsize=chr(15); longsize=chr(31);
  floatsize=chr(31); doublesize=chr(63);
type
{Meaning of addrstates:
  liter   - literal (immediate value)
  based   - offset from base register
  indexed - offset from specified address
  indirect- operand is pointer
  loaded  - operand is on stack
  saved   - is in temp area of stack frame
  stored  - has been stored in target
  temp    - anonymous pointer from WITH
  copy    - copy of temp value
}
  addrstates = (liter,based,indexed,indirect,loaded,saved,stored,temp,copy);
  operstates = set of addrstates;
  operand = record
    state: operstates;
    adr: record case boolean of
      false: (addr: integer);
      true:  (xval: fvalptr) end;
    rel: relpair;
    reg: registers;
    opsize: byte
    end;
var
  tos: integer;
  opstk: array[0..maxopstk] of operand;
{whatwhere: specifies what to generate and where to leave it.
  noload    - Don't load value on stack
  loadvalue - Value of expression to be loaded
  loadaddr  - Address of operand to be loaded
  tryupdate - Check for possible in situ operation
}
type whatwhere=(noload,loadvalue,loadaddr,tryupdate);
{disposition: what to do with current tos.
  pop   - pop it off
  leave - leave it on
  push  - put a new value on
}
  disposition = (pop,leave,push);
 
 
 
				{Branch conditions}
				{*****************}
type
  brtypes=0..18 {encoding for branch types on PDP-11};
  brtabform=array[brtypes] of brtypes;
  brtabcode=array[brtypes] of integer;
const
  unconditional=1;	{ br code for unconditional branch }
  brtab=brtabcode(		{branch instruction codes}
  { 0-nop} 160,		{ 1-br} 256,	
  {signed tests}
  { 2-beq} 768,		{ 3-bne} 512,		{ 4-bgt} 1536,
  { 5-ble} 1792,	{ 6-bge} 1024,		{ 7-blt} 1280,
  { 8-bpl} -32768,	{ 9-bmi} -32512,
  {unsigned tests}
  {10-beq} 768,		{11-bne} 512,		{12-bhi} -32256,
  {13-blos} -32000,	{14-bhis,bcc} -31232,	{15-blo,bcs} -30976,
  {misc.}
  {16-bvc} -31744,	{17-bvs} -31488,	{18-sob} 32256);
  brinv=brtabform(	{inverse conditions}
    1,0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,18);
 
  brrev=brtabform(	{reverse conditions}
    0,1,2,3,7,6,5,4,8,9,10,11,15,14,13,12,16,17,18);
 
			{Branching and state information}
type
  fpustates = set of (double,single,long,short);
const
  fpuunknown = [double,single,long,short];
type
  blockstate = record
    roving: 0..maxlexlev;
    fpustate: fpustates
  end;
  branchlist = record
    last: codeindex;
    state: blockstate
  end;
const
  emptychain = branchlist( 0, ( 0, fpuunknown));
var
  lastbr: codeindex;			{ points to list of all branches }
  falsechain, truechain: branchlist;	{ conditional lists, state info. }
  curstate: blockstate;
 
 
 
				{Miscellaneous variables}
				{***********************}
var
  namesize: integer; 			{length of current procedure name}
  name: array [1..maxnamesize] of char;	{current procedure name}
  localsize,				{size of local variable area}
  tempbase,				{start of temp storage}
  paramsize,				{size of parameter area}
  rvsize,				{size of returned value, 0 if none}
  procnr,				{unique index of this procedure}
  calltype,				{internal,external,cee,fortran indicator}
  lexlev: integer;			{current lex level}
 
 
				{Files used in pass2}
				{*******************}
const
  intx=2;	{argv index to int code filename}
  olsx=5;       {" object listing filename}
  objx=4;	{" object code filename}
  datx=3;	{" initialized data filename}
  flgx=1;	{" pass2 switches}
  {switches to control output from pass2:
  list:  generate object listing (.ols); char O
  sdump: generate stack dump (standard output); char S
  dproc: generate name/procnumber concordance (.ols); char P
  xtern: generate symbolic external procedure names; char X
  }
var
  list, sdump, dproc, xtern: boolean;
  ols_opened, Ok_to_proceed: boolean;
  runtimcheks: integer;
 
  {files used by second pass:}
  int: text;			{file of intermediate code}
  ols: text;			{file to put object listings}
  obj: file of integer;		{object module file}
  dat: file of char;		{intermediate home for data and case tables}
 
procedure error(n:integer);
{assigned error numbers (arbitrary, more or less):
	#	where		why
	1	buildtree	stack-arg mismatch (s < argn)
	2	buildtree	stack overflow
	3	emit0
		emitaddr
		emitbranch	codebuf overflow
	4	emitaddr	reltab overflow
	6	newtos		opstk overflow
	9	buildtree	non-immediate litd processed (**TEMP**)
	10	refertotemp	can't find temp
	18	load		double load unimplemented
	19	store		multiple store unimplemented
	20	genfpconvert	round not yet implemented
	30	searchid	symtab overflow
	31	gencode		sadel not yet implemented
	32	gencode		set inclusion operators
				(<=, >=) not yet impl.
	44	getregister	no reg available
	45	move		insufficient registers available
	99	moduleident	illegal data in intermediate file
}
begin {error}
write(output,nl,'pass2 error ',n,' in ',name: namesize); break(output)
end {error};
 
 
function getbyte: byte;
begin
  getbyte := int@; get(int)
end {getbyte};
 
function getword: integer;
var temp: integer;
begin
  temp := ord(int@)*256;  get(int);
  getword := ord(int@)+temp;  get(int)
end {getword};
 
 
procedure openols; forward;
 
 
procedure readoptions;
var
  intopt: integer;
  boolopt: boolean;  ch: char;
begin {readoptions}
  ch := getbyte;	{ options switch A..Z }
  intopt := getword;	{ option value }
  boolopt := intopt > 0;
  if ch = 'O' then list  := boolopt
  else if ch = 'P' then dproc := boolopt
  else if ch = 'R' then runtimcheks := intopt
  else if ch = 'S' then sdump := boolopt
  else if ch = 'X' then xtern := boolopt
  else if ch = chr(2) then {abort p2}
  begin
    if Ok_to_proceed then
      writeln(output, nl, 'Code generation aborted.');
    Ok_to_proceed := false
  end
  { else ignore option. };
  if list or dproc then openols
end {readoptions};
 
 
procedure ident;
{Obtain main or procedure identification and id size}
var i: integer;
begin {ident}
  i := ord(getbyte);
  namesize := 0;
  while i > 0 do begin
    if namesize < maxnamesize
      then namesize := succ(namesize);
    name[namesize] := getbyte;
    i := pred(i)
  end
end {ident};
 
 
procedure buildtree;
 
	{special code values: call, varb, and parm all have the form
			+____+____+
			|    |    |
			+____+____+
			   |    |
			   |    Lex level referred to
			  "code"				}
const stacksize=256;
  ENDCODE=7;
var
  s: 0..stacksize;
  stack: array[1..stacksize] of ptn;
  coden,argn: integer;
  adrn: record case boolean of
    false: (addrn: integer);
    true:  (xval:  fvalptr) end;
  temp: ptn;
  sizen,segn,ch: byte;
  allign: integer; {to round out localsize if odd}
 
 
procedure read8 (var p: fvalptr);
{read 8 bytes of data to be used as a float constant.}
begin
  new(p);
  p@[0] := getword;
  p@[1] := getword;
  p@[2] := getword;
  p@[3] := getword
end {read8};
 
 
begin {buildtree}
s := 0;
repeat
  coden := ord(getbyte);
  if coden > 7
  then begin {not a pseudo op}
    if coden = 8
    then tree:=nil	{null node}
    else begin
      segn:=chr(0); adrn.addrn:=0; sizen:=chr(0);	{so subtreematch will work}
      argn:=0;
      case coden of
      176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191, {varb}
      192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207: {parm}
      begin segn:=chr(coden mod 16) {segn = lex level};
        sizen:=getbyte; adrn.addrn:=getword;
	{collapse code value} if coden < 192 then coden:=176 else coden:=192 end;
      162,163 {lit,rdata}: adrn.addrn := getword;
      164 {litd}: begin
      {Read in a floating lit, and make it 4 words long.}
	read8(adrn.xval);	{collect data for float lit}
        sizen := chr(2)
      end;
      140,141 {rtemp,dtemp}: begin adrn.addrn:=ord(getbyte);
        if coden=141 then argn:=2 end;
      131,132,133,134,135,168,169,170,171,172,173
	 {addressing, "vector" ops}: begin sizen:=getbyte; adrn.addrn:=getword;
        if coden>=134 then argn:=2 else argn:=1 end;
      146,147,152 {n-ary}: argn:=ord(getbyte) + 1;
      145 {case}: begin argn:=ord(getbyte); adrn.addrn:=ord(getbyte); end;
      138 {invoke}: begin argn:=ord(getbyte); adrn.addrn:=ord(getbyte);
	  if adrn.addrn=4 {new} then sizen:=chr(2)
	  {eof and eoln return a boolean value}
	  else if (adrn.addrn=47) or (adrn.addrn=48) then sizen := chr(1)
          else if adrn.addrn>100 then if FPU then sizen:= chr(8)
					else sizen := chr(4)
          {Note: system routines whose index is > 100
           are assumed to be longreal functions if fpu else real.}
      end;
      208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223: {call}
	begin segn:=chr(coden mod 16) {segn = lex level};
	sizen:=getbyte;
        adrn.addrn:=ord(getbyte); argn:=ord(getbyte);
	coden:=208 {collapse code value} end;
      149 {for}: argn:=5;
      144 {tertiary}: argn:=3;
      10,12,24,25,26,27,28,29,30,31,32,33,34,35,36,44,45,56,57,58,59,60,61,62,
      63,64,65,66,67,88,89,90,91,92,93,94,95,
      104,105,106,107,108,109,110,111,113,114,115,118,120,121,122,123,124,125,
      126,148 {binary}: begin argn:=2; sizen:=chr(2) end;
      9,16,17,37,40,41,42,69,72,73,74,75,76,96,112,117,127,159 {unary}:
        begin argn:=1; sizen:=chr(2) end
      end; {case}
      new(tree,argn);
      with tree@ do begin
 	code:=chr(coden); size:=chr(ord(sizen)*8-1);
 	dsp.disp:=adrn.addrn; segnr:=segn; nrarg:=chr(argn);
        if s<argn then begin error(1); argn:=0 end;
        while argn>0 do begin
          arg[argn] := stack[s]; argn := argn-1; s := s-1
          end
        end
      end; {not null node}
    if s>=stacksize then begin error(2); s:=0 end;
    s := s+1;
    stack[s] := tree
    end {not a pseudo op}
  else case coden of {pseudo ops}
    1 {xch}: {swap(stack[s],stack[s-1])}
      begin temp:=stack[s]; stack[s]:=stack[s-1]; stack[s-1]:=temp end;
    2 {del}: if s>0 then s:=s-1 else error(1);
    3: {option} readoptions;
    4: {word - should not occur};
    5 {ident}: ident;
    6: {proc} begin lexlev := lexlev+1; calltype := ord(getbyte) end;
    7 {end}:begin procnr:=ord(getbyte); rvsize:=ord(getbyte);
      localsize:=getword;
      allign:=1;
      if localsize<0 then allign:=-1;
      if odd(localsize) then localsize:=localsize+allign;
      tempbase:=localsize; paramsize:=getword;
      if odd(paramsize) then paramsize:=paramsize+1;
      dcnt:=getword;		{data size (bytes) as of this procedure}
      end
    end {pseudo ops}
until coden = ENDCODE;
end {buildtree};
 
 
 
procedure prescan;
{General tree-walk to permit any "1st pass" computations needed prior to
 code generation.  Currently, this includes:
	1. Register usage for temp values (FORCODE and DTEMP nodes)
 Starts with global pointer "tree", pointing to the head of the code
 tree for the current procedure.}
var i: integer;
 
  function tracetemp(pn: ptn): integer;
  {Count temps used by this subtree.  Store and return value as appropriate}
  const {node type, logic:}
    FORCODE  = 149; {check arg[5]; return num+1}
    DTEMP    = 141; {check arg[2]; return num+1}
    LOOPCODE = 147; {check arg[1]-arg[n]; return max}
    EXITCODE = 148; {check arg[2]; return num}
    SEQ      = 152; {check arg[1]-arg[n]; return max}
    IFCODE   = 144; {check arg[2],arg[3]; return max}
    CASECODE = 145; {check arg[1]-arg[n]; return max}
    ENDCODE  = 7;   {check arg[1]; return value}
 
  var lsize,i: integer;
 
  begin {tracetemp}
    lsize:=0;
    with pn@ do
      if ord(code)=FORCODE then
	begin lsize:=tracetemp(arg[5])+1; size:=chr(lsize) end
      else if ord(code)=DTEMP then
	begin lsize:=tracetemp(arg[2])+1; size:=chr(lsize) end
    else if ord(code)=CASECODE then 
    for i := 2 to ord(nrarg) do
      with arg[i]@ do
        lsize := max(lsize, tracetemp(arg[ord(nrarg)]))
    else if (ord(code)=LOOPCODE) or (ord(code)=SEQ) then
	for i:=1 to nrarg do lsize := max(lsize,tracetemp(arg[i]))
      else if ord(code)=IFCODE then begin
	lsize:=tracetemp(arg[2]);
	lsize:=max(lsize,tracetemp(arg[3]))
	end
      else if ord(code)=EXITCODE then
	lsize:=tracetemp(arg[2])
      else if ord(code)=ENDCODE then
	lsize:=tracetemp(arg[1]);
    tracetemp:=lsize
  end {tracetemp};
 
begin {prescan}
 i:=tracetemp(tree) {discard the temp count for the whole tree}
end {prescan};
 
 
 
{searchid - search symbol table, return the index of requested symbol;
	if not found, the symbol is added to the table and the new index
	is returned.  Its value is initialized to zero, and its type is
	set up according to isuser}
function searchid(symno:integer; isuser:boolean): integer;
 
var lchar: char;
  sym: array[0..5] of char;
  found: boolean;
  i: 0..maxsym;
 
procedure itoa(N:integer);
{translate N to a string, length 3, and start storing at sym[3]}
begin {itoa}
  sym[5]:=chr((N mod 10)+ord('0')); N:=N div 10;
  sym[4]:=chr((N mod 10)+ord('0')); N:=N div 10;
  sym[3]:=chr((N mod 10)+ord('0'))
end {itoa};
 
 
begin {searchid}
  if isuser and ((calltype<>0) or xtern) then
  begin {use first part of actual name:}
    i := 0;
    loop
      if i>namesize-1 then sym[i] := ' '
	else sym[i] := name[i+1];
      if (sym[i]>='a') and (sym[i]<='z')
	then sym[i]:=chr(ord(sym[i])-32);
      if sym[i] = '_' then sym[i] := '$';
    exit if i >= 5;
      i := succ(i);
    end {loop};
    if symno < 0 then
    begin {make const psect name unique
	   by ending it with a '.'}
      i := 0;
      repeat
	i := i + 1
      until (i = 5) or (sym[i] = ' ');
      sym[i] := '.'
    end
  end {use actual name}
  else begin {build a unique symbol:}
    if isuser then
      if symno >= 0 then lchar := 'I' {user proc}
		    else lchar := 'D' {consts}
	else lchar := '$'; {library proc}
    sym[0]:=lchar; sym[1]:=lchar; sym[2]:=lchar;
    itoa(max (0, symno))  {put 3 chars of symno into sym, from sym[3]}
  end;
  {look for the symbol}
  i:=0; found:=false;
  if i <= lastid then
    loop
      with stable[i] do if isuser
        then found := (sname[0]<>'$') and (sval=symno)
        else found := (sname[0]='$') and (sval=symno);
    exit if found or (i >= lastid);
      i:=i+1
    end;
  {put in table if not there}
  if not found then begin
    lastid:=succ(lastid);
    if lastid<=maxsym then
      with stable[lastid] do begin
        sname := sym;
        snum := 0;
        sval := symno;
        if isuser
          then case calltype of
            0: stype := localsy;
            1: stype := externalsy;
            2: stype := ceesy;
            3: stype := fortransy
            end
          else stype := localsy
      end
    else begin error(30); lastid:=pred(lastid) end;
    i:=lastid
  end;
  searchid:=ord(i)
end {searchid};
 
 
 
procedure newtos;
begin
if tos<maxopstk then tos:=tos+1 else error(6)
end {newtos};
 
procedure duptos;
begin
  newtos; opstk[tos]:=opstk[tos-1]
end {duptos};
 
procedure pushlit(n: integer);
begin
newtos;
with opstk[tos] do begin
  state:=[liter]; opsize:=wordsize;
  reg:=mem;
  adr.addr:=n; rel:=ordinary
  end
end {pushlit};
 
procedure pushlitd (n: integer);
begin
  pushlit( n );
  if FPU then opstk[tos].opsize := doublesize
  else opstk[tos].opsize := floatsize
end {pushlitd};
 
procedure emitaddr(i:integer; r:relpair);
begin
if r.reltype<>absact then begin
  with reltab[rlp] do begin rs:=r; cix:=cp end;
  if rlp=maxrel then error(4) else rlp:=rlp+1
  end;
codebuf[cp]:=i;
if cp=maxcode then error(3) else cp:=cp+1
end {emitaddr};
 
procedure emit0(i:integer);
begin
codebuf[cp]:=i;
if cp=maxcode then error(3) else cp:=cp+1
end {emit0};
 
 
 
procedure freeregister(reg: registers);
begin
avail:=avail + ([reg]*{inter}assignable);
end {freeregister};
 
procedure moveregister(from,too: registers);
const mov=4096{mov instr}; ldf=-2816{load floating reg};
	 stf=-2048{store floating reg};
var src,dst,lop: integer;
begin {moveregister}
lop:=mov;
if from=stk
then src:=22			{(sp)+}
else if from<fr0
  then src:=ord(from)
  else begin lop:=stf; src:=ord(from)-ord(fr0) end;
if too=stk
then dst:=38			{-(sp)}
else if too<fr0
  then dst:=ord(too)
  else begin lop:=ldf; dst:=ord(too)-ord(fr0) end;
if lop=ldf
then emit0(ldf+dst*64+src)
else emit0(lop+src*64+dst)
end {moveregister};
 
procedure saveregister(saveall: boolean; desire: resources);
var n,taddr: integer;
begin {saveregister}
n:=0;	{start from bottom of operand stack}
while (n<=tos) and (saveall or ((avail *{inter} desire)=[])) do
  begin with opstk[n] do
    if (state *{inter} [loaded,based,indexed] <> []) and
	 ([saved,copy,temp] *{inter} state = []) and (reg < stk) then begin
      moveregister(reg,stk);
      freeregister(reg);
      state:=state + [saved] -{sdiff} [copy]
    end;
  n:=succ(n)
  end
end {saveregister};
 
 
 
function getregister(desire: resources): registers;
var reg: registers;
begin {getregister}
if desire <> []
then if desire*{inter}assignable <> []
  then begin
    if desire * avail = [] then
      if gr4 in desire then avail := avail + [gr4]
      else saveregister(false, desire);
    if desire * avail = [] then error(44);
    reg:=any(desire*{inter}avail);
    avail:=avail-{sdiff}[reg];
    usedregs:=usedregs + [reg]
    end
  else reg:=any(desire)
else reg:=mem;
if reg = gr4 then curstate.roving:=0; {may use as scratch}
getregister:=reg
end {getregister};
 
procedure restoreregister(thru: integer; desire: resources);
var i: integer; lreg: registers; ldesire: resources;
begin {restoreregister}
i:=tos;		{restore from top of operand stack}
while i>=thru do begin
  with opstk[i] do if (saved in state) or (reg = stk) then
  begin
    if reg in avail then ldesire := [reg] else ldesire := desire;
    lreg := getregister(ldesire);
    moveregister(stk,lreg);
    reg := lreg;
    state:=state-[saved]
  end;
  i:=pred(i)
  end
end {restoreregister};
 
 
procedure swaptos;
var temp: operand;
begin {swaptos}
  if ((saved in opstk[tos].state) or (opstk[tos].reg=stk))
    and
     ((saved in opstk[tos-1].state) or (opstk[tos-1].reg=stk))
      then restoreregister(tos-1, gregs);
  temp := opstk[tos];
  opstk[tos] := opstk[tos-1];
  opstk[tos-1] := temp;
end {swaptos};
 
 
procedure emitbranch(brtype: brtypes; var list: branchlist);
begin {emitbranch}
if cp >= maxcode-3 then begin error(3); cp := 0 end;
if list.last = 0 then
  list.state := curstate
else begin
  if list.state.roving <> curstate.roving then list.state.roving := 0;
  list.state.fpustate := list.state.fpustate * curstate.fpustate
  end;
codebuf[cp] := brtype;
codebuf[cp+1] := lastbr; lastbr := cp;	{ list of all branches }
codebuf[cp+2] := list.last; list.last := cp; { list of branches to this target}
cp := cp+3
end {emitbranch};
 
procedure mergebranchchains(var from, into: branchlist);
var
  nextbr, temp: codeindex;
begin {mergebranchchains}
if from.last <> 0 then
  if into.last <> 0 then begin
    if from.state.roving <> into.state.roving then into.state.roving := 0;
    into.state.fpustate := into.state.fpustate * from.state.fpustate;
    nextbr := from.last;
    while nextbr > 0 do begin
      temp := codebuf[nextbr+2];
      codebuf[nextbr+2] := into.last;
      into.last := nextbr;
      nextbr := temp
      end
    end
  else
    into := from
end {mergebranchchains};
 
procedure fixbranch(fallthru: boolean; var chain: branchlist);
var
  nextbr, temp: codeindex;
begin {fixbranch}
if chain.last <> 0 then begin
  nextbr := chain.last;
  while nextbr > 0 do begin
    temp := codebuf[nextbr+2];
    codebuf[nextbr+2] := cp-nextbr;
    nextbr := temp
    end;
  if fallthru then begin
    if curstate.roving <> chain.state.roving then curstate.roving := 0;
    curstate.fpustate := curstate.fpustate * chain.state.fpustate
    end
  else
    curstate := chain.state
  end
end {fixbranch};
 
procedure label_;
begin
curstate.roving := 0;
curstate.fpustate := fpuunknown
end {label_};
 
 
 
{ Getenvironment - sets up addressability to lex level 'oflevel', and
  leaves the stack frame pointer in register 'leaveitin'.  Note that
  this is not called to access globals, since these are addressed
  relative to the BSS segment}
function getenvironment(oflevel: integer; leaveitin: resources): registers;
var n: integer; src,dst: registers;
begin {getenvironment}
{assert leaveitin <= [gr0,gr1,gr2,gr3,gr4,gr5,stk]}
if oflevel=lexlev
then dst:=gr5						{at current level}
else if oflevel=curstate.roving
  then dst:=gr4						{at curstate.roving level}
  else begin						{must chain to get it}
    if oflevel<curstate.roving
    then begin src:=gr4; n:=curstate.roving-oflevel end		{chain from curstate.roving}
    else begin src:=gr5; n:=lexlev-oflevel end;		{chain from current}
    if not (gr4 in leaveitin)
    then dst:=getregister(gregs)
    else dst:=gr4;
    if src<>dst then begin
      emit0(4608+ord(src)*64+ord(dst));			{mov @src,dst}
      n:=n-1
      end;
    if odd(n) then begin
      emit0(4608+ord(dst)*64+ord(dst));			{mov @dst,dst}
      n:=n-1
      end;
    while n>0 do begin
      emit0(5632+ord(dst)*64+ord(dst));			{mov @(dst)+,dst}
      n:=n-2
      end
    end;
  if not (dst in leaveitin) then
  begin
    src := dst;
    if (gr4 in leaveitin) or (oflevel = curstate.roving)
      then dst := gr4	{this is the preferred dst}
      else dst := getregister(leaveitin); {else any one will do}
    if src <> dst then moveregister(src, dst)
  end;
if dst=gr4 then curstate.roving:=oflevel; {adjust curstate.roving if gr4 changes}
getenvironment:=dst
end {getenvironment};
 
 
 
{Address - determine the state of addressing for the top operand on opstk.
  Set up for accessing.}
procedure address(lockr4: boolean; dispose: disposition;
                   var mr: integer; var hasaddr: boolean);
var baseregs: resources; rb: registers;
begin {address}
with opstk[tos] do begin
  if liter in state
  then begin mr:=23; hasaddr:=true end			{immediate addressing}
  else begin
    if loaded in state
    then begin						{register or stack}
      if dispose=push then
        begin rb:=getregister(pushdesire); reg:=rb end;
      if (reg=stk) or (saved in state)
      then case dispose of
        leave: mr:=14;					{(sp)}
        push: mr:=38;					{-(sp)}
        pop: mr:=22					{(sp)+}
        end
      else begin						{register}
	mr:=ord(reg);
	if reg>=fr0 then mr:=mr-ord(fr0) {float regs numbered from 0}
      end;
      hasaddr:=false
      end
    else begin						{memory reference}
      dispose:=pop;	{can discard register used for addressing}
      {if (state * [based,indexed]) <> [] then restoreregister(tos,gregs);}
      if based in state
      then rel.reltype:=absact
      else if (rel.reltype=absact) {or (lexlev=1)}
        then begin					{non-global reference}
	{For NBS-PASCAL, globals will be in BSS,
	 so they are not checked for here.}
          baseregs:=gregs + [gr4,gr5];
          rel.reltype:=absact;
          if lockr4 then baseregs:=baseregs -{setdiff} [gr4];
          rb:=getenvironment(ord(rel.segnr),baseregs);
	  if indexed in state
	    then begin
	      emit0(24576 + ord(rb)*64 + ord(reg) {add rb,reg});
	      freeregister(rb)
	    end
	    else reg := rb
          end
        else						{global reference}
	{if reltype is actual, make it relative; don't touch if indexed}
	  if not (indexed in state) then
	    if not odd(ord(rel.reltype)) then rel.reltype := succ(rel.reltype);
      if odd(ord(rel.reltype))
      then begin				{use relative addressing}
        if indirect in state then mr:=63 else mr:=55;		{[@]addr(pc)}
        hasaddr:=true
        end
      else if indirect in state
        then begin mr:=56+ord(reg); hasaddr:=true end		{@addr(reg)}
	else if (adr.addr=0) and (rel.reltype=absact)
          then begin mr:=8+ord(reg); hasaddr:=false end		{(reg)}
          else begin mr:=48+ord(reg); hasaddr:=true end		{addr(reg)}
        end;
    if (dispose=pop) and not (copy in state) then freeregister(reg)
    end
  end {with opstk[tos]}
end {address};
 
 
 
procedure load(desire: resources); forward;
procedure loadaddress(desire: resources); forward;
 
 
procedure emit7(fop: integer; dstdis: disposition);
var dstmr: integer; dstaddr: boolean;
begin {emit7}
if (opstk[tos].opsize<=bytesize) and (fop<512) then fop:=fop+512;	
address(false,dstdis,dstmr,dstaddr);
emit0(fop*64+dstmr);
if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel)
end {emit7};
 
procedure emit10(fop: integer; srcdis: disposition);
var srcmr,srcword: integer; srcrel: relpair; srcaddr: boolean;
begin {emit10}
restoreregister(tos-1,gregs);	{the destination must be a register}
address(false,srcdis,srcmr,srcaddr);
if srcaddr then with opstk[tos] do
  begin srcword := adr.addr; srcrel := rel end;
tos:=tos-1;
emit0((fop*8+ord(opstk[tos].reg))*64+srcmr);
if srcaddr then emitaddr(srcword,srcrel)
end {emit10};
 
 
 
procedure gencall(u:boolean;n:integer);
var r: relpair;
  s: integer;
begin {gencall}
emit0(2551 {jsr pc,0(pc)});
s := searchid(n,u);	{find symbol number}
if u then r.reltype:=txtrel else r.reltype:=uxtrel;
r.segnr:=chr(n);
emitaddr(0,r);
codebuf[cp-1] := 0
end {gencall};
 
 
 
procedure emitfop2(fop: integer; srcdis,dstdis: disposition);
{ floating version of emit15;
  for instrs of the form "op ac,src/dst".
 
	fop	instr	fop	instr
	---	-----	---	-----
	18	muld	19	modd
	20	addd	21	ldd
	22	subd	23	cmpd
	24	std	25	divd
	26	stexp	27	stcdi
	28	stcdf	29	ldexp
	30	ldcid	31	ldcfd	}
type
  optype = (load,store);
  {the strange bounds are to make it easy to convert to opcode form}
  fpoptabt=array[18..31] of optype;
const
  {to tell us whether the result will be in "ac" or a general dst}
  fpoptab=fpoptabt(load,load,load,load,load,load,store,load,store,
		store,store,load,load,load);
var
  srcaddr,dstaddr: boolean;	{will an address be needed}
  lrel: relpair;		{for relocation of address}
  srcmr,dstmr,lword: integer;	{mode bytes, address value}
  loptype: optype;
  n: integer;
 
function flitsize (f: fvalptr): integer;
{ determine the minimum size of the
  floating literal:  1, 2 or 4 words. }
begin {flitsize}
  flitsize := 4 {assume double prec.};
  if (f@[2] = 0) and (f@[3] = 0) then
  begin
    flitsize := 2 {single prec.};
    if f@[1] = 0 then flitsize := 1 {inline literal}
  end
end {flitsize};
 
begin {emitfop2}
  if opstk[tos-1].state *{inter} [indexed,based] <> [] then
  restoreregister(tos-1,gregs);	{restore buried addressing register}
  if FPU then begin {FPU}
    loptype:=fpoptab[fop];		{load or store}
    address(false,srcdis,srcmr,srcaddr);
    if srcaddr then with opstk[tos] do begin
      lword := adr.addr; lrel := rel
    end;
    if loptype = load then begin
      if (srcmr = 23 {immediate mode}) and
      not ((fop=29 {ldexp}) or (fop=30 {ldcid})) then
      with opstk[tos].adr do begin
        n := flitsize(xval);
        if n = 2 {single floating lit} then begin
          if fop = 21 {ldd} then fop := 31 {force ldcfd}
	  else if fop <> 31 {ldcfd} then n := 4
	  {if not ldcfd then use double lit,
	   because other instructions can't
	   convert from single to double.}
        end {n = 2};
        if n = 4 {double floating lit} then begin
          if fop = 31 {ldcfd} then fop := 21 {force ldd}
        end;
        if n = 1 then lword := xval@[0]  {use short inline literal:}
        else begin {build floating literal on stack}
          repeat
            n:=n-1;
            if xval@[n] = 0
            then emit0(5046b {clr -(SP)})
	    else begin
	      emit0(12746b {mov #,-(SP)});
	      emit0(xval@[n])
	    end
          until n = 0;
          { the floating instr will pop
	  the literal off the stack: }
          srcmr := 22 { (SP)+ };
          srcaddr := false
        end { n > 1 }
      end { with opstk[tos].adr };
    end { loptype = load };
    tos:=tos-1;
    address(false,dstdis,dstmr,dstaddr);
    if dstaddr then with opstk[tos] do begin
      lword := adr.addr; lrel := rel
    end;
    {emit the instr}
    if loptype = load then
    emit0(((fop+224{340B})*4+dstmr)*64+srcmr)
    else { loptype = store }
    emit0(((fop+224{340B})*4+srcmr)*64+dstmr);
    {because of form of floating instrs, only one address will be needed}
    if srcaddr or dstaddr then emitaddr(lword,lrel);	{put out the address}
  end {FPU}
  else begin {FIS}
    if odd(fop) {load} then begin
      if opstk[tos-1].reg=stk then begin
        if liter in opstk[tos].state then with opstk[tos].adr do begin
          if xval@[1]=0
	  then emit0( 5046b {clr -(SP)} )
	  else begin
	    emit0( 12746b {mov #,-(SP)} );
	    emit0( xval@[1] )
          end;
          if xval@[0]=0
	  then emit0( 5046b {clr -(SP)} )
	  else begin
	    emit0( 12746b {mov #,-(SP)} );
	    emit0( xval@[0] )
          end
	end
        else {variable to stack}
	if indirect in opstk[tos].state then with opstk[tos] do begin
          loadaddress(gregs);	{mov address,reg}
          emit0(16046b+ord(reg)*100b {mov 2(reg),-(sp)});
          emit0(2);
          emit0(11046b+ord(reg)*100b {mov (reg),-(sp)});
          freeregister(reg);
        end
	else begin
	  opstk[tos].opsize := wordsize;
	  duptos;
	  opstk[tos].adr.addr := opstk[tos].adr.addr + 2;
	  address(false,srcdis,srcmr,srcaddr);
	  emit0( 10046b+srcmr*64 {mov src,-(SP)} );
	  if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel);
	  tos := pred(tos);
	  address(false,srcdis,srcmr,srcaddr);
	  emit0( 10046b+srcmr*64 {mov src,-(SP)} );
	  if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel);
        end;
      end; {if reg=stk}
      tos:=pred(tos);
     end {load}
    else begin {store}
      tos:=pred(tos);
      if indirect in opstk[tos].state then with opstk[tos] do begin
        loadaddress(gregs);   {mov address,reg}
        emit0(12620b+ord(reg) {mov (sp)+,(reg)+});
        emit0(12620b+ord(reg) {mov (sp)+,(reg)+});
        freeregister(reg);     
      end {indirect}
      else begin
        opstk[tos].opsize := wordsize;
        duptos;
        address(false,dstdis,dstmr,dstaddr);
        emit0(12600b+dstmr {mov (sp)+,dst});
        if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel);
        tos := pred(tos);
        opstk[tos].adr.addr := opstk[tos].adr.addr + 2;
        address(false,dstdis,dstmr,dstaddr);
        emit0(12600b+dstmr {mov (sp)+,dst});
        if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel);
      end;
    end {store}
  end; {FIS}
end {emitfop2};
 
 
 
procedure emit15(fop: integer; srcdis,dstdis: disposition);
var srcmr,dstmr,srcword: integer;
  srcrel: relpair;
  srcaddr,dstaddr: boolean;
  opt: (none,some,all);
begin {emit15}
if (opstk[tos].opsize<=bytesize) or (opstk[tos-1].opsize<=bytesize)
  then fop:=fop+8;	{if either is byte then use byte instruction}
			{must assure that add,sub always enter with words}
opt:= none;
with opstk[tos] do
if (liter in state) and (rel.reltype=absact) then case fop of
  1  {mov }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end;
  9  {movb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end;
  5,13 {bis,bisb}: if adr.addr=0 then opt:=all;
  0  {and }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end
    else if adr.addr=-1 then opt:=all;
  8  {andb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end
    else if adr.addr=255 then opt:=all;
  4  {bic }: if adr.addr=0 then opt:=all
    else if adr.addr=-1 then begin fop:=40 {clr}; opt:=some end;
  12 {bicb}: if adr.addr=0 then opt:=all
    else if adr.addr=255 then begin fop:=552 {clrb}; opt:=some end;
  6  {add }: if adr.addr=0 then opt:=all
    else if adr.addr=1 then begin fop:=42 {inc}; opt:=some end
    else if adr.addr=-1 then begin fop:=43 {dec}; opt:=some end;
  14 {sub }: if adr.addr=0 then opt:=all
    else if adr.addr=1 then begin fop:=43 {dec}; opt:=some end
    else if adr.addr=-1 then begin fop:=42 {inc}; opt:=some end;
  2  {cmp }: if adr.addr=0 then begin fop:=47 {tst}; opt:=some end;
  10 {cmpb}: if adr.addr=0 then begin fop:=559 {tstb}; opt:=some end;
  7,15: {not used}
  end;
if opt=none
then begin
  if (fop=2 {cmp}) or (fop=10 {cmpb})
  then swaptos				{because pdp11 cmp is backwards}
  else if (fop=0 {and}) or (fop=8 {andb})
    then begin		{pdp11 lacks and, must simulate with bic}
      if liter in opstk[tos].state
      then opstk[tos].adr.addr:=-(opstk[tos].adr.addr+1)
      else begin load(gregs + [stk]); emit7(41 {com},leave) end;
      fop:=fop+4			{change to bic[b]}
      end;
  {check for buried addressing register and restore it:}
  if opstk[tos-1].state *{inter} [indexed,based] <> [] then
    restoreregister(tos-1,gregs);
  address(false,srcdis,srcmr,srcaddr);
  if srcaddr then with opstk[tos] do begin srcword:=adr.addr; srcrel:=rel end;
  tos:=tos-1;
  address((srcmr mod 8)=4,dstdis,dstmr,dstaddr);
  emit0((fop*64+srcmr)*64+dstmr);
  if srcaddr then emitaddr(srcword,srcrel);
  if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel)
  end
else begin
  tos:=tos-1;
  if opt=some then emit7(fop,dstdis)
  end
end {emit15};
 
 
 
procedure adjuststack(i:integer);
var expand: boolean;
begin {if i<0 then expand stack else shrink stack}
if i<>0 then begin
  if i<0 then begin i:=-i; expand:=true end else expand:=false;
  if odd(i) then i:=i+1;
  if i=2
  then if expand then emit0(2598 {clr -(sp)}) else emit0(3030 {tst (sp)+})
  else begin
    if expand then emit0(-6714 {sub $i,sp}) else emit0(26054 {add $i,sp});
    emit0(i)
    end
  end
end {adjuststack};
 
{load - put operand value on stack}
procedure load{(desire: resources)}; {Previously declared as forward}
var
  dstreg: registers; hasaddr: boolean;
begin {load}
{assert desire <= [gr0,gr1,gr2,gr3,fr0,fr1,fr2,fr3,stk,gcc]}
with opstk[tos] do
  if loaded in state
  then begin			{loaded, but perhaps in the wrong place}
    if not (reg in desire) then begin
      if gcc in desire
      then begin {convert boolean to gcc}
        emit7(47 {tst[b]},pop); truecode:=3; reg:=gcc
        end
      else if reg=gcc
        then begin	{convert gcc to boolean in desired register}
	  pushdesire := desire;
	  emit0(brtab[truecode] + 2);
          emit7(40 {clr},push);
          freeregister(reg);
	  emit0(brtab[unconditional] + 2);
          pushlit(1); emit15(1 {mov $1,reg},pop,push);
          opsize:=wordsize
          end
        else begin	{move from current register to desired register}
          dstreg:=getregister(desire);
          moveregister(reg,dstreg);
          freeregister(reg);
          reg:=dstreg
          end
      end
    end
  else begin				{not loaded, lets do it}
    newtos; opstk[tos]:=opstk[tos-1];
    {opstk[tos-1].}state:=[loaded];
    pushdesire:=desire; dstreg:=any(desire);
    case dstreg of			{different loads for different folks}
    gr0,gr1,gr2,gr3,gr4,gr5:begin
      if (opsize<=bytesize) and (pushdesire * avail <> []) then begin
	reg := getregister(pushdesire);
	emit0(2560 + ord(reg) {clr r?});
	emit15(5 {bis[b]}, pop, leave);
	opsize:=wordsize
	end
      else if opsize<=wordsize then
	emit15(1 {mov[b]},pop,push)
      else
	error(18) {double load to register}
      end;
    stk:begin
      if opsize <= bytesize then begin
	{To avoid high-order garbage from "movb s,-(sp)", clear first:}
	emit0(2598 {clr -(sp)});
	reg:=stk;	{ force to stack in address }
	emit15(1 {mov[b]}, pop,leave);
	opsize:=wordsize	{now tos is a word}
	end
      else if opsize<=wordsize
	then emit15(1 {mov[b]},pop,push)
      else if opsize<=doublesize then begin
	{ assumed to be long floating point }
	if FPU then begin
	  pushdesire := fregs;
	  if opsize<=longsize then begin {short floating point}
	    emitfop2(31 {ldcfd}, pop, push);
	    emit0(((ord(reg)-ord(fr0))*64) + 176046b {stcdf reg,-(sp)});
	  end else begin {long floating point}
	    emitfop2(21 {ldf}, pop, push);
	    emit0(((ord(reg)-ord(fr0))*64) + 174046b {stf reg,-(sp)});
	  end;
	  freeregister(reg);
	  reg := stk;
	end {FPU} else begin {FIS}
	  reg := stk;
	  emitfop2(1 {load},pop,push);
	end
      end
      else
	error(18)	{ multiple load to stack }
      end;
    fr0,fr1,fr2,fr3:
      if opsize=doublesize then
	emitfop2(21{ldf},pop,push)
      else begin
	emitfop2(31{ldcfd},pop,push);
	opsize:=doublesize
      end;
    gcc:begin emit7(47 {tst[b]},pop); tos:=tos-1;
      truecode:=3 {ne}; reg:=gcc
      end;
    mem:
    end;
    end
end {load};
 
 
 
{ Loadaddress - determine addressing state of top operand; prepare to load
  its address onto stack}
procedure loadaddress{(desire: resources)};	{previously declared as forward}
var dobase,dodisp: integer; nxtdis: disposition; rb,rx: registers;
{ dobase: 0 => nothing; 1 => move; 6 => add}
begin {loadaddress}
{assert desire <= [gr0,gr1,gr2,gr3,stk]}
with opstk[tos] do begin
  if indirect in state
  then begin
    state:=state -{sdiff}[indirect]; opsize:=wordsize;
    load(desire)
    end
  else begin
    rb:=reg; rx:=rb;
    if based in state
    then begin
      if copy in state
      then begin nxtdis:=push; dobase:=1 end
      else begin nxtdis:=leave; dobase:=0 end;
      dodisp:=6
      end
    else begin
      if indexed in state
      then begin nxtdis:=leave; dobase:=6 end
      else begin nxtdis:=push; dobase:=1 end;
      if rel.reltype=absact
      then begin
        rb:=getenvironment(ord(rel.segnr),[gr4,gr5]);
        dodisp:=6
        end
      else begin dodisp:=dobase; dobase:=0 end
      end;
    pushdesire:=desire;
    newtos;
    with opstk[tos] do begin state:=[loaded]; reg:=rx; opsize:=wordsize end;
    if dobase<>0 then begin
      newtos;
      with opstk[tos] do begin state:=[loaded,copy]; reg:=rb; opsize:=wordsize end;
      emit15(dobase,pop,nxtdis);
      nxtdis:=leave
      end;
    swaptos; opstk[tos].state:=[liter];
    opstk[tos].opsize := wordsize;
    emit15(dodisp,pop,nxtdis)
    end
  end
end {loadaddress};
 
 
 
procedure extend(tosize: byte; desire: resources);
type table=array[bitsize..pred(wordsize)] of integer;
const mask=table(-2,-4,-8,-16,-32,-64,-128,-256,-512,-1024,-2048,-4096,
  -8192,-16384,-32768);
begin {extend}
{assert tosize<=wordsize}
with opstk[tos] do if opsize<tosize then begin
  load(desire);
  if opsize < tosize then begin {the load may have changed things}
    pushlit(mask[opsize]);
    opsize:=tosize;
    emit15(4 {bic},pop,leave)
    end
  end
end {extend};
 
procedure cvtdouble;
{a wordsize value is assumed to loaded in an odd register,
the sign is extended through the paired even register}
var lcp: codeindex; lreg: registers;
begin {cvtdouble}
lcp:=cp;
with opstk[tos] do begin
  lreg:=pred(reg);	{lreg is the even register of the pair}
  lreg:=getregister([lreg]);	{seize the even register}
	{getregister may save registers and thus destroy the cond code}
  if lcp<cp then emit7(47 {tst}, leave);
  reg:=lreg;		{change to even register}
  emit7(55 {sxt}, leave);	{extend the sign thru even register}
  opsize:=longsize	{size is now longword}
  end
end {cvtdouble};
 
procedure cvtsingle(keepeven: boolean);
{a longsize value is assumed to loaded in an even/odd register pair,
one of the registers is discarded and the size changed to wordsize}
begin {cvtsingle}
with opstk[tos] do begin
  if keepeven
  then freeregister(succ(reg))
  else begin freeregister(reg); reg:=succ(reg) end;
  opsize:=wordsize
  end
end {cvtsingle};
 
 
 
procedure genscan;
 
procedure gencode(node:ptn; desire: resources; force: whatwhere);
 
procedure dumpstack(p: integer);
type
  regstrtab = array[0..13] of {packed} array [1..3] of char;
  relstrtab = array[0..15] of {packed} array [1..6] of char;
const
  regstring = regstrtab('gr0','gr1','gr2','gr3','gr4','gr5','fr0','fr1',
		'fr2','fr3','stk','gcc', 'mem','dbl');
  relstring = relstrtab('absact','absrel','txtact','txtrel','datact','datrel',
		'bssact','bssrel','uxtact','uxtrel',
		'      ','      ','      ','      ','       ','       ');
var ss:array[0..9] of char; n: integer;
begin {dumpstack}
writeln(output);
writeln(output,'stackdump, node = ',p,', cp=',cp);
n:=tos;
while n>=0 do with opstk[n] do begin
  ss := '          ';
  if copy     in state then ss[0] := 'c';
  if temp     in state then ss[1] := 't';
  if stored   in state then ss[2] := '_';
  if saved    in state then ss[3] := 's';
  if loaded   in state then ss[4] := 'l';
  if indirect in state then ss[5] := 'i';
  if indexed  in state then ss[6] := 'x';
  if based    in state then ss[7] := 'b';
  if liter    in state then ss[8] := '#';
  writeln(output, n:3, ' ':3, ss:10, ord(opsize):5, ' ',
	regstring[ord(reg)]:4, adr.addr:8, ' ',
	relstring[ord(rel.reltype)]:6,
	'(', ord(rel.segnr):3, ')');
  break(output);
  n:=n-1
  end
end {dumpstack};
 
 
function subtreematch(st1,st2: ptn): boolean;
var i: integer; matchsofar: boolean;
begin {subtreematch}
if st1=nil
then subtreematch:=(st2=nil)
else if st2=nil
  then subtreematch:=false
  else with st1@ do begin
    if (code=st2@.code) and (size=st2@.size) and
       (dsp.disp=st2@.dsp.disp) and (segnr=st2@.segnr) and
       (nrarg=st2@.nrarg)
      then matchsofar:=true else matchsofar:=false;
    i:=1;
    while matchsofar and (i<=ord(nrarg)) do begin
      matchsofar:=subtreematch(arg[i],st2@.arg[i]); i:=i+1 end;
    subtreematch:=matchsofar
    end
end {subtreematch};
 
 
 
 
 
{store value in varble - fop indicates storage class of value/varble}
procedure store(fop:integer);
var savetarget: ptn; loadit: whatwhere; targetsize: byte; dispose: disposition;
  lop: integer;
  ldesire: resources;
begin {store}
savetarget:=target; target:=node@.arg[1];
sideeffects:=false;		{must check for side effects}
ldesire:=gregs;
if fop=2 {storf} then if FPU then ldesire:=fregs else ldesire:=[stk];
gencode(target,gregs,noload);	{get addr of lhs in gregs}
targetsize:=opstk[tos].opsize;
if (force=noload) and (fop <> 2) {because floating ops don't do mem to mem}
then if sideeffects then loadit:=noload else loadit:=tryupdate
else loadit:=loadvalue;
gencode(node@.arg[2],ldesire,loadit);{get rhs in gregs or fregs, depending}
with opstk[tos] do if not (stored in state) then begin
  if (targetsize<=wordsize) or (fop = 2 {float})
  then begin			{simple store}
    if reg=gcc then load(gregs);	{load will convert to boolean}
    if fop <> 2 then extend(targetsize,gregs + [stk]);
    opsize:=targetsize;
    if force=noload then dispose:=pop else dispose:=leave;
    if fop = 0 then	{16 bit value}
      emit15(1 {mov},dispose,pop)
    else begin		{assume float}
      if FPU then begin
	if targetsize = doublesize then lop:= 24{stf}
	else {convert to single} lop:=28{stcfd};
	emitfop2(lop,dispose,pop)
      end else {FIS}
	emitfop2(2 {store},dispose,pop);
    end
  end
  else {multiple store} error(19)
  end;
if force=noload
then tos:=tos-1
else opstk[tos]:=opstk[tos+1];
sideeffects:=true;	{tell parent node that there are side effects}
target:=savetarget
end {store};
 
 
 
procedure move;
var lop: integer;
    ra, rb, rc: registers;
begin {move}
  with node@ do
  begin
    gencode(arg[1], gregs, loadaddr);
    gencode(arg[2], gregs, loadaddr);
    if size <= bytesize
      then lop := 112020B {movb (rb)+,(rc)+}
      else lop :=  12020B {mov  (rb)+,(rc)+};
    pushlit(dsp.disp);  load(gregs + [gr4]);	{mov #n,ra}
    restoreregister(tos-2, gregs);	{top 3 must be in registers}
    ra := opstk[tos].reg;
    rb := opstk[tos-1].reg;
    rc := opstk[tos-2].reg;
    emit0(lop + ord(rb)*64 + ord(rc));	{mov/b (rb)+,(rc)+}
    emit0(77002B + ord(ra)*64);		{sob ra,.-2}
    if (ra = rb) or (rb = rc)
      or (rc = ra)  then error(45);
    freeregister(ra);
    freeregister(rb);
    freeregister(rc);
    tos := tos - 3
  end {with node@}
end {move};
 
 
 
procedure genunary(fop: integer);
var update: boolean;
begin {genunary}
with node@ do if (force=tryupdate) and subtreematch(target,arg[1])
  then update:=true
  else begin
    gencode(arg[1],desire,loadvalue);
    update:=false
    end;
emit7(fop,leave);
if update then opstk[tos].state:=[stored]
end {genunary};
 
{generate code for unary floating ops}
{fop will be: 0: clrf, 1: tstf, 2: absf, 3: negf (only 2 & 3 at present)}
procedure genfpunary(fop: integer);
var update: boolean;
  dstmr: integer;	{mode/reg field for instr}
  dstaddr: boolean;	{set up by address - is address needed?}
  regr: registers;	{register for negation operation}
begin {genfpunary}
  with node@ do
    if (force=tryupdate) and subtreematch(target,arg[1])
    then update:=true
    else begin
      if FPU then gencode(arg[1],desire-gregs,loadvalue)
      else gencode(arg[1],[stk],loadvalue);
      update:=false
    end;
  address(false,leave,dstmr,dstaddr);		{compute oprnd address}
  if FPU then begin
    fop:=fop+964{1704B};			{form op from fop}
    emit0(fop*64+dstmr);
  end {FPU}
  else begin {FIS}
    if fop=2 {absf} then begin
      emit0(42700b+dstmr {bic #100000,dst});
      emit0(100000b);
    end
    else if fop=3 {negf} then begin
      regr := getregister(gregs);
      emit0(12700b+ord(regr) {mov #100000,regr});
      emit0(100000b);
      emit0(74000b+ord(regr)*64+dstmr {xor regr,dst});
      freeregister(regr);
    end;
  end; {FIS}
  if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel);
  if update then opstk[tos].state:=[stored]
end {genfpunary};
 
procedure genfpconvert(fop: integer);
{generate code for conversions from/to floating}
{fop: 0 => float; 1 => trunc; 2 => round }
type opvalue = array[0..2] of integer;
     opsze  = array[0..2] of byte;
const
  stacksize = opvalue(-4,-2,-2);
  procno    = opvalue(201,98,99);
  parmsize  = opsze(floatsize,wordsize,wordsize);
var
  srcdesire, dstdesire: resources;
  lop: integer;
  loadit: whatwhere;
  dispose: disposition;
  update: boolean;
begin {genfpconvert}
if FPU then begin {FPU}
  update := false;	{ initial assumption }
  if fop = 0 then begin	{ float }
    srcdesire := gregs; loadit := noload;
    dstdesire := desire * fregs;
    if dstdesire = [] then dstdesire := fregs;
    lop := 30	{ ldcif }
  end
  else begin		{ trunc, round }
    if fop = 2 then error(20);	{ round not yet impl }
    srcdesire := fregs; loadit := loadvalue;
    dstdesire := desire * gregs;
    lop := 27;	{ stcfi }
    update := force = tryupdate
  end;
  gencode(node@.arg[1], srcdesire, loadit);
  dispose := pop;
  if not update then begin	{ code similar to that in procedure load }
    newtos;
    opstk[tos] := opstk[tos-1];
    opstk[tos-1].state := [loaded];
    pushdesire := dstdesire;
    dispose := push
  end;
  emitfop2(lop,pop,dispose);
  if update then opstk[tos].state := [stored]
end {FPU}
else begin {FIS}
  saveregister(true,[]);
  adjuststack(stacksize[fop]);  {returned value}
  gencode(node@.arg[1],[stk],loadvalue);
  gencall(false,procno[fop]);
  opstk[tos].opsize := parmsize[fop];
end; {FIS}
end {genfpconvert};
 
 
 
{generate code for floating binary ops, including compares.  The
distinction between compares and others is made on value, the
compare fops being smaller than the others (the same relative values
as other compares (only the signed compares are used, codes 0..9)}
procedure genfpbinary(fop: integer);
var
  ldesire: resources;
  lop: integer;
  dispose: disposition;
begin {genfpbinary}
if FPU then begin {FPU}
  {floating ops can't update in place}
  lop:=fop; dispose:=leave;
  if fop < 18 then begin lop:=23; dispose:=pop end;
  ldesire := desire * fregs;   {if result needed in stack,
                                 gencode will put it there}
  if ldesire = [] then ldesire := fregs;
  with node@ do begin
    gencode(arg[1],ldesire,loadvalue);			{to be "ac"}
    gencode(arg[2],fregs,noload);			{to be "fsrc"}
    {only need to force a load when 2nd is double and not literal}
    with opstk[tos] do
      if not (liter in state) and (opsize <> doublesize) then load(fregs)
  end;
  restoreregisters(tos-1,fregs);
  emitfop2(lop,pop,dispose);
  if lop=23{cmpf} then begin {set up for test/boolean}
    emit0(-4096{cfcc});		{move float cc's to gcc's}
    truecode := brrev[fop];	{reverse test for reverse compare}
    with opstk[tos] do begin
      state:=[loaded];
      reg:=gcc
    end
  end
end {FPU}
else begin {FIS}
  with node@ do begin
    gencode(arg[1],[stk],loadvalue);
    gencode(arg[2],[stk],loadvalue);
    emit0(75006b+fop*10b {FIS opcode});
    tos := pred(tos);
    with opstk[tos] do begin
      state:=[loaded];
      opsize:=floatsize;
      reg:=stk;
    end; {with opstk}
  end; {with node}
end; {FIS}
end {genfpbinary};
 
{generate floating point compare operations for FIS}
procedure fpcompare(fop:integer);
begin
  gencode(node@.arg[1],[stk],loadvalue);
  gencode(node@.arg[2],[stk],loadvalue);
  tos := pred(tos);
  gencall(false,97 {fpcmp});
  truecode := fop;
  with opstk[tos] do begin
    state := [loaded];
    opsize := bitsize;
    reg := gcc;
  end;
end; {fpcompare}
 
 
procedure genbinary(fop: integer; nobyte: boolean);
var update: boolean;
begin {genbinary}
with node@ do begin
  if (force=tryupdate) and (not nobyte or (opstk[tos].opsize=wordsize))
    and subtreematch(target,arg[1])
  then update:=true
  else begin
    gencode(arg[1],desire*(gregs + [stk]),loadvalue);
    if nobyte then extend(wordsize,desire*(gregs + [stk]));
    update:=false
    end;
  gencode(arg[2],gregs,noload)
  end;
if nobyte then extend(wordsize,gregs);
if loaded in opstk[tos].state then load(gregs);	{convert gcc to boolean}
emit15(fop,pop,leave);
if update then opstk[tos].state:=[stored]
end {genbinary};
 
procedure compare(fop: brtypes);
begin {compare}
with node@ do begin
  gencode(arg[1],gregs,noload);
  gencode(arg[2],gregs,noload)
  end;
emit15(2 {cmp},pop,pop);
truecode:=fop;
with opstk[tos] do begin
  state:=[loaded];
  reg:=gcc
  end
end {compare};
 
 
 
procedure vcompare(fop:integer);
{emit code to do "multiple compare", leaving the condition codes set
 according to the last compare done.  Higher level stuff will have to
 weave together sequences of these as well as convert condition codes
 to booleans.  Does not touch truechain or falsechain}
var
  savecp: codeindex;
  lop: integer;
begin {vcompare}
  with node@ do begin
    gencode(arg[1],gregs,loadaddr);	{get left arg address into reg}
    gencode(arg[2],gregs,loadaddr);	{get right arg address into new reg}
    if size <= bytesize then lop:= -23536 {cmpb (r?)+,(r?)+}
			else lop:= 9232;	  {cmp  (r?)+,(r?)+}
    pushlit(dsp.disp); load(gregs+[gr4]);	{load length and force to reg}
    restoreregister(tos-2,gregs);		{make sure all 3 are in regs}
    savecp:=cp;				{mark point for sob return}
    emit0(lop+ord(opstk[tos-2].reg)*64+ord(opstk[tos-1].reg));
    emit0(brtab[3]+1);	{bne around sob, ending comparison on first nonequal}
    emit0(32259 {sob} + ord(opstk[tos].reg)*64);	{sob r?,.-4}
    truecode:=fop;
    freeregister(opstk[tos].reg);
    freeregister(opstk[tos-1].reg);
    freeregister(opstk[tos-2].reg);
    tos:=tos-2;				{leave something on stack as result}
    with opstk[tos] do begin
      state:=[loaded];			{ ...which is loaded...}
      reg:=gcc				{ ...in the condition codes...}
    end;
  end {with node@}
end {vcompare};
 
 
 
procedure minmax(fop: integer);
{	fop	function
	0	umax
	1	umin
	2	imax
	3	imin
}
var
  lcp: codeindex;
  this,other: ptn;
  loadit: whatwhere;
  loperand: operand;
begin {minmax}
  {generate for u, i max/min functions.  Optimize for x:=max(x,y)}
  loadit:=loadvalue; {assuming no optimization}
  this:=node@.arg[1];
  other:=node@.arg[2];
  if force=tryupdate then {check subtrees}
    if subtreematch(target{lhs},this) then loadit:=noload
    else
      if subtreematch(target,other) then begin {flip subtree}
	this:=other;
	other:=node@.arg[1];
	loadit:=noload
      end;
  {Now, generate the code:}
  if loadit<>noload {if not updating} then gencode(this,desire,loadit);  {for "1st" arg}
  gencode(other,gregs,noload);  {for "2nd" arg...don't load its value}
  if loaded in opstk[tos].state then load(gregs); {pop off stack if there}
  loperand:=opstk[tos];		{save for later use}
  swaptos;			{to counteract the same in emit15}
  emit15(2{cmp},pop,leave);
  case fop of {make the branch codes-bxx .+1; will fix up target after store}
    0 {umax}: fop := 101400B {blos};
    1 {umin}: fop := 103000B {bhis};
    2 {imax}: fop :=   3400B {ble};
    3 {imin}: fop :=   2000B {bge}
  end;
  emit0(fop);			{store the branch and}
  lcp:=cp;			{note its location}
  newtos;
  opstk[tos]:=loperand;		{restore "other" arg}
  emit15(1{mov},pop,leave);	{and emit the store.}
  if loadit=noload {only if update} then opstk[tos].state:=[stored];
  codebuf[lcp-1]:=codebuf[lcp-1]+cp-lcp; {point the branch to the right target}
end {minmax};
 
 
 
procedure mdmconst(fop,n:integer; desire:resources; update:boolean);
var i,j: integer;
{ code generated for values of fop
		    mod		    div		    mul
	n=0	0) error	1) error	2) clr dst
	n=1	3) clr dst	4) nop		5) nop
	n=2	6) bic $-n,dst	7) asr dst	8) asl dst
	n=2^i	9) bic $-n,dst	10) ash $-i,dst	11) ash $i,dst
	n<>2^i	12) div $n,dst	13) div $n,dst	14) mul $n,dst	}
begin {mdmconst}
if n<>0 then begin
  i:=0; j:=1;
  while (i<15) and (j<n) do begin i:=i+1; j:=j*2 end;
  if j=n
  then if i=0
    then fop:=fop+3			{n=1}
    else if i=1
      then fop:=fop+6			{n=2}
      else fop:=fop+9			{n=2^i, 1<i<16}
  else fop:=fop+12			{n$2^i}
  end;
if not update or (fop>9) then begin {can't update...get operand in reg}
  update:=false;
  if fop>=12 then desire:=oddregs {for mul,div,mod} else desire:=gregs;
  load(desire);
  extend(wordsize,desire)
end else opstk[tos].state := opstk[tos].state-[copy]; {ok to release addr reg}
case fop of
0 {mod 0}, 1 {div 0}: {error};
2 {mul 0}, 3 {mod 1}: emit7(40 {clr},leave);
6,9 {mod 2^i, i>0}: begin pushlit(-n); emit15(4 {bic},pop,leave) end;
7 {div 2}: emit7(50 {asr},leave);
8 {mul 2}: emit7(51 {asl},leave);
10 {div 2^i, i>1}: begin pushlit(-i); emit10(58 {ash},pop) end;
11 {mul 2^i, i>1}: begin pushlit(i); emit10(58 {ash},pop) end;
12 {mod n, n$2^i}, 13 {div n, n$2^i}: begin
  cvtdouble;
  pushlit(n); emit10(57 {div},pop);
  cvtsingle(odd(fop))
  end;
14 {mul n, n$2^i}: begin pushlit(n); emit10(56 {mul},pop) end
end;
if update then opstk[tos].state:=[stored];
end {mdmconst};
 
 
 
procedure muldivmod(fop: integer {0=mod, 1=div, 2=mul});
var update:boolean;
begin {muldivmod}
with node@ do begin
  if (force = tryupdate) and subtreematch(target,arg[1]) then begin
    update:=true;
    duptos;
    opstk[tos].state:=opstk[tos].state + [copy]
  end else begin
    update:=false;
    gencode(arg[1],gregs,noload)
  end;
  if arg[2]@.code=litcode then begin
    mdmconst(fop, arg[2]@.dsp.disp, desire, update);
    if stored in opstk[tos].state then begin
      tos:=tos-1;
      opstk[tos].state:=opstk[tos].state + [stored]
    end
  end else begin
    load(oddregs);
    extend(wordsize,oddregs);
    if fop<2 then cvtdouble;	{mod, div need doublesize dst}
    gencode(arg[2],gregs + [stk],noload);
    extend(wordsize, gregs + [stk]);	{source must be wordsize}
    if fop<2
    then begin {mod, div}
      emit10(57 {div}, pop);
      cvtsingle(odd(fop))
    end else emit10(56 {mul},pop)
  end
end {with}
end {muldivmod};
 
 
 
procedure iabs;
var update: boolean;
  savecp: codeindex;
begin {iabs}
  with node@ do begin
    if (force=tryupdate) and subtreematch(target,arg[1])
    then begin
      emit7(47{tst},leave);
      update:=true
    end else begin
      gencode(arg[1],desire,loadvalue);
      update:=false
    end
  end;
  savecp:=cp;
  cp:=succ(cp);				{save space for a branch}
  emit7(44{neg},leave);			{turn around sign}
  codebuf[savecp]:= -32768{bpl} + (cp-savecp-1);
  if update then opstk[tos].state:=[stored]	{because we have done the op}
end {iabs};
 
 
 
procedure iodd;
begin {iodd}
gencode(node@.arg[1],gregs,noload);
with opstk[tos] do if gcc in desire
then begin
  if loaded in state
  then begin
    emit7(48 {ror},pop);
    truecode:=15 {carry set}
    end
  else begin
    pushlit(1); emit15(3 {bit},pop,pop);
    truecode:=3 {not equal}
    end;
  state:=[loaded]; reg:=gcc
  end
else begin
  load(desire);
  opsize:=bitsize; {only least significant bit is valid}
  if stk in desire then extend(wordsize,desire) {to handle "odd(val)" as arg}
  end
end {iodd};
 
 
procedure square(fop: integer);
{emit code for sqr.
 fop:  0 => integer;  2 => real }
var r: integer;
begin {square}
  with node@ do
    if fop = 0 then
    begin {sqr integer}
      gencode(arg[1], oddregs, loadvalue);
      r := ord(opstk[tos].reg);
      emit0(70000b + 64*r + r)	{mul r,r}
    end else
    begin {sqr real}
      if FPU then begin {FPU}
	gencode(arg[1], fregs, loadvalue);
	r := ord(opstk[tos].reg) - ord(fr0);
	emit0(171000b + 64*r + r)	{muld r,r}
      end {FPU} else begin {FIS}
	gencode(arg[1],[stk],loadvalue);
        emit0(16646b {mov 2(sp),-(sp)});
        emit0(2);
        emit0(16646b {mov 2(sp),-(sp)});
        emit0(2);
        emit0(75026b {fmul sp});
      end; {FIS}
    end;
end {square};
 
 
procedure notnode;
var
  tempchain: branchlist;
  lstate: operstates;
begin {notnode}
with node@ do
  if (force=tryupdate) and subtreematch(target,arg[1])
  then lstate:=[stored]
  else begin
    gencode(arg[1],desire*(gregs + [stk,gcc]),loadvalue);
    lstate:=[loaded]
    end;
with opstk[tos] do begin
  if reg=gcc
  then begin
    tempchain:=truechain; truechain:=falsechain; falsechain:=tempchain;
    truecode:=brinv[truecode]
    end
  else begin
    emit7(44 {neg},leave); emit7(42 {inc},leave)
  end;
  state:=lstate
  end
end {notnode};
 
 
 
procedure condandor(isand: boolean);
var savechain: branchlist;
begin {condandor}
gencode(node@.arg[1],[gcc],loadvalue);
tos:=tos-1;
if isand
then begin {and}
  emitbranch(brinv[truecode],falsechain);
  fixbranch(true,truechain);
  savechain:=falsechain
  end
else begin {or}
  emitbranch(truecode,truechain);
  fixbranch(true,falsechain);
  savechain:=truechain
  end;
truechain:=emptychain; falsechain:=emptychain;
gencode(node@.arg[2],[gcc],loadvalue);
if isand
then mergebranchchains(savechain,falsechain)
else mergebranchchains(savechain,truechain);
with opstk[tos] do begin state:=[loaded]; reg:=gcc end;
if not (gcc in desire) then load(desire)	{will convert gcc to boolean}
end {condandor};
 
 
 
procedure sgens;
begin {sgens}
gencode(node@.arg[1],gregs,noload);
if (opstk[tos].opsize < wordsize) then load(gregs); {ash src must be word-aligned}
pushlit(1); load(gregs);
swaptos;
emit10(58 {ash},pop)
end {sgens};
 
 
procedure sin;
type table=array[0..15] of integer;
const powerof2=table(1,2,4,8,16,32,64,128,256,512,
  1024,2048,4096,8192,16384,-32768);
var ltruecode,lop: integer; loadit: whatwhere;
begin {sin}
gencode(node@.arg[1],gregs,noload);
loadit:=loadvalue;
with opstk[tos] do if liter in state
then if gcc in desire
  then begin
    if adr.addr<16 then adr.addr:=powerof2[adr.addr] else adr.addr:=0;
    loadit:=noload; ltruecode:=3 {not equal}
    end
  else adr.addr:=-adr.addr
else begin
  load(gregs);
  if gcc in desire then lop:=41 {com} else lop:=44 {neg};
  emit7(lop,leave); ltruecode:=15 {carry set}
  end;
gencode(node@.arg[2],gregs,loadit);
swaptos;
if loadit=noload	{this means we can use a "bit" instruction}
then emit15(3 {bit},pop,pop)
else emit10(58 {ash},pop);
with opstk[tos] do begin
  if gcc in desire then begin
    if loaded in state then freeregister(reg);
    reg:=gcc; truecode:=ltruecode
  end else opsize:=bitsize; {only low order bit is valid}
  state:=[loaded];
  end
end {sin};
 
 
procedure sany;
var lop: integer; rega: registers;
begin {sany}
gencode(node@.arg[1],gregs,loadvalue);
with opstk[tos] do begin
  rega:=reg;
  if opsize<=bytesize then lop:=-29696 {rorb} else lop:=3072 {ror};
  opsize:=wordsize
  end;
pushdesire:=desire;
emit7(40 {clr},push);
emit0(177 {sec});
emit0(lop+ord(rega) {ror rega});
emit0(-30974 {bcs .+6});
emit7(42 {inc},leave);
emit0(508 {br .-10});
freeregister(rega)
end {sany};
 
 
 
procedure indexnode(node: ptn; multiplier: integer);
type
  doset = set of
    (chkreg, getinx, mmult, swap, add, mdisp, chkcst, merge);
  dotabtype = array[0..7] of record
    todo: doset;
    fstate: operstates
  end;
const
  dotab = dotabtype(
    ( [], [] ),					{ [], const index }
    ( [getinx,mdisp,merge], [indexed] ),	{ [] }
    ( [chkreg], [indexed] ),			{ [indexed], const index }
    ( [chkreg,getinx,add,mdisp], [indexed] ),	{ [indexed] }
    ( [chkcst], [indirect] ),			{ [indirect], const index }
    ( [getinx,mmult,swap,add], [based] ),	{ [indirect] }
    ( [], [based] ),				{ [based], const index }
    ( [chkreg,getinx,mmult,add], [based] )	{ [based] }
  );
var variable: ptn;
  fixed,laddr,offset,n: integer;
  lrel: relpair;
  lstate: operstates;
  ldesire: resources;
  doit: doset;
 
 
  procedure findcstpart(node: ptn; var varpart: ptn; var cstpart: integer);
  const
    litcode = chr(162); addcode = chr(32); subcode = chr(33);
  var
    subpart: integer;
  begin {findcstpart}
  with node@ do
    if code = litcode then begin
      varpart := nil;
      cstpart := dsp.disp
      end
    else if (code = addcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart + arg[2]@.dsp.disp
      end
    else if (code = addcode) and (arg[1]@.code = litcode) then begin
      findcstpart(arg[2], varpart, subpart);
      cstpart := arg[1]@.dsp.disp + subpart
      end
    else if (code = subcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart - arg[2]@.dsp.disp
      end
    else begin
      varpart := node;
      cstpart := 0
      end
  end {findcstpart};
 
 
begin {indexnode}
with node@ do if code <> chr(134) then
  gencode(node, gregs, noload)
else begin
  multiplier := dsp.disp;
  indexnode(arg[1], multiplier);
  findcstpart(arg[2], variable, fixed);
  offset := fixed * multiplier;
  with opstk[tos] do begin
    laddr:=adr.addr; lrel:=rel; lstate:=state;
    if state = [] then n := 0
    else if indexed in state then n := 2
    else if indirect in state then n := 4
    else n := 6;	{ must be based }
    if variable <> nil then n := n + 1;
    doit := dotab[n].todo;
    if swap in doit then begin	{ will convert indirect to based }
      state := state - [indirect];
      laddr := 0
      end;
    if chkreg in doit then begin
      restoreregisters(tos,gregs);
      state := state + [loaded];	{ so later add will work }
      if copy in state then
	doit := doit + [swap]		{ so we don't destroy register }
      end
    end;
  if getinx in doit then begin
    gencode(variable,gregs,noload); {compute index value}
    extend(wordsize, gregs)
    end;
  if mmult in doit then mdmconst(2 {mul}, multiplier, gregs, false);
  if swap in doit then begin
    load(gregs);
    swaptos
    end;
  if mdisp in doit then mdmconst(2 {mul}, dsp.disp, gregs, false);
  if add in doit then emit15(6 {add}, pop, leave);
  if merge in doit then begin
    opstk[tos-1].reg := opstk[tos].reg;
    tos := tos - 1
    end;
  if (chkcst in doit) and (offset <> 0) then begin { convert indirect to based }
    loadaddress(gregs); laddr := 0; lstate := [based]
    end;
  with opstk[tos] do begin
    if getinx in doit then
      state := dotab[n].fstate	{ possibly a new addressing state }
    else
      state := lstate;
    opsize := size; adr.addr := laddr + offset; rel := lrel
    end
  end {with node@}
end {indexnode};
 
 
 
procedure definetemp;
var
  taddr: integer; usereg: boolean;
begin {definetemp}
with node@ do begin
{the number of temp regs required by "inner" code will be left in
 the node's size field, courtesy of prescan}
  usereg := ord(size)<=maxtmpregs;
  if not usereg then begin {reserve a local spot for it}
    newtos;
    with opstk[tos] do begin
      if lexlev=1 then begin {local are is in bss}
	taddr:=tempbase+dsp.disp*2;
	if taddr>localsize then localsize:=taddr;
	rel.reltype:=bssact;
	state:=[]
      end else begin {local area is in stack}
	taddr:=tempbase-dsp.disp*2;
	if taddr<localsize then localsize:=taddr;
	rel.reltype:=absact;
	reg:=gr5; {force to r5 for stored temps}
	state:=[based]
      end;
      adr.addr:=taddr;
      rel.segnr:=chr(lexlev); {make sure it resides in this frame}
      opsize:=wordsize;
      desire:=gregs
    end
  end else desire:=tregs; {its in a temp reg}
  gencode(arg[1],desire,noload); {get recvar}
  if not usereg then emit15(1{mov},pop,leave) {store in local area}
  else load(desire); {force to a reg}
  with opstk[tos] do begin
    if lexlev = 1 then state := state + [temp]
      else state := state + [temp, based];
    rel.segnr := chr(dsp.disp);
    gencode(arg[2],assignable,noload);
    if loaded in state then freeregister(reg)
    end;
  tos:=tos-1
  end
end {definetemp};
 
 
procedure refertotemp;
var i: integer; found: boolean; lookfor: byte;
begin {refertotemp}
found:=false; i:=tos; lookfor:=chr(node@.dsp.disp);
while not found and (i>=0) do with opstk[i] do
  if (temp in state) and (rel.segnr=lookfor)
  then found:=true
  else i:=i-1;
newtos;
if found
then begin
  opstk[tos]:=opstk[i]; opstk[tos].state:=opstk[tos].state-[temp] + [copy];
  end
else error(10)
end {refertotemp};
 
 
 
procedure ifnode;
var
  endchain,lfalsechain,ltruechain: branchlist;
  which_stmt: integer;
begin {ifnode}
  with node@ do
  begin
    if ord(arg[1]@.code) = 162 {liter} then
    begin {const Boolean-expression, optimize by
	   generating only the executable statement.}
      if arg[1]@.dsp.disp = 1	{ true }
	then which_stmt := 2	{ then-stmt }
	else which_stmt := 3;	{ else-stmt }
      gencode(arg[which_stmt], desire, force)
    end {const expression}
 
    else begin {var expression}
      lfalsechain := falsechain; falsechain := emptychain;
      ltruechain := truechain; truechain := emptychain;
      endchain := emptychain;
      saveregister(true, []);
      gencode(arg[1], [gcc], loadvalue); { Boolean-expression }
      tos := tos-1;	{remove condition code operand}
      emitbranch(brinv[truecode], falsechain);
      fixbranch(true, truechain);
      gencode(arg[2], desire, force);	{ then-stmt }
      emitbranch(1, endchain);
      fixbranch(false, falsechain);
      gencode(arg[3], desire, force);	{ else-stmt }
      fixbranch(true, endchain);
      falsechain := lfalsechain; truechain := ltruechain
    end {var expression}
  end {with node@}
end {ifnode};
 
 
procedure casenode;
var
  endchain: branchlist;
  casestate: blockstate;
  tp: codeindex;
  i, j: integer;
begin {casenode}
saveregister(true,[]); {push all tos registers}
with node@ do begin
  gencode(arg[1],gregs,loadvalue); extend(wordsize,gregs);
  emit0(0 {case}); emit0(lastbr); lastbr := cp-2;
  emit0(dsp.disp+1); emit0(ord(opstk[tos].reg));
  freeregister(opstk[tos].reg); tos := tos-1;
  tp := cp;
  endchain.last := 0; endchain.state := curstate;
  casestate := curstate;
  for i := 0 to dsp.disp do emit0(-1);	{ initialize jump table }
  for i := 2 to ord(nrarg) do begin
    with arg[i]@ do begin
      for j := 1 to ord(nrarg)-1 do
        codebuf[arg[j]@.dsp.disp+tp] := cp-tp+4; { fixup this entry in jump table }
      curstate := casestate;	{ restore state as of case jump }
      saveregister(true,[]); {push all tos registers}
      gencode(arg[ord(nrarg)],desire,force)
      end;
    emitbranch(1 {br}, endchain)
    end;
  for i := 0 to dsp.disp do	{ fixup all unused entries in jumptable }
    if codebuf[tp+i]=-1 then codebuf[tp+i] := cp-tp+4;
  end;
fixbranch(false,endchain)
end {casenode};
 
 
 
procedure loopnode;
var
  lfalsechain, ltruechain: branchlist;
  loophead: codeindex;
  i: integer;
begin {loopnode}
lfalsechain := falsechain; falsechain := emptychain;
ltruechain := truechain; truechain := emptychain;
saveregister(true,[]);
label_;
loophead := cp;
with node@ do for i:=1 to ord(nrarg) do
  gencode(arg[i],assignable+[stk],noload);
falsechain := emptychain;
emitbranch(1, falsechain);
codebuf[falsechain.last+2] := loophead-cp+3;	{ fixup backward branch }
fixbranch(false,truechain);	{ fixup all exit branches }
falsechain := lfalsechain; truechain := ltruechain
end {loopnode};
 
 
procedure exitnode;
var
  savechain: branchlist;
begin {exitnode}
{ truechain is used globally to accumulate exits from current loop }
{ falsechain is used locally to accumulate continues for this exit }
falsechain := emptychain;
savechain := truechain; truechain := emptychain;
with node@ do begin
  gencode(arg[1],[gcc],loadvalue);
  tos := tos - 1;	{ pop off condition code value }
  if arg[2] <> nil then begin
    emitbranch(brinv[truecode],falsechain);
    fixbranch(true,truechain);
    truechain := emptychain;
    gencode(arg[2],desire,force);
    emitbranch(1,truechain)
    end
  else
    emitbranch(truecode,truechain)
  end;
fixbranch(false,falsechain); falsechain := emptychain;
mergebranchchains(savechain,truechain)
end {exitnode};
 
 
 
procedure fornode;
{decision table for setting up for node:}
{todo:	FLD1 - load expr1 (from value is not constant)
	FLD2 - load expr 2 (to value is not constant)
	FDEC - increment is -1 (downto)
	FADD -
	FNEG -
	FSUB -
	FSWP -
	FREG -
}
type todo = (FLD1,FLD2,FDEC,FADD,FNEG,FSUB,FSWP,FREG);
  whattodo = set of todo;
  fortabtype = array [0..7] of whattodo;
const fortab = fortabtype(
	[     FSWP,FSUB,     FADD,     FLD2,FLD1],
	[                    FADD,     FLD2     ],
	[FREG,          FNEG,FADD,          FLD1],
	[FREG                                   ],
	[FREG,     FSUB,     FADD,FDEC,FLD2,FLD1],
	[               FNEG,FADD,FDEC,FLD2     ],
	[FREG,               FADD,FDEC,     FLD1],
	[FREG,                    FDEC          ]);
var
  backchain, forwchain: branchlist;
  dowhat: whattodo;
  usereg: boolean;
  targetsize: byte;
  lop,tcadjust: integer;
  regs1,regs2,tcregs: resources;
  looptop: codeindex;
  tabindex: 0..7;
  howload: whatwhere;
 
begin {fornode}
  with node@ do begin
    forwchain := emptychain;  backchain := emptychain;
    tcadjust := 0; tabindex := 0;
    {following assumes arg[4] is LIT with value +-1}
    if arg[2]@.code = litcode then tabindex:=tabindex+1;
    if arg[3]@.code = litcode then tabindex:=tabindex+2;
    if arg[4]@.dsp.disp<0 then tabindex:=tabindex+4;
    dowhat:=fortab[tabindex];
    {find out if we can leave trip count in a temp register}
    if (ord(size) <= maxtmpregs) then begin
      usereg:=true;
      tcregs:=tregs
    end else begin
      usereg:=false;
      tcregs:=[stk]
    end;
    if FREG in dowhat then begin
      regs1:=tcregs; regs2:=gregs end
    else begin
      regs1:=gregs; regs2:=tcregs end;
    {Now, get loop variable}
    gencode(arg[1],gregs,noload);
    targetsize:=opstk[tos].opsize;
    {Now, get initial value:}
    if FLD1 in dowhat then howload:=loadvalue else howload:=noload;
    gencode(arg[2],regs1,howload);
    emit15(1{mov},leave,pop);
    if FLD1 in dowhat then begin
      opstk[tos]:=opstk[tos+1];
      extend(wordsize,gregs)
    end else begin
      tcadjust:=tcadjust-arg[2]@.dsp.disp;
      tos:=tos-1
    end;
    {Next, the final value:}
    if FLD2 in dowhat then howload:=loadvalue else howload:=noload;
    gencode(arg[3],regs2,howload);
    if FLD2 in dowhat then extend(wordsize,gregs)
    else begin
      tcadjust:=tcadjust+arg[3]@.dsp.disp;
      tos:=tos-1
    end;
    if FSWP in dowhat then swaptos;
    if FSUB in dowhat then emit15(14{sub},pop,leave);
    if FNEG in dowhat then emit7(44{neg},leave);
    if FDEC in dowhat then tcadjust:=1-tcadjust
    else tcadjust:=tcadjust+1;
    {if haven't loaded anything and tcadjust<=0, don't generate code}
    if (dowhat*[FLD1,FLD2] <> []) or (tcadjust>0) then begin
      pushlit(tcadjust);
      if FADD in dowhat then begin
	emit15(6{add},pop,leave);
	emitbranch(5{ble},forwchain)
      end else load(regs1);
      {trip count next...mark temp}
      opstk[tos].state:=opstk[tos].state + [temp];
      { Store very large temp # (as segnr) so it won't match anything set up
	by with }
      opstk[tos].rel.segnr:=chr(255);
      label_;
      looptop:=cp;
      gencode(arg[5],desire,force);
      gencode(arg[1],gregs,noload);
      opstk[tos].opsize:=targetsize;
      if FDEC in dowhat then lop:=43{dec} else lop:=42{inc};
      emit7(lop,pop);
      tos:=tos-1;
      {if we're using a temp register, emit an sob; else do dec,bgt}
      if usereg then begin
	emitbranch(18{sob},backchain);
	codebuf[lastbr+2] := looptop-cp+3;
	emit0(ord(opstk[tos].reg));
	fixbranch(true,forwchain);
	freeregister(opstk[tos].reg);
      end else begin
	emit7(43{dec},leave);
	emitbranch( 4{bgt},backchain);
	codebuf[lastbr+2] := looptop-cp+3;
	fixbranch(true,forwchain);
	emit7(47{tst},pop) {delete trip count from stack}
      end;
      tos:=tos-1
    end { if }
  end { with node@ do }
end {fornode};
 
 
 
procedure sequence;
var numarg,i: integer;
begin {sequence}
numarg:=ord(node@.nrarg);
for i:=1 to numarg-1 do
  gencode(node@.arg[i],assignable + [stk],noload);
gencode(node@.arg[numarg],desire,force)
end {sequence};
 
 
procedure call(isfunc: boolean; isuser: boolean);
var
  i: integer; reg: registers;
  symindex: integer; cctype: symbol_types;
begin {call}
with node@ do begin
  symindex := searchid( dsp.disp, isuser );
  cctype := stable[symindex].stype;
  saveregister(true,[]);	{save stack registers}
  if cctype=fortransy then
    for i:=2 to 5 do emit0( 10046b+i*64 {mov Ri,-(SP)} );
  if isfunc then begin
    newtos;
    with opstk[tos] do begin
      state := [loaded];
      opsize := size;
      reg := stk;
      if isuser and (cctype <= externalsy) then
        adjuststack(-(ord(size)+1) div 8);
      end
    end;
  if cctype <= externalsy then {local proc or pascal ext}
    for i:=1 to ord(node@.nrarg) do
    begin
      gencode(arg[i], [stk], loadvalue);
      tos:=tos-1
    end
    else begin {C or fortran ext}
      for i:=ord(node@.nrarg) downto 1 do
      begin
        gencode(arg[i], [stk], loadvalue);
        tos := tos -1
      end;
  if cctype = fortransy then
  begin
    emit0( 12746b {mov lit,-(SP)} );
    emit0( ord(node@.nrarg) );
    emit0( 10605b {mov SP,R5} )
    end
  end;
  if isuser and (cctype<=externalsy) then
	reg:=getenvironment(ord(segnr), [gr4]);
	{getenvironment called for effect}
  if isfunc and (cctype >= ceesy) then
    opstk[tos].reg := getregister( [gr0] );
  gencall(isuser,dsp.disp);
  if cctype >= ceesy then begin
    i := stable[symindex].snum;
    if cctype = fortransy then i := succ(i);
    adjuststack( 2*i );
    if cctype = fortransy then
      for i:=5 downto 2 do
	emit0( 12600b+i {mov (SP)+,Ri} )
    end
  end
end {call};
 
 
 
begin {gencode}
if node<>nil then with node@ do begin
  case ord(code) of
  9 {refer}: begin
    gencode(arg[1],desire*(gregs + [stk]),noload);
    if indirect in opstk[tos].state then begin {just turn it off}
      opstk[tos].state:=opstk[tos].state-[indirect];
      opstk[tos].opsize:=wordsize {it's a pointer}
    end else
      loadaddress(desire*(gregs + [stk]))
    end;
  10,12 {stol,stof}: store(ord(code)-10);
  16,17 {succ,pred}: genunary(ord(code)+26 {inc,dec});
  24,25,26,27,28,29 {uceq-uclt}: compare(ord(code)-14);
  30,31 {umax,umin}: minmax(ord(code)-30);
  32 {iadd}: genbinary(6 {add},true);
  33 {isub}: genbinary(14 {sub},true);
  34 {imul}: muldivmod(2);
  35 {idiv}: muldivmod(1);
  36 {imod}: muldivmod(0);
  37 {isqr}: square(0);
  40 {ineg}: genunary(44 {neg});
  41 {iabs}: iabs;
  42 {iodd}: iodd;
  56,57,58,59,60,61 {iceq-iclt}: compare(ord(code)-54);
  62,63 {imax,imin}: minmax(ord(code)-60);
  64 {fadd}: if FPU then genfpbinary(20{addf}) else genfpbinary(0{fadd});
  65 {fsub}: if FPU then genfpbinary(22{subf}) else genfpbinary(1{fsub});
  66 {fmul}: if FPU then genfpbinary(18{mulf}) else genfpbinary(2{fmul});
  67 {fdiv}: if FPU then genfpbinary(25{divf}) else genfpbinary(3{fdiv});
  69 {fsqr}: square(2);
  72 {fneg}: genfpunary(3);
  73 {fabs}: genfpunary(2);
  74,75,76 {float - round}: genfpconvert(ord(code)-74);
  88,89,90,91,92,93 {fceq - fclt}:
	if FPU then genfpbinary(ord(code)-86{brtype})
		else fpcompare(ord(code)-86{brtype});
  96 {not}: notnode;
  104,105,106,107,108,109 {eqv-nrimp, aka "bceq"-"bclt"}:
    {With no packed values, booleans are bytes, so can call compare}
    compare(ord(code)-102);
  110 {or}: if gcc in desire
    then condandor(false)
    else genbinary(5 {bis},false);
  111 {and}: if gcc in desire
    then condandor(true)
    else genbinary(0 {and},false);
  113 {union}: if size<=wordsize
    then genbinary(5 {bis}, false);
  114 {inter}: if size<=wordsize
    then genbinary(0 {and}, false);
  115 {sdiff}: if size<=wordsize
    then genbinary(4 {bic}, false);
  117 {sgens}: sgens;
  118 {sadel}: error( 31 );
  120,121 {sceq,scne}: if size<=wordsize
    then compare(ord(code)-118);
  123,124 {scle,scge}: error(32);
  126 {sin}: sin;
  127 {sany}: sany;
  132 {ofset}: begin
    gencode(arg[1],gregs,noload);
    with opstk[tos] do begin
      if indirect in state
      then begin
        loadaddress(gregs);
	rel.reltype:=absact; {no relocation for offset}
        adr.addr:=dsp.disp;
        state:=[based]
        end
      else adr.addr:=adr.addr+dsp.disp;
      opsize:=size
      end
    end;
  133 {indir}: begin
    gencode(arg[1],gregs,noload);
    with opstk[tos] do begin
      if loaded in state
      then begin	{result of a refer-to-temp}
        adr.addr:=dsp.disp;
	rel.reltype:=absact;	{offset needs no relocation}
        state:=(state-[loaded]) + [based]
        end
      else if (indirect in state) or (dsp.disp<>0)
        then begin
	  opsize:=wordsize;
          load(gregs); adr.addr:=dsp.disp;
	  rel.reltype:=absact;
          state:=[based]
          end
	else state:=state + [indirect];
      opsize:=size
      end
    end;
  134 {index}: indexnode(node, 1);
  135 {movem}: move;
  138 {invok}: if size=chr(255) then call(false,false) else call(true,false);
  140 {rtemp}: refertotemp;
  141 {dtemp}: definetemp;
  144 {if}: ifnode;
  145 {case}: casenode;
  147 {loop}: loopnode;
  148 {exit}: exitnode;
  149 {for}: fornode;
  152 {seq}: sequence;
  168,169,170,171,172,173 {vceq-vclt}: vcompare(ord(code)-158);
  208 {call}: if size=chr(255) then call(false,true) else call(true,true);
  162 {liter}: pushlit(dsp.disp);
  164 {litd}: pushlitd(dsp.disp);
  163,176,192 {rdata,varb,parm}: begin
    newtos;
    with opstk[tos] do begin
      state:=[]; opsize:=size; reg:=mem;
      adr.addr:=dsp.disp; rel.segnr:=segnr;
      {Resolve relocation type for varbles here so we know what to do back
       up the tree}
      if code=chr(176)	{is it a variable}
      then if ord(segnr)=1	{make level 1 varbles reside in BSS segment}
	then rel.reltype:=bssact
	else rel.reltype:=absact {no mod for local addresses.  Done in p1. Tacky}
      else if code=chr(192)	{parm}
	then begin
	  rel.reltype:=absact; adr.addr:=adr.addr+6 {stack frame header} end
	else rel.reltype:=datact	{rdata}
      end
    end
  end; {of case}
  if force=loadvalue then load(desire)
  else if force=loadaddr then loadaddress(desire);
  if sdump then dumpstack(ord(code))
  end {of node<>nil}
end {gencode};
 
 
 
begin {genscan}
  if lexlev=1 then rlp:=rlp+1;	{reserve one entry in reltab}
  cp:=cp+9;			{reserve 9 words in code}
  avail:=assignable;		{initialize free registers}
  usedregs:=[];
  tos:=-1; curstate.roving:=lexlev-1;
  gencode(tree,assignable + [stk],noload);
  codebuf[cp]:=0	{something solid so optimize branches doesn't barf}
end {genscan};
 
 
 
 
procedure finalgeneration;
{this procedure completes code generation by generating
code for branches and compacting code in the buffer}
var maxcp,maxrlp,oldcp: integer;
 
procedure optimizebranches;
const {limits on branch targets}
  soblow=-63; sobhigh=0;
  brlow=-128; brhigh=127;
var temp,adjust,nextbr,target,i: integer; brtype: brtypes;
 
procedure sumadjust(from:integer; back:boolean; var target:integer);
var too:integer;
begin {sumadjust}
too:=nextbr+target;
while from>0 do
  if back
  then if from>too
    then begin
      target:=target+(codebuf[from] div 256);
      from:=codebuf[from+1]
      end
    else from:=0
  else if from<too
    then begin
      target:=target-(codebuf[from] div 256);
      from:=codebuf[from+1]
      end
    else from:=0
end {sumadjust};
 
begin {optimizebranches}
{optimize branches whose target is an unconditional branch}
nextbr:=lastbr;
while nextbr>0 do begin
  brtype:=codebuf[nextbr];
  if (brtype>0) and (brtype<18) then begin {simple branches only}
    target:=codebuf[nextbr+2] + nextbr;
    if codebuf[target]=1 {assumes no legal instr has opcode 1!!}
      then codebuf[nextbr+2]:=codebuf[target+2]+target-nextbr
  end;
  nextbr:=codebuf[nextbr+1]
end;
{optimize branches which merely skip over an unconditional branch}
nextbr:=lastbr;
while nextbr>0 do begin
  brtype:=codebuf[nextbr];
  if (brtype>0) and (brtype<18) then begin {simple branches only}
    target:=codebuf[nextbr+2];
    if (target=6) and (brtype<>1) and (codebuf[nextbr+3]=1)
					{assumes no legal instr has opcode 1!!}
      then begin {conditional skipping over unconditional}
        codebuf[nextbr]:=brinv[brtype]; {invert branch type}
        codebuf[nextbr+2]:=codebuf[nextbr+5]+3; {create new target}
        codebuf[nextbr+5]:=3 {make unconditional into a null}
    end
  end;
  nextbr:=codebuf[nextbr+1]
end; {while}
{now optimize each branch as to size
and type depending on distance to target}
nextbr:=0;
while lastbr>0 do begin {swap(codebuf[lastbr+1],nextbr,lastbr)}
  temp:=codebuf[lastbr+1]; codebuf[lastbr+1]:=nextbr;
  nextbr:=lastbr; lastbr:=temp; {reverse links}
  adjust:=0; brtype:=codebuf[nextbr];
  if brtype=0
  then begin {case}
    i:=0;	{%for i:=0 to codebuf[nextbr]-1}
    while i<codebuf[nextbr+2] do begin
      sumadjust(nextbr,false,codebuf[nextbr+i+4]);
      i:=i+1
      end
    end
  else begin {not a case}
    target:=codebuf[nextbr+2]; {optimize adjust for forward branches only}
    if target>0 then sumadjust(nextbr,false,target);
    if brtype=18
    then {branch on count}
      if (target<=sobhigh+1) and (target>=soblow+1)
      then adjust:=3 {can use sob instruction}
      else if (target<=brhigh+2) and (target>=brlow+2)
        then adjust:=2 {can use dec,bne}
        else adjust:=0 {must use dec,beq,jmp}
    else {unconditional or simple conditional}
      if (target<=brhigh+1) and (target>=brlow+1)
      then if target=3
        then adjust:=3 {null branch, will be removed}
        else adjust:=2 {can use br or bcond}
      else if brtype=1
        then adjust:=1 {can use jmp}
        else adjust:=0;{must use bnot cond,jmp}
    {fixup targets of forward branches}
    if target>0 then codebuf[nextbr+2]:=target-adjust;
    codebuf[nextbr]:=adjust*256+brtype
    end {not a case}
  end; {while}
{now we can adjust targets for backward branches}
lastbr:=0;
while nextbr>0 do begin
  if ((codebuf[nextbr] mod 256)>0) and (codebuf[nextbr+2]<0) then
    {not a case and is backward target, adjust it}
      sumadjust(lastbr,true,codebuf[nextbr+2]);
  {swap(codebuf[nextbr+1],lastbr,nextbr)}
  temp:=codebuf[nextbr+1]; codebuf[nextbr+1]:=lastbr;
  lastbr:=nextbr; nextbr:=temp {reverse links}
  end {while}
end {optimizebranches};
 
 
 
procedure generatebranches;
var nextbr,nxtrel,adjust,reg,target,nrtargets,temp: integer; brtype: brtypes;
 
procedure emit5(i:brtypes; offset:integer);
begin {emit5}
emit0(brtab[i]+(offset mod 256))
end {emit5};
 
begin {generatebranches}
nextbr:=0;      {go up list and reverse links}
while lastbr<>0 do begin {swap(codebuf[lastbr+1],nextbr,lastbr)}
  temp:=codebuf[lastbr+1]; codebuf[lastbr+1]:=nextbr;
  nextbr:=lastbr; lastbr:=temp end;
                {set up first relocatable word}
if rlp<maxrlp then nxtrel:=reltab[rlp].cix else nxtrel:=0;
                {main loop follows:}
while oldcp<maxcp do begin
  if (nextbr>0) and (oldcp=nextbr)
  then begin {must generate code for a branch}
    temp:=codebuf[oldcp]; adjust:=temp div 256; brtype:=temp mod 256;
    nextbr:=codebuf[oldcp+1];
    if brtype>0
    then begin {not a case}
      target:=codebuf[oldcp+2];
      if brtype<18
      then begin {simple branch}
        if adjust>=2
        then begin
          if adjust=2 then emit5(brtype,target-1 {short branch}) end
        else begin
          if adjust=0 then begin
            if brtype=1 then emit0(160{nop}) else emit5(brinv[brtype],2);
            target:=target-1
            end;
          emit0(119 {jmp target(pc)});
          emit0((target-2)*2)
          end;
        oldcp:=oldcp+3 end
      else begin {branch on count}
        reg:=codebuf[oldcp+3];
        if adjust=3
        then emit0(32256+(reg*64)-(target-1) {sob reg,target})
        else begin
          emit0(2752+reg {dec reg});
          if adjust=2
          then emit5(3,target-2 {bne target})
          else begin
	    emit5(2{ble},2);
            emit0(119 {jmp target(pc)});
            emit0((target-4)*2)
            end
          end;
        oldcp:=oldcp+4
        end {branch on count}
      end {not a case}
    else begin {case}
      nrtargets:=codebuf[oldcp+2]; reg:=codebuf[oldcp+3];
      emit0(3264+reg {asl reg});
      emit0(25024+reg {add pc,reg});
      emit0(27655+(reg*64) {add 4(reg),pc});
      emit0(4);
      oldcp:=oldcp+4;
      while nrtargets>0 do begin
        codebuf[cp]:=(codebuf[oldcp]-4)*2;
        cp:=cp+1; oldcp:=oldcp+1; nrtargets:=nrtargets-1
        end
      end {case}
    end {code generation for a branch}
  else begin {not a branch, move up code and adjust reltab}
    codebuf[cp]:=codebuf[oldcp];
    if oldcp=nxtrel then begin {adjust entry in relocation table}
      reltab[rlp].cix:=cp; rlp:=rlp+1;
      if rlp<maxrlp then nxtrel:=reltab[rlp].cix else nxtrel:=0
      end;
    cp:=cp+1; oldcp:=oldcp+1
    end {of not a branch}
  end {of main loop}
end {generatebranches};
 
 
begin {finalgeneration}
optimizebranches;
                {get ready for final code generation}
maxcp:=cp; cp:=0; maxrlp:=rlp; rlp:=0;
if lexlev=1                {generate code for procedure entry}
then begin {outermost  procedure}
  gencall(false,0 {jsr pc,$$$000}) end
else begin {inner procedure}
  emit0(4454 {mov r5,-(sp)});
  emit0(4390 {mov r4,-(sp)});
  emit0(4485 {mov sp,r5});
  adjuststack(localsize);
  if gr3 in usedregs then emit0(4326{mov r3,-(sp)});
  if gr2 in usedregs then emit0(4262{mov r2,-(sp)})
end;
oldcp:=9; {9 words were reserved for procedure entry}
generatebranches;
	{generate code for procedure exit}
if lexlev=1
then begin
  emit0(4422{mov r5,sp});
  gencall(false,1 {jsr pc,$$$001}) {outermost procedure}
end else begin
  if gr2 in usedregs then emit0(5506{mov (sp)+,r2});
  if gr3 in usedregs then emit0(5507{mov (sp)+,r3});
  emit0(4422{mov r5,sp});
  emit0(5508 {mov (sp)+,r4});
  emit0(5509 {mov (sp)+,r5});
  if paramsize>0 then {move down return address and purge parameters}
    if paramsize > 4 then begin
      emit0(5558{mov (sp)+,[paramsize-2](sp)});
      emit0(paramsize-2);
      adjuststack(paramsize-2)
    end else begin
      if paramsize > 2 then emit0(5518{mov (sp)+,(sp)});
      emit0(5518{mov (sp)+,(sp)})
    end;
  emit0(135 {rts pc})
  end
end {finalgeneration};
 
 
 
procedure printcode;
const ht=chr(9); nl=chr(10);
type itabform=array[0..122] of {packed} record
  class:integer;
  mnemonic:array[1..5] of char
  end;
const itab=itabform(
  ( 0,'halt '),( 0,'wait '),( 0,'rti  '),( 0,'bpt  '),
  ( 0,'iot  '),( 0,'reset'),( 0,'rtt  '),( 0,'.....'),
  ( 7,'jmp  '),
  ( 6,'rts  '),( 1,'spl  '),( 2,'ccc  '),( 2,'scc  '),
  ( 7,'swab '),( 5,'br   '),( 5,'bne  '),( 5,'beq  '),
  ( 5,'bge  '),( 5,'blt  '),( 5,'bgt  '),( 5,'ble  '),
  (11,'jsr  '),
  ( 7,'clr  '),( 7,'com  '),( 7,'inc  '),( 7,'dec  '),
  ( 7,'neg  '),( 7,'adc  '),( 7,'sbc  '),( 7,'tst  '),
  ( 7,'ror  '),( 7,'rol  '),( 7,'asr  '),( 7,'asl  '),
  ( 3,'mark '),( 7,'mfpi '),( 7,'mtpi '),( 7,'sxt  '),
  (15,'mov  '),(15,'cmp  '),(15,'bit  '),
  (15,'bic  '),(15,'bis  '),(15,'add  '),
  (10,'mul  '),(10,'div  '),(10,'ash  '),(10,'ashc '),
  (11,'xor  '),
  ( 6,'fadd '),( 6,'fsub '),( 6,'fmul '),( 6,'fdiv '),
  ( 9,'sob  '),
  ( 5,'bpl  '),( 5,'bmi  '),( 5,'bhi  '),( 5,'blos '),
  ( 5,'bvc  '),( 5,'bvs  '),( 5,'bcc  '),( 5,'bcs  '),
  ( 4,'emt  '),( 4,'trap '),
  ( 7,'clrb '),( 7,'comb '),( 7,'incb '),( 7,'decb '),
  ( 7,'negb '),( 7,'adcb '),( 7,'sbcb '),( 7,'tstb '),
  ( 7,'rorb '),( 7,'rolb '),( 7,'asrb '),( 7,'aslb '),
  ( 0,'.....'),( 7,'mfpd '),( 7,'mtpd '),( 0,'.....'),
  (15,'movb '),(15,'cmpb '),(15,'bitb '),
  (15,'bicb '),(15,'bisb '),(15,'sub  '),
  ( 0,'cfcc '),( 0,'setf '),( 0,'seti '),( 0,'ldub '),
  ( 0,'ldsc '),( 0,'sta0 '),( 0,'mrs  '),( 0,'stq0 '),
  ( 0,'.....'),( 0,'setd '),( 0,'setl '),( 0,'.....'),
  ( 0,'.....'),( 0,'.....'),( 0,'.....'),( 0,'.....'),
  ( 7,'ldfps'),( 7,'stfps'),( 7,'stst '),
  ( 8,'clrf '),( 8,'tstf '),( 8,'absf '),( 8,'negf '),
  (13,'mulf '),(13,'modf '),(13,'addf '),(13,'ldf  '),
  (13,'subf '),(13,'cmpf '),(14,'stf  '),(13,'divf '),
  (16,'stexp'),(16,'stcfi'),(14,'stcfd'),(12,'ldexp'),
  (12,'ldcif'),(13,'ldcfd'));
const {indicies to entries in above table}
  merr=7; mjmp=8; mrts=mjmp+1; mccc=mrts+2; mswab=mrts+4;
  mbr=mswab+1; mjsr=mbr+7; mclr=mjsr+1; mmov=mclr+16;
  mmul=mmov+6; mfadd=mmul+5; msob=mfadd+4;
  mbpl=mmul+10; mclrb=mbpl+10; mmovb=mclrb+16;
  mcfcc=mmovb+6; mldfps=mcfcc+16;
  mclrf=mldfps+3; mmulf=mclrf+4;
var lcs,lcp,inst,ix,t:integer;
  lrlp:relindex;
  ch: char;
 
procedure writeoctal(i:integer);
begin
write(ols,ord(i<0):1,i div 4096 mod 8:1,i div 512 mod 8:1,
  i div 64 mod 8:1,i div 8 mod 8:1,i mod 8:1)
end {writeoctal};
 
procedure greg(i:integer);
type rtab=array[0..7] of array[1..2] of char;
const grtab=rtab('r0','r1','r2','r3','r4','r5','sp','pc');
begin
write(ols,grtab[i mod 8])
end {greg};
 
procedure freg(i:integer);
type rtab=array[0..7] of array[1..2] of char;
const frtab=rtab('f0','f1','f2','f3','f4','f5','f*','f*');
begin
write(ols,frtab[i mod 8])
end {freg};
 
procedure srcdst(i:integer; isfloat:boolean);
 
procedure breg;
begin {breg}
write(ols,'('); greg(i); write(ols,')')
end {breg};
 
begin {srcdst}
case (i div 8) mod 8 of
0:if isfloat then freg(i) else greg(i);
1:breg;
2,3:begin if odd(i div 8) then write(ols,'@');
  if (i mod 8)=7
  then begin write(ols,'#'); write(ols,codebuf[lcp]); lcp:=lcp+1 end
  else begin breg; write(ols,'+') end;
  end;
4,5:begin if odd(i div 8) then write(ols,'@');
   write(ols,'-'); breg end;
6,7:begin
  if odd(i div 8) then write(ols,'@');
  if (i mod 8)=7
  then writeoctal((lcp+1)*2+codebuf[lcp])
  else begin write(ols,codebuf[lcp]); breg end;
  lcp:=lcp+1
  end
end {of case}
end {srcdst};
 
 
begin {printcode}
if procnr >= 0 then begin
  writeln(ols, ' ');
  writeln(ols,'; procedure ',name:namesize,'(',procnr:3,')')
end;
lcp:=0;
lrlp:=0;
while lcp<cp do begin
  writeoctal(lcp*2); write(ols,ht);
  inst:=codebuf[lcp]; lcp:=lcp+1; lcs:=lcp;
  writeoctal(inst);
  {decode instruction}
  case (inst div 4096) mod 16 of
  0:case (inst div 512) mod 8 of
    0:case (inst div 64) mod 8 of
        0:if ((inst div 8) mod 8) = 0
          then ix:=inst mod 8                             {halt,wait,...}
          else ix:=merr;                                  {illegal}
        1:ix:=mjmp;                                       {jmp}
        2:case (inst div 8) mod 8 of
          0:ix:=mrts;					{rts}
          1,2:ix:=merr;					{illegal}
          3:ix:=mrts+1;					{spl}
          4,5:ix:=mccc;					{ccc}
          6,7:ix:=mccc+1					{scc}
          end;
        3:ix:=mswab;                                      {swab}
        4,5,6,7:ix:=mbr					{br}
        end;
    1,2,3:ix:=((inst div 256) mod 8)+(mbr-1);               {bne-ble}
    4:ix:=mjsr;                                           {jsr}
    5,6:ix:=((inst div 64+8) mod 16)+mclr;                    {clr-tst}
    7:ix:=merr                                            {illegal}
    end;
  1,2,3,4,5,6:ix:=((inst div 4096) mod 8)+(mmov-1);           {mov-add}
  7:case (inst div 512) mod 8 of
    0,1,2,3,4:ix:=((inst div 512) mod 8)+mmul;		{mul-xor}
    5:if ((inst div 32) mod 16)=0
      then ix:=((inst div 8) mod 4)+mfadd			{fadd-fdiv}
      else ix:=merr;					{illegal}
    6:ix:=merr;						{illegal}
    7:ix:=msob						{sob}
    end;
  8:case (inst div 512) mod 8 of
    0,1,2,3,4:ix:=((inst div 256) mod 16)+mbpl;               {bpl-trap}
    5,6:ix:=((inst div 64+8) mod 16)+mclrb;                   {clrb-mtpd}
    7:ix:=merr                                            {illegal}
    end;
  9,10,11,12,13,14:ix:=((inst div 4096) mod 8)+(mmovb-1);     {movb-sub}
  15:case (inst div 256) mod 16 of
    0:if ((inst div 64) mod 4)=0
      then if (inst mod 64)<16
        then ix:=(inst mod 64)+mcfcc                      {cfcc-setl}
        else ix:=merr                                     {illegal}
      else ix:=((inst div 64) mod 4)+(mldfps-1);              {ldfps-stst}
    1:ix:=((inst div 64) mod 4)+mclrf;                        {clrf-negf}
    2,3,4,5,6,7,8,9,10,11,12,13,14,15:
      ix:=((inst div 256) mod 16)+(mmulf-2)                   {mulf-ldcfd}
    end
  end; {of outer case}
  write(ols,ht,itab[ix].mnemonic:8);
  case itab[ix].class of
  1:write(ols,inst mod 8);
  2:write(ols,inst mod 16);
  3:write(ols,inst mod 64);
  4:write(ols,inst mod 256);
  5:begin t:=inst mod 256;
    if t>127 then t:=t-256;	{byte sign extend}
    writeoctal((lcp+t)*2) end;
  6:greg(inst);
  7:srcdst(inst,false);
  8:srcdst(inst,true);
  9:begin greg(inst div 64);
    write(ols,','); writeoctal((lcp-(inst mod 64))*2) end;
  10:begin srcdst(inst,false); write(ols,','); greg(inst div 64) end;
  11:begin greg(inst div 64); write(ols,','); srcdst(inst,false) end;
  12:begin srcdst(inst,false); write(ols,','); freg(inst div 64 mod 4) end;
  13:begin srcdst(inst,true); write(ols,','); freg(inst div 64 mod 4) end;
  14:begin freg(inst div 64 mod 4); write(ols,','); srcdst(inst,true) end;
  15:begin srcdst(inst div 64,false); write(ols,','); srcdst(inst,false) end;
  16:begin freg(inst div 64 mod 4); write(ols,','); srcdst(inst,false) end
  end; {of case}
  writeln(ols);
  while lcs<lcp do begin
    write(ols,ht); writeoctal(codebuf[lcs]);
    ch:=' ';
    if lrlp < rlp then {OK to look for relocation info}
      if lcs = reltab[lrlp].cix then begin {got relocation}
	case reltab[lrlp].rs.reltype of
	  absact,absrel: ch:=' '; {none}
	  txtact,txtrel: ch:='t'; {local text}
	  datact,datrel: ch:='d'; {fixed data}
	  bssact,bssrel: ch:='b'; {uninitted data}
	  uxtact,uxtrel: ch:='T' {external text}
	end;
	lrlp:=lrlp+1
      end;
    write(ols,ch);
    if (ch='t') or (ch='T') then
    begin
      { print procedure name }
      ix := searchid(ord(reltab[lrlp-1].rs.segnr), (ch='t'));
      write(ols,ht,ht,stable[ix].sname)
    end;
    writeln(ols);
    lcs:=lcs+1
    end {of "while lcs<lcp"}
  end {of outer while}
end {printcode};
 
 
 
procedure options;
var
  c: char;
  i: 0..255;
begin {options}
  if argv[flgx]@[0] = '-' then begin {parse switches}
    i:=1;
    loop
      c := argv[flgx]@[i];
    exit if c=chr(0);
      if c='O' then list:=true
      else
	if c='S' then sdump:=true
	else
	  if c='P' then dproc:=true
	  else
	    if c='X' then xtern:=true;
      i:=i+1
    end
  end
end {options};
 
 
 
{Here follows the output routines which set up "object module"}
 
type recordbuf = record
	index:integer;
	buff:array[-2..workspace] of integer;
	end;
var recbufptr:@recordbuf;

procedure writerecord ( finished:boolean; s,f:integer );
  var ss:integer;
      checksum:integer;
begin {writerecord}
  ss := s;  {Start of object data}
  if RSX11 then begin
  while ss<f do begin
    obj@ := codebuf[ss];  put(obj);
    ss := succ(ss)
    end;
  if finished then break(obj)  {Write out this record keeping
				  correct byte count.}
  end {RSX11} else begin {RT11}
  while ss<f do with recbufptr@ do begin
    buff[index] := codebuf[ss];
    index := succ(index);
    ss := succ(ss);
  end;
  if finished then with recbufptr@ do begin
    buff[-2] := 1;	{binary record start sequence}
    buff[-1] := (index+2)*2;	{number of bytes this record}
    checksum := 0;
    for ss:= -2 to index-1 do begin
      obj@ := buff[ss]; put(obj);	{output two bytes of data}
      checksum := checksum + (buff[ss] mod 256)
			   + ((buff[ss] div 256) mod 256)
    end;
    checksum := checksum mod 256;
    checksum := 400b - checksum;
    checksum := checksum mod 256;
    obj@ := checksum; put(obj);	{output checksum}
    index := 0;
  end;
end; {RT11}
end {writerecord};
 
procedure outheader( prefix,suffix:integer );
const w=maxcode+1;  {start of workspace}
      gsdrec=1;
begin {outheader}
  codebuf[w+0] := gsdrec;  {Type = GSD}
  {Module name entry}
  codebuf[w+1] := prefix;  codebuf[w+2] := suffix;
  codebuf[w+3] := 0;       codebuf[w+4] := 0;
  writerecord( true, w, w+5 )
end {outheader};
 
 
function radcvt( var s:array [0..5] of char; i:integer):integer;
{ convert 3 chars starting at s[i] from ascii to rad50. }
type radlist = array [40b..132b] of integer;
const rad50 = radlist( 0,0,0,0,33b,0,0,0,0,0,0,0,0,0,34b,0,36b,
		       37b,40b,41b,42b,43b,44b,45b,46b,47b,0,0,0,0,0,0,0,
		       1,2,3,4,5,6,7,10b,11b,12b,13b,14b,15b,16b,17b,20b,
		       21b,22b,23b,24b,25b,26b,27b,30b,31b,32b);
begin {radcvt}
  radcvt := ((rad50[ ord(s[i]) ] * 50b) +
		rad50[ ord(s[i+1]) ] ) * 50b +
		rad50[ ord(s[i+2]) ]
end {radcvt};
 
 
 
 
procedure outtrailer;
const w=maxcode+1;  {Start of workspace}
      endgsdrec=2;  endmodrec=6;
      gsdrec=1;  rldrec=4;  txtrec=3;  lcentry=7;
      psectentry=5; relocate=32; global=64; readonly=16; kludge=8;
      overlay=4; glbsym=4; glbsymdef=8;
      dataentry=psectentry*256+relocate+global+kludge+overlay;
      datadef=glbsym*256+relocate+glbsymdef+global;
      maxtxt=42;
var
  count, address, i,
  dataprefix, datasuffix: integer;
  byte1, byte2: char;
 
begin {outtrailer}
  i := searchid( -1, true );
  dataprefix := radcvt( stable[i].sname, 0 );
  datasuffix := radcvt( stable[i].sname, 3 );
  outheader( dataprefix, datasuffix );
  codebuf[w+0] := gsdrec;
  codebuf[w+1] := dataprefix;  codebuf[w+2] := datasuffix;
  codebuf[w+3] := dataentry;   codebuf[w+4] := dcnt;
  codebuf[w+5] := dataprefix;  codebuf[w+6] := datasuffix;
  codebuf[w+7] := datadef;     codebuf[w+8] := 0;
  writerecord( true, w, w+9 );
  if dcnt <> 0 then begin
    codebuf[w+0] := rldrec;
    codebuf[w+1] := lcentry;  codebuf[w+2] := dataprefix;
    codebuf[w+3] := datasuffix;  codebuf[w+4] := 0;
    writerecord( true, w, w+5 );
    reset(dat, "PASDAT.TMP");
    address := 0;
    codebuf[w] := txtrec;
    while dcnt>0 do begin
      count := 0;
      codebuf[w+1] := address;
      while (dcnt>0) and (count < maxtxt) do begin
        byte1 := dat@; get(dat);
        dcnt := pred(dcnt);
        if dcnt<=0 then byte2 := chr(0) else 
	begin
          byte2 := dat@; get(dat); dcnt := pred(dcnt)
	end;
        codebuf[w+2+count] := ord(byte1) + ord(byte2)*256;
        address := address+2;  count := succ(count)
      end {while};
      writerecord(true,w,w+2+count);
      count := 0
    end {while dcnt>0};
  end {if dcnt <> 0};
  codebuf[w] := endgsdrec;  writerecord(true, w, w+1);
  codebuf[w] := endmodrec;  writerecord(true, w, w+1);
end  {outtrailer};
 
 
 
 
procedure outprocedure;	{write out procedure code and relocation data}
const w=maxcode+1; gsdrec=1; txtrec=3; rldrec=4; glbsym=4; glbsymdef=8;
      psectentry=5; fastmem=1; library=2; overlay=4; kludge=8;
      readonly=16; relocate=32; global=64; dataref=128;
      instentry=psectentry*256+relocate+kludge;
      globentry=psectentry*256+relocate+global+kludge+overlay;
      dataentry=psectentry*256+relocate+global+kludge+overlay;
      instdef=glbsym*256+relocate+glbsymdef+global;
      traentry=3*256;
      systprefix = 126423B;	{RAD50('$$$'), heap psect}
      globpref1  = 124744B;	{RAD50('$GL'), globals psect}
      globpref2  =  57043B;	{RAD50('OBS'), globals psect}
 
type reference=record link:@reference; value:integer end;
var prefix,suffix,gx,rx,
    dataprefix, datasuffix, i: integer;
    globlist:@reference;
  
procedure setcodebuf( var s:array [0..5] of char );
begin {setcodebuf}
  codebuf[rx+1] := radcvt( s, 0 );
  codebuf[rx+2] := radcvt( s, 3 )
end {setcodebuf};
  
 
procedure addlist( ptr:@reference; ref:integer );
  
var nptr:@reference;
  
begin {addlist}
  loop
    exit if ref=ptr@.value;
    exit if ptr@.link=nil then begin
      new(nptr);
      ptr@.link := nptr;
      nptr@.link := nil;
      nptr@.value := ref;
      end;
    ptr := ptr@.link;
  end;
end {addlist};
 
  
procedure addglobref( procnr:integer; isuser:boolean );
  
var ptr:@reference;
    ref:integer;
  
begin {addglobref}
  ptr := globlist;
  ref := searchid( procnr, isuser );
  setcodebuf( stable[ref].sname );
  if ptr=nil then begin
    new(globlist);
    globlist@.link := nil;
    globlist@.value := ref;
    end
  else addlist( ptr, ref );
end {addglobref};
  
 
procedure outgblref;
  
const maxrld=w+7+42;
      instref=glbsym*256+global;
var ptr:@reference;
  
begin {outgblref}
  codebuf[w+0] := gsdrec;
  rx := w;
  ptr := globlist;
  loop
    exit if ptr=nil;
    setcodebuf( stable[ptr@.value].sname );
    codebuf[rx+3] := instref;
    codebuf[rx+4] := 0;
    rx := rx + 4;
    ptr := ptr@.link;
    if rx>=maxrld then begin
      writerecord(true,w,rx+1);
      rx := w;
      end;
  end;
  if rx>w then writerecord(true,w,rx+1);
end {outgblref};
 
 
 
procedure outtxtandrld(prefix,f: integer);
const lcentry=7; maxtxt=42; maxrld=w+7+42;
      endgsdrec=2; endmodrec=6;
type relsiztab = array [0..14] of integer;
const relentsize = relsiztab(0,2,3,2,3,4,4,4,2,1,3,0,3,4,4);
var relent,txtaddr,lrlp,lcp,rcp,tcp: integer;
begin {outtxtandrld}
  mark;
  globlist := nil;
  {*** create TXT record header and RLD record header}
  codebuf[w+2] := txtrec;
  codebuf[w+6] := rldrec;
  {create and write out initial RLD record to define location counter}
  codebuf[w+7] := lcentry;
  codebuf[w+8] := prefix;
  codebuf[w+9] := suffix;
  codebuf[w+10] := 0;  {begin at relative zero}
  writerecord(true, w+6, w+11);
  {write out a text record followed by a RLD record (if required)}
  {until all text has been processed}
  lrlp:=0;  lcp:=0;
  if rlp>0 then rcp:=reltab[0].cix else rcp:=f; {first relocated word}
  while lcp<f do begin
    tcp := lcp + maxtxt;  if tcp>f then tcp := f;
    rx:=w+7;  txtaddr:=lcp*2;
    while (rcp<tcp) and (rx<maxrld-4) do begin {build RLD entries}
      with reltab[lrlp] do begin
	case rs.reltype of
	  absact,absrel: relent:=0;
	  bssact,datact: if codebuf[cix]=0 then relent:=10 else relent:=13;
	  bssrel,datrel: if codebuf[cix]=0 then relent:=12 else relent:=14;
	  txtact,uxtact: if codebuf[cix]=0 then relent:=2 else relent:=5;
	  txtrel,uxtrel: if codebuf[cix]=0 then relent:=4 else relent:=6
	end;{case}
	codebuf[rx]:=(rcp*2-txtaddr+4)*256+relent;
	case rs.reltype of
	  absact,absrel:  {nochange};
	  txtact,txtrel: addglobref( ord(rs.segnr), true );
	  uxtact,uxtrel: addglobref( ord(rs.segnr), false );
	  datact,datrel: addglobref( -1, true );
	  bssact,bssrel: begin
			   codebuf[rx+1] := globpref1;
			   codebuf[rx+2] := globpref2
			   end
	end;{case}
	codebuf[rx+3]:=codebuf[rcp];
	rx:=rx+relentsize[relent]
	end;
      lrlp:=succ(lrlp);
      if lrlp<rlp then rcp:=reltab[lrlp].cix else rcp:=f
      end;
    if rcp<tcp then tcp:=rcp;
    {write out text header}
    codebuf[w+3]:=txtaddr;     {load address of the text}
    writerecord(false,w+2,w+4);
    writerecord(true,lcp,tcp); {write out body of the text}
    if rx>w+7 then  {write out relocation entries}
      writerecord(true,w+6,rx);
    {bump up text index and continue}
    lcp:=tcp
    end;
  outgblref;  {Output global references}
  release;
  codebuf[w] := endgsdrec;  writerecord(true, w, w+1);
  codebuf[w] := endmodrec;  writerecord(true, w, w+1);
end  {outtxtandrld};
 
 
begin {outprocedure}
  if RT11 then begin
    new(recbufptr);	{allocate temporary object record buffer}
    recbufptr@.index := 0;	{initialize the index to it}
  end; {RT11}
  gx := searchid( procnr, true);
  prefix := radcvt( stable[gx].sname, 0 );
  suffix := radcvt( stable[gx].sname, 3 );
  i := searchid( -1, true );
  dataprefix := radcvt( stable[i].sname, 0 );
  datasuffix := radcvt( stable[i].sname, 3 );
  {create GSD record for an object module}
  outheader( prefix, suffix );
  {create GSD record for this procedure}
  codebuf[w+0]:=gsdrec;
  {create entry for psect containing instructions}
  codebuf[w+1]:=prefix;  codebuf[w+2]:=suffix;  {psect name}
  codebuf[w+3]:=instentry;  {entry type and flags}
  codebuf[w+4]:=cp*2;       {size in bytes}
  codebuf[w+5]:=prefix;  codebuf[w+6]:=suffix;  {entry name}
  codebuf[w+7]:=instdef;     codebuf[w+8]:=0;
  codebuf[w+9]:=dataprefix;  codebuf[w+10]:=datasuffix;
  codebuf[w+11]:=dataentry;  codebuf[w+12]:=0;
  codebuf[w+13]:=globpref1;  codebuf[w+14]:=globpref2;
  codebuf[w+15]:=globentry;  codebuf[w+16]:=0;
  gx := w + 17;
  {if this is outermost procedure, then generate transfer address entry}
  if procnr=0 then begin
    codebuf[gx]:=prefix;  codebuf[gx+1]:=suffix;  {transfer name}
    codebuf[gx+2]:=traentry;  codebuf[gx+3]:=0;  {start at location zero}
    codebuf[gx+4]:=globpref1; codebuf[gx+5]:=globpref2;
    codebuf[gx+6]:=globentry; codebuf[gx+7]:=localsize;
    gx:=gx+8
    end;
  writerecord(true,w,gx);
  {now output the text and relocation entries}
  outtxtandrld(prefix, cp)
end  {outprocedure};
 
 
procedure openols;
begin {openols}
  if Ok_to_proceed and not ols_opened then
  begin
    ols_opened := true;
    rewrite(ols, argv[olsx]@, 2);
    writeln(ols);
    writeln(ols, compiler_version)
  end
end {openols};
 
 
procedure openp2files;
begin {openp2files}
  if (argc = 5) or (argc = 6) then
  begin
    Ok_to_proceed := true;
    reset(int, "PASINT.TMP");
    rewrite(obj, argv[objx]@);
    ols_opened := false;
    if list or dproc then openols
  end
  else begin
    Ok_to_proceed := false;
    writeln(output, nl, 'P2: command line error.')
  end
end {openp2files};
 
 
procedure moduleident;
{ read module name and initial options, if any. }
var
  s: -1..maxsym;
  ch: byte;
begin {moduleident}
  ch := getbyte;
  while ch = chr(3) do
  begin
    readoptions;  ch := getbyte
  end;
  if ch = chr(5) then
  begin
    ident;			{get module identification}
    s := searchid(-1, true);	{place in symbol table for data name}
    s := searchid( 0, true);	{and for main procedure name}
  end
  else begin
    error(99);
    Ok_to_proceed := false
  end
end {moduleident};
 
 
 
 
begin {P2FP}
  {initialize output flags and then process option flags}
  list:=false; sdump:=false; dproc:=false; xtern:=false;
  options;
  openp2files;
  if Ok_to_proceed then
  begin
 
    lastid := -1;			{No id's entered}
    {initialize object module output}
    lexlev:=0; procnr:=0;
    moduleident;
    {initialize code buffer indicies}
    while Ok_to_proceed and not eof(int) do
    begin
      mark;
      buildtree;
      if Ok_to_proceed then
      begin
	if sdump then
	  writeln(output, NL, '-------- ', name: namesize);
	cp:=0;		{init code buffer pointer}
	rlp:=0;		{relocation data buffer pointer}
	lastbr:=0;	{branch chain optimization index}
	{Set up symbol table entry for this procedure}
	s:=searchid(procnr,true);	{get symbol for user proc}
	stable[s].snum:=paramsize div 2;	{number of parms, for pdb}
	if calltype = 0 then
	begin
	  prescan;
	  genscan;			{generate code in code buffer}
	  finalgeneration;		{finish code generation of branches}
	  {output code, both binary and symbolic forms}
	  if dproc then
	    writeln(ols,procnr:3,' ':2,name:namesize,
		' ':18-namesize,dcnt:6,cp:6);
	  if list then printcode;
	  outprocedure;
	end;
	{update counters:}
	calltype := 0;
	lexlev := lexlev-1;
	release;
	if RT11 then while not eof(int) and (int@=chr(0)) do get(int);
      end {Ok_to_proceed}
    end {while not eof};
    outtrailer
  end {Ok_to_proceed}
end {P2FP}.