{$t-}
program pascal_pass2_RSX;
{Modified to correspond, more or less, to pass2.c.  JCW\770303}
{Modified to generate RSX-11 object modules  JRB\780410}

const ht=chr(9); nl=chr(10); ff=chr(12);
type byte = char;

			{Description of node}
			{*******************}
const maxarg=255; litcode=chr(162);
type ptn = @node;			{description of tree nodes}
  node = record
 	code: byte;	{indicates node type}
 	size: byte;
 	disp: integer;
 	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 for UNIX loader}
		{*******************************************}

{UNIX load module symbol table form:}
const  maxsym=120;
{symbol type: external symbol type is same as local, with bit 5 set.}
{define these as const's, since they are structured, and bootstrap
	 version will not pack things}
  abssym = 1 {absolute symbol};
  undsym = 0 {undefined symbol};
  txtsym = 2 {text segment symbol};
  datsym = 3 {data segment symbol};
  bsssym = 4 {bss segment symbol};
  filsym = 31 {octal 37. File name symbol.  Not used};
  undext = 32 {undefined external symbol};
  absext = 33 {absolute external symbol};
  txtext = 34 {text segment external symbol};
  datext = 35 {data segment external symbol};
  bssext = 36 {bss segment external symbol};

type
  stab =  {packed} record
   sname: array [0..7] of char;
   stype: 0..255; {packed record val:0..31; isextern: boolean end;}
   snum: 0..255;  {arg count for use by pdb}
   sval: integer;
	end;

var stable: array[0..maxsym] of stab;
  s,lastid: -1..maxsym;

			{Description of relocation info}
			{******************************}
{UNIX appends to the code module one word per word of text and data.  The
 format of the word is:

		+-----------------+
		|        |      | |
		+-----------------+
		     |       |   |
		     |       |   0 => actual value
		     |       |   1 => PC-relative
		     |      Relocation type (below)
		   Symbol number/Unused
}
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=255;
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,fr4,fr5,stk,gcc,mem,dbl);
  resources=set of registers;
  {savetype mnemonics:	ssr - save stack registers
			str - save temp registers
			mte - mark temp empty
			csr - conditional save register (until desired is free)}
{  no longer used...at one time an arg to restoreregister}
{  savetypes=set of (ssr,str,mte,csr);}
const
  evenregs=[gr0,gr2];
  oddregs=[gr1,gr3];
  gregs=evenregs + oddregs;
  fregs=[fr0,fr1,fr2,fr3,fr4,fr5];
  gfregs=[fr0,fr1,fr2,fr3];		{"good" fregs}
  ofregs=[fr4,fr5];			{other fregs...can't be used easily}
  tregs=[gr2,gr3];
  assignable=gregs + gfregs;
  maxtmpregs=2 {use two regs for temps};
  tmpuseregs=[gr3];
var
  avail,			{the set of free registers}
  tmpreg,			{the set of registers in use as temps}
  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;
    addr: integer;
    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..15] 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}
  lexlev: integer;			{current lex level}


				{Files used in pass2}
				{*******************}
const
  intx=2;	{argv index to int code filename}
  dbgx=6;       {" tree-dump filename}
  olsx=5;       {" object listing filename}
  lstx=7;       {" procedure name/number index filename}
  objx=4;	{" object code filename}
  datx=3;	{" initialized data filename}
  flgx=1;	{" pass2 switches}
  {switches to control output from pass2:
  debug: generate tree dump (pascal.dbg) char d
  list:  generate object listing (pascal.ols) char l
  sdump: generate stack dump (standard output) char s
  dproc: generate name/procnumber concordance (pascal.lst) char p
  }
var
  debug,list,sdump,dproc: boolean;

  {files used by second pass:}
  int: text;			{file of intermediate code}
  dbg: text;			{file to dump debug info}
  ols,lst: 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
	30	searchid	symtab overflow
}
begin
write(output,nl,'pass2 error ',n,' in ',name: namesize); break(output)
end;

procedure buildtree;

	{special code values: call, varb, and parm all have the form

			+____+____+
			|    |    |
			+____+____+
			   |    |
			   |    Lex level referred to
			  "code"				}


const stacksize=256;
  END=7;
var
  s: 0..stacksize;
  stack: array[1..stacksize] of ptn;
  coden,argn,addrn: integer;
  temp: ptn;
  sizen,segn,ch: byte;
  allign: integer; {to round out localsize if odd}
  fvalue: array[0..3] of integer; {to hold litf/litd data}
  shortlit,		{set by read8; read by buildtree to indicate 16-bit reals}
  midlit: boolean;	{set by read8; read by buildtree to indicate 32-bit reals}

function getbyte: byte;
begin getbyte:=int@; get(int) end;

function getword: integer;
var temp: integer;
begin
temp:=ord(int@)*256; get(int);
getword:=ord(int@)+temp; get(int)
end {getword};

{read 8 bytes of data to be used as a float constant.  Decide whether
 16 (shortlit) or 32 (midlit) bits will suffice to hold it.}
procedure read8;
begin
  fvalue[0]:=getword;
  fvalue[1]:=getword;
  fvalue[2]:=getword;
  fvalue[3]:=getword;
  shortlit:=(fvalue[1]=0) and (fvalue[2]=0) and (fvalue[3]=0);
  midlit:=(fvalue[2]=0) and (fvalue[3]=0);
  shortlit:=midlit and (fvalue[1]=0)
end;

procedure dumptree(node: ptn);
var i: integer;
begin
if node<>nil then begin
  write(dbg,node:6,ord(node@.code):5,ord(node@.size):5,
    node@.disp:8,ord(node@.segnr):5,ord(node@.nrarg):5);
  i:=1;
  while i<=ord(node@.nrarg) do begin
    write(dbg,node@.arg[i]:7); i:=i+1
    end;
  write(dbg,nl);
  i:=1;
  while i<=ord(node@.nrarg) do begin
    dumptree(node@.arg[i]); i:=i+1
    end
  end
end; {dumptree}

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); 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; addrn:=getword;
	{collapse code value} if coden < 192 then coden:=176 else coden:=192 end;
      162,163 {lit,rdata}: addrn := getword;
      164 {litd}: begin
      {read in a floating lit, decide if it can be a lit and build
       either a lit or rdata node to account for it}
	read8;		{collect data for float lit}
	if shortlit then begin
	  coden:=162;	{fake a lit node}
	  addrn:=fvalue[0]	{will be treated as binary data}
	end else begin
	  error(9);	{let user know; **TEMP**}
	  coden:=162;	{***TEMP: should be an rdata(163)***}
	  if midlit then sizen:=chr(2) else sizen:=chr(4);
	  addrn:=fvalue[0]	{***TEMP: should write to dat***}
	end
      end;
      140,141 {rtemp,dtemp}: begin 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; addrn:=getword;
        if coden>=134 then argn:=2 else argn:=1 end;
      146,147,152 {n-ary}: argn:=ord(getbyte) + 1;
      145,138 {case,invoke}: begin argn:=ord(getbyte); addrn:=ord(getbyte);
        if (coden=138) and (addrn=4) then {new} sizen:=chr(2) 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;
        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,40,41,42,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);
 	disp:=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,4: {byte,word} {Shouldn't occur};
    5 {ident}:begin argn:=ord(getbyte); namesize:=0;
      while argn>0 do begin
        if namesize<15 then namesize:=succ(namesize);
        ch:=getbyte; name[namesize]:=ch;
        argn:=pred(argn)
        end
      end;
    6: {proc} lexlev := lexlev+1;
    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 = END;
if debug then begin
  dumptree(tree); write(dbg,ff); break(dbg)
end
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 (FOR 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:}
    FOR  = 149; {check arg[5]; return num+1}
    DTEMP= 141; {check arg[2]; return num+1}
    LOOP = 147; {check arg[1]-arg[n]; return max}
    EXIT = 148;	{check arg[2]; return num}
    SEQ  = 152; {check arg[1]-arg[n]; return max}
    IF   = 144; {check arg[2],arg[3]; return max}
    CASE = 145; {check arg[1]-arg[n]; return max}
    END = 7; {check arg[1]; return value}

  var lsize,i: integer;

  begin
    lsize:=0;
    with pn@ do
      if ord(code)=FOR 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)=LOOP) or (ord(code)=SEQ) or (ord(code)=CASE) then
	for i:=1 to nrarg do lsize := max(lsize,tracetemp(arg[i]))
      else if ord(code)=IF then begin
	lsize:=tracetemp(arg[2]);
	lsize:=max(lsize,tracetemp(arg[3]))
	end
      else if ord(code)=EXIT then
	lsize:=tracetemp(arg[2])
      else if ord(code)=END then
	lsize:=tracetemp(arg[1]);
    tracetemp:=lsize
  end{tracetemp};

begin
 i:=tracetemp(tree) {discard the temp count for the whole tree}
end;

{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..7] 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
  sym[5]:=chr((N mod 10)+ord('0')); N:=N/10;
  sym[4]:=chr((N mod 10)+ord('0')); N:=N/10;
  sym[3]:=chr((N mod 10)+ord('0'))
end;

function match(var s1,s2: array[0..7] of char): integer;
{s1, s2 are "var" to avoid loading them into stack}

{ s1<s2 => 0; s1=s2 => 1; s1>s2 => 2}
var val: integer;
  i:0..7;
begin
  i:=0;
  while (s1[i]=s2[i]) and (s1[i] <> chr(0)) do i:=i+1;
  if s1[i]=chr(0) then val:=1
  else if s1[i]<s2[i] then val:=0 else val:=2;
  match:=val
end;

begin
  lchar:='_';
  if isuser then lchar:='i';
  sym[0]:='_';	{for cdb reasons}
  sym[1]:=lchar; sym[2]:=lchar;
  itoa(symno);	{put 3 chars of symno into sym, from sym[3]}
  sym[6]:=chr(0); sym[7]:=chr(0);

  {look for the symbol}
  i:=0; found:=false;
  if i <= lastid then
    loop
      found:=odd(match(sym,stable[i].sname));
    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 begin
      stable[lastid].sname:=sym;
      if isuser then stable[lastid].stype:=ord(txtsym)
      else stable[lastid].stype:=ord(undext);
      stable[lastid].snum:=0;
      stable[lastid].sval:=0 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;


procedure swaptos;
var temp: operand;
begin
temp:=opstk[tos]; opstk[tos]:=opstk[tos-1]; opstk[tos-1]:=temp
end;

procedure duptos;
begin
  newtos; opstk[tos]:=opstk[tos-1]
end;


procedure pushlit(n: integer);
begin
newtos;
with opstk[tos] do begin
  state:=[liter]; opsize:=wordsize;
  reg:=mem;
  addr:=n; rel:=ordinary
  end
end;


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;


procedure emit0(i:integer);
begin
codebuf[cp]:=i;
if cp=maxcode then error(3) else cp:=cp+1
end;

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
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
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
if desire <> []
then if desire*{inter}assignable <> []
  then begin
    if desire*avail=[] then saveregister(false,desire);
    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
i:=tos;		{restore from top of operand stack}
while i>=thru do begin
  with opstk[i] do if saved in state then begin
    if reg in avail then ldesire := [reg] else ldesire := desire;
    lreg := getregister(desire);
    moveregister(stk,lreg);
    reg := lreg;
    state:=state-[saved]
  end;
  i:=pred(i)
  end
end {restoreregister};

procedure emitbranch(brtype: brtypes; var list: branchlist);
begin
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;


procedure mergebranchchains(var from, into: branchlist);
var
  nextbr, temp: codeindex;
begin
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;


procedure fixbranch(fallthru: boolean; var chain: branchlist);
var
  nextbr, temp: codeindex;
begin
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;


procedure label;
begin
curstate.roving := 0;
curstate.fpustate := fpuunknown
end;

{ 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 (UNIX-specific)}
function getenvironment(oflevel: integer; leaveitin: resources): registers;
var n: integer; src,dst: registers;
begin
{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
  then dst:=gr4 {this is the preferred dst}
  else dst:=getregister(leaveitin); {else any one will do}
  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 fo 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
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 {%%%bug pass2(bsm)} 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 UNIX-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 emit0(24576+ord(rb)*64+ord(reg) {add rb,reg})
          else reg:=rb
          end
        else						{global reference}
	{assume type is absact, and make it absrel}
          if not (indexed in state) 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 (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 emit7(fop: integer; dstdis: disposition);
var dstmr: integer; dstaddr: boolean;
begin
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(addr,rel)
end;

{code emitter for floating ops of form "op [f]dst"}
procedure emitfop1(fop:integer; dstdis: disposition);
{fop will be: 0: clrf, 1: tstf, 2: absf, 3: negf}
var dstmr: integer;	{mode/reg field for instr}
  dstaddr: boolean;	{set up by address - is address needed?}
begin
  fop:=fop+964{1704B};				{form op from fop}
  address(false,dstdis,dstmr,dstaddr);		{compute oprnd address}
  emit0(fop*64+dstmr);
  if dstaddr then with opstk[tos] do emitaddr(addr,rel)
end;

procedure emit10(fop: integer; srcdis: disposition);
var srcmr,srcword: integer; srcrel: relpair; srcaddr: boolean;
begin
restoreregister(tos-1,gregs);	{the destination must be a register}
address(false,srcdis,srcmr,srcaddr);
if srcaddr then with opstk[tos] do begin srcword:=addr; srcrel:=rel end;
tos:=tos-1;
emit0((fop*8+ord(opstk[tos].reg))*64+srcmr);
if srcaddr then emitaddr(srcword,srcrel)
end;

{floating version of emit15; for instrs of the form "op ac,src/dst"}
procedure emitfop2(fop: integer; srcdis,dstdis: disposition);
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;
{for floating ops, no optimization will be done.  This requires passing
 floating values as literals which is not yet resolved}
begin
  loptype:=fpoptab[fop];		{load or store}
  if opstk[tos-1].state *{inter} [indexed,based] # [] then
    restoreregister(tos-1,gregs);	{restore buried addressing register}
  address(false,srcdis,srcmr,srcaddr);
  if srcaddr then with opstk[tos] do begin
    lword:=addr; lrel:=rel
  end;
  tos:=tos-1;
  address(false,dstdis,dstmr,dstaddr);
  if dstaddr then with opstk[tos] do begin
    lword:=addr; lrel:=rel
  end;
  {emit the instr}
  if loptype = load then
    emit0(((fop+224{340B})*4+dstmr)*64+srcmr)
  else
    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;

procedure emit15(fop: integer; srcdis,dstdis: disposition);
var srcmr,dstmr,srcword: integer;
  srcrel: relpair;
  srcaddr,dstaddr: boolean;
  opt: (none,some,all);
begin
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 addr=0 then begin fop:=40 {clr}; opt:=some end;
  9  {movb}: if addr=0 then begin fop:=552 {clrb}; opt:=some end;
  5,13 {bis,bisb}: if addr=0 then opt:=all;
  0  {and }: if addr=0 then begin fop:=40 {clr}; opt:=some end
    else if addr=-1 then opt:=all;
  8  {andb}: if addr=0 then begin fop:=552 {clrb}; opt:=some end
    else if addr=255 then opt:=all;
  4  {bic }: if addr=0 then opt:=all
    else if addr=-1 then begin fop:=40 {clr}; opt:=some end;
  12 {bicb}: if addr=0 then opt:=all
    else if addr=255 then begin fop:=552 {clrb}; opt:=some end;
  6  {add }: if addr=0 then opt:=all
    else if addr=1 then begin fop:=42 {inc}; opt:=some end
    else if addr=-1 then begin fop:=43 {dec}; opt:=some end;
  14 {sub }: if addr=0 then opt:=all
    else if addr=1 then begin fop:=43 {dec}; opt:=some end
    else if addr=-1 then begin fop:=42 {inc}; opt:=some end;
  2  {cmp }: if addr=0 then begin fop:=47 {tst}; opt:=some end;
  10 {cmpb}: if 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].addr:=-(opstk[tos].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:=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(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;


procedure gencall(u:boolean;n:integer);
var r: relpair;
  s: integer;
begin
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);
if u then codebuf[cp-1] := stable[s].sval else codebuf[cp-1] := 0
end;

{load - put operand value on stack}
procedure load{(desire: resources)}; {Previously declared as forward}
var
  dstreg: registers; hasaddr: boolean;
begin
{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<=longsize then begin
	{ assumed to be short floating point }
	pushdesire := gfregs;
	emitfop2(31 {ldcfd}, pop, push);
	emit0(((ord(reg)-ord(fr0))*64) + 176046b {stcdf reg,-(sp)});
	freeregister(reg);
	reg := stk
	end
      else if opsize<=doublesize then begin
	{ assumed to be long floating point }
	pushdesire := gfregs;
	emitfop2(21 {ldf}, pop, push);
	emit0(((ord(reg)-ord(fr0))*64) + 174046b {stf reg,-(sp)});
	freeregister(reg);
	reg := stk
	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;

{ Loadaddress - determine addressing state of top operand; prepare to load
  its address onto stack}
procedure loadaddress(desire: resources);
var dobase,dodisp: integer; nxtdis: disposition; rb,rx: registers;
{ dobase: 0 => nothing; 1 => move; 6 => add}
begin
{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
{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;


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
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;


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
with opstk[tos] do begin
  if keepeven
  then freeregister(succ(reg))
  else begin freeregister(reg); reg:=succ(reg) end;
  opsize:=wordsize
  end
end {single};

procedure genscan;

procedure gencode(node:ptn; desire: resources; force: whatwhere);


procedure dumpstack(p: integer);
type
  regstrtab = array[0..15] 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','fr4','fr5','stk','gcc', 'mem','dbl');
  relstring = relstrtab('absact','absrel','txtact','txtrel','datact','datrel',
		'bssact','bssrel','uxtact','uxtrel',
		'      ','      ','      ','      ','       ','       ');
var ss:array[0..8] of char; n: integer;
begin
write(output,nl,'stackdump, node = ',p,', cp=',cp,nl);
n:=tos;
while n>=0 do with opstk[n] do begin
  if copy in state then ss[0]:='c' else ss[0]:=' ';
  if temp in state then ss[1]:='t' else ss[1]:=' ';
  if stored in state then ss[2]:='_' else ss[2]:=' ';
  if saved in state then ss[3]:='s' else ss[3]:=' ';
  if loaded in state then ss[4]:='l' else ss[4]:=' ';
  if indirect in state then ss[5]:='i' else ss[5]:=' ';
  if indexed in state then ss[6]:='x' else ss[6]:=' ';
  if based in state then ss[7]:='b' else ss[7]:=' ';
  if liter in state then ss[8]:='#' else ss[8]:=' ';
  write(output,n:3,' ':3,ss:9,ord(opsize):5,' ',
	regstring[ord(reg)]:4,addr:8,' ',
	relstring[ord(rel.reltype)]:6,'(',ord(rel.segnr):3,')',nl); break(output);
  n:=n-1
  end
end {dumpstack};


function subtreematch(st1,st2: ptn): boolean;
var i: integer; matchsofar: boolean;
begin
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
      (disp=st2@.disp) 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
savetarget:=target; target:=node@.arg[1];
sideeffects:=false;		{must check for side effects}
ldesire:=gregs;
if fop=2 {storf} then ldesire:=gfregs;
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 gfregs, 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 targetsize = doublesize then lop:= 24{stf}
      else {convert to single} lop:=28{stcfd};
      emitfop2(lop,dispose,pop)
      end
    end
  else {multiple store}
  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;
begin
with node@ do begin
  gencode(arg[1],gregs,loadaddr);
  gencode(arg[2],gregs,loadaddr);
  if size <= bytesize then lop:=-27632 {movb (r?)+,(r?)+}
  else lop:=5136 {mov (r?)+,(r?)+};
  pushlit(disp); load(gregs + [gr4]);	{mov $n,r?}
  restoreregister(tos-2,gregs);	{top 3 must be in registers}
  emit0(lop+ord(opstk[tos-1].reg)*64+ord(opstk[tos-2].reg));
  emit0(32258+ord(opstk[tos].reg)*64);	{sob r?,.-2}
  freeregister(opstk[tos].reg);
  freeregister(opstk[tos-1].reg);
  freeregister(opstk[tos-2].reg);
  tos:=tos-3
  end
end {move};

procedure genunary(fop: integer);
var update: boolean;
begin
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}
procedure genfpunary(fop: integer);
var update: boolean;
begin
  with node@ do
    if (force=tryupdate) and subtreematch(target,arg[1])
    then update:=true
    else begin
      gencode(arg[1],desire-gregs,loadvalue);
      update:=false
    end;
  emitfop1(fop,leave);
  if update then opstk[tos].state:=[stored]
end {genfpunary};

{generate code for conversions from/to floating}
procedure genfpconvert(fop: integer);
var
  srcdesire, dstdesire: resources;
  lop: integer;
  loadit: whatwhere;
  dispose: disposition;
  update: boolean;
begin
update := false;	{ initial assumption }
if fop = 0 then begin	{ float }
  srcdesire := gregs; loadit := noload;
  dstdesire := desire * gfregs;
  if dstdesire = [] then dstdesire := gfregs;
  lop := 30	{ ldcif }
  end
else begin		{ trunc, round }
  srcdesire := gfregs; 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;

{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
  {floating ops can't update in place}
  lop:=fop; dispose:=leave;
  if fop < 18 then begin lop:=23; dispose:=pop end;
  ldesire := desire * (gfregs+[stk]);
  if ldesire = [] then ldesire := gfregs;
  with node@ do begin
    gencode(arg[1],ldesire,loadvalue);			{to be "ac"}
    gencode(arg[2],gfregs,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(gfregs)
  end;
  restoreregisters(tos-1,gfregs);
  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:=brinv[fop];	{invert sense for backwards compare on PDP11}
    with opstk[tos] do begin
      state:=[loaded];
      reg:=gcc
    end
  end
end;

procedure genbinary(fop: integer; nobyte: boolean);
var update: boolean;
begin
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
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
  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(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);
var
  lcp: codeindex;
  this,other: ptn;
  loadit: whatwhere;
  loperand: operand;

begin
  {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=blos}: fop:=-31232;
    1 {umin=bhis}: fop:=-32000;
    2 {imax=ble} : fop:=1792;
    3 {imin=bge} : fop:=1024
  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
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
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]@.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);
    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
  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
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 notnode;
var
  tempchain: branchlist;
  lstate: operstates;
begin
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
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
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
gencode(node@.arg[1],gregs,noload);
loadit:=loadvalue;
with opstk[tos] do if liter in state
then if gcc in desire
  then begin
    if addr<16 then addr:=powerof2[addr] else addr:=0;
    loadit:=noload; ltruecode:=3 {not equal}
    end
  else addr:=-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
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);

  procedure findcstpart(node: ptn; var varpart: ptn; var cstpart: integer);
  const
    litcode = chr(162); addcode = chr(32); subcode = chr(33);
  var
    subpart: integer;
  begin
  with node@ do
    if code = litcode then begin
      varpart := nil;
      cstpart := disp
      end
    else if (code = addcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart + arg[2]@.disp
      end
    else if (code = addcode) and (arg[1]@.code = litcode) then begin
      findcstpart(arg[2], varpart, subpart);
      cstpart := arg[1]@.disp + subpart
      end
    else if (code = subcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart - arg[2]@.disp
      end
    else begin
      varpart := node;
      cstpart := 0
      end
  end;

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,mdisp], [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;
begin
with node@ do if code <> chr(134) then
  gencode(node, gregs, noload)
else begin
  multiplier := multiplier * disp;
  indexnode(arg[1], multiplier);
  findcstpart(arg[2], variable, fixed);
  offset := fixed * multiplier;
  with opstk[tos] do begin
    laddr:=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 add in doit then emit15(6 {add}, pop, leave);
  if mdisp in doit then mdmconst(2 {mul}, disp, gregs, false);
  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; addr := laddr + offset; rel := lrel
    end
  end {with node@}
end {indexnode};

procedure definetemp;
var
  taddr: integer; usereg: boolean;
begin
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+disp*2;
	if taddr>localsize then localsize:=taddr;
	rel.reltype:=bssact;
	state:=[]
      end else begin {local area is in stack}
	taddr:=tempbase-disp*2;
	if taddr<localsize then localsize:=taddr;
	rel.reltype:=absact;
	reg:=gr5; {force to r5 for stored temps}
	state:=[based]
      end;
      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
    state:=state + [temp,based]; rel.segnr:=chr(disp);
    gencode(arg[2],assignable,noload);
    if loaded in state then freeregister(reg)
    end;
  tos:=tos-1
  end
end;


procedure refertotemp;
var i: integer; found: boolean; lookfor: byte;
begin
found:=false; i:=tos; lookfor:=chr(node@.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;

procedure ifnode;
var
  endchain,lfalsechain,ltruechain: branchlist;
begin
lfalsechain := falsechain; falsechain := emptychain;
ltruechain := truechain; truechain := emptychain;
endchain := emptychain;
saveregister(true,[]);
with node@ do begin
  gencode(arg[1],[gcc],loadvalue);
  tos := tos-1;	{remove condition code operand}
  emitbranch(brinv[truecode],falsechain);
  fixbranch(true,truechain);
  gencode(arg[2],desire,force);
  emitbranch(1,endchain);
  fixbranch(false,falsechain);
  gencode(arg[3],desire,force);
  fixbranch(true,endchain)
  end;
falsechain := lfalsechain; truechain := ltruechain
end {ifnode};


procedure casenode;
var
  endchain: branchlist;
  casestate: blockstate;
  tp: codeindex;
  i, j: integer;
begin
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(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 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]@.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 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
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;


procedure exitnode;
var
  savechain: branchlist;
begin
{ 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;

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
  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]@.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]@.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]@.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,bge}
      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(12{bhi},backchain);
	codebuf[lastbr+2] := looptop-cp+3;
	fixbranch(true,forwchain);
	emit7(47{tst},pop) {delete trip count from stack}
      end;
      tos:=tos-1
    end
  end {if}
end{fornode};

procedure sequence;
var numarg,i: integer;
begin
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;


procedure call(isfunc: boolean; isuser: boolean);
var i: integer; reg: registers;
begin
with node@ do begin
  saveregister(true,[]);	{save stack registers}
  if isfunc then begin
    if isuser then adjuststack(-(ord(size)+1)/8);
    newtos;
    with opstk[tos] do
      begin state:=[loaded]; reg:=stk; opsize:=size end
    end;
  for i:=1 to ord(node@.nrarg) do begin
    gencode(arg[i],[stk],loadvalue);
    tos:=tos-1
    end;
  if isuser then reg:=getenvironment(ord(segnr),[gr4]);
		 {getenvironment called for effect}
  gencall(isuser,disp);
  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);
  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}: genfpbinary(20{addf});
  65 {fsub}: genfpbinary(22{subf});
  66 {fmul}: genfpbinary(18{mulf});
  67 {fdiv}: genfpbinary(25{divf});
  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}: genfpbinary(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;
  120,121 {sceq,scne}: if size<=wordsize
    then compare(ord(code)-118);
  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}
        addr:=disp;
        state:=[based]
        end
      else addr:=addr+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}
        addr:=disp;
	rel.reltype:=absact;	{offset needs no relocation}
        state:=(state-[loaded]) + [based]
        end
      else if (indirect in state) or (disp<>0)
        then begin
	  opsize:=wordsize;
          load(gregs); addr:=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(disp);
  163,176,192 {rdata,varb,parm}: begin
    newtos;
    with opstk[tos] do begin
      state:=[]; opsize:=size; reg:=mem;
      addr:=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; addr:=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; tmpreg:=[];	{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
too:=nextbr+target;
while from>0 do
  if back
  then if from>too
    then begin
      target:=target+(codebuf[from]/256);
      from:=codebuf[from+1]
      end
    else from:=0
  else if from<too
    then begin
      target:=target-(codebuf[from]/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
emit0(brtab[i]+(offset mod 256))
end;

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/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/4096 mod 8:1,i/512 mod 8:1,
  i/64 mod 8:1,i/8 mod 8:1,i mod 8:1)
end;

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;

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;

procedure srcdst(i:integer; isfloat:boolean);

procedure breg;
begin
write(ols,'('); greg(i); write(ols,')')
end;

begin
case (i/8) mod 8 of
0:if isfloat then freg(i) else greg(i);
1:breg;
2,3:begin if odd(i/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/8) then write(ols,'*');
   write(ols,'-'); breg end;
6,7:begin
  if odd(i/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
  write(ols,'/procedure ',name:namesize,'(',procnr:3,')',nl);
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/4096) mod 16 of
  0:case (inst/512) mod 8 of
    0:case (inst/64) mod 8 of
        0:if ((inst/8) mod 8) = 0
          then ix:=inst mod 8                             {halt,wait,...}
          else ix:=merr;                                  {illegal}
        1:ix:=mjmp;                                       {jmp}
        2:case (inst/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/256) mod 8)+(mbr-1);                 {bne-ble}
    4:ix:=mjsr;                                           {jsr}
    5,6:ix:=((inst/64+8) mod 16)+mclr;                    {clr-tst}
    7:ix:=merr                                            {illegal}
    end;
  1,2,3,4,5,6:ix:=((inst/4096) mod 8)+(mmov-1);           {mov-add}
  7:case (inst/512) mod 8 of
    0,1,2,3,4:ix:=((inst/512) mod 8)+mmul;		{mul-xor}
    5:if ((inst/32) mod 16)=0
      then ix:=((inst/8) mod 4)+mfadd			{fadd-fdiv}
      else ix:=merr;					{illegal}
    6:ix:=merr;						{illegal}
    7:ix:=msob						{sob}
    end;
  8:case (inst/512) mod 8 of
    0,1,2,3,4:ix:=((inst/256) mod 16)+mbpl;               {bpl-trap}
    5,6:ix:=((inst/64+8) mod 16)+mclrb;                   {clrb-mtpd}
    7:ix:=merr                                            {illegal}
    end;
  9,10,11,12,13,14:ix:=((inst/4096) mod 8)+(mmovb-1);     {movb-sub}
  15:case (inst/256) mod 16 of
    0:if ((inst/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/64) mod 4)+(mldfps-1);              {ldfps-stst}
    1:ix:=((inst/64) mod 4)+mclrf;                        {clrf-negf}
    2,3,4,5,6,7,8,9,10,11,12,13,14,15:
      ix:=((inst/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/64);
    write(ols,','); writeoctal((lcp-(inst mod 64))*2) end;
  10:begin srcdst(inst,false); write(ols,','); greg(inst/64) end;
  11:begin greg(inst/64); write(ols,','); srcdst(inst,false) end;
  12:begin srcdst(inst,false); write(ols,','); freg(inst/64 mod 4) end;
  13:begin srcdst(inst,true); write(ols,','); freg(inst/64 mod 4) end;
  14:begin freg(inst/64 mod 4); write(ols,','); srcdst(inst,true) end;
  15:begin srcdst(inst/64,false); write(ols,','); srcdst(inst,false) end;
  16:begin freg(inst/64 mod 4); write(ols,','); srcdst(inst,false) end
  end; {of case}
  write(ols,nl);
  while lcs<lcp do begin
    write(ols,ht); writeoctal(codebuf[lcs]);
    ch:=' ';
    if lrlp <= rlp then {OK to look for relocation stuff}
      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,nl);
    lcs:=lcs+1
    end {of "while lcs<lcp"}
  end {of outer while}
end {printcode};

procedure options;
var
  c: char;
  i: 0..255;
begin
  if argv[flgx]@[0] = '-' then begin {parse switches}
    i:=1;
    loop
      c:=argv[1]@[i];
    exit if c=chr(0);
      if c='O' then list:=true
      else
	if c='D' then debug:=true
	else
	  if c='S' then sdump:=true
	  else
	    if c='P' then dproc:=true;
      i:=i+1
    end
  end
end {options};

{Here follows the RSX-specific output routines which set up "object module"}


procedure writerecord ( finished:boolean; s,f:integer );
  var ss:integer;

begin
  ss := s;  {Start of object data}
  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;  {writerecord}

procedure outheader;
const w=maxcode+1;  {start of workspace}
      gsdrec=1;

begin
  codebuf[w+0] := gsdrec;  {Type = GSD}
  {Module name entry}
  codebuf[w+1] := -31211;  codebuf[w+2] := 8441;
  codebuf[w+3] := 0;       codebuf[w+4] := 0;
  writerecord( true, w, w+5 )
end;  {outheader}


procedure outtrailer;
const w=maxcode+1;  {Start of workspace}
      dataprefix=6564;  endgsdrec=2;  endmodrec=6;
      gsdrec=1;  rldrec=4;  txtrec=3;  lcentry=7;
      psectentry=5; relocate=32; global=64; readonly=16; kludge=8;
      dataentry=psectentry*256+relocate+global+kludge;
      maxtxt=42;
var count,address:integer;  byte1,byte2:char;

begin
  reset(dat, argv[datx]@);
  count := 0;
  while not eof(dat) do begin count := succ(count); get(dat) end;
  codebuf[w+0] := gsdrec;
  codebuf[w+1] := dataprefix;  codebuf[w+2] := dataprefix;
  codebuf[w+3] := dataentry;   codebuf[w+4] := count;
  writerecord( true, w, w+5 );
  codebuf[w+0] := rldrec;
  codebuf[w+1] := lcentry;  codebuf[w+2] := dataprefix;
  codebuf[w+3] := dataprefix;  codebuf[w+4] := 0;
  writerecord( true, w, w+5 );
  reset(dat, argv[datx]@);
  address := 0;
  while not eof(dat) do begin
    count := 0;
    obj@ := txtrec; put(obj);
    obj@ := address; put(obj);
    while not eof(dat) and (count < maxtxt) do begin
      byte1 := dat@; get(dat);
      if eof(dat) then byte2 := chr(0) else begin byte2 := dat@; get(dat) end;
      obj@ := ord(byte1) + ord(byte2)*256;  put(obj);
      address := address+2;  count := succ(count)
      end;
    break(obj);
    count := 0
    end;
  obj@ := endgsdrec; put(obj);
  break(obj);
  obj@ := endmodrec; put(obj);
  break(obj)
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+global+kludge;
      globentry=psectentry*256+relocate+global+kludge+overlay;
      instdef=glbsym*256+relocate+glbsymdef;
      traentry=3*256;
      instprefix=14769;  {RAD50('III')}
      dataprefix=6564;   {RAD50('DDD')}
      systprefix=-21229; {RAD50('$$$')}
      globprefix=25659;  {RAD50('PAS')}
var suffix,gx:integer;

function radcvt(n: integer):integer;

begin
  radcvt:=(((n/100)*40+((n mod 100)/10))*40+(n mod 10))-16306
end;  {radcvt}

procedure outtxtandrld(prefix,f: integer);
const lcentry=7; maxtxt=42; maxrld=w+7+42;
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 radvalue,relent,txtaddr,lrlp,lcp,rcp,tcp,rx: integer;

begin
  {*** 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,
	  txtact,datact: if codebuf[cix]=0 then relent:=10 else relent:=13;
	  bssrel,
	  txtrel,datrel: if codebuf[cix]=0 then relent:=12 else relent:=14;
	  uxtact: if codebuf[cix]=0 then relent:=2 else relent:=5;
	  uxtrel: if codebuf[cix]=0 then relent:=4 else relent:=6
	end;{case}
	codebuf[rx]:=(rcp*2-txtaddr+4)*256+relent;
	radvalue := ord(rs.segnr);
	radvalue := radcvt(radvalue);
	case rs.reltype of
	  absact,absrel:  {nochange};
	  txtact,txtrel: begin
			   codebuf[rx+1]:=instprefix;
			   codebuf[rx+2]:=radvalue
			   end;
	  uxtact,uxtrel: begin
			   codebuf[rx+1]:=systprefix;
			   codebuf[rx+2]:=radvalue
			   end;
	  datact,datrel: begin
			   codebuf[rx+1]:=dataprefix;
			   codebuf[rx+2]:=dataprefix
			   end;
	  bssact,bssrel: begin
			   codebuf[rx+1]:=globprefix;
			   codebuf[rx+2]:=globprefix
			   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
end;  {outtxtandrld}

begin
  suffix:=radcvt(procnr);
  {create GSD record for this procedure}
  codebuf[w+0]:=gsdrec;
  {create entry for psect containing instructions}
  codebuf[w+1]:=instprefix;  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]:=instprefix;  codebuf[w+6]:=suffix;  {entry name}
  codebuf[w+7]:=instdef;     codebuf[w+8]:=0;
  gx:=w+9;
  {if this is outermost procedure, then generate transfer address entry}
  if procnr=0 then begin
    codebuf[gx]:=instprefix;  codebuf[gx+1]:=suffix;  {transfer name}
    codebuf[gx+2]:=traentry;  codebuf[gx+3]:=0;  {start at location zero}
    codebuf[gx+4]:=globprefix;codebuf[gx+5]:=globprefix;
    codebuf[gx+6]:=globentry; codebuf[gx+7]:=localsize;
    gx:=gx+8
    end;
  writerecord(true,w,gx);
  {now output the text and relocation entries}
  outtxtandrld(instprefix,cp)
end;  {outprocedure}


begin {pascal_pass2_RSX}
{intitialize output flags and then process option flags}
debug:=false; list:=false; sdump:=false; dproc:=false;
options;
reset(int,argv[intx]@);
if dproc then rewrite(lst,argv[lstx]@,2 {fd.cr indicator} );
if list then rewrite(ols,argv[olsx]@,2 {fd.cr indicator} );
if debug then rewrite(dbg,argv[dbgx]@,2 {fd.cr indicator} );
rewrite(obj,argv[objx]@);

{initialize some globals}
stable[0].sname:="_fixed";	{Beginning of fixed data segment}
stable[0].sname[7]:=chr(0);	{fill in with <NUL>s}
stable[0].stype:=ord(datext);
stable[0].snum:=0;
stable[0].sval:=0;
stable[1].sname:="_globs";	{Beginning of bss segment}
stable[1].sname[7]:=chr(0);	{fill in with <NUL>s}
stable[1].stype:=ord(bssext);
stable[1].snum:=0;
stable[1].sval:=0;
lastid := 1;			{Two id's entered}

{initialize object module output}
lexlev:=0; procnr:=-1;
outheader;
{initialize code buffer indicies}
while not eof(int) do begin
  mark;
  buildtree;
  prescan;
  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/2;	{number of parms, for pdb}
  stable[s].sval:=0;

  genscan;				{generate code in code buffer}
  finalgeneration;			{finish code generation of branches}
  {output code, both binary and symbolic forms}
  if dproc then begin
    write(lst,procnr:3,' ':2,name:namesize,' ':18-namesize,dcnt:6,cp:6,nl);
    break(lst);
  end;
  if list then printcode;
  outprocedure;
  {update counters:}
  lexlev:=lexlev-1;
  {release the current heap}
  release
  end;
outtrailer
end.