program pascal_pass2;
 
{N B S      P a s c a l      C o m p i l e r  --   P a s s   2}
 
{
 *Authors: Brian G. Lucas
 *         Justin C. Walker
 *Address comments to:
 *         Justin C. Walker
 *         Systems and Software Div.
 *         Rm. A264, Technology Bldg.
 *         National Bureau of Standards
 *         Washington, D.C.   20234
 * This software has been developed at the National Bureau of Standards.
 * As a product of the U.S. Government, it is in the public domain, and
 * should not be sold or otherwise used for profit.
 * RSX-11 version developed by John R. Barr and J. Bill Heidebrecht.
 * RT-11 version developed by John R. Barr through a grant from
 * Lawrence Livermore Laboratories.
 * Address comments on RSX-11 and RT-11 versions to:
 *	John R. Barr
 *	Department of Computer Science
 *	University of Montana
 *	Missoula, Montana  59812
}
 
(*DEC OS versions maintained by DECUS Pascal SIG:
 John R. Barr     - University of Montana
 Bill Heidebrecht - TRW DSSG
*) 
 
const ht=chr(9); nl=chr(10); ff=chr(12);
      compiler_version = ' Pascal-N  V1.6d  6 Dec 79';
      RT11 = true;
      RSX11= false;
type byte = char;
 
			{Description of node}
			{*******************}
const maxarg=255; litcode=chr(162);
type ptn = @node;			{description of tree nodes}
  fvalue = array [0..3] of integer;
  node = record
 	code: byte;	{indicates node type}
 	size: byte;
 	dsp: record case boolean of
          false: (disp: integer);
          true:  (xval: @fvalue) end;
 	segnr: byte;
        nrarg: byte;
        arg: array[1..maxarg] of ptn
	end;
var tree,				{pointer to expression tree}
  target: ptn;			{pointer to subtree target of store}
  sideeffects: boolean;	{true if subtree just traversed has sideeffects}

		{Description of symbol table}
		{***************************}

const  maxsym=120;

type
  symbol_types = (localsy, pascalsy, ceesy, fortransy);
  stab =  {packed} record
   sname: array [0..5] of char;
   stype: symbol_types;
   snum: 0..255;  {arg count for use by pdb}
   sval: integer; {unique symbol number for searching}
	end;

var stable: array[0..maxsym] of stab;
  s,lastid: -1..maxsym;
 
 
 
			{Description of relocation info}
			{******************************}
type
  reltypes = (absact,absrel,txtact,txtrel,datact,datrel,bssact,bssrel,
		uxtact,uxtrel);
  relpair = record
		segnr: byte;
		reltype: reltypes
	    end;
const	{commonly used kinds of relocation}
  ordinary = relpair(chr(0), absact);
  global = relpair(chr(0), uxtact);

			{Description of code buffer}
			{**************************}
const maxcode=2047;	{size of code buffer}
  workspace=54;		{size of workspace area in code buffer}
  maxlexlev=15;		{Max lexical nesting level}
  maxrel=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,sfis,stk,gcc,mem,dbl);
  resources=set of registers;
const
  evenregs=[gr0,gr2];
  oddregs=[gr1,gr3];
  gregs=evenregs + oddregs;
  tregs=[gr2,gr3];
  assignable=gregs;
  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
  fistack - loaded on FIS stack
}
  addrstates = (liter,based,indexed,indirect,loaded,saved,stored,temp,copy,fistack);
  operstates = set of addrstates;
  operand = record
    state: operstates;
    adr: record case boolean of
      false: (addr: integer);
      true:  (xval: @fvalue) end;
    rel: relpair;
    reg: registers;
    opsize: byte
    end;
var
  tos: integer;
  opstk: array[0..maxopstk] of operand;

{whatwhere: specifies what to generate and where to leave it.
  noload    - Don't load value on stack
  loadvalue - Value of expression to be loaded
  loadaddr  - Address of operand to be loaded
  tryupdate - Check for possible in situ operation
}
type whatwhere=(noload,loadvalue,loadaddr,tryupdate);
{disposition: what to do with current tos.
  pop   - pop it off
  leave - leave it on
  push  - put a new value on
}
  disposition = (pop,leave,push);
 
 
 
				{Branch conditions}
				{*****************}
type
  brtypes=0..18 {encoding for branch types on PDP-11};
  brtabform=array[brtypes] of brtypes;
  brtabcode=array[brtypes] of integer;

const
  unconditional=1;	{ br code for unconditional branch }
  brtab=brtabcode(		{branch instruction codes}
  { 0-nop} 160,		{ 1-br} 256,	
  {signed tests}
  { 2-beq} 768,		{ 3-bne} 512,		{ 4-bgt} 1536,
  { 5-ble} 1792,	{ 6-bge} 1024,		{ 7-blt} 1280,
  { 8-bpl} -32768,	{ 9-bmi} -32512,
  {unsigned tests}
  {10-beq} 768,		{11-bne} 512,		{12-bhi} -32256,
  {13-blos} -32000,	{14-bhis,bcc} -31232,	{15-blo,bcs} -30976,
  {misc.}
  {16-bvc} -31744,	{17-bvs} -31488,	{18-sob} 32256);

  brinv=brtabform(		{inverse conditions}
  1,0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,18);

  brrev=brtabform(		{reverse conditions}
  0,1,2,3,7,6,5,4,8,9,10,11,15,14,13,12,16,17,18);

			{Branching and state information}
type
  blockstate = record
    roving: 0..maxlexlev
  end;
  branchlist = record
    last: codeindex;
    state: blockstate
  end;
const
  emptychain = branchlist( 0, ( 0 ));
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}
  calltype,				{internal,pascal,cee,fortran indicator}
  lexlev: integer;			{current lex level}
 
 
				{Files used in pass2}
				{*******************}
const
  intx=2;	{argv index to int code filename}
  olsx=5;       {" object listing filename}
	        {" 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:
  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
  xtern: generate symbolic procedure names char X
  }
var
  list,sdump,dproc,xtern: boolean;

  {files used by second pass:}
  int: text;			{file of intermediate code}
  ols: text;			{file to put object listings}
  obj: file of integer;		{object module file}
  dat: file of char;		{intermediate home for data and case tables}
 
 
 
procedure error(n:integer);
{assigned error numbers (arbitrary, more or less):
	#	where		why
	1	buildtree	stack-arg mismatch (s < argn)
	2	buildtree	stack overflow
	3	emit0
		emitaddr
		emitbranch	codebuf overflow
	4	emitaddr	reltab overflow
	6	newtos		opstk overflow
	9	buildtree	non-immediate litd processed (**TEMP**)
	10	refertotemp	can't find temp
	18	load		double load unimplemented
	19	store		multiple store unimplemented
	20	genfpconvert	round not yet implemented
	30	searchid	symtab overflow
	31	gencode		sadel not yet implemented
}
begin {error}
writeln(output,'pass2 error ',n,' in ',name: namesize); break(output)
end {error};
 

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

procedure ident;
(*Obtains main or procedure identification and size*)
var i: integer;
begin (*ident*)
  i := ord(getbyte);
  namesize := 0;
  while i>0 do begin
    if namesize<15 then namesize := succ(namesize);
    name[namesize] := getbyte;
    i := pred(i)
    end
end (*ident*);
 
procedure buildtree;
 
	{special code values: call, varb, and parm all have the form

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


const stacksize=256;
  ENDCODE=7;
var
  s: 0..stacksize;
  stack: array[1..stacksize] of ptn;
  coden,argn: integer;
  adrn: record case boolean of
    false: (addrn: integer);
    true:  (xval:  @fvalue) end;
  temp: ptn;
  sizen,segn,ch: byte;
  allign: integer; {to round out localsize if odd}
 
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.}
procedure read8(var p:@fvalue);
begin
  new(p);
  p@[0]:=getword;
  p@[1]:=getword;
  p@[2]:=getword;
  p@[3]:=getword
end {read8};
 
begin {buildtree}
s := 0;
repeat
  coden := ord(getbyte);
  if coden > 7
  then begin {not a pseudo op}
    if coden = 8
    then tree:=nil	{null node}
    else begin
      segn:=chr(0); adrn.addrn:=0; sizen:=chr(0);	{so subtreematch will work}
      argn:=0;
      case coden of
      176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191, {varb}
      192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207: {parm}
      begin segn:=chr(coden mod 16) {segn = lex level};
        sizen:=getbyte; adrn.addrn:=getword;
	{collapse code value} if coden < 192 then coden:=176 else coden:=192 end;
      162,163 {lit,rdata}: adrn.addrn := getword;
      164 {litd}: begin
      {Read in a floating lit, and make it 2 words long.}
	read8(adrn.xval);	{collect data for float lit}
        coden := 164;
        sizen := chr(2)
      end;
      140,141 {rtemp,dtemp}: begin adrn.addrn:=ord(getbyte);
        if coden=141 then argn:=2 end;
      131,132,133,134,135,168,169,170,171,172,173
	 {addressing, "vector" ops}: begin sizen:=getbyte; adrn.addrn:=getword;
        if coden>=134 then argn:=2 else argn:=1 end;
      146,147,152 {n-ary}: argn:=ord(getbyte) + 1;
      145,138 {case,invoke}: begin argn:=ord(getbyte); adrn.addrn:=ord(getbyte);
        if coden=138 then if adrn.addrn=4 {new} then sizen:=chr(2)
          else if adrn.addrn>100 then sizen:= chr(4)
          {Note: system routines whose index is > 100
           are assumed to be real functions.}
      end;
      208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223: {call}
	begin segn:=chr(coden mod 16) {segn = lex level};
	sizen:=getbyte;
        adrn.addrn:=ord(getbyte); argn:=ord(getbyte);
	coden:=208 {collapse code value} end;
      149 {for}: argn:=5;
      144 {tertiary}: argn:=3;
      10,12,24,25,26,27,28,29,30,31,32,33,34,35,36,44,45,56,57,58,59,60,61,62,
      63,64,65,66,67,88,89,90,91,92,93,94,95,
      104,105,106,107,108,109,110,111,113,114,115,118,120,121,122,123,124,125,
      126,148 {binary}: begin argn:=2; sizen:=chr(2) end;
      9,16,17,37,40,41,42,69,72,73,74,75,76,96,112,117,127,159 {unary}:
        begin argn:=1; sizen:=chr(2) end
      end; {case}
      new(tree,argn);
      with tree@ do begin
 	code:=chr(coden); size:=chr(ord(sizen)*8-1);
 	dsp.disp:=adrn.addrn; segnr:=segn; nrarg:=chr(argn);
        if s<argn then begin error(1); argn:=0 end;
        while argn>0 do begin
          arg[argn] := stack[s]; argn := argn-1; s := s-1
          end
        end
      end; {not null node}
    if s>=stacksize then begin error(2); s:=0 end;
    s := s+1;
    stack[s] := tree
    end {not a pseudo op}
  else case coden of {pseudo ops}
    1 {xch}: {swap(stack[s],stack[s-1])}
      begin temp:=stack[s]; stack[s]:=stack[s-1]; stack[s-1]:=temp end;
    2 {del}: if s>0 then s:=s-1 else error(1);
    3,4: {byte,word} {Shouldn't occur};
    5 {ident}: ident;
    6: {proc} begin lexlev := lexlev+1; calltype := ord(getbyte) end;
    7 {end}:begin procnr:=ord(getbyte); rvsize:=ord(getbyte);
      localsize:=getword;
      allign:=1;
      if localsize<0 then allign:=-1;
      if odd(localsize) then localsize:=localsize+allign;
      tempbase:=localsize; paramsize:=getword;
      if odd(paramsize) then paramsize:=paramsize+1;
      dcnt:=getword;		{data size (bytes) as of this procedure}
      end
    end {pseudo ops}
until coden = ENDCODE
end {buildtree};
 
 
 
procedure prescan;
{General tree-walk to permit any "1st pass" computations needed prior to
 code generation.  Currently, this includes:
	1. Register usage for temp values (FORCODE and DTEMP nodes)

 Starts with global pointer "tree", pointing to the head of the code
 tree for the current procedure.}

var i: integer;
 
  function tracetemp(pn: ptn): integer;
  {Count temps used by this subtree.  Store and return value as appropriate}
  const {node type, logic:}
    FORCODE  = 149; {check arg[5]; return num+1}
    DTEMP    = 141; {check arg[2]; return num+1}
    LOOPCODE = 147; {check arg[1]-arg[n]; return max}
    EXITCODE = 148; {check arg[2]; return num}
    SEQ      = 152; {check arg[1]-arg[n]; return max}
    IFCODE   = 144; {check arg[2],arg[3]; return max}
    CASECODE = 145; {check arg[1]-arg[n]; return max}
    ENDCODE  = 7;   {check arg[1]; return value}
 
  var lsize,i: integer;
 
  begin {tracetemp}
    lsize:=0;
    with pn@ do
      if ord(code)=FORCODE then
	begin lsize:=tracetemp(arg[5])+1; size:=chr(lsize) end
      else if ord(code)=DTEMP then
	begin lsize:=tracetemp(arg[2])+1; size:=chr(lsize) end
      else if (ord(code)=LOOPCODE) or (ord(code)=SEQ) or (ord(code)=CASECODE) then
	for i:=1 to nrarg do lsize := max(lsize,tracetemp(arg[i]))
      else if ord(code)=IFCODE then begin
	lsize:=tracetemp(arg[2]);
	lsize:=max(lsize,tracetemp(arg[3]))
	end
      else if ord(code)=EXITCODE then
	lsize:=tracetemp(arg[2])
      else if ord(code)=ENDCODE then
	lsize:=tracetemp(arg[1]);
    tracetemp:=lsize
  end {tracetemp};
 
begin {prescan}
 i:=tracetemp(tree) {discard the temp count for the whole tree}
end {prescan};
 
 
 
{searchid - search symbol table, return the index of requested symbol;
	if not found, the symbol is added to the table and the new index
	is returned.  Its value is initialized to zero, and its type is
	set up according to isuser}
function searchid(symno:integer; isuser:boolean): integer;
 
var lchar: char;
  sym: array[0..5] of char;
  found: boolean;
  i: 0..maxsym;
 
procedure itoa(N:integer);
{translate N to a string, length 3, and start storing at sym[3]}
begin {itoa}
  sym[5]:=chr((N mod 10)+ord('0')); N:=N/10;
  sym[4]:=chr((N mod 10)+ord('0')); N:=N/10;
  sym[3]:=chr((N mod 10)+ord('0'))
end {itoa};
 
begin {searchid}
  if isuser and ((calltype<>0) or xtern)
  then begin (*use first part of actual name:*)
    i := 0;
    loop
      if i>namesize-1 then sym[i] := ' ' else sym[i] := name[i+1];
      if sym[i]='_' then sym[i] := '$';
      if (sym[i]>='a') and (sym[i]<='z') then sym[i]:=chr(ord(sym[i])-32);
    exit if i=5;
      i := succ(i);
    end;
  end
  else begin (*build a unique symbol*)
    if isuser then if symno >= 0 then lchar := 'I' (*user proc*)
				 else lchar := 'D' (*consts*)
	      else lchar := '$'; (*library proc*)
    sym[0] := lchar; sym[1] := lchar; sym[2] := lchar;
    itoa( max( 0, symno ) ) (*put 3 chars of symno into sym, from sym[3]*)
  end;

  {look for the symbol}
  i:=0; found:=false;
  if i <= lastid then
    loop
      with stable[i] do if isuser
        then found := (sname[0]<>'$') and (sval=symno)
        else found := (sname[0]='$') and (sval=symno);
    exit if found or (i >= lastid);
      i:=i+1
    end;

  {put in table if not there}
  if not found then begin
    lastid:=succ(lastid);
    if lastid<=maxsym then
      with stable[lastid] do begin
        sname := sym;
        snum := 0;
        sval := symno;
        if isuser
          then case calltype of
            0: stype := localsy;
            1: stype := pascalsy;
            2: stype := ceesy;
            3: stype := fortransy
            end
          else stype := localsy
      end
    else begin error(30); lastid:=pred(lastid) end;
    i:=lastid
  end;
  searchid:=ord(i)
end {searchid};
 
 
 
procedure newtos;
begin
if tos<maxopstk then tos:=tos+1 else error(6)
end {newtos};
 
procedure swaptos;
var temp: operand;
begin
temp:=opstk[tos]; opstk[tos]:=opstk[tos-1]; opstk[tos-1]:=temp
end {swaptos};
 
procedure duptos;
begin
  newtos; opstk[tos]:=opstk[tos-1]
end {duptos};
 
procedure pushlit(n: integer);
begin
newtos;
with opstk[tos] do begin
  state:=[liter]; opsize:=wordsize;
  reg:=mem;
  adr.addr:=n; rel:=ordinary
  end
end {pushlit};
  
procedure pushlitd( n:integer );
begin
  pushlit( n );
  opstk[tos].opsize := floatsize
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 {emitaddr};
 
procedure emit0(i:integer);
begin
codebuf[cp]:=i;
if cp=maxcode then error(3) else cp:=cp+1
end {emit0};
 
 
 
procedure freeregister(reg: registers);
begin
avail:=avail + ([reg]*{inter}assignable)
end {freeregister};
 
procedure moveregister(from,too: registers);
const mov=4096{mov instr};
var src,dst,lop: integer;
begin {moveregister}
lop:=mov;
if from=stk
then src:=22			{(sp)+}
else src := ord(from);
if too=stk
then dst:=38			{-(sp)}
else dst := ord(too);
emit0(lop+src*64+dst)
end {moveregister};
 
procedure saveregister(saveall: boolean; desire: resources);
var n,taddr: integer;
begin {saveregister}
n:=0;	{start from bottom of operand stack}
while (n<=tos) and (saveall or ((avail *{inter} desire)=[])) do
  begin with opstk[n] do
    if (state *{inter} [loaded,based,indexed] <> []) and
	 ([saved,copy,temp] *{inter} state = []) and (reg < stk) then begin
      moveregister(reg,stk);
      freeregister(reg);
      state:=state + [saved] -{sdiff} [copy]
    end;
  n:=succ(n)
  end
end {saveregister};
 
 
 
function getregister(desire: resources): registers;
var reg: registers;
begin {getresister}
if desire <> []
then if desire*{inter}assignable <> []
  then begin
    if desire*avail=[] then if gr4 in desire
      then avail := avail + [gr4]
      else saveregister(false,desire);
    reg:=any(desire*{inter}avail);
    avail:=avail-{sdiff}[reg];
    usedregs:=usedregs + [reg]
    end
  else reg:=any(desire)
else reg:=mem;
if reg = gr4 then curstate.roving:=0; {may use as scratch}
getregister:=reg
end {getregister};
 
procedure restoreregister(thru: integer; desire: resources);
var i: integer; lreg: registers; ldesire: resources;
begin {restoreregister}
i:=tos;		{restore from top of operand stack}
while i>=thru do begin
  with opstk[i] do if (saved in state) or (reg = stk) then
  begin
    if reg in avail then ldesire := [reg] else ldesire := desire;
    lreg := getregister(ldesire);
    moveregister(stk,lreg);
    reg := lreg;
    state:=state-[saved]
  end;
  i:=pred(i)
  end
end {restoreregister};
 
 
 
procedure emitbranch(brtype: brtypes; var list: branchlist);
begin {emitbranch}
if cp >= maxcode-3 then begin error(3); cp := 0 end;
if list.last = 0 then
  list.state := curstate
  else if list.state.roving <> curstate.roving then list.state.roving := 0;
codebuf[cp] := brtype;
codebuf[cp+1] := lastbr; lastbr := cp;	{ list of all branches }
codebuf[cp+2] := list.last; list.last := cp; { list of branches to this target}
cp := cp+3
end {emitbranch};
 
procedure mergebranchchains(var from, into: branchlist);
var
  nextbr, temp: codeindex;
begin {mergebranchchains}
if from.last <> 0 then
  if into.last <> 0 then begin
    if from.state.roving <> into.state.roving then into.state.roving := 0;
    nextbr := from.last;
    while nextbr > 0 do begin
      temp := codebuf[nextbr+2];
      codebuf[nextbr+2] := into.last;
      into.last := nextbr;
      nextbr := temp
      end
    end
  else
    into := from
end {mergebranchchains};
 
procedure fixbranch(fallthru: boolean; var chain: branchlist);
var
  nextbr, temp: codeindex;
begin {fixbranch}
if chain.last <> 0 then begin
  nextbr := chain.last;
  while nextbr > 0 do begin
    temp := codebuf[nextbr+2];
    codebuf[nextbr+2] := cp-nextbr;
    nextbr := temp
    end;
  if fallthru then begin
    if curstate.roving <> chain.state.roving then curstate.roving := 0
    end
  else
    curstate := chain.state
  end
end {fixbranch};
 
procedure label_;
begin
curstate.roving := 0
end {label_};
 
 
 
{ Getenvironment - sets up addressability to lex level 'oflevel', and
  leaves the stack frame pointer in register 'leaveitin'.  Note that
  this is not called to access globals, since these are addressed
  relative to the BSS segment}
function getenvironment(oflevel: integer; leaveitin: resources): registers;
var n: integer; src,dst: registers;
begin {getenvironment}
{assert leaveitin <= [gr0,gr1,gr2,gr3,gr4,gr5,stk]}
if oflevel=lexlev
then dst:=gr5						{at current level}
else if oflevel=curstate.roving
  then dst:=gr4						{at curstate.roving level}
  else begin						{must chain to get it}
    if oflevel<curstate.roving
    then begin src:=gr4; n:=curstate.roving-oflevel end		{chain from curstate.roving}
    else begin src:=gr5; n:=lexlev-oflevel end;		{chain from current}
    if not (gr4 in leaveitin)
    then dst:=getregister(gregs)
    else dst:=gr4;
    if src<>dst then begin
      emit0(4608+ord(src)*64+ord(dst));			{mov *src,dst}
      n:=n-1
      end;
    if odd(n) then begin
      emit0(4608+ord(dst)*64+ord(dst));			{mov *dst,dst}
      n:=n-1
      end;
    while n>0 do begin
      emit0(5632+ord(dst)*64+ord(dst));			{mov *(dst)+,dst}
      n:=n-2
      end
    end;
if not (dst in leaveitin) then begin
  src:=dst;
  if gr4 in leaveitin
  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 for the top operand on opstk.
  Set up for accessing.}
procedure address(lockr4: boolean; dispose: disposition;
                   var mr: integer; var hasaddr: boolean);
var baseregs: resources; rb: registers;
begin {address}
with opstk[tos] do begin
  if liter in state
  then begin mr:=23; hasaddr:=true end			{immediate addressing}
  else begin
    if loaded in state
    then begin						{register or stack}
      if dispose=push then
        begin rb:=getregister(pushdesire); reg:=rb end;
      if (reg=stk) or (saved in state)
      then case dispose of
        leave: mr:=14;					{(sp)}
        push: mr:=38;					{-(sp)}
        pop: mr:=22					{(sp)+}
        end
      else mr:=ord(reg);					{register}
      hasaddr:=false
      end
    else begin						{memory reference}
      dispose:=pop;	{can discard register used for addressing}
      {if (state * [based,indexed]) <> [] then restoreregister(tos,gregs);}
      if based in state
      then rel.reltype:=absact
      else if (rel.reltype=absact) {or (lexlev=1)}
        then begin					{non-global reference}
	{For NBS-PASCAL, globals will be in BSS, so they are not checked
	 for here.}
          baseregs:=gregs + [gr4,gr5];
          rel.reltype:=absact;
          if lockr4 then baseregs:=baseregs -{setdiff} [gr4];
          rb:=getenvironment(ord(rel.segnr),baseregs);
          if indexed in state
          then emit0(24576+ord(rb)*64+ord(reg) {add rb,reg})
          else reg:=rb
          end
        else						{global reference}
	{if reltype is actual, make it relative; don't touch if indexed}
	  if not (indexed in state) then
	    if not odd(ord(rel.reltype)) then rel.reltype := succ(rel.reltype);
      if odd(ord(rel.reltype))
      then begin				{use relative addressing}
        if indirect in state then mr:=63 else mr:=55;		{[*]addr(pc)}
        hasaddr:=true
        end
      else if indirect in state
        then begin mr:=56+ord(reg); hasaddr:=true end		{*addr(reg)}
        else if (adr.addr=0) and (rel.reltype=absact)
          then begin mr:=8+ord(reg); hasaddr:=false end		{(reg)}
          else begin mr:=48+ord(reg); hasaddr:=true end		{addr(reg)}
        end;
    if (dispose=pop) and not (copy in state) then freeregister(reg)
    end
  end {with opstk[tos]}
end {address};
 
 
 
procedure load(desire: resources); forward;
procedure loadaddress(desire: resources); forward;
 
 
procedure emit7(fop: integer; dstdis: disposition);
var dstmr: integer; dstaddr: boolean;
begin {emit7}
if (opstk[tos].opsize<=bytesize) and (fop<512) then fop:=fop+512;	
address(false,dstdis,dstmr,dstaddr);
emit0(fop*64+dstmr);
if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel)
end {emit7};
 
procedure 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?}
  regr: registers;	{register for negation operation}
begin {emitfop1}
  address(false,dstdis,dstmr,dstaddr);		{compute oprnd address}
  if fop=2 {absf} then begin
    emit0( 42700b+dstmr {bic #10000,dst} );
    emit0( 100000b )
    end
  else if fop=3 {negf} then begin
    regr := getregister( gregs );
    emit0( 12700b+ord(regr) {mov #100000,regr} );
    emit0( 100000b );
    emit0( 74000b+ord(regr)*64+dstmr {xor regr,dst} );
    freeregister( regr )
    end;
  if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel)
end {emitfop1};
 
procedure emit10(fop: integer; srcdis: disposition);
var srcmr,srcword: integer; srcrel: relpair; srcaddr: boolean;
begin {emit10}
restoreregister(tos-1,gregs);	{the destination must be a register}
address(false,srcdis,srcmr,srcaddr);
if srcaddr then with opstk[tos] do begin srcword:=adr.addr; srcrel:=rel end;
tos:=tos-1;
emit0((fop*8+ord(opstk[tos].reg))*64+srcmr);
if srcaddr then emitaddr(srcword,srcrel)
end {emit10};
 
 
 
 
 
procedure adjuststack(i:integer);
var expand: boolean;
begin {if i<0 then expand stack else shrink stack}
if i<>0 then begin
  if i<0 then begin i:=-i; expand:=true end else expand:=false;
  if odd(i) then i:=i+1;
  if i=2
  then if expand then emit0(2598 {clr -(sp)}) else emit0(3030 {tst (sp)+})
  else begin
    if expand then emit0(-6714 {sub $i,sp}) else emit0(26054 {add $i,sp});
    emit0(i)
    end
  end
end {adjuststack};
 
procedure gencall(u:boolean;n:integer);
var r: relpair;
  s: integer;
begin {gencall}
emit0(2551 {jsr pc,0(pc)});
s := searchid(n,u);	{find symbol number}
if u then r.reltype:=txtrel else r.reltype:=uxtrel;
r.segnr:=chr(n);
emitaddr(0,r);
codebuf[cp-1] := 0
end {gencall};
 
 
procedure emitfop2(fop: integer; srcdis,dstdis: disposition);
var
  srcaddr: boolean;	{will an address be needed}
  srcmr: integer;	{mode bytes, address value}
begin {emitfop2}
  if opstk[tos-1].state *{inter} [indexed,based] <> [] then
    restoreregister(tos-1,gregs);	{restore buried addressing register}
  if odd(fop) {load} then begin
    if opstk[tos-1].reg=stk then begin
      if fistack in opstk[tos].state
      then gencall( false, 214 {Pop FIS to stack} )
      else if liter in opstk[tos].state then with opstk[tos].adr do begin
	if xval@[1]=0
	  then emit0( 5046b {clr -(SP)} )
	  else begin
	    emit0( 12746b {mov #,-(SP)} );
	    emit0( xval@[1] )
	    end;
	if xval@[0]=0
	  then emit0( 5046b {clr -(SP)} )
	  else begin
	    emit0( 12746b {mov #,-(SP)} );
	    emit0( xval@[0] )
	    end
	end
      else {variable to stack}
	if indirect in opstk[tos].state then begin
	  loadaddress( [stk] );
	  gencall( false, 211 {Push FIS} );
	  gencall( false, 214 {Pop FIS to stack} )
	  end
	else begin
	  opstk[tos].opsize := wordsize;
	  duptos;
	  opstk[tos].adr.addr := opstk[tos].adr.addr + 2;
	  address(false,srcdis,srcmr,srcaddr);
	  emit0( 10046b+srcmr*64 {mov src,-(SP)} );
	  if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel);
	  tos := pred(tos);
	  address(false,srcdis,srcmr,srcaddr);
	  emit0( 10046b+srcmr*64 {mov src,-(SP)} );
	  if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel)
	  end
      end
    else with opstk[tos] do {loading to fis stack}
      if reg=stk then begin
	gencall( false, 213 {Push FIS from stack} )
	end
      else if liter in state then begin
	reg := getregister( gregs );
	gencall( false, 212 {Push addr FIS} );
	emit0( 12600b+ord(reg) {mov (SP)+,reg} );
	if adr.xval@[0]=0
	  then emit0( 5020b+ord(reg) {clr (reg)+} )
	  else begin
	    emit0( 12720b+ord(reg) {mov #,(reg)+} );
	    emit0( adr.xval@[0] )
	    end;
	if adr.xval@[1]=0
	  then emit0( 5020b+ord(reg) {clr (reg)+} )
	  else begin
	    emit0( 12720b+ord(reg) {mov #,(reg)+} );
	    emit0( adr.xval@[1] )
	    end;
	freeregister( reg )
	end
      else begin {Variable to FIS stack}
	loadaddress( [stk] );
	gencall( false, 211 {Push FIS} )
	end;
    tos := pred(tos)
    end
  else {store}
    if fistack in opstk[tos].state then begin
      tos := pred(tos);
      if opstk[tos].reg=stk
      then gencall( false, 214 {Pop FIS to stack} )
      else begin
        loadaddress( [stk] );
	gencall( false, 210 {Pop FIS} )
	end
      end
end {emitfop2};
 
 
 
procedure emit15(fop: integer; srcdis,dstdis: disposition);
var srcmr,dstmr,srcword: integer;
  srcrel: relpair;
  srcaddr,dstaddr: boolean;
  opt: (none,some,all);
begin {emit15}
if (opstk[tos].opsize<=bytesize) or (opstk[tos-1].opsize<=bytesize)
  then fop:=fop+8;	{if either is byte then use byte instruction}
			{must assure that add,sub always enter with words}
opt:= none;
with opstk[tos] do
if (liter in state) and (rel.reltype=absact) then case fop of
  1  {mov }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end;
  9  {movb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end;
  5,13 {bis,bisb}: if adr.addr=0 then opt:=all;
  0  {and }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end
    else if adr.addr=-1 then opt:=all;
  8  {andb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end
    else if adr.addr=255 then opt:=all;
  4  {bic }: if adr.addr=0 then opt:=all
    else if adr.addr=-1 then begin fop:=40 {clr}; opt:=some end;
  12 {bicb}: if adr.addr=0 then opt:=all
    else if adr.addr=255 then begin fop:=552 {clrb}; opt:=some end;
  6  {add }: if adr.addr=0 then opt:=all
    else if adr.addr=1 then begin fop:=42 {inc}; opt:=some end
    else if adr.addr=-1 then begin fop:=43 {dec}; opt:=some end;
  14 {sub }: if adr.addr=0 then opt:=all
    else if adr.addr=1 then begin fop:=43 {dec}; opt:=some end
    else if adr.addr=-1 then begin fop:=42 {inc}; opt:=some end;
  2  {cmp }: if adr.addr=0 then begin fop:=47 {tst}; opt:=some end;
  10 {cmpb}: if adr.addr=0 then begin fop:=559 {tstb}; opt:=some end;
  7,15: {not used}
  end;
if opt=none
then begin
  if (fop=2 {cmp}) or (fop=10 {cmpb})
  then swaptos				{because pdp11 cmp is backwards}
  else if (fop=0 {and}) or (fop=8 {andb})
    then begin		{pdp11 lacks and, must simulate with bic}
      if liter in opstk[tos].state
      then opstk[tos].adr.addr:=-(opstk[tos].adr.addr+1)
      else begin load(gregs + [stk]); emit7(41 {com},leave) end;
      fop:=fop+4			{change to bic[b]}
      end;
  {check for buried addressing register and restore it:}
  if opstk[tos-1].state *{inter} [indexed,based] <> [] then
    restoreregister(tos-1,gregs);
  address(false,srcdis,srcmr,srcaddr);
  if srcaddr then with opstk[tos] do begin srcword:=adr.addr; srcrel:=rel end;
  tos:=tos-1;
  address((srcmr mod 8)=4,dstdis,dstmr,dstaddr);
  emit0((fop*64+srcmr)*64+dstmr);
  if srcaddr then emitaddr(srcword,srcrel);
  if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel)
  end
else begin
  tos:=tos-1;
  if opt=some then emit7(fop,dstdis)
  end
end {emit15};
 
 
{load - put operand value on stack}
procedure load{(desire: resources)}; {Previously declared as forward}
var
  dstreg: registers; hasaddr: boolean;
begin {load}
{assert desire <= [gr0,gr1,gr2,gr3,sfis,stk,gcc]}
with opstk[tos] do
  if (loaded in state) and ((opsize<=wordsize) or (reg in desire))
  {Must be loaded and the opsize<=wordsize or loaded in the
   proper register if opsize>wordsize.  This will only be
   the stack.}
  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 if not((fistack in state) and (reg in desire)) then begin	{not loaded, lets do it}
    newtos; opstk[tos]:=opstk[tos-1];
    {opstk[tos-1].}state:=[loaded];
    pushdesire:=desire;
    if {opstk[tos-1].}opsize>wordsize then desire := desire -{setdiff} gregs;
    dstreg := any(desire);
    case dstreg of			{different loads for different folks}
    gr0,gr1,gr2,gr3,gr4,gr5:begin
      if (opsize<=bytesize) and (pushdesire * avail <> []) then begin
	reg := getregister(pushdesire);
	emit0(2560 + ord(reg) {clr r?});
	emit15(5 {bis[b]}, pop, leave);
	opsize:=wordsize
	end
      else if opsize<=wordsize then
	emit15(1 {mov[b]},pop,push)
      else
	error(18) {double load to register}
      end;
    stk:begin
      if opsize <= bytesize then begin
	{To avoid high-order garbage from "movb s,-(sp)", clear first:}
	emit0(2598 {clr -(sp)});
	reg:=stk;	{ force to stack in address }
	emit15(1 {mov[b]}, pop,leave);
	opsize:=wordsize	{now tos is a word}
	end
      else if opsize<=wordsize
	then emit15(1 {mov[b]},pop,push)
      else if opsize<=doublesize then begin
	{doublesize check temporary until pass1 corrected}
	{ assumed to be short floating point }
	reg := stk;
	emitfop2( 1 {load}, pop, push )
	end
      else
	error(18)	{ multiple load to stack }
      end;
    sfis: begin {Put operand on FIS stack}
      {opstk[tos-1].}state := [fistack];
      {opstk[tos-1].}reg := sfis;
      emitfop2( 1 {load}, pop, push )
      end;
    gcc:begin emit7(47 {tst[b]},pop); tos:=tos-1;
      truecode:=3 {ne}; reg:=gcc
      end;
    mem:
    end;
    end
end {load};
 
 
 
{ Loadaddress - determine addressing state of top operand; prepare to load
  its address onto stack}
procedure loadaddress{(desire: resources)}; {Previously declared as forward}
var dobase,dodisp: integer; nxtdis: disposition; rb,rx: registers;
{ dobase: 0 => nothing; 1 => move; 6 => add}
begin {loadaddress}
{assert desire <= [gr0,gr1,gr2,gr3,stk]}
with opstk[tos] do begin
  if indirect in state
  then begin
    state:=state -{sdiff}[indirect]; opsize:=wordsize;
    load(desire)
    end
  else begin
    rb:=reg; rx:=rb;
    if based in state
    then begin
      if copy in state
      then begin nxtdis:=push; dobase:=1 end
      else begin nxtdis:=leave; dobase:=0 end;
      dodisp:=6
      end
    else begin
      if indexed in state
      then begin nxtdis:=leave; dobase:=6 end
      else begin nxtdis:=push; dobase:=1 end;
      if rel.reltype=absact
      then begin
        rb:=getenvironment(ord(rel.segnr),[gr4,gr5]);
        dodisp:=6
        end
      else begin dodisp:=dobase; dobase:=0 end
      end;
    pushdesire:=desire;
    newtos;
    with opstk[tos] do begin state:=[loaded]; reg:=rx; opsize:=wordsize end;
    if dobase<>0 then begin
      newtos;
      with opstk[tos] do begin state:=[loaded,copy]; reg:=rb; opsize:=wordsize end;
      emit15(dobase,pop,nxtdis);
      nxtdis:=leave
      end;
    swaptos; opstk[tos].state:=[liter];
    opstk[tos].opsize := wordsize;
    emit15(dodisp,pop,nxtdis)
    end
  end
end {loadaddress};
 
 
 
procedure extend(tosize: byte; desire: resources);
type table=array[bitsize..pred(wordsize)] of integer;
const mask=table(-2,-4,-8,-16,-32,-64,-128,-256,-512,-1024,-2048,-4096,
  -8192,-16384,-32768);
begin {extend}
{assert tosize<=wordsize}
with opstk[tos] do if opsize<tosize then begin
  load(desire);
  if opsize < tosize then begin {the load may have changed things}
    pushlit(mask[opsize]);
    opsize:=tosize;
    emit15(4 {bic},pop,leave)
    end
  end
end {extend};
 
procedure cvtdouble;
{a wordsize value is assumed to loaded in an odd register,
the sign is extended through the paired even register}
var lcp: codeindex; lreg: registers;
begin {cvtdouble}
lcp:=cp;
with opstk[tos] do begin
  lreg:=pred(reg);	{lreg is the even register of the pair}
  lreg:=getregister([lreg]);	{seize the even register}
	{getregister may save registers and thus destroy the cond code}
  if lcp<cp then emit7(47 {tst}, leave);
  reg:=lreg;		{change to even register}
  emit7(55 {sxt}, leave);	{extend the sign thru even register}
  opsize:=longsize	{size is now longword}
  end
end {cvtdouble};
 
procedure cvtsingle(keepeven: boolean);
{a longsize value is assumed to loaded in an even/odd register pair,
one of the registers is discarded and the size changed to wordsize}
begin {cvtsingle}
with opstk[tos] do begin
  if keepeven
  then freeregister(succ(reg))
  else begin freeregister(reg); reg:=succ(reg) end;
  opsize:=wordsize
  end
end {cvtsingle};
 
 
 
procedure genscan;
 
procedure gencode(node:ptn; desire: resources; force: whatwhere);
 
procedure dumpstack(p: integer);
type
  regstrtab = array[0..10] 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','fis',
		'stk','gcc', 'mem','dbl');
  relstring = relstrtab('absact','absrel','txtact','txtrel','datact','datrel',
		'bssact','bssrel','uxtact','uxtrel',
		'      ','      ','      ','      ','       ','       ');
var ss:array[0..9] of char; n: integer;
begin {dumpstack}
writeln(output);
writeln(output,'stackdump, node = ',p,', cp=',cp);
n:=tos;
while n>=0 do with opstk[n] do begin
  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]:=' ';
  if fistack in state then ss[9]:='F' else ss[9]:=' ';
  writeln(output,n:3,' ':3,ss:10,ord(opsize):5,' ',
	regstring[ord(reg)]:4,adr.addr:8,' ',
	relstring[ord(rel.reltype)]:6,'(',ord(rel.segnr):3,')'); break(output);
  n:=n-1
  end
end {dumpstack};
 
 
function subtreematch(st1,st2: ptn): boolean;
var i: integer; matchsofar: boolean;
begin {subtreematch}
if st1=nil
then subtreematch:=(st2=nil)
else if st2=nil
  then subtreematch:=false
  else with st1@ do begin
    if (code=st2@.code) and (size=st2@.size)and
      (dsp.disp=st2@.dsp.disp) and (nrarg=st2@.nrarg)
      and (segnr=st2@.segnr)
      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;
  ldesire: resources;
begin {store}
savetarget:=target; target:=node@.arg[1];
sideeffects:=false;		{must check for side effects}
if fop=0 then ldesire:=gregs else ldesire:=[sfis];
gencode(target,gregs,noload);	{get addr of lhs in gregs}
targetsize:=opstk[tos].opsize;
if (force=noload) and (fop<>2) {Don't want to do floating 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 sfis, 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}
      emitfop2(2 {store},dispose,pop)
      end
    end
  else {multiple store} error(19)
  end;
if force=noload
then tos:=tos-1
else opstk[tos]:=opstk[tos+1];
sideeffects:=true;	{tell parent node that there are side effects}
target:=savetarget
end {store};
 
 
 
procedure move;
var lop: integer;
begin {move}
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(dsp.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 {genunary}
with node@ do if (force=tryupdate) and subtreematch(target,arg[1])
  then update:=true
  else begin
    gencode(arg[1],desire,loadvalue);
    update:=false
    end;
emit7(fop,leave);
if update then opstk[tos].state:=[stored]
end {genunary};
 
{generate code for unary floating ops}
procedure genfpunary(fop: integer);
var update: boolean;
begin {genfpunary}
  with node@ do
    if (force=tryupdate) and subtreematch(target,arg[1])
    then update:=true
    else begin
      gencode(arg[1],[stk],loadvalue);
      update:=false
    end;
  emitfop1(fop,leave);
  if update
    then opstk[tos].state:=[stored]
    else if not (stk in desire) and (sfis in desire)
      then load( desire )
end {genfpunary};
 
procedure genfpconvert(fop: integer);
{generate code for conversions from/to floating}
{fop: 0 => float; 1 => trunc; 2 => round }
type opvalue = array [0..2] of integer;
     opsze   = array [0..2] of byte;
const
  stacksize = opvalue ( -4, -2, -2 );
  procno    = opvalue ( 201, 98, 99 );
  parmsize  = opsze ( floatsize, wordsize, wordsize );
begin {genfpconvert}
  saveregister( true, [] );
  adjuststack( stacksize[fop] );  {returned value}
  gencode( node@.arg[1], [stk], loadvalue );
  gencall( false,procno[fop] );
  opstk[tos].opsize := parmsize[fop]
end {genfpconvert};
 
 
 
{generate code for floating binary ops.}
procedure genfpbinary(fop: integer);
begin {genfpbinary}
  with node@ do begin
    gencode( arg[1], [sfis], loadvalue );
    gencode( arg[2], [sfis], loadvalue );
    gencall( false, fop+215 );
    tos := pred(tos);
    if stk in desire then load( desire )
    end
end {genfpbinary};
 
procedure fpcompare( fop:integer );
{generate floating point compare operations}
begin {fpcompare}
  gencode(node@.arg[1], [stk], loadvalue);
  gencode(node@.arg[2], [stk], loadvalue);
  tos := tos -1;
  gencall( false,97 {fpcmp} );
  truecode := fop;
  with opstk[tos] do begin
    state := [loaded];
    opsize := bitsize;
    reg := gcc
    end
end {fpcompare};
 
 
procedure genbinary(fop: integer; nobyte: boolean);
var update: boolean;
begin {genbinary}
with node@ do begin
  if (force=tryupdate) and (not nobyte or (opstk[tos].opsize=wordsize))
    and subtreematch(target,arg[1])
  then update:=true
  else begin
    gencode(arg[1],desire*(gregs + [stk]),loadvalue);
    if nobyte then extend(wordsize,desire*(gregs + [stk]));
    update:=false
    end;
  gencode(arg[2],gregs,noload)
  end;
if nobyte then extend(wordsize,gregs);
if loaded in opstk[tos].state then load(gregs);	{convert gcc to boolean}
emit15(fop,pop,leave);
if update then opstk[tos].state:=[stored]
end {genbinary};
 
procedure compare(fop: brtypes);
begin {compare}
with node@ do begin
  gencode(arg[1],gregs,noload);
  gencode(arg[2],gregs,noload)
  end;
emit15(2 {cmp},pop,pop);
truecode:=fop;
with opstk[tos] do begin
  state:=[loaded];
  reg:=gcc
  end
end {compare};
 
 
 
procedure vcompare(fop:integer);
{emit code to do "multiple compare", leaving the condition codes set
 according to the last compare done.  Higher level stuff will have to
 weave together sequences of these as well as convert condition codes
 to booleans.  Does not touch truechain or falsechain}
var
  savecp: codeindex;
  lop: integer;
begin {vcompare}
  with node@ do begin
    gencode(arg[1],gregs,loadaddr);	{get left arg address into reg}
    gencode(arg[2],gregs,loadaddr);	{get right arg address into new reg}
    if size <= bytesize then lop:= -23536 {cmpb (r?)+,(r?)+}
			else lop:= 9232;	  {cmp  (r?)+,(r?)+}
    pushlit(dsp.disp); load(gregs+[gr4]);	{load length and force to reg}
    restoreregister(tos-2,gregs);		{make sure all 3 are in regs}
    savecp:=cp;				{mark point for sob return}
    emit0(lop+ord(opstk[tos-2].reg)*64+ord(opstk[tos-1].reg));
    emit0(brtab[3]+1);	{bne around sob, ending comparison on first nonequal}
    emit0(32259 {sob} + ord(opstk[tos].reg)*64);	{sob r?,.-4}
    truecode:=fop;
    freeregister(opstk[tos].reg);
    freeregister(opstk[tos-1].reg);
    freeregister(opstk[tos-2].reg);
    tos:=tos-2;				{leave something on stack as result}
    with opstk[tos] do begin
      state:=[loaded];			{ ...which is loaded...}
      reg:=gcc				{ ...in the condition codes...}
    end;
  end {with node@}
end {vcompare};
 
 
 
procedure minmax(fop: integer);
var
  lcp: codeindex;
  this,other: ptn;
  loadit: whatwhere;
  loperand: operand;

begin {minmax}
  {generate for u, i max/min functions.  Optimize for x:=max(x,y)}
  loadit:=loadvalue; {assuming no optimization}
  this:=node@.arg[1];
  other:=node@.arg[2];
  if force=tryupdate then {check subtrees}
    if subtreematch(target{lhs},this) then loadit:=noload
    else
      if subtreematch(target,other) then begin {flip subtree}
	this:=other;
	other:=node@.arg[1];
	loadit:=noload
      end;

  {Now, generate the code:}
  if loadit<>noload {if not updating} then gencode(this,desire,loadit);  {for "1st" arg}
  gencode(other,gregs,noload);  {for "2nd" arg...don't load its value}
  if loaded in opstk[tos].state then load(gregs); {pop off stack if there}
  loperand:=opstk[tos];		{save for later use}
  swaptos;			{to counteract the same in emit15}
  emit15(2{cmp},pop,leave);
  case fop of {make the branch codes-bxx .+1; will fix up target after store}
    0 {umax=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 {mdmconst}
if n<>0 then begin
  i:=0; j:=1;
  while (i<15) and (j<n) do begin i:=i+1; j:=j*2 end;
  if j=n
  then if i=0
    then fop:=fop+3			{n=1}
    else if i=1
      then fop:=fop+6			{n=2}
      else fop:=fop+9			{n=2^i, 1<i<16}
  else fop:=fop+12			{n$2^i}
  end;
if not update or (fop>9) then begin {can't update...get operand in reg}
  update:=false;
  if fop>=12 then desire:=oddregs {for mul,div,mod} else desire:=gregs;
  load(desire);
  extend(wordsize,desire)
end else opstk[tos].state := opstk[tos].state-[copy]; {ok to release addr reg}
case fop of
0 {mod 0}, 1 {div 0}: {error};
2 {mul 0}, 3 {mod 1}: emit7(40 {clr},leave);
6,9 {mod 2^i, i>0}: begin pushlit(-n); emit15(4 {bic},pop,leave) end;
7 {div 2}: emit7(50 {asr},leave);
8 {mul 2}: emit7(51 {asl},leave);
10 {div 2^i, i>1}: begin pushlit(-i); emit10(58 {ash},pop) end;
11 {mul 2^i, i>1}: begin pushlit(i); emit10(58 {ash},pop) end;
12 {mod n, n$2^i}, 13 {div n, n$2^i}: begin
  cvtdouble;
  pushlit(n); emit10(57 {div},pop);
  cvtsingle(odd(fop))
  end;
14 {mul n, n$2^i}: begin pushlit(n); emit10(56 {mul},pop) end
end;
if update then opstk[tos].state:=[stored];
end {mdmconst};
 
 
 
procedure muldivmod(fop: integer {0=mod, 1=div, 2=mul});
var update:boolean;
begin {muldivmod}
with node@ do begin
  if (force = tryupdate) and subtreematch(target,arg[1]) then begin
    update:=true;
    duptos;
    opstk[tos].state:=opstk[tos].state + [copy]
  end else begin
    update:=false;
    gencode(arg[1],gregs,noload)
  end;
  if arg[2]@.code=litcode then begin
    mdmconst(fop,arg[2]@.dsp.disp,desire,update);
    if stored in opstk[tos].state then begin
      tos:=tos-1;
      opstk[tos].state:=opstk[tos].state + [stored]
    end
  end else begin
    load(oddregs);
    extend(wordsize,oddregs);
    if fop<2 then cvtdouble;	{mod, div need doublesize dst}
    gencode(arg[2],gregs + [stk],noload);
    extend( wordsize, gregs+[stk]); (*Source must be wordsize*)
    if fop<2
    then begin {mod, div}
      emit10(57 {div}, pop);
      cvtsingle(odd(fop))
    end else emit10(56 {mul},pop)
  end
end {with}
end {muldivmod};
 
 
 
procedure iabs;
var update: boolean;
  savecp: codeindex;
begin {iabs}
  with node@ do begin
    if (force=tryupdate) and subtreematch(target,arg[1])
    then begin
      emit7(47{tst},leave);
      update:=true
    end else begin
      gencode(arg[1],desire,loadvalue);
      update:=false
    end
  end;
  savecp:=cp;
  cp:=succ(cp);				{save space for a branch}
  emit7(44{neg},leave);			{turn around sign}
  codebuf[savecp]:= -32768{bpl} + (cp-savecp-1);
  if update then opstk[tos].state:=[stored]	{because we have done the op}
end {iabs};
 
 
 
procedure iodd;
begin {iodd}
gencode(node@.arg[1],gregs,noload);
with opstk[tos] do if gcc in desire
then begin
  if loaded in state
  then begin
    emit7(48 {ror},pop);
    truecode:=15 {carry set}
    end
  else begin
    pushlit(1); emit15(3 {bit},pop,pop);
    truecode:=3 {not equal}
    end;
  state:=[loaded]; reg:=gcc
  end
else begin
  load(desire);
  opsize:=bitsize; {only least significant bit is valid}
  if stk in desire then extend(wordsize,desire) {to handle "odd(val)" as arg}
  end
end {iodd};
 
 
procedure square(fop: integer);
{emit code for sqr.
 fop:  0 => integer;  2 => real }
var r: integer;
begin {square}
  with node@ do
    if fop = 0 then
    begin {sqr integer}
      gencode(arg[1], oddregs, loadvalue);
      r := ord(opstk[tos].reg);
      emit0(70000b + 64*r + r)	{mul r,r}
    end else
    begin {sqr real}
      gencode(arg[1], [sfis], loadvalue);
      gencall( false, 202 {FSQR} )
    end
end {square};
 
 
procedure notnode;
var
  tempchain: branchlist;
  lstate: operstates;
begin {notnode}
with node@ do
  if (force=tryupdate) and subtreematch(target,arg[1])
  then lstate:=[stored]
  else begin
    gencode(arg[1],desire*(gregs + [stk,gcc]),loadvalue);
    lstate:=[loaded]
    end;
with opstk[tos] do begin
  if reg=gcc
  then begin
    tempchain:=truechain; truechain:=falsechain; falsechain:=tempchain;
    truecode:=brinv[truecode]
    end
  else begin
    emit7(44 {neg},leave); emit7(42 {inc},leave)
  end;
  state:=lstate
  end
end {notnode};
 
 
 
procedure condandor(isand: boolean);
var savechain: branchlist;
begin {condandor}
gencode(node@.arg[1],[gcc],loadvalue);
tos:=tos-1;
if isand
then begin {and}
  emitbranch(brinv[truecode],falsechain);
  fixbranch(true,truechain);
  savechain:=falsechain
  end
else begin {or}
  emitbranch(truecode,truechain);
  fixbranch(true,falsechain);
  savechain:=truechain
  end;
truechain:=emptychain; falsechain:=emptychain;
gencode(node@.arg[2],[gcc],loadvalue);
if isand
then mergebranchchains(savechain,falsechain)
else mergebranchchains(savechain,truechain);
with opstk[tos] do begin state:=[loaded]; reg:=gcc end;
if not (gcc in desire) then load(desire)	{will convert gcc to boolean}
end {condandor};
 
 
 
procedure sgens;
begin {sgens}
gencode(node@.arg[1],gregs,noload);
if (opstk[tos].opsize < wordsize) then load(gregs); {ash src must be word-aligned}
pushlit(1); load(gregs);
swaptos;
emit10(58 {ash},pop)
end {sgens};
 
 
procedure sin;
type table=array[0..15] of integer;
const powerof2=table(1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,
  32768);
var ltruecode,lop: integer; loadit: whatwhere;
begin {sin}
gencode(node@.arg[1],gregs,noload);
loadit:=loadvalue;
with opstk[tos] do if liter in state
then if gcc in desire
  then begin
    if adr.addr<16 then adr.addr:=powerof2[adr.addr] else adr.addr:=0;
    loadit:=noload; ltruecode:=3 {not equal}
    end
  else adr.addr:=-adr.addr
else begin
  load(gregs);
  if gcc in desire then lop:=41 {com} else lop:=44 {neg};
  emit7(lop,leave); ltruecode:=15 {carry set}
  end;
gencode(node@.arg[2],gregs,loadit);
swaptos;
if loadit=noload	{this means we can use a "bit" instruction}
then emit15(3 {bit},pop,pop)
else emit10(58 {ash},pop);
with opstk[tos] do begin
  if gcc in desire then begin
    if loaded in state then freeregister(reg);
    reg:=gcc; truecode:=ltruecode
  end else opsize:=bitsize; {only low order bit is valid}
  state:=[loaded];
  end
end {sin};
 
 
procedure sany;
var lop: integer; rega: registers;
begin {sany}
gencode(node@.arg[1],gregs,loadvalue);
with opstk[tos] do begin
  rega:=reg;
  if opsize<=bytesize then lop:=-29696 {rorb} else lop:=3072 {ror};
  opsize:=wordsize
  end;
pushdesire:=desire;
emit7(40 {clr},push);
emit0(177 {sec});
emit0(lop+ord(rega) {ror rega});
emit0(-30974 {bcs .+6});
emit7(42 {inc},leave);
emit0(508 {br .-10});
freeregister(rega)
end {sany};
 
 
 
procedure indexnode(node: ptn; multiplier: integer);
 
  procedure findcstpart(node: ptn; var varpart: ptn; var cstpart: integer);
  const
    litcode = chr(162); addcode = chr(32); subcode = chr(33);
  var
    subpart: integer;
  begin {findcstpart}
  with node@ do
    if code = litcode then begin
      varpart := nil;
      cstpart := dsp.disp
      end
    else if (code = addcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart + arg[2]@.dsp.disp
      end
    else if (code = addcode) and (arg[1]@.code = litcode) then begin
      findcstpart(arg[2], varpart, subpart);
      cstpart := arg[1]@.dsp.disp + subpart
      end
    else if (code = subcode) and (arg[2]@.code = litcode) then begin
      findcstpart(arg[1], varpart, subpart);
      cstpart := subpart - arg[2]@.dsp.disp
      end
    else begin
      varpart := node;
      cstpart := 0
      end
  end {findcstpart};
 
 
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 {indexnode}
with node@ do if code <> chr(134) then
  gencode(node, gregs, noload)
else begin
  multiplier := multiplier * dsp.disp;
  indexnode(arg[1], multiplier);
  findcstpart(arg[2], variable, fixed);
  offset := fixed * multiplier;
  with opstk[tos] do begin
    laddr:=adr.addr; lrel:=rel; lstate:=state;
    if state = [] then n := 0
    else if indexed in state then n := 2
    else if indirect in state then n := 4
    else n := 6;	{ must be based }
    if variable <> nil then n := n + 1;
    doit := dotab[n].todo;
    if swap in doit then begin	{ will convert indirect to based }
      state := state - [indirect];
      laddr := 0
      end;
    if chkreg in doit then begin
      restoreregisters(tos,gregs);
      state := state + [loaded];	{ so later add will work }
      if copy in state then
	doit := doit + [swap]		{ so we don't destroy register }
      end
    end;
  if getinx in doit then begin
    gencode(variable,gregs,noload); {compute index value}
    extend(wordsize, gregs)
    end;
  if mmult in doit then mdmconst(2 {mul}, multiplier, gregs, false);
  if swap in doit then begin
    load(gregs);
    swaptos
    end;
  if add in doit then emit15(6 {add}, pop, leave);
  if mdisp in doit then mdmconst(2 {mul}, dsp.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; adr.addr := laddr + offset; rel := lrel
    end
  end {with node@}
end {indexnode};
 
 
 
procedure definetemp;
var
  taddr: integer; usereg: boolean;
begin {definetemp}
with node@ do begin
{the number of temp regs required by "inner" code will be left in
 the node's size field, courtesy of prescan}
  usereg := ord(size)<=maxtmpregs;
  if not usereg then begin {reserve a local spot for it}
    newtos;
    with opstk[tos] do begin
      if lexlev=1 then begin {local are is in bss}
	taddr:=tempbase+dsp.disp*2;
	if taddr>localsize then localsize:=taddr;
	rel.reltype:=bssact;
	state:=[]
      end else begin {local area is in stack}
	taddr:=tempbase-dsp.disp*2;
	if taddr<localsize then localsize:=taddr;
	rel.reltype:=absact;
	reg:=gr5; {force to r5 for stored temps}
	state:=[based]
      end;
      adr.addr:=taddr;
      rel.segnr:=chr(lexlev); {make sure it resides in this frame}
      opsize:=wordsize;
      desire:=gregs
    end
  end else desire:=tregs; {its in a temp reg}
  gencode(arg[1],desire,noload); {get recvar}
  if not usereg then emit15(1{mov},pop,leave) {store in local area}
  else load(desire); {force to a reg}
  with opstk[tos] do begin
    if lexlev>1
      then state := state + [temp,based]
      else state := state + [temp];
    rel.segnr:=chr(dsp.disp);
    gencode(arg[2],assignable,noload);
    if loaded in state then freeregister(reg)
    end;
  tos:=tos-1
  end
end {definetemp};
 
 
procedure refertotemp;
var i: integer; found: boolean; lookfor: byte;
begin {refertotemp}
found:=false; i:=tos; lookfor:=chr(node@.dsp.disp);
while not found and (i>=0) do with opstk[i] do
  if (temp in state) and (rel.segnr=lookfor)
  then found:=true
  else i:=i-1;
newtos;
if found
then begin
  opstk[tos]:=opstk[i]; opstk[tos].state:=opstk[tos].state-[temp] + [copy];
  end
else error(10)
end {refertotemp};
 
 
 
procedure ifnode;
var
  endchain,lfalsechain,ltruechain: branchlist;
  which_stmt: integer;
begin {ifnode}
with node@ do begin
  if ord(arg[1]@.code) = 162 (*liter*) then begin
  (*const Boolean-expression, optimize by generating
    only the executable statement.*)
    if arg[1]@.dsp.disp = 1	(* true *)
    then which_stmt := 2	(* then-stmt *)
    else which_stmt := 3;	(* else-stmt *)
    gencode(arg[which_stmt], desire, force)
    end (*const expression*)
  else begin (*var expression*)
    lfalsechain := falsechain; falsechain := emptychain;
    ltruechain := truechain; truechain := emptychain;
    endchain := emptychain;
    saveregister(true,[]);
    gencode(arg[1],[gcc],loadvalue); (* Boolean-expression *)
    tos := tos-1;	{remove condition code operand}
    emitbranch(brinv[truecode],falsechain);
    fixbranch(true,truechain);
    gencode(arg[2],desire,force);	(* then-stmt *)
    emitbranch(1,endchain);
    fixbranch(false,falsechain);
    gencode(arg[3],desire,force);	(* else-stmt *)
    fixbranch(true,endchain);
    falsechain := lfalsechain; truechain := ltruechain
    end (*var expression*)
  end (*with node@*)
end {ifnode};
 
 
procedure casenode;
var
  endchain: branchlist;
  casestate: blockstate;
  tp: codeindex;
  i, j: integer;
begin {casenode}
saveregister(true,[]); {push all tos registers}
with node@ do begin
  gencode(arg[1],gregs,loadvalue); extend(wordsize,gregs);
  emit0(0 {case}); emit0(lastbr); lastbr := cp-2;
  emit0(dsp.disp+1); emit0(ord(opstk[tos].reg));
  freeregister(opstk[tos].reg); tos := tos-1;
  tp := cp;
  endchain.last := 0; endchain.state := curstate;
  casestate := curstate;
  for i := 0 to dsp.disp do emit0(-1);	{ initialize jump table }
  for i := 2 to ord(nrarg) do begin
    with arg[i]@ do begin
      for j := 1 to ord(nrarg)-1 do
        codebuf[arg[j]@.dsp.disp+tp] := cp-tp+4; { fixup this entry in jump table }
      curstate := casestate;	{ restore state as of case jump }
      saveregister(true,[]); {push all tos registers}
      gencode(arg[ord(nrarg)],desire,force)
      end;
    emitbranch(1 {br}, endchain)
    end;
  for i := 0 to dsp.disp do	{ fixup all unused entries in jumptable }
    if codebuf[tp+i]=-1 then codebuf[tp+i] := cp-tp+4;
  end;
fixbranch(false,endchain)
end {casenode};
 
 
 
procedure loopnode;
var
  lfalsechain, ltruechain: branchlist;
  loophead: codeindex;
  i: integer;
begin {loopnode}
lfalsechain := falsechain; falsechain := emptychain;
ltruechain := truechain; truechain := emptychain;
saveregister(true,[]);
label_;
loophead := cp;
with node@ do for i:=1 to ord(nrarg) do
  gencode(arg[i],assignable+[stk],noload);
falsechain := emptychain;
emitbranch(1, falsechain);
codebuf[falsechain.last+2] := loophead-cp+3;	{ fixup backward branch }
fixbranch(false,truechain);	{ fixup all exit branches }
falsechain := lfalsechain; truechain := ltruechain
end {loopnode};
 
 
procedure exitnode;
var
  savechain: branchlist;
begin {exitnode}
{ truechain is used globally to accumulate exits from current loop }
{ falsechain is used locally to accumulate continues for this exit }
falsechain := emptychain;
savechain := truechain; truechain := emptychain;
with node@ do begin
  gencode(arg[1],[gcc],loadvalue);
  tos := tos - 1;	{ pop off condition code value }
  if arg[2] <> nil then begin
    emitbranch(brinv[truecode],falsechain);
    fixbranch(true,truechain);
    truechain := emptychain;
    gencode(arg[2],desire,force);
    emitbranch(1,truechain)
    end
  else
    emitbranch(truecode,truechain)
  end;
fixbranch(false,falsechain); falsechain := emptychain;
mergebranchchains(savechain,truechain)
end {exitnode};
 
 
 
procedure fornode;
{decision table for setting up for node:}
{todo:	FLD1 - load expr1 (from value is not constant)
	FLD2 - load expr 2 (to value is not constant)
	FDEC - increment is -1 (downto)
	FADD -
	FNEG -
	FSUB -
	FSWP -
	FREG -
}
type todo = (FLD1,FLD2,FDEC,FADD,FNEG,FSUB,FSWP,FREG);
  whattodo = set of todo;
  fortabtype = array [0..7] of whattodo;
const fortab = fortabtype(
	[     FSWP,FSUB,     FADD,     FLD2,FLD1],
	[                    FADD,     FLD2     ],
	[FREG,          FNEG,FADD,          FLD1],
	[FREG                                   ],
	[FREG,     FSUB,     FADD,FDEC,FLD2,FLD1],
	[               FNEG,FADD,FDEC,FLD2     ],
	[FREG,               FADD,FDEC,     FLD1],
	[FREG,                    FDEC          ]);
var
  backchain, forwchain: branchlist;
  dowhat: whattodo;
  usereg: boolean;
  targetsize: byte;
  lop,tcadjust: integer;
  regs1,regs2,tcregs: resources;
  looptop: codeindex;
  tabindex: 0..7;
  howload: whatwhere;
 
begin {fornode}
  with node@ do begin
    forwchain := emptychain;  backchain := emptychain;
    tcadjust := 0; tabindex := 0;
    {following assumes arg[4] is LIT with value +-1}
    if arg[2]@.code = litcode then tabindex:=tabindex+1;
    if arg[3]@.code = litcode then tabindex:=tabindex+2;
    if arg[4]@.dsp.disp<0 then tabindex:=tabindex+4;
    dowhat:=fortab[tabindex];
    {find out if we can leave trip count in a temp register}
    if (ord(size) <= maxtmpregs) then begin
      usereg:=true;
      tcregs:=tregs
    end else begin
      usereg:=false;
      tcregs:=[stk]
    end;
    if FREG in dowhat then begin
      regs1:=tcregs; regs2:=gregs end
    else begin
      regs1:=gregs; regs2:=tcregs end;
    {Now, get loop variable}
    gencode(arg[1],gregs,noload);
    targetsize:=opstk[tos].opsize;
    {Now, get initial value:}
    if FLD1 in dowhat then howload:=loadvalue else howload:=noload;
    gencode(arg[2],regs1,howload);
    emit15(1{mov},leave,pop);
    if FLD1 in dowhat then begin
      opstk[tos]:=opstk[tos+1];
      extend(wordsize,gregs)
    end else begin
      tcadjust:=tcadjust-arg[2]@.dsp.disp;
      tos:=tos-1
    end;
    {Next, the final value:}
    if FLD2 in dowhat then howload:=loadvalue else howload:=noload;
    gencode(arg[3],regs2,howload);
    if FLD2 in dowhat then extend(wordsize,gregs)
    else begin
      tcadjust:=tcadjust+arg[3]@.dsp.disp;
      tos:=tos-1
    end;
    if FSWP in dowhat then swaptos;
    if FSUB in dowhat then emit15(14{sub},pop,leave);
    if FNEG in dowhat then emit7(44{neg},leave);
    if FDEC in dowhat then tcadjust:=1-tcadjust
    else tcadjust:=tcadjust+1;
    {if haven't loaded anything and tcadjust<=0, don't generate code}
    if (dowhat*[FLD1,FLD2] <> []) or (tcadjust>0) then begin
      pushlit(tcadjust);
      if FADD in dowhat then begin
	emit15(6{add},pop,leave);
	emitbranch(5{ble},forwchain)
      end else load(regs1);
      {trip count next...mark temp}
      opstk[tos].state:=opstk[tos].state + [temp];
      { Store very large temp # (as segnr) so it won't match anything set up
	by with }
      opstk[tos].rel.segnr:=chr(255);
      label_;
      looptop:=cp;
      gencode(arg[5],desire,force);
      gencode(arg[1],gregs,noload);
      opstk[tos].opsize:=targetsize;
      if FDEC in dowhat then lop:=43{dec} else lop:=42{inc};
      emit7(lop,pop);
      tos:=tos-1;
      {if we're using a temp register, emit an sob; else do dec,bgt}
      if usereg then begin
	emitbranch(18{sob},backchain);
	codebuf[lastbr+2] := looptop-cp+3;
	emit0(ord(opstk[tos].reg));
	fixbranch(true,forwchain);
	freeregister(opstk[tos].reg);
      end else begin
	emit7(43{dec},leave);
	emitbranch( 4{bgt},backchain);
	codebuf[lastbr+2] := looptop-cp+3;
	fixbranch(true,forwchain);
	emit7(47{tst},pop) {delete trip count from stack}
      end;
      tos:=tos-1
    end
  end {if}
end {fornode};
 
 
 
procedure sequence;
var numarg,i: integer;
begin {sequence}
numarg:=ord(node@.nrarg);
for i:=1 to numarg-1 do
  gencode(node@.arg[i],assignable + [stk],noload);
gencode(node@.arg[numarg],desire,force)
end {sequence};
 
 
procedure call(isfunc: boolean; isuser: boolean);
var i: integer; reg: registers; symindex: integer; cctype: symbol_types;
begin {call}
with node@ do begin
  symindex := searchid( dsp.disp, isuser );
  cctype := stable[symindex].stype;
  saveregister(true,[]);	{save stack registers}
  if cctype=fortransy then
    for i:=2 to 5 do emit0( 10046b+i*64 {mov Ri,-(SP)} );
  if isfunc then begin
    newtos;
    with opstk[tos] do begin
      state := [loaded];
      opsize := size;
      reg := stk;
      if isuser and (cctype <= pascalsy) then
        adjuststack(-(ord(size)+1) div 8);
      end
    end;
  if cctype <= pascalsy then
    for i:=1 to ord(node@.nrarg) do begin
      gencode(arg[i],[stk],loadvalue);
      tos:=tos-1
      end
    else begin
      for i:=ord(node@.nrarg) downto 1 do begin
        gencode(arg[i],[stk],loadvalue);
        tos := tos -1 end;
  if cctype = fortransy then begin
    emit0( 12746b {mov lit,-(SP)} );
    emit0( ord(node@.nrarg) );
    emit0( 10605b {mov SP,R5} )
    end
  end;
  if isuser and (cctype<=pascalsy) then reg:=getenvironment(ord(segnr),[gr4]);
		 {getenvironment called for effect}
  if isfunc and (cctype >= ceesy) then
    opstk[tos].reg := getregister( [gr0] );
  gencall(isuser,dsp.disp);
  if cctype >= ceesy then begin
    i := stable[symindex].snum;
    if cctype = fortransy then i := succ(i);
    adjuststack( 2*i );
    if cctype = fortransy then
      for i:=5 downto 2 do emit0( 12600b+i {mov (SP)+,Ri} )
    end
  end
end {call};
 
 
 
begin {gencode}
if node<>nil then with node@ do begin
  case ord(code) of
  9 {refer}: begin
    gencode(arg[1],desire*(gregs + [stk]),noload);
    if indirect in opstk[tos].state then begin {just turn it off}
      opstk[tos].state:=opstk[tos].state-[indirect];
      opstk[tos].opsize:=wordsize {it's a pointer}
    end else
      loadaddress(desire*(gregs + [stk]))
    end;
  10,12 {stol,stof}: store(ord(code)-10);
  16,17 {succ,pred}: genunary(ord(code)+26 {inc,dec});
  24,25,26,27,28,29 {uceq-uclt}: compare(ord(code)-14);
  30,31 {umax,umin}: minmax(ord(code)-30);
  32 {iadd}: genbinary(6 {add},true);
  33 {isub}: genbinary(14 {sub},true);
  34 {imul}: muldivmod(2);
  35 {idiv}: muldivmod(1);
  36 {imod}: muldivmod(0);
  37 {isqr}: square(0);
  40 {ineg}: genunary(44 {neg});
  41 {iabs}: iabs;
  42 {iodd}: iodd;
  56,57,58,59,60,61 {iceq-iclt}: compare(ord(code)-54);
  62,63 {imax,imin}: minmax(ord(code)-60);
  64,65,66,67 {fadd,fsub,fmul,fdiv}: genfpbinary(ord(code)-64);
  69 {fsqr}: square(2);
  72 {fneg}: genfpunary(3);
  73 {fabs}: genfpunary(2);
  74,75,76 {float - round}: genfpconvert(ord(code)-74);
  88,89,90,91,92,93 {fceq - fclt}: fpcompare(ord(code)-86{brtype});
  96 {not}: notnode;
  104,105,106,107,108,109 {eqv-nrimp, aka "bceq"-"bclt"}:
    {With no packed values, booleans are bytes, so can call compare}
    compare(ord(code)-102);
  110 {or}: if gcc in desire
    then condandor(false)
    else genbinary(5 {bis},false);
  111 {and}: if gcc in desire
    then condandor(true)
    else genbinary(0 {and},false);
  113 {union}: if size<=wordsize
    then genbinary(5 {bis}, false);
  114 {inter}: if size<=wordsize
    then genbinary(0 {and}, false);
  115 {sdiff}: if size<=wordsize
    then genbinary(4 {bic}, false);
  117 {sgens}: sgens;
  118 {sadel}: error( 31 );
  120,121 {sceq,scne}: if size<=wordsize
    then compare(ord(code)-118);
  126 {sin}: sin;
  127 {sany}: sany;
  132 {ofset}: begin
    gencode(arg[1],gregs,noload);
    with opstk[tos] do begin
      if indirect in state
      then begin
        loadaddress(gregs);
	rel.reltype:=absact; {no relocation for offset}
        adr.addr:=dsp.disp;
        state:=[based]
        end
      else adr.addr:=adr.addr+dsp.disp;
      opsize:=size
      end
    end;
  133 {indir}: begin
    gencode(arg[1],gregs,noload);
    with opstk[tos] do begin
      if loaded in state
      then begin	{result of a refer-to-temp}
        adr.addr:=dsp.disp;
	rel.reltype:=absact;	{offset needs no relocation}
        state:=(state-[loaded]) + [based]
        end
      else if (indirect in state) or (dsp.disp<>0)
        then begin
	  opsize:=wordsize;
          load(gregs); adr.addr:=dsp.disp;
	  rel.reltype:=absact;
          state:=[based]
          end
	else state:=state + [indirect];
      opsize:=size
      end
    end;
  134 {index}: indexnode(node, 1);
  135 {movem}: move;
  138 {invok}: if size=chr(255) then call(false,false) else call(true,false);
  140 {rtemp}: refertotemp;
  141 {dtemp}: definetemp;
  144 {if}: ifnode;
  145 {case}: casenode;
  147 {loop}: loopnode;
  148 {exit}: exitnode;
  149 {for}: fornode;
  152 {seq}: sequence;
  168,169,170,171,172,173 {vceq-vclt}: vcompare(ord(code)-158);
  208 {call}: if size=chr(255) then call(false,true) else call(true,true);
  162 {liter}: pushlit(dsp.disp);
  164 {litd}: pushlitd(dsp.disp);
  163,176,192 {rdata,varb,parm}: begin
    newtos;
    with opstk[tos] do begin
      state:=[]; opsize:=size; reg:=mem;
      adr.addr:=dsp.disp; rel.segnr:=segnr;
      {Resolve relocation type for varbles here so we know what to do back
       up the tree}
      if code=chr(176)	{is it a variable}
      then if ord(segnr)=1	{make level 1 varbles reside in BSS segment}
	then rel.reltype:=bssact
	else rel.reltype:=absact {no mod for local addresses.  Done in p1. Tacky}
      else if code=chr(192)	{parm}
	then begin rel.reltype:=absact; adr.addr:=adr.addr+6 {stack frame header} end
	else rel.reltype:=datact	{rdata}
      end
    end
  end; {of case}
  if force=loadvalue then load(desire)
  else if force=loadaddr then loadaddress(desire);
  if sdump then dumpstack(ord(code))
  end {of node<>nil}
end {gencode};
 
 
 
begin {genscan}
  if lexlev=1 then rlp:=rlp+1;	{reserve one entry in reltab}
  cp:=cp+9;			{reserve 9 words in code}
  avail:=assignable; 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 {sumadjust}
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 {emit5}
emit0(brtab[i]+(offset mod 256))
end {emit5};
 
begin {generatebranches}
nextbr:=0;      {go up list and reverse links}
while lastbr<>0 do begin {swap(codebuf[lastbr+1],nextbr,lastbr)}
  temp:=codebuf[lastbr+1]; codebuf[lastbr+1]:=nextbr;
  nextbr:=lastbr; lastbr:=temp end;
                {set up first relocatable word}
if rlp<maxrlp then nxtrel:=reltab[rlp].cix else nxtrel:=0;
                {main loop follows:}
while oldcp<maxcp do begin
  if (nextbr>0) and (oldcp=nextbr)
  then begin {must generate code for a branch}
    temp:=codebuf[oldcp]; adjust:=temp/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 {writeoctal};
 
procedure greg(i:integer);
type rtab=array[0..7] of array[1..2] of char;
const grtab=rtab('r0','r1','r2','r3','r4','r5','sp','pc');
begin
write(ols,grtab[i mod 8])
end {greg};
 
procedure freg(i:integer);
type rtab=array[0..7] of array[1..2] of char;
const frtab=rtab('f0','f1','f2','f3','f4','f5','f*','f*');
begin
write(ols,frtab[i mod 8])
end {freg};
 
procedure srcdst(i:integer; isfloat:boolean);
 
procedure breg;
begin {breg}
write(ols,'('); greg(i); write(ols,')')
end {breg};
 
begin {srcdst}
case (i/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 begin
  writeln(ols);
  writeln(ols,' ;procedure ',name:namesize,'(',procnr:3,')')
  end;
lcp:=0;
lrlp:=0;
while lcp<cp do begin
  writeoctal(lcp*2); write(ols,ht);
  inst:=codebuf[lcp]; lcp:=lcp+1; lcs:=lcp;
  writeoctal(inst);
  {decode instruction}
  case (inst/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}
  writeln(ols);
  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);
    if (ch='t') or (ch='T') then begin
      ix:=searchid(ord(reltab[lrlp-1].rs.segnr),(ch='t'));
      write(ols,ht,ht,stable[ix].sname)
      end;
    writeln(ols);
    lcs:=lcs+1
    end {of "while lcs<lcp"}
  end {of outer while}
end {printcode};
 
 
 
procedure options;
var
  c: char;
  i: 0..255;
begin {options}
  if argv[flgx]@[0] = '-' then begin {parse switches}
    i:=1;
    loop
      c:=argv[1]@[i];
    exit if c=chr(0);
      if c='O' then list:=true
      else
	if c='S' then sdump:=true
	else
	    if c='P' then dproc:=true
	    else
		if c='X' then xtern:=true;
      i:=i+1
    end
  end
end {options};
 
 
 
{Here follows the output routines which set up "object module"}
 
type recordbuf = record
       index:integer;
       buff:array [-2..workspace] of integer
       end;
var recbufptr:@recordbuf;
 
procedure writerecord ( finished:boolean; s,f:integer );
  var ss:integer; checksum:integer;
begin {writerecord}
  ss := s;  {Start of object data}
  while ss<f do with recbufptr@ do begin
    buff[index] := codebuf[ss];
    index := succ(index);
    ss := succ(ss)
    end;
  if finished then  {Write out this record keeping
				  correct byte count.}
    with recbufptr@ do begin
     if RT11 then begin
      buff[-2] := 1;  {Binary record start sequence}
      buff[-1] := (index+2)*2;  {Number of bytes this record}
      checksum := 0;
      for ss:= -2 to index-1 do begin
        obj@ := buff[ss]; put(obj);  {Output two bytes of data}
        checksum := checksum + (buff[ss] mod 256)
                             + ((buff[ss] div 256) mod 256)
        end;
      checksum := checksum mod 256;
      checksum := 400b - checksum;
      checksum := checksum mod 256;
      obj@ := checksum; put(obj)  {Output checksum}
      end
     else if RSX11 then begin
      for ss := 0 to index-1 do begin
	obj@ := buff[ss]; put(obj) (*Output two bytes of data*)
	end;
      break(obj)
      end;
     index := 0
     end

end {writerecord};
 
procedure outheader( prefix,suffix:integer );
const w=maxcode+1;  {start of workspace}
      gsdrec=1;
begin {outheader}
  codebuf[w+0] := gsdrec;  {Type = GSD}
  {Module name entry}
  codebuf[w+1] := prefix;  codebuf[w+2] := suffix;
  codebuf[w+3] := 0;       codebuf[w+4] := 0;
  writerecord( true, w, w+5 )
end {outheader};
 
function radcvt( var s:array [0..5] of char; i:integer):integer;

type radlist = array [40b..132b] of integer;

const rad50 = radlist( 0,0,0,0,33b,0,0,0,0,0,0,0,0,0,34b,0,36b,
		       37b,40b,41b,42b,43b,44b,45b,46b,47b,0,0,0,0,0,0,0,
		       1,2,3,4,5,6,7,10b,11b,12b,13b,14b,15b,16b,17b,20b,
		       21b,22b,23b,24b,25b,26b,27b,30b,31b,32b);
begin (*radcvt*)
  radcvt := ((rad50[ ord(s[i]) ] * 50b) +
		rad50[ ord(s[i+1]) ] ) * 50b +
		rad50[ ord(s[i+2]) ]
end (*radcvt*);
 
 
procedure outtrailer;
const w=maxcode+1;  {Start of workspace}
      endgsdrec=2;  endmodrec=6;
      gsdrec=1;  rldrec=4;  txtrec=3;  lcentry=7;
      psectentry=5; relocate=32; global=64; readonly=16; kludge=8;
      overlay=4; glbsym=4; glbsymdef=8;
      dataentry=psectentry*256+relocate+global+kludge+overlay;
      datadef=glbsym*256+relocate+glbsymdef+global;
      maxtxt=38;
var count,address:integer;  byte1,byte2:char;
    dataprefix, datasuffix: integer;
 
begin {outtrailer}
  address := searchid( -1, true );
  dataprefix := radcvt( stable[address].sname, 0 );
  datasuffix := radcvt( stable[address].sname, 3 );
  outheader( dataprefix, datasuffix );
  codebuf[w+0] := gsdrec;
  codebuf[w+1] := dataprefix;  codebuf[w+2] := datasuffix;
  codebuf[w+3] := dataentry;   codebuf[w+4] := dcnt;
  codebuf[w+5] := dataprefix;  codebuf[w+6] := datasuffix;
  codebuf[w+7] := datadef;     codebuf[w+8] := 0;
  writerecord( true, w, w+9 );
  if dcnt <> 0 then begin
    codebuf[w+0] := rldrec;
    codebuf[w+1] := lcentry;  codebuf[w+2] := dataprefix;
    codebuf[w+3] := datasuffix;  codebuf[w+4] := 0;
    writerecord( true, w, w+5 );
    reset(dat, argv[datx]@);
    address := 0;
    codebuf[w] := txtrec;
    while dcnt>0 do begin
      count := 0;
      codebuf[w+1] := address;
      while (dcnt>0) and (count < maxtxt) do begin
        byte1 := dat@; get(dat);
        dcnt := pred(dcnt);
        if dcnt<=0 then byte2 := chr(0) else begin 
          byte2 := dat@; get(dat); dcnt := pred(dcnt) end;
        codebuf[w+2+count] := ord(byte1) + ord(byte2)*256;
        address := address+2;  count := succ(count)
        end;
      writerecord(true,w,w+2+count);
      count := 0
      end;
    end;
  codebuf[w] := endgsdrec;  writerecord(true, w, w+1);
  codebuf[w] := endmodrec;  writerecord(true, w, w+1);
end  {outtrailer};
 
 
procedure outprocedure;	{write out procedure code and relocation data}
const w=maxcode+1; gsdrec=1; txtrec=3; rldrec=4; glbsym=4; glbsymdef=8;
      psectentry=5; fastmem=1; library=2; overlay=4; kludge=8;
      readonly=16; relocate=32; global=64; dataref=128;
      instentry=psectentry*256+relocate+kludge;
      globentry=psectentry*256+relocate+global+kludge+overlay;
      dataentry=psectentry*256+relocate+global+kludge+overlay;
      instdef=glbsym*256+relocate+glbsymdef+global;
      traentry=3*256;
      dataprefix=6564;   {RAD50('DDD')}
      systprefix=-21229; {RAD50('$$$')}
      globprefix=25659;  {RAD50('PAS')}
type reference=record link:@reference; value:integer end;
var prefix,suffix,gx,rx:integer;
    globlist:@reference;
  


procedure setcodebuf( var s:array [0..5] of char );
begin {setcodebuf}
  codebuf[rx+1] := radcvt( s, 0 );
  codebuf[rx+2] := radcvt( s, 3 )
end {setcodebuf};
  
 
procedure addlist( ptr:@reference; ref:integer );
  
var nptr:@reference;
  
begin {addlist}
  loop
    exit if ref=ptr@.value;
    exit if ptr@.link=nil then begin
      new(nptr);
      ptr@.link := nptr;
      nptr@.link := nil;
      nptr@.value := ref;
      end;
    ptr := ptr@.link;
  end;
end {addlist};
 
  
procedure addglobref( procnr:integer; isuser:boolean );
  
var ptr:@reference;
    ref:integer;
  
begin {addglobref}
  ptr := globlist;
  ref := searchid( procnr, isuser );
  setcodebuf( stable[ref].sname );
  if ptr=nil then begin
    new(globlist);
    globlist@.link := nil;
    globlist@.value := ref;
    end
  else addlist( ptr, ref );
end {addglobref};
  
 
procedure outgblref;
  
const maxrld=w+7+38;
      instref=glbsym*256+global;
var ptr:@reference;
  
begin {outgblref}
  codebuf[w+0] := gsdrec;
  rx := w;
  ptr := globlist;
  loop
    exit if ptr=nil;
    setcodebuf( stable[ptr@.value].sname );
    codebuf[rx+3] := instref;
    codebuf[rx+4] := 0;
    rx := rx + 4;
    ptr := ptr@.link;
    if rx>=maxrld then begin
      writerecord(true,w,rx+1);
      rx := w;
      end;
  end;
  if rx>w then writerecord(true,w,rx+1);
end {outgblref};
 
 
procedure outtxtandrld(f: integer);
const lcentry=7; maxtxt=38; maxrld=w+7+38;
      endgsdrec=2; endmodrec=6;
type relsiztab = array [0..14] of integer;
const relentsize = relsiztab(0,2,3,2,3,4,4,4,2,1,3,0,3,4,4);
var relent,txtaddr,lrlp,lcp,rcp,tcp: integer;
begin {outtxtandrld}
  mark;
  globlist := nil;
  {*** create TXT record header and RLD record header}
  codebuf[w+2] := txtrec;
  codebuf[w+6] := rldrec;
  {create and write out initial RLD record to define location counter}
  codebuf[w+7] := lcentry;
  codebuf[w+8] := prefix;
  codebuf[w+9] := suffix;
  codebuf[w+10] := 0;  {begin at relative zero}
  writerecord(true, w+6, w+11);
  {write out a text record followed by a RLD record (if required)}
  {until all text has been processed}
  lrlp:=0;  lcp:=0;
  if rlp>0 then rcp:=reltab[0].cix else rcp:=f; {first relocated word}
  while lcp<f do begin
    tcp := lcp + maxtxt;  if tcp>f then tcp := f;
    rx:=w+7;  txtaddr:=lcp*2;
    while (rcp<tcp) and (rx<maxrld-4) do begin {build RLD entries}
      with reltab[lrlp] do begin
	case rs.reltype of
	  absact,absrel: relent:=0;
	  bssact,datact: if codebuf[cix]=0 then relent:=10 else relent:=13;
	  bssrel,datrel: if codebuf[cix]=0 then relent:=12 else relent:=14;
	  txtact,uxtact: if codebuf[cix]=0 then relent:=2 else relent:=5;
	  txtrel,uxtrel: if codebuf[cix]=0 then relent:=4 else relent:=6
	end;{case}
	codebuf[rx]:=(rcp*2-txtaddr+4)*256+relent;
	case rs.reltype of
	  absact,absrel:  {nochange};
	  txtact,txtrel: addglobref( ord(rs.segnr), true );
	  uxtact,uxtrel: addglobref( ord(rs.segnr), false );
	  datact,datrel: addglobref( -1, true );
	  bssact,bssrel: begin
			   codebuf[rx+1]:=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;
  outgblref;  {Output global references}
  release;
  codebuf[w] := endgsdrec;  writerecord(true, w, w+1);
  codebuf[w] := endmodrec;  writerecord(true, w, w+1);
end  {outtxtandrld};
 
 
begin {outprocedure}
  new(recbufptr);  {Allocate temporary object record buffer}
  recbufptr@.index := 0;  {Initialize the index to it}
  gx := searchid( procnr, true);
  prefix := radcvt( stable[gx].sname, 0 );
  suffix:=radcvt( stable[gx].sname, 3 );
  {create GSD record for an object module}
  outheader( prefix, suffix );
  {create GSD record for this procedure}
  codebuf[w+0]:=gsdrec;
  {create entry for psect containing instructions}
  codebuf[w+1]:=prefix;  codebuf[w+2]:=suffix;  {psect name}
  codebuf[w+3]:=instentry;  {entry type and flags}
  codebuf[w+4]:=cp*2;       {size in bytes}
  codebuf[w+5]:=prefix;  codebuf[w+6]:=suffix;  {entry name}
  codebuf[w+7]:=instdef;     codebuf[w+8]:=0;
  codebuf[w+9]:=globprefix; codebuf[w+10]:=globprefix;
  codebuf[w+11]:=globentry;  codebuf[w+12]:=0;
  gx:=w+13;
  {if this is outermost procedure, then generate transfer address entry}
  if procnr=0 then begin
    codebuf[gx]:=prefix;  codebuf[gx+1]:=suffix;  {transfer name}
    codebuf[gx+2]:=traentry;  codebuf[gx+3]:=0;  {start at location zero}
    codebuf[gx+4]:=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(cp)
end  {outprocedure};
 
 
 
 
begin {pascal_pass2}
{intitialize output flags and then process option flags}
  list:=false; sdump:=false; dproc:=false; xtern:=false;
  options;
  reset(int, argv[intx]@);
  if list or dproc then
  begin
    rewrite(ols, argv[olsx]@, 2);
    writeln(ols);
    writeln(ols, compiler_version)
  end;
  rewrite(obj, argv[objx]@);
 
  lastid := -1;			{No id's entered}
{initialize object module output}
  lexlev:=0; procnr:=0;
  get(int); (*skip ident code byte*)
  ident;  (*get module identification*)
  s := searchid( -1, true ); (*place in symbol table for data name*)
  s := searchid( 0, true ); (*and for main procedure name*)
{initialize code buffer indicies}
  while not eof(int) do begin
    mark;
    buildtree;
    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}
    if calltype = 0 then begin
      prescan;
      genscan;			{generate code in code buffer}
      finalgeneration;		{finish code generation of branches}
      {output code, both binary and symbolic forms}
      if dproc then begin
        writeln(ols,procnr:3,' ':2,name:namesize,' ':18-namesize,dcnt:6,cp:6);
        break(ols)
      end;
      if list then printcode;
      outprocedure
    end;
    {update counters:}
    calltype := 0;
    lexlev:=lexlev-1;
    if RT11 then while not eof(int) and (int@=chr(0)) do get(int);
    if eof(int) then outtrailer;
    {release the current heap}
    release
    end
end.