{$T-}
program PASCAL_PASS2;

const HT=CHR(9); NL=CHR(10); FF=CHR(12);
type BYTE=CHAR;
{****************************** description of node ****************}
const MAXARG=255; LITCODE=CHR(162);
type PTN = @NODE;
  NODE = record
	CODE: BYTE;			{indicates node type}
	SIZE: BYTE;
	DISP: INTEGER;
	SEGNR: BYTE;
	NRARG: BYTE;
	ARG: array[1..MAXARG] of PTN
	end;
var TREE,				{pointer to expression tree}
  TARGET: PTN;				{pointer to subtree target of store}
  SIDEEFFECTS: BOOLEAN; {true if subtree just traversed has sideeffects}
{****************************** description of relocation info *******}
type
  RELTYPES = (NONEA,NONER,HEAPA,HEAPR,GLOBA,GLOBR,DATAA,DATAR,
               INSTA,INSTR,SYSTA,SYSTR);
  RELPAIR = record
                SEGNR: BYTE;
                RELTYPE: RELTYPES
                end;
const      {commonly used kinds of relocation}
  ORDINARY = RELPAIR(CHR(0), NONEA);
  GLOBAL = RELPAIR(CHR(0),GLOBA);
{****************************** description of core buffer ********}
const MAXCODE=2047; WORKSPACE=54; MAXREL=300; MAXLEXLEV=15;
type CODEINDEX=0..MAXCODE+WORKSPACE; RELINDEX=0..MAXREL;
var
  CODEBUF: array[CODEINDEX] of INTEGER;
  RELTAB: array[RELINDEX] of record
        RS: RELPAIR;
        CIX: CODEINDEX
        end;
DP: array[0..MAXLEXLEV] of CODEINDEX; {data display}
CS,                                  {start of data}
CD,                                  {start of instructions}
CP,                                  {first empty cell beyond instruc tions}
LASTBR: CODEINDEX;                   {last branch instruction skeleton}
TRUECHAIN,FALSECHAIN: CODEINDEX;     {heads of unresolved branch chains}
RLP: RELINDEX;                       {current reloc tab index}
{****************************** description of register resources ********}
type
  REGISTERS=(GR0,GR1,GR2,GR3,GR4,GR5,FR0,FR1,FR2,FR3,FR4,FR5,STK,GCC,MEM,DBL);
  RESOURCES=set of REGISTERS;
  SAVETYPES=set of (SSR,STR,MTE,CSR);
const
  EVENREGS=[GR0,GR2];
  ODDREGS=[GR1,GR3];
  GREGS=EVENREGS ! ODDREGS;
  FREGS=[FR0,FR1,FR2,FR3,FR4,FR5];
  ASSIGNABLE=GREGS;
  MAXTMPREGS=1;
  TMPUSEREGS=[GR3];
var
  AVAIL,                      {the set of free registers}
  TMPREG,                     {the set of registers in use as temps}
  PUSHDESIRE: RESOURCES;      {the set of registers desired for next push}
  TRUECODE: INTEGER;          {code of hte last setting of condition code}

{****************************** description of operand status ********}
const MAXOPSTK=127;
      BITSIZE=CHR(0); BYTESIZE=CHR(7); WORDSIZE=CHR(15); DOUBLESIZE=CHR(31);
type
  ADDRSTATES = (LITER,BASED,INDEXED,INDIRECT,LOADED,SAVED,STORED,TEMP,COPY);
  OPERSTATES = set of ADDRSTATES;
  OPERAND = record
    STATE: OPERSTATES;
    ADDR: INTEGER;
    REL: RELPAIR;
    REG: REGISTERS;
    OPSIZE: BYTE
    end;
var
  TOS: INTEGER;
  OPSTK: array[0..MAXOPSTK] of OPERAND;
type
  WHATWHERE=(NOLOAD,LOADVALUE,LOADADDR,TRYUPDATE);
  DISPOSITION=(POP,LEAVE,PUSH);
{****************************** branch conditions ********}
type
  BRTYPES=0..18;
  BRTABFORM=array[BRTYPES] of BRTYPES;
  EXTENSION=array[0..19] of INTEGER;
const				{file name extensions}
 CODEEXT=EXTENSION(46,88,76,83,32,46,68,66,71,32,46,79,76,83,32,46,79,66,74,32);
const				{inverse conditions}
  BRINV=BRTABFORM(1,0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,18);
const				{reverse conditions}
  BRREV=BRTABFORM(0,1,2,3,7,6,5,4,8,9,10,11,15,14,13,12,16,17,18);
var
  NAMESIZE: INTEGER;
  NAME: array[1..15] of CHAR;	{current procedure name}
  LOCALSIZE,			{size of local variables}
  TEMPBASE,			{start of temporary storage}
  PARAMSIZE,			{size of parameters}
  RVSIZE,			{size of returned value, 0 if none}
  PROCNR,			{unique index of this procedure}
  LEXLEV,			{current lex level}
  ROVING: INTEGER;   		{lex level of roving base register}
  FILENAMES: array[1..10] of CHAR;  {various file names}
  IX,JX,KX: INTEGER;            {indexes for filename transfer}

{files used by second pass:        }
  INT: TEXT;			{file of intermediate code}
{  DBG: TEXT;  }		{file to dump debug information}
  OLS,LST: TEXT;		{file to put object list}
  OBJ: file of INTEGER;		{object module file}
{debug switches}
{  DEBUGS,DEBUG:BOOLEAN; }	{debug switches}
  CH:CHAR;



procedure ERROR(N:INTEGER);
begin
WRITE(OUT,NL,'PASS2 ERROR #',N); BREAK(OUT)
end; {ERROR}


procedure BUILDTREE;
const
  STACKSIZE=256;
  RETN=159;
type
  TABFORM=packed array[BYTE] of 0..255;
const
  CODTAB=TABFORM(
  {  0   1   2   3   4   5   6   7   8   9   A   B   C   D   E   F}
{0}  0, 16, 32, 48, 64,  0, 96,112,162,164,161,  0,  0,  0,  0,144,
{1}  1, 17, 33, 49, 65,  0,  0,113,162,164,161,  0,  0,  0,  0,145,
{2}  2,  0, 34,  0, 66,  0,  0,114,163,164,161,  0,  0,  0,  0,146,
{3}  8,  0, 35,  0, 67,  0,  0,115,131,164,161,  0,  0,  0,  0,147,
{4}  0,  0, 36,  0,  0,  0,  0,  0,132,164,161,  0,  0,  0,  0,148,
{5}  0,  0,  0,  0,  0,  0,  0,117,133,164,161,  0,  0,  0,  0,149,
{6}  0,  0,  0,  0,  0,  0,102,118,134,164,161,  0,  0,  0,  0,150,
{7}  0,  0,  0,  0,  0,  0,103,119,135,164,161,  0,  0,  0,  0,151,
{8}  0, 24, 40, 56, 72, 88,104,120,  3,164,161,  0,  0,  0,  0,152,
{9}  9, 25, 41, 57, 73, 89,105,121,  4,164,161,  0,  0,  0,  0,  0,
{A} 10, 26, 42, 58, 74, 90,106,122,138,164,161,  0,  0,  0,  0,  0,
{B}  0, 27, 43, 59, 75, 91,107,123,  0,164,161,  0,  0,  0,  0,  0,
{C}  0, 28, 44, 60,  0, 92,108,124,140,164,161,  0,  0,  0,  0,  0,
{D}  0, 29, 45, 61,  0, 93,109,125,141,164,161,  0,  0,  0,  0,  6,
{E}  0, 30,  0, 62,  0, 94,110,126,  0,164,161,  0,  0,  0,  0,  7,
{F}  0, 31,  0, 63,  0, 95,111,127,  5,164,161,  0,  0,  0,  0,159);
var
  S: 0..STACKSIZE;
  STACK: array[1..STACKSIZE] of PTN;
  CODEN,ARGN,ADDRN: INTEGER;
  TEMP: PTN;
  SIZEN,SEGN,CH: BYTE;


procedure GETBYTE: BYTE;
begin
GETBYTE:=INT@; GET(INT)
end;  {GETBYTE}


procedure GETWORD: INTEGER;
var TEMP: INTEGER;
begin
TEMP:=ORD(INT@)*256; GET(INT);
GETWORD:=ORD(INT@)+TEMP; GET(INT)
end;  {GETWORD}



procedure DUMPTREE(NODE: PTN);
{var I: INTEGER; }
begin
{if NODE#NIL then begin
  WRITE(DBG,NODE:6,ORD(NODE@.CODE):5,ORD(NODE@.SIZE):5,
    NODE@.DISP:8,ORD(NODE@.SEGNR):5,ORD(NODE@.NRARG):5);
  I:=1;
  while I<=ORD(NODE@.NRARG) do begin
    WRITE(DBG,NODE@.ARG[I]:7); I:=I+1
    end;
  WRITE(DBG,NL);
  I:=1;
  while I<=ORD(NODE@.NRARG) do begin
    DUMPTREE(NODE@.ARG[I]); I:=I+1
    end
  end }
end;  {DUMPTREE}

begin {BUILDTREE}
S:=0;
repeat
  CH:=GETBYTE; CODEN:=CODTAB[CH];
  if CODEN > 7
  then begin {not a pseudo op}
    if CODEN = 8
    then TREE:=NIL  {null node}
    else begin
      SEGN:=CHR(0); ADDRN:=0; SIZEN:=CHR(0);  {so SUBTREEMATCH will work}
      ARGN:=0;
      case CODEN of
      164 {varbl}: begin SEGN:=CHR(ORD(CH)/16);
        SIZEN:=GETBYTE; ADDRN:=GETWORD end;
      163 {rdata}: begin SEGN:=GETBYTE; ADDRN:=GETWORD end;
      162 {lit}: ADDRN:=GETWORD;
      140,141 {rtemp,dtemp}: begin ADDRN:=ORD(GETBYTE);
        if CODEN=141 then ARGN:=2 end;
      131,132,133,134,135 {addressing}: begin SIZEN:=GETBYTE; ADDRN:=GETWORD;
        if CODEN>=134 then ARGN:=2 else ARGN:=1 end;
      146,147,152 {n-ary}: ARGN:=ORD(GETBYTE) + 1;
      145,138 {case,invoke}: begin ARGN:=ORD(GETBYTE); ADDRN:=ORD(GETBYTE);
        if (CODEN=138) & (ADDRN=4) then {NEW} SIZEN:=CHR(2) end;
      161 {call}: begin SEGN:=CHR(ORD(CH)/16); SIZEN:=GETBYTE;
        ADDRN:=ORD(GETBYTE); ARGN:=ORD(GETBYTE) end;
      149 {for}: ARGN:=5;
      144 {tertiary}: ARGN:=3;
      10,24,25,26,27,28,29,30,31,32,33,34,35,36,56,57,58,59,60,61,62,63,
      104,105,106,107,108,109,110,111,113,114,115,118,120,121,122,123,124,
      125,126,148 {binary}: begin ARGN:=2; SIZEN:=CHR(2) end;
      9,16,17,40,41,42,96,112,117,127,159 {unary}:
        begin ARGN:=1; SIZEN:=CHR(2) end
      end; {big case statement}

      NEW(TREE,ARGN);
      with TREE@ do begin
        CODE:=CHR(CODEN); SIZE:=CHR(ORD(SIZEN)*8-1);
        DISP:=ADDRN; SEGNR:=SEGN; NRARG:=CHR(ARGN);
        if S<ARGN then begin ERROR(1); ARGN:=0 end;
        while ARGN>0 do begin
          ARG[ARGN]:=STACK[S]; ARGN:=ARGN-1; S:=S-1
          end
      end
      end; {not a 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 op}
    1 {XCH}: 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 {BYTE}: begin if ODD(CP)
      then ARGN:=ORD(GETBYTE)*256+CODEBUF[CP/2]
      else ARGN:=ORD(GETBYTE);
      CODEBUF[CP/2]:=ARGN;
      CP:=CP+1 end;
    4 {WORD}: begin if ODD(CP) then CP:=CP+1;
      ARGN:=GETWORD;  {%%%bug in pass2(BSM)}
      CODEBUF[CP/2]:=ARGN;
      CP:=CP+2 end;
    5 {IDENT}: begin ARGN:=ORD(GETBYTE); NAMESIZE:=0;
      while ARGN>0 do begin
        if NAMESIZE<15 then NAMESIZE:=SUCC(NAMESIZE);
        CH:=GETBYTE; NAME[NAMESIZE]:=CH; ARGN:=PRED(ARGN)
        end
      end;
    6 {PROC}: begin DP[LEXLEV]:=CP;
      if ODD(CP) then CP:=CP+1;
      CS:=CP; LEXLEV:=LEXLEV+1 end;
    7 {BEGIN}: begin PROCNR:=ORD(GETBYTE); RVSIZE:=ORD(GETBYTE);
      LOCALSIZE:=GETWORD;
      PARAMSIZE:=GETWORD-RVSIZE-6;
      if ODD(LOCALSIZE) then LOCALSIZE:=PRED(LOCALSIZE);
      TEMPBASE:=LOCALSIZE end
    end  {pseudo ops case statement}
until CODEN=RETN; 
{if DEBUGS then begin DUMPTREE(TREE); WRITE(DBG,FF) end}
end;  {BUILDTREE}



procedure NEWTOS;
begin
{if DEBUGS then WRITE(OUT,NL,'NEWTOS');}
if TOS<MAXOPSTK then TOS:=TOS+1 else ERROR(6)
end; {NEWTOS}


procedure SWAPTOS;
var TEMP: OPERAND;
begin
{if DEBUGS then WRITE(OUT,NL,'SWAPTOS');}
TEMP:=OPSTK[TOS]; OPSTK[TOS]:=OPSTK[TOS-1]; OPSTK[TOS-1]:=TEMP
end; {SWAPTOS}


procedure PUSHLIT(N: INTEGER);
begin
{if DEBUGS then WRITE(OUT,NL,'PUSHLIT');}
NEWTOS;
with OPSTK[TOS] do begin
  STATE:=[LITER]; OPSIZE:=WORDSIZE; REG:=MEM;
  ADDR:=N; REL:=ORDINARY
  end
end; {PUSHLIT}

procedure EMITADDR(I:INTEGER; R:RELPAIR);
begin
{if DEBUGS then WRITE(OUT,NL,'EMITADDR');}
if R.RELTYPE#NONEA 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
{if DEBUGS then WRITE(OUT,NL,'EMIT0');}
CODEBUF[CP]:=I;
if CP=MAXCODE then ERROR(3) else CP:=CP+1
end;  {EMIT0}


procedure FREEREGISTER(REG: REGISTERS);
begin
{if DEBUGS then WRITE(OUT,NL,'FREEREGISTER');}
AVAIL:=AVAIL !{union} ([REG] &{inter} ASSIGNABLE)
end;  {FREEREGISTER}


procedure MOVEREGISTER(FROM,TO: REGISTERS);
const MOV=4096; LDF=-2816; STF=-2048;
var SRC,DST,LOP: INTEGER;
begin
{if DEBUGS then WRITE(OUT,NL,'MOVEREGISTER');}
LOP:=MOV;
if FROM=STK
then SRC:=22  {(sp)+}
else if FROM<FR0
     then SRC:=ORD(FROM)
     else begin LOP:=STF; SRC:=ORD(FROM)-ORD(FR0) end;
if TO=STK
then DST:=38  {-(sp)}
else if TO<FR0
     then DST:=ORD(TO)
     else begin LOP:=LDF; DST:=ORD(TO)-ORD(FR0) end;
if LOP=LDF
then EMIT0(LDF+DST*64+SRC)
else EMIT0(LOP+SRC*64+DST)
end;  {MOVEREGISTER}



procedure SAVEREGISTER(WHICH: SAVETYPES; DESIRE: RESOURCES);
var N,TADDR: INTEGER;
begin
{if DEBUGS then WRITE(OUT,NL,'SAVEREGISTER');}
N:=0;  {start from bottom of operand stack}
while (N<=TOS) &{and} (~(CSR in WHICH) !{or} ((AVAIL &{inter} DESIRE)=[]))
  do begin with OPSTK[N] do
  if (STATE &{inter} [LOADED,BASED,INDEXED]#[]) then if ~(SAVED in STATE)
  then if TEMP in STATE then begin  {its atemp register}
      if STR in WHICH then begin
        TADDR:=TEMPBASE-ORD(REL.SEGNR)*2;
        if TADDR<LOCALSIZE then LOCALSIZE:=TADDR;
        EMIT0(4149+ORD(REG)*64); EMIT0(TADDR);  {mov reg,taddr(r5)}
        STATE:=STATE ! [SAVED]
        end;
      if MTE in WHICH then begin 
	STATE:=STATE-[LOADED];
	FREEREGISTER(REG)
	end
      end
    else begin  {its a stack register}
      if (SSR in WHICH) &{and} (REG<STK) then begin
        MOVEREGISTER(REG,STK);
        FREEREGISTER(REG);
        STATE:=STATE-[COPY]![SAVED]
        end
      end
    else if TEMP in STATE then
      if MTE in WHICH then begin
        FREEREGISTER(REG);
	STATE:=STATE-[LOADED]
	end;
  N:=SUCC(N)
  end
end;  {SAVEREGISTER}


procedure GETREGISTER(DESIRE: RESOURCES): REGISTERS;
var REGR: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'GETREGISTER');}
if DESIRE # []
then if DESIRE &{inter} ASSIGNABLE # []
     then begin
          if DESIRE&AVAIL=[] then SAVEREGISTER([SSR,CSR],DESIRE);
	  REGR:=ANY(DESIRE &{inter} AVAIL);
          AVAIL:=AVAIL -{set diff} [REGR];
          end
     else REGR:=ANY(DESIRE)
else REGR:=MEM;
{if DEBUGS then WRITE(OUT,' returns ',ORD(REGR));}
GETREGISTER:=REGR
end;  {GETREGISTER}



procedure RESTORETEMP(I: INTEGER; DESIRE: RESOURCES);
begin
{if DEBUGS then WRITE(OUT,NL,'RESTORETEMP');}
with OPSTK[I] do begin
  REG:=GETREGISTER(DESIRE);
  EMIT0(7488+ORD(REG));  {mov taddr(r5),reg}
  EMIT0(TEMPBASE-ORD(REL.SEGNR)*2);
  STATE:=STATE ! [LOADED]
  end
end;  {RESTORETEMP}


procedure RESTOREREGISTER(WHICH: SAVETYPES; THRU: INTEGER);
var I: INTEGER;
begin
{if DEBUGS then WRITE(OUT,NL,'RESTOREREGISTER');}
I:=TOS;     {restore from operand stack}
while I>=THRU do begin
  with OPSTK[I] do if SAVED in STATE then
    if TEMP in STATE then begin  {its a temp register}
      if STR in WHICH then RESTORETEMP(I,GREGS)
      end
    else begin  {its a stack register}
      if SSR in WHICH then begin  {restore it}
        REG:=GETREGISTER(GREGS);
        MOVEREGISTER(STK,REG);
        STATE:=STATE-[SAVED]
        end
      end;
  I:=PRED(I)
  end
end;  {RESTOREREGISTER}


procedure EMITBRANCH(BRTYPE: BRTYPES; var CHAIN: CODEINDEX);
begin
{if DEBUGS then WRITE(OUT,NL,'EMITBRANCH');}
if CP>=MAXCODE-3 then begin ERROR(3); CP:=0 end;
CODEBUF[CP]:=BRTYPE;
CODEBUF[CP+1]:=LASTBR; LASTBR:=CP;
CODEBUF[CP+2]:=CHAIN; CHAIN:=CP;
CP:=CP+3
end;  {EMITBRANCH}


procedure MERGEBRANCHCHAINS(FROM: CODEINDEX; var TO: CODEINDEX);
var NEXTBR: CODEINDEX;
begin
{if DEBUGS then WRITE(OUT,NL,'MERGEBRANCHCHAINS');}
while FROM>0 do begin  {SWAP(CODEBUF[FROM+2], TO, FROM)}
  NEXTBR:=CODEBUF[FROM+2]; CODEBUF[FROM+2]:=TO;
  TO:=FROM; FROM:=NEXTBR
  end
end;  {MERGEBRANCHCHAINS}



procedure LABEL;
begin
{if DEBUGS then WRITE(OUT,NL,'LABEL');}
ROVING:=0; SAVEREGISTER([MTE],[])
end;  {LABEL}


procedure FIXBRANCH(CHAIN: CODEINDEX);
var NEXTBR: CODEINDEX;
begin
{if DEBUGS then WRITE(OUT,NL,'FIXBRANCH');}
LABEL;
while CHAIN>0 do begin
  NEXTBR:=CODEBUF[CHAIN+2];
  CODEBUF[CHAIN+2]:=CP-CHAIN;
  CHAIN:=NEXTBR
  end
end;  {FIXBRANCH}


procedure GETENVIRONMENT(OFLEVEL: INTEGER; LEAVEITIN: RESOURCES): REGISTERS;
var N: INTEGER; SRC,DST: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'GETENVIRONMENT');}
if OFLEVEL=LEXLEV  {assert LEAVEITIN <= [GR0,GR1,GR2,GR3,GR4,GR5,STK]}
then DST:=GR5  {at current level}
else if OFLEVEL=ROVING
  then DST:=GR4  {at roving level}
  else begin  {must chain to get it}
    if OFLEVEL<ROVING
    then begin SRC:=GR4; N:=ROVING-OFLEVEL end  {chain from roving}
    else begin SRC:=GR5; N:=LEXLEV-OFLEVEL end;  {chain from current}
    if ~(GR4 in LEAVEITIN)
    then DST:=GETREGISTER(GREGS)
    else begin DST:=GR4; ROVING:=OFLEVEL end;
    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 ~(DST in LEAVEITIN) then begin
  SRC:=DST; DST:=GETREGISTER(LEAVEITIN);
  MOVEREGISTER(SRC,DST)
  end;
GETENVIRONMENT:=DST
end;  {GETENVIRONMENT}



procedure ADDRESS(LOCKR4: BOOLEAN; DISPOSE: DISPOSITION;
                  var MR: INTEGER; var HASADDR: BOOLEAN);
var BASEREGS: RESOURCES; RB: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'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 {%%%bug pass2(BSM)} RB:=GETREGISTER(PUSHDESIRE); REG:=RB end;
      if (REG=STK) ! (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 BASED in STATE  {if (STATE & [BASED,INDEXED]) # [] then RESTOREREGISTER}
      then REL.RELTYPE:=NONEA
      else if (REL.RELTYPE=NONEA)
        then begin  {non-global reference}
          BASEREGS:=GREGS !{union} [GR4,GR5];
          if LOCKR4 then BASEREGS:=BASEREGS -{set diff} [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 ~(INDEXED in STATE) then REL.RELTYPE:=SUCC(REL.RELTYPE);
      if ODD(ORD(REL.RELTYPE))
      then begin  {use relative addressing}
        if INDIRECT in STATE then MR:=63 else MR:=55;  {[@]addr(pc)}
        HASADDR:=TRUE
        end
      else if INDIRECT in STATE
        then begin MR:=56+ORD(REG); HASADDR:=TRUE end  {@addr(reg)}
        else {INDEXED} if (ADDR=0) &{and} (REL.RELTYPE=NONEA)
          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} ~(COPY in STATE) then FREEREGISTER(REG)
    end
  end  {with OPSTK[TOS]}
end;  {ADDRESS}

procedure LOAD(DESIRE:RESOURCES); forward;


procedure EMIT7(FOP: INTEGER; DSTDIS: DISPOSITION);
var DSTMR: INTEGER; DSTADDR: BOOLEAN;
begin
{if DEBUGS then WRITE(OUT,NL,'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(ADDR,REL)
end;  {EMIT7}


procedure EMIT10(FOP: INTEGER; SRCDIS: DISPOSITION);
var SRCMR,SRCWORD: INTEGER; SRCREL: RELPAIR; SRCADDR: BOOLEAN;
begin
{if DEBUGS then WRITE(OUT,NL,'EMIT10');}
RESTOREREGISTER([SSR],TOS-1);  {the destination must be a register}
ADDRESS(FALSE,SRCDIS,SRCMR,SRCADDR);
if SRCADDR then with OPSTK[TOS] do begin SRCWORD:=ADDR; SRCREL:=REL end;
TOS:=TOS-1;
EMIT0((FOP*8+ORD(OPSTK[TOS].REG))*64+SRCMR);
if SRCADDR then EMITADDR(SRCWORD,SRCREL)
end;  {EMIT10}



procedure EMIT15(FOP: INTEGER; SRCDIS,DSTDIS: DISPOSITION);
var SRCMR,DSTMR,SRCWORD: INTEGER;
  SRCREL: RELPAIR;
  SRCADDR,DSTADDR: BOOLEAN;
  OPT: (NONE,SOME,ALL);
begin
{if DEBUGS then WRITE(OUT,NL,'EMIT15');}
if (OPSTK[TOS].OPSIZE<=BYTESIZE) !{or} (OPSTK[TOS-1].OPSIZE<=BYTESIZE)
  then FOP:=FOP+8;     {if either is byte then use byte instructuon}
                       {must assure that add,sub always enter with words}
OPT:=NONE;
with OPSTK[TOS] do
if (LITER in STATE) &{and} (REL.RELTYPE=NONEA) then case FOP of
  1  {mov }: if ADDR=0 then begin FOP:=40 {clr}; OPT:=SOME end;
  9  {movb}: if ADDR=0 then begin FOP:=552 {clrb}; OPT:=SOME end;
  5,13 {bis,bisb}: if ADDR=0 then OPT:=ALL;
  0  {and }: if ADDR=0 then begin FOP:=40 {clr}; OPT:=SOME end
    else if ADDR=-1 then OPT:=ALL;
  8  {andb}: if ADDR=0 then begin FOP:=552 {clrb}; OPT:=SOME end
    else if ADDR=255 then OPT:=ALL;
  4  {bic }: if ADDR=0 then OPT:=ALL
    else if ADDR=-1 then begin FOP:=40 {clr}; OPT:=SOME end;
  12 {bicb}: if ADDR=0 then OPT:=ALL
    else if ADDR=255 then begin FOP:=552 {clrb}; OPT:=SOME end;
  6  {add }: if ADDR=0 then OPT:=ALL
    else if ADDR=1 then begin FOP:=42 {inc}; OPT:=SOME end
    else if ADDR=-1 then begin FOP:=43 {dec}; OPT:=SOME end;
  14 {sub }: if ADDR=0 then OPT:=ALL
    else if ADDR=1 then begin FOP:=43 {dec}; OPT:=SOME end
    else if ADDR=-1 then begin FOP:=42 {inc}; OPT:=SOME end;
  2  {cmp }: if ADDR=0 then begin FOP:=47 {tst}; OPT:=SOME end;
  10 {cmpb}: if ADDR=0 then begin FOP:=559 {tstb}; OPT:=SOME end;
  7,15: {not used}
  end;
if OPT=NONE
then begin
  if (FOP=2 {cmp}) !{or} (FOP=10 {cmpb})
  then SWAPTOS     {because PDP11 cmp is backwards}
  else if (FOP=0 {and}) !{or} (FOP=8 {andb})
    then begin    {PDP11 lacks and, must simulate with bic}
      if LITER in OPSTK[TOS].STATE
      then OPSTK[TOS].ADDR:=-(OPSTK[TOS].ADDR+1)
      else begin LOAD(GREGS !{union} [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
    RESTOREREGISTERS([SSR],TOS-1);
  ADDRESS(FALSE,SRCDIS,SRCMR,SRCADDR);
  if SRCADDR then with OPSTK[TOS] do begin SRCWORD:=ADDR; SRCREL:=REL end;
  TOS:=TOS-1;
ADDRESS((SRCMR mod 8)=4,DSTDIS,DSTMR,DSTADDR);
  EMIT0((FOP*64+SRCMR)*64+DSTMR);
  if SRCADDR then EMITADDR(SRCWORD,SRCREL);
  if DSTADDR then with OPSTK[TOS] do EMITADDR(ADDR,REL)
  end
else begin
  TOS:=TOS-1;
  if OPT=SOME then EMIT7(FOP,DSTDIS)
  end;
end;  {EMIT15}



procedure ADJUSTSTACK(I: INTEGER);
var EXPAND: BOOLEAN;
begin        {if I<0 then expand stack else shrink stack}
{if DEBUGS then WRITE(OUT,NL,'ADJUSTSTACK');}
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;
begin
{if DEBUGS then WRITE(OUT,NL,'GENCALL');}
EMIT0(2551 {jsr pc,0(pc)});
if U then R.RELTYPE:=INSTR else R.RELTYPE:=SYSTR;
R.SEGNR:=CHR(N);
EMITADDR(0,R)
end;  {GENCALL}



procedure LOAD {(DESIRE:REGISTERS)};
var SRCMR,LOP: INTEGER; TCHAIN,FCHAIN:CODEINDEX;
    DSTREG: REGISTERS; HASADDR: BOOLEAN;  RB: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'LOAD');}
{assert DESIRE <= [GR0,GR1,GR2,GR3,FR0,FR1,FR2,FR3,STK,GCC]}
with OPSTK[TOS] do
  if LOADED in STATE
  then begin     {loaded, but perhaps in the wrong place}
    if ~(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; FCHAIN:=0; TCHAIN:=0;
          EMITBRANCH(TRUECODE,TCHAIN);
          EMIT7(40 {clr},PUSH);
          FREEREGISTER(REG);
          EMITBRANCH(1 {br},FCHAIN);
          FIXBRANCH(TCHAIN);
          PUSHLIT(1); EMIT15(1 {mov #1,reg},POP,PUSH);
          FIXBRANCH(FCHAIN);
          OPSIZE:=WORDSIZE
          end
        else begin  {move from current register to desired register}
          DSTREG:=GETREGISTER(DESIRE);
          MOVEREGISTER(REG,DSTREG);
          FREEREGISTER(REG);
          REG:=DSTREG
          end
      end
    end
  else begin {not loaded, lets do it}
    NEWTOS; OPSTK[TOS]:=OPSTK[TOS-1];
    {OPSTK[TOS-1].}STATE:=[LOADED];
    PUSHDESIRE:=DESIRE; DSTREG:=ANY(DESIRE);
    case DSTREG of  {different loads for different folks}
    GR0,GR1,GR2,GR3,GR4,GR5: begin
      if OPSIZE<=WORDSIZE
      then EMIT15(1 {mov[b]},POP,PUSH)
      else {double load to register}
      end;
    STK: begin
      if OPSIZE<=BYTESIZE then begin
	EMIT0(2598 {clr -(sp)});
	REG:=STK;
	EMIT15(1 {mov[b]},POP,LEAVE);
	OPSIZE:=WORDSIZE
      end
      else if OPSIZE<=WORDSIZE
      then EMIT15(1 {mov[b]},POP,PUSH)
      else  {double load to stack}
      end;
    FR0,FR1,FR2,FR3:;
    GCC: begin EMIT7(47 {tst[b]},POP); TOS:=TOS-1;
      TRUECODE:=3 {ne}; REG:=GCC
      end;
    MEM:
    end;
    end
end;  {LOAD}



procedure LOADADDRESS(DESIRE: RESOURCES);
var DOBASE,DODISP: INTEGER; NXTDIS: DISPOSITION; RB,RX: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'LOADADDRESS');}
{assert DESIRE <= [GR0,GR1,GR2,GR3,STK]}
with OPSTK[TOS] do begin
  if INDIRECT in STATE
  then begin
    STATE:=STATE -{set diff} [INDIRECT]; OPSIZE:=WORDSIZE;
    LOAD(DESIRE)
    end
  else begin
    RB:=REG; RX:=RB;
    if BASED in STATE
    then begin
      if TEMP in STATE
      then begin NXTDIS:=PUSH; DOBASE:=1 end
      else if COPY in STATE then begin
        RX:=GETREGISTER(DESIRE);
        MOVEREGISTER(RB,RX);
        NXTDIS:=LEAVE; DOBASE:=0
      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=NONEA
      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]; REG:=RB; OPSIZE:=WORDSIZE end;
      EMIT15(DOBASE,POP,NXTDIS);
      NXTDIS:=LEAVE
      end;
    SWAPTOS; OPSTK[TOS].STATE:=[LITER];
    EMIT15(DODISP,POP,NXTDIS)
    end
  end
end;  {LOADADRESS}


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
{if DEBUGS then WRITE(OUT,NL,'EXTEND');}
{assert TOSIZE<=WORDSIZE}
with OPSTK[TOS] do if OPSIZE<TOSIZE then begin
  LOAD(DESIRE);
  PUSHLIT(MASK[OPSIZE]);
  OPSIZE:=TOSIZE;
  EMIT15(4 {bic},POP,LEAVE)
  end
end;  {EXTEND}



procedure DOUBLE;
{a wordsize value is assumed to be loaded in an odd register,
the sign is extended through the paired even register}
var LCP: CODEINDEX; LREG: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'DOUBLE');}
LCP:=CP;
with OPSTK[TOS] do begin
  LREG:=PRED(REG);  {LREG is the even register of the pair}
  LREG:=GETREGISTER([LREG]);  {sieze the even register}
  {GETREGISTER may not return the register we want so check}
  if LREG#PRED(REG) then ERROR(102);
  {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:=DOUBLESIZE  {size is now doubleword}
  end
end;  {DOUBLE}


procedure SINGLE(KEEPEVEN: BOOLEAN);
{a doublesize value is assumed to be loaded in an even/odd register pair,
one of the registers is discarded and the size is changed to wordsize}
begin
{if DEBUGS then WRITE(OUT,NL,'SINGLE');}
with OPSTK[TOS] do begin
  if KEEPEVEN
  then FREEREGISTER(SUCC(REG))
  else begin FREEREGISTER(REG); REG:=SUCC(REG) end;
  OPSIZE:=WORDSIZE
  end
end;  {SINGLE}


procedure GENCODE(NODE: PTN; DESIRE: RESOURCES; FORCE: WHATWHERE);
var TEMP_NODE:PTN;


procedure DUMPSTACK(P: INTEGER);
{var SS: array[0..8] of CHAR; N: INTEGER; }
begin
{WRITE(OUT,NL,'STACKDUMP, NODE = ',P,', CP =',CP,NL);
N:=TOS;
while N>=0 do with OPSTK[N] do begin
  if COPY in STATE then SS[0]:='C' else SS[0]:=' ';
  if TEMP in STATE then SS[1]:='T' else SS[1]:=' ';
  if STORED in STATE then SS[2]:='_' else SS[2]:=' ';
  if SAVED in STATE then SS[3]:='S' else SS[3]:=' ';
  if LOADED in STATE then SS[4]:='L' else SS[4]:=' ';
  if INDIRECT in STATE then SS[5]:='I' else SS[5]:=' ';
  if INDEXED in STATE then SS[6]:='X' else SS[6]:=' ';
  if BASED in STATE then SS[7]:='B' else SS[7]:=' ';
  if LITER in STATE then SS[8]:='#' else SS[8]:=' ';
  WRITE(OUT,N:3,' ':3,SS:9,ORD(OPSIZE):5,ORD(REG):3,ADDR:8,
    ORD(REL.SEGNR):5,ORD(REL.RELTYPE):4,NL); BREAK(OUT);
  N:=N-1
  end }
end;  {DUMPSTACK}


procedure SUBTREEMATCH(ST1,ST2: PTN): BOOLEAN;
var I: INTEGER; MATCHSOFAR: BOOLEAN;
begin
{if DEBUGS then WRITE(OUT,NL,'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}
      (DISP=ST2@.DISP) &{and} (NRARG=ST2@.NRARG)
      then MATCHSOFAR:=TRUE else MATCHSOFAR:=FALSE;
    I:=1;
    while MATCHSOFAR &{and} (I<=ORD(NRARG)) do begin
      MATCHSOFAR:=SUBTREEMATCH(ARG[I],ST2@.ARG[I]); I:=I+1 end;
    SUBTREEMATCH:=MATCHSOFAR
    end
end;  {SUBTREEMATCH}


procedure STORE;
var SAVETARGET: PTN; LOADIT: WHATWHERE; TARGETSIZE: BYTE; DISPOSE: DISPOSITION;
begin
{if DEBUGS then WRITE(OUT,NL,'STORE');}
SAVETARGET:=TARGET; TARGET:=NODE@.ARG[1];
SIDEEFFECTS:=FALSE;  {must check for side effects}
GENCODE(TARGET,GREGS,NOLOAD);
TARGETSIZE:=OPSTK[TOS].OPSIZE;
if FORCE=NOLOAD
then if SIDEEFFECTS then LOADIT:=NOLOAD else LOADIT:=TRYUPDATE
else LOADIT:=LOADVALUE;
GENCODE(NODE@.ARG[2],DESIRE,LOADIT);
with OPSTK[TOS] do if ~(STORED in STATE) then begin
  if TARGETSIZE<=WORDSIZE
  then begin  {simple store}
    if REG=GCC then begin LOAD(GREGS); end;  {LOAD will convert to Boolean}
    EXTEND(TARGETSIZE,GREGS![STK]);
    OPSIZE:=TARGETSIZE;
    if FORCE=NOLOAD then DISPOSE:=POP else DISPOSE:=LEAVE;
    EMIT15(1  {mov},DISPOSE,POP)
    end
  else  {multiple store}
  end;
if FORCE=NOLOAD
then TOS:=TOS-1
else OPSTK[TOS]:=OPSTK[TOS+1];
SIDEEFFECTS:=TRUE;  {tell parent node that there are side effects}
TARGET:=SAVETARGET
end;  {STORE}



procedure MOVE;
var LOP: INTEGER;
begin
with NODE@ do begin
  GENCODE(ARG[1],GREGS,LOADADDR);
  GENCODE(ARG[2],GREGS,LOADADDR);
  if SIZE <= BYTESIZE then LOP:=-27632 {movb (r?)+,(r?)+}
  else begin LOP:=5136  {mov (r?)+,(r?)+};
     {%%% Bug pass2(BSM)} NODE@.DISP:=DISP/2 end;
  PUSHLIT(DISP); LOAD(GREGS);  {mov #n,r?}
  RESTOREREGISTER([SSR],TOS-2);  {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
{if DEBUGS then WRITE(OUT,NL,'GENUARY');}
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}


procedure GENBINARY(FOP: INTEGER; NOBYTE: BOOLEAN);
var UPDATE: BOOLEAN;
begin
{if DEBUGS then WRITE(OUT,NL,'GENBINARY');}
with NODE@ do begin
  if (FORCE=TRYUPDATE) &{and} (~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 begin LOAD(GREGS) end;  {convert GCC to Boolean}
EMIT15(FOP,POP,LEAVE);
if UPDATE then OPSTK[TOS].STATE:=[STORED]
end;  {GENBINARY}


procedure COMPARE(FOP: BRTYPES);
begin
{if DEBUGS then WRITE(OUT,NL,'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 MDMCONST(NODE: PTN; FOP,N: INTEGER; DESIRE: RESOURCES; UPDATE: BOOLEAN);
var I,J: INTEGER;

{ code generated for values of FOP

		mod			div			mul
	N=0	0)  error		1)  error		2)  clr dst
	N=1	3)  clr dst		4)  nop			5)  nop
	N=2	6)  bic #-N,dst		7)  asr dst		8)  asl dst
	N=2**I	9)  bic #-N,dst		10) ash #-I,dst		11) ash #I,dst
	N#2**I	12) div #N,dst		13) div #N,dst		14) mul #N,dst  }

begin
{if DEBUGS then WRITE(OUT,NL,'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 FOP>9 then begin
  if FOP<12 then DESIRE:=GREGS else DESIRE:=ODDREGS;
  UPDATE:=FALSE
  end;
if ~UPDATE then begin
  GENCODE(NODE,DESIRE,LOADVALUE);
  EXTEND(WORDSIZE,DESIRE)
  end;
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
  DOUBLE;  {mod, div must use doubleword destination}
  PUSHLIT(N); EMIT10(57 {div},POP);
  SINGLE(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});
begin
{if DEBUGS then WRITE(OUT,NL,'MULDIVMOD');}
with NODE@ do if ARG[2]@.CODE=LITCODE
then MDMCONST(ARG[1],FOP,ARG[2]@.DISP,DESIRE,
  (FORCE=TRYUPDATE) &{and} SUBTREEMATCH(TARGET,ARG[1]))
else begin
  GENCODE(ARG[1],ODDREGS,LOADVALUE);
  EXTEND(WORDSIZE,ODDREGS);
  if FOP<2 then DOUBLE;  {mod, div need doublesize dst}
  GENCODE(ARG[2],GREGS,NOLOAD);
  if FOP<2
  then begin {mod,div}
    EMIT10(57 {div},POP);
    SINGLE(ODD(FOP))
    end
  else EMIT10(56 {mul},POP)
  end
end;  {MULDIVMOD}


procedure IODD;
begin
{if DEBUGS then WRITE(OUT,NL,'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);
  PUSHLIT(-2);
  EMIT15(4 {bic},POP,LEAVE);
  OPSIZE:=BITSIZE {only least significant bit is valid}
  end
end;  {IODD}



procedure NOTNODE;
var LSTATE: OPERSTATES; TEMP: CODEINDEX;
begin
{if DEBUGS then WRITE(OUT,NL,'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
    TEMP:=TRUECHAIN; TRUECHAIN:=FALSECHAIN; FALSECHAIN:=TEMP;
    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: CODEINDEX;
    BRTYPE: BRTYPES;
begin
{if DEBUGS then WRITE(OUT,NL,'CONDANDOR');}
GENCODE(NODE@.ARG[1],[GCC],LOADVALUE);
TOS:=TOS-1;
if ISAND
then begin {and}
  BRTYPE:=BRINV[TRUECODE];
  EMITBRANCH(BRTYPE,FALSECHAIN);
  FIXBRANCH(TRUECHAIN);
  SAVECHAIN:=FALSECHAIN
  end
else begin {or}
  EMITBRANCH(TRUECODE,TRUECHAIN);
  FIXBRANCH(FALSECHAIN);
  SAVECHAIN:=TRUECHAIN
  end;
TRUECHAIN:=0; FALSECHAIN:=0;
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 ~(GCC in DESIRE) then LOAD(DESIRE)  {will convert GCC to Boolean}
end;  {CONDANDOR}



procedure SGENS;
begin
{if DEBUGS then WRITE(OUT,NL,'SGENS');}
GENCODE(NODE@.ARG[1],GREGS,NOLOAD);
EXTEND(WORDSIZE,GREGS);
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
{if DEBUGS then WRITE(OUT,NL,'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 ADDR<16 then ADDR:=POWEROF2[ADDR] else ADDR:=0;
    LOADIT:=NOLOAD; LTRUECODE:=3 {not equal}
    end
  else ADDR:=-ADDR
else begin
  LOAD(GREGS);
  if GCC in DESIRE then LOP:=41 {com} else LOP:=44 {neg};
  EMIT7(LOP,LEAVE); LTRUECODE:=15 {carry set}
  end;
GENCODE(NODE@.ARG[2],GREGS,LOADIT);
SWAPTOS;
if LOADIT=NOLOAD  {this means we can use a bit' instruction}
then EMIT15(3 {bit},POP,POP)
else EMIT10(58 {ash},POP);
with OPSTK[TOS] do begin
  STATE:=[LOADED];
  if GCC in DESIRE
  then begin FREEREGISTER(REG); REG:=GCC; TRUECODE:=LTRUECODE end
  else OPSIZE:=BITSIZE  {only low order bit is valid}
  end
end;  {SIN}


procedure SANY;
var LOP: INTEGER; REGA: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'SANY');}
GENCODE(NODE@.ARG[1],GREGS,LOADVALUE);
with OPSTK[TOS] do begin
  REGA:=REG;
  if OPSIZE<=BYTESIZE then LOP:=-29692 {rorb} else LOP:=3072 {ror};
  OPSIZE:=WORDSIZE
  end;
PUSHDESIRE:=DESIRE;
EMIT7(40 {clr},PUSH);
EMIT0(161 {clc});
EMIT0(LOP+ORD(REGA) {ror rega});
EMIT0(-30974 {bcs .+6});
EMIT7(42 {inc},LEAVE);
EMIT0(508 {br .-10});
FREEREGISTER(REGA)
end;  {SANY}



procedure INDEXNODE;
var VARIABLE: PTN;
  FIXED,LADDR: INTEGER;
  LREL: RELPAIR;
  LSTATE: OPERSTATES;
  LDESIRE: RESOURCES;
  FORCE: WHATWHERE;
begin
{if DEBUGS then WRITE(OUT,NL,'INDEXNODE');}
LDESIRE:=DESIRE & (GREGS ! [STK]);
with NODE@ do begin
  GENCODE(ARG[1],LDESIRE,NOLOAD);
  with OPSTK[TOS] do begin
    if INDIRECT in STATE
    then begin LOADADDRESS(LDESIRE);
      LSTATE:=[BASED]; LADDR:=0; LREL:=ORDINARY end
    else begin LSTATE:=STATE; LADDR:=ADDR; LREL:=REL end;
    STATE:=STATE ! [LOADED]  {so that later add will work}
    end; {with OPSTK[TOS]}
  with ARG[2]@ do begin
    if CODE=CHR(162) {LITER}
    then begin FIXED:=DISP; VARIABLE:=NIL end
    else begin FIXED:=0; VARIABLE:=NODE@.ARG[2] end
    end; {with ARG[2]@}
  if DISP=-1 then DISP:=1;
  if DISP>0
  then begin {normal indexing}
    LADDR:=LADDR+(FIXED*DISP);
    if VARIABLE#NIL then begin
      MDMCONST(VARIABLE,2 {multiply},DISP,GREGS,FALSE);
      if LSTATE=[]
      then begin
        TOS:=TOS-1; LSTATE:=[INDEXED];
        OPSTK[TOS].REG:=OPSTK[TOS+1].REG
        end
      else begin
        if COPY in LSTATE then begin
          SWAPTOS; LSTATE:=LSTATE-[COPY,TEMP] end;
        EMIT15(6 {add},POP,LEAVE);
        LSTATE:=LSTATE ! [INDEXED]
        end
      end
    end
  else; {packed indexing}
  with OPSTK[TOS] do begin
    STATE:=LSTATE; OPSIZE:=SIZE;
    ADDR:=LADDR; REL:=LREL
    end
  end {with NODE@}
end;  {INDEXNODE}



procedure DEFINETEMP;
begin
{if DEBUGS then WRITE(OUT,NL,'DEFINETEMP');}
with NODE@ do begin
  GENCODE(ARG[1],GREGS,LOADVALUE);
  with OPSTK[TOS] do begin
    STATE:=[TEMP,LOADED]; REL.SEGNR:=CHR(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
{if DEBUGS then WRITE(OUT,NL,'REFERTOTEMP');}
FOUND:=FALSE; I:=TOS; LOOKFOR:=CHR(NODE@.DISP);
while ~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
  if ~(LOADED in OPSTK[I].STATE) then RESTORETEMP(I,GREGS);
  OPSTK[TOS]:=OPSTK[I]; OPSTK[TOS].STATE:=[COPY,LOADED];
  OPSTK[TOS].REL.RELTYPE:=NONEA
  end
else ERROR(10)
end;  {REFERTOTEMP}


procedure IFNODE;
var ENDCHAIN,LFALSECHAIN,LTRUECHAIN: CODEINDEX;
    BRTYPE: BRTYPES;
begin
{if DEBUGS then WRITE(OUT,NL,'IFNODE');}
LFALSECHAIN:=FALSECHAIN; FALSECHAIN:=0;
LTRUECHAIN:=TRUECHAIN; TRUECHAIN:=0;
SAVEREGISTER([SSR,STR],[]);
GENCODE(NODE@.ARG[1],[GCC],LOADVALUE);
TOS:=TOS-1;  {remove condition code operand}
BRTYPE:=BRINV[TRUECODE];
EMITBRANCH(BRTYPE,FALSECHAIN);
FIXBRANCH(TRUECHAIN);
GENCODE(NODE@.ARG[2],DESIRE,FORCE);
ENDCHAIN:=0;  {if the else part is null, the following branch will be removed}
EMITBRANCH(1,ENDCHAIN);
FIXBRANCH(FALSECHAIN);
GENCODE(NODE@.ARG[3],DESIRE,FORCE);
FIXBRANCH(ENDCHAIN);
FALSECHAIN:=LFALSECHAIN; TRUECHAIN:=LTRUECHAIN
end;  {IFNODE}
  
  
procedure IABS;
var UPDATE: BOOLEAN;
begin
  with NODE@ do if (FORCE=TRYUPDATE) &{and} SUBTREEMATCH(TARGET,ARG[1])
  then UPDATE:=TRUE
  else begin
    GENCODE(ARG[1],DESIRE,LOADVALUE);
    UPDATE:=FALSE
    end;
  EMIT7( 47 {tst}, LEAVE);
  EMIT0( 1025+ORD(UPDATE) {bge .+2,4});
  EMIT7( 44 {neg}, LEAVE);
  if UPDATE then OPSTK[TOS].STATE:=[STORED]
end; {IABS}



procedure CASENODE;
var I,J,SAVEROVING1,SAVEROVING2: INTEGER;
  TP,ENDCHAIN: CODEINDEX;
begin
{if DEBUGS then WRITE(OUT,NL,'CASENODE');}
{%%%bug in pass2(BSM) with NODE@ do} begin
  SAVEREGISTER([SSR,STR],[]);
  GENCODE({%}NODE@.ARG[1],GREGS,LOADVALUE);
  RESTOREREGISTER([SSR],TOS); EXTEND(WORDSIZE,GREGS);
  EMIT0(0 {case}); EMIT0(LASTBR); LASTBR:=CP-2;
  EMIT0({%}NODE@.DISP+1); EMIT0(ORD(OPSTK[TOS].REG));
  FREEREGISTER(OPSTK[TOS].REG); TOS:=TOS-1;
  TP:=CP; ENDCHAIN:=0; SAVEROVING1:=ROVING; SAVEROVING2:=ROVING;
  I:=0;  {% for I:=0 to DISP} {initialize jump table}
  while I<={%}NODE@.DISP do begin EMIT0(-1); I:=I+1 end;
  I:=2;  {% for I:=2 to ORD(NRARG)}
  while I<=ORD({%}NODE@.NRARG) do begin
    with {%}NODE@.ARG[I]@ do begin
      J:=1; {% for J:=1 to ORD(NRARG)-1)}
      while J<ORD(NRARG) do begin
        CODEBUF[ARG[J]@.DISP+TP]:=CP-TP+4;
        J:=J+1
        end;
      if ROVING#SAVEROVING1 then begin SAVEROVING2:=0; ROVING:=SAVEROVING1 end;
      SAVEREGISTER([MTE],[]);
      GENCODE(ARG[ORD(NRARG)],DESIRE,FORCE)
      end;
    EMITBRANCH(1 {br},ENDCHAIN);
    I:=I+1
    end;
  I:=0;  {% for I:=0 to DISP} {fixup null entries in table}
  while I<={%}NODE@.DISP do begin
    if CODEBUF[TP+I]=-1 then CODEBUF[TP+I]:=CP-TP+4;
    I:=I+1
    end
  end;
FIXBRANCH(ENDCHAIN); ROVING:=SAVEROVING2
end;  {CASENODE}


procedure LOOPNODE;
var LOOPHEAD,LFALSECHAIN,LTRUECHAIN: CODEINDEX;
  I,NUMARG: INTEGER;
begin
{if DEBUGS then WRITE(OUT,NL,'LOOPNODE');}
LFALSECHAIN:=FALSECHAIN; FALSECHAIN:=0;
LTRUECHAIN:=TRUECHAIN; TRUECHAIN:=0;
SAVEREGISTER([SSR,STR],[]); LABEL;
LOOPHEAD:=CP;
with NODE@ do begin
  GENCODE(ARG[1],ASSIGNABLE![STK],NOLOAD);
  I:=2; NUMARG:=ORD(NRARG)-1;  {% for I:=2 to ORD(NRARG)-1}
  while I<=NUMARG do  begin
    GENCODE(ARG[I]@.ARG[1],[GCC],LOADVALUE);
    TOS:=TOS-1;  {pop off cond code value}
    EMITBRANCH(TRUECODE,TRUECHAIN);
    FIXBRANCH(FALSECHAIN); FALSECHAIN:=0;
    I:=I+1
    end;
  GENCODE(ARG[ORD(NRARG)],ASSIGNABLE![STK],NOLOAD);
  end;
FALSECHAIN:=0;
EMITBRANCH(1 {br},FALSECHAIN);
CODEBUF[FALSECHAIN+2]:=LOOPHEAD-CP+3;  {fixup backward branch}
FIXBRANCH(TRUECHAIN);
FALSECHAIN:=LFALSECHAIN; TRUECHAIN:=LTRUECHAIN
end;  {LOOPNODE}



procedure SEQUENCE;
var NUMARG,I: INTEGER;
begin
{if DEBUGS then WRITE(OUT,NL,'SEQUENCE');}
NUMARG:=ORD(NODE@.NRARG);
I:=1;  {% for: replace with for loop}
while I<NUMARG do begin
  GENCODE(NODE@.ARG[I],ASSIGNABLE![STK],NOLOAD);
  I:=I+1
  end;
GENCODE(NODE@.ARG[NUMARG],DESIRE,FORCE)
end;  {SEQUENCE}


procedure CALL(ISFUNC: BOOLEAN; ISUSER: BOOLEAN);
var I,NUMARG: INTEGER; REG: REGISTERS;
begin
{if DEBUGS then WRITE(OUT,NL,'CALL');}
with NODE@ do begin
  SAVEREGISTER([SSR],[]);  {save stack registers}
  if ISFUNC then begin
    if ISUSER then ADJUSTSTACK(-(ORD(SIZE)+1)/8);
    NEWTOS;
    with OPSTK[TOS] do
      begin STATE:=[LOADED,SAVED]; REG:=ANY(DESIRE); OPSIZE:=SIZE end
    end;
  {%for I:=1 to ORD(NODE@.NRARG)}
  I:=1; NUMARG:=ORD(NODE@.NRARG);
  while I<=NUMARG do begin
    GENCODE(ARG[I],[STK],LOADVALUE);
    TOS:=TOS-1; I:=I+1;
    end;
  SAVEREGISTER([STR,MTE],[]);  {save temp registers}
  if ISUSER then REG:=GETENVIRONMENT(ORD(SEGNR),[GR4]);
  GENCALL(ISUSER,DISP);
  if OPSTK[TOS].REG=GCC then OPSTK[TOS].REG:=STK
  end
end;  {CALL}



begin  {GENCODE starts here}
{if DEBUGS then WRITE(OUT,NL,'GENCODE');}
{if DEBUGS then WRITE(OUT,NL,'GENCODE CASE OF ',ORD(NODE@.CODE));}
if NODE#NIL then with NODE@ do begin
  case ORD(CODE) of
  9 {REFER}: begin
    ARG[1]@.SIZE:=WORDSIZE;
    GENCODE(ARG[1],GREGS,NOLOAD);
    LOADADDRESS(DESIRE&(GREGS![STK]))
    end;
  10 {STOL}: STORE;
  16,17 {SUCC,PRED}: GENUNARY(ORD(CODE)+26 {inc,dec});
  24,25,26,27,28,29 {UCEQ,UCLT}: COMPARE(ORD(CODE)-14);
  32 {IADD}: GENBINARY(6 {add},TRUE);
  33 {ISUB}: GENBINARY(14 {sub},TRUE);
  34 {IMUL}: MULDIVMOD(2);
  35 {IDIV}: MULDIVMOD(1);
  36 {IMOD}: MULDIVMOD(0);
  40 {INEG}: GENUNARY(44 {neg});
  41 {IABS}: IABS;
  42 {IODD}: IODD;
  56,57,58,59,60,61 {ICEQ-ICLT}: COMPARE(ORD(CODE)-54);
  96 {NOT}: NOTNODE;
  110 {OR}: if GCC in DESIRE
    then CONDANDOR(FALSE)
    else GENBINARY(5 {bis},FALSE);
  111 {AND}: if GCC in DESIRE
    then CONDANDOR(TRUE)
    else GENBINARY(0 {and},FALSE);
  113 {UNION}: if SIZE<=WORDSIZE
    then GENBINARY(5 {bis},FALSE);
  114 {INTER}: if SIZE<=WORDSIZE
    then GENBINARY(0 {and},FALSE);
  115 {SDIFF}: if SIZE<=WORDSIZE
    then GENBINARY(4 {bic},FALSE);
  117 {SGENS}: SGENS;
  120,121 {SCEQ,SCNE}: if SIZE<=WORDSIZE
    then COMPARE(ORD(CODE)-118);
  126 {SIN}: SIN;
  127 {SANY}: SANY;
  132 {OFSET}: begin
    GENCODE(ARG[1],GREGS,NOLOAD);
    with OPSTK[TOS] do begin
      if INDIRECT in STATE
      then begin
        LOADADDRESS(GREGS);
        ADDR:=DISP;
        STATE:=[BASED]
        end
      else ADDR:=ADDR+DISP;
      OPSIZE:=SIZE
      end
    end;

  133 {INDIR}: begin
    GENCODE(ARG[1],GREGS,NOLOAD);
    with OPSTK[TOS] do begin
      if LOADED in STATE
      then begin  {result of refer-to-temp}
        ADDR:=DISP;
        STATE:=(STATE-[LOADED])![BASED]
        end
      else if (INDIRECT in STATE) !{or} (DISP#0)
        then begin
          LOAD(GREGS); ADDR:=DISP;
          STATE:=[BASED]
          end
        else STATE:=STATE ! [INDIRECT];
      OPSIZE:=SIZE
      end
    end;
  134 {INDEX}: INDEXNODE;
  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;
  152 {SEQ}: SEQUENCE;
  159 {RETN}: begin
    if LEXLEV=1  then RLP:=RLP+3;  {reserve three entries in RELTAB}
    CP:=CP+11;  {reserve 11 words in CODE for entry code}
    AVAIL:=ASSIGNABLE; TMPREG:=[];  {initialize free registers}
    TOS:=-1; ROVING:=LEXLEV-1;
    GENCODE(ARG[1],ASSIGNABLE![STK],NOLOAD);
    CODEBUF[CP]:=0  {something solid so optimize branches doesn't barf}
    end;
  161 {PCALL}: if SIZE=CHR(255) then CALL(FALSE,TRUE) else CALL(TRUE,TRUE);
  162 {LITER}: PUSHLIT(DISP);
  163,164 {RDATA,VARBL}: begin
    NEWTOS;
    with OPSTK[TOS] do begin
      STATE:=[]; OPSIZE:=SIZE; REG:=MEM; 
      ADDR:=DISP; REL.SEGNR:=SEGNR;
      if CODE=CHR(164) {is it a variable}
      then if ORD(SEGNR)=1 then REL.RELTYPE:=GLOBA else REL.RELTYPE:=NONEA 
      else REL.RELTYPE:=DATAA
      end
    end
  end; {of the preceeding case statement}
  
{  if DEBUGS then DUMPSTACK(ORD(CODE));}
  if FORCE=LOADVALUE then LOAD(DESIRE)
  else if FORCE=LOADADDR then LOADADDRESS(DESIRE);
{   if DEBUGS then DUMPSTACK(ORD(CODE))}
  end {of NODE#NIL}
end;  {GENCODE}



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 TO: INTEGER;
begin
TO:=NEXTBR+TARGET;
while FROM>0 do
  if BACK
  then if FROM>TO
    then begin
      TARGET:=TARGET+(CODEBUF[FROM]/256);
      FROM:=CODEBUF[FROM+1] 
      end
    else FROM:=0
  else if FROM<TO
    then begin
      TARGET:=TARGET-(CODEBUF[FROM]/256);
      FROM:=CODEBUF[FROM+1]
      end
    else FROM:=0
end;  {SUMADJUST}


begin  {OPTIMIZEBRANCHES starts here}
{optimize branches whose target is an unconditional branch and
conditional 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#3 then  {ignore full branches, will optimize later}
      if (TARGET=6) &{and} (BRTYPE#1) &{and} (CODEBUF[NEXTBR+3]=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 end  {make unconditional into a null}
      else begin  {check for unconditional target}
        TARGET:=TARGET+NEXTBR;
        if CODEBUF[TARGET]=1  {this assumes no legal instruction has code=1}
          then CODEBUF[NEXTBR+2]:=CODEBUF[TARGET+2]+TARGET-NEXTBR
        end
    end;
  NEXTBR:=CODEBUF[NEXTBR+1]
  end;  {while}


{now optimize each branch as to size and type
depending upon 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 statement}
    TARGET:=CODEBUF[NEXTBR+2];  {optimmize 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 B~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;
    TEMPBR: BRTYPES;


procedure EMIT5(I: BRTYPES; OFFSET: INTEGER);
type BRTABFORM = array[BRTYPES] of INTEGER;
const BRTAB = BRTABFORM(                         {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,
  {miscellaneous}
  {16-bvc} -31744,		{17-bvs} -31488,		{18-sob} 32256);
begin
EMIT0(BRTAB[I]+(OFFSET mod 256))
end;  {EMIT5}


begin  {GENERATEBRANCHES starts here}
NEXTBR:=0;  {go up list and reverse links}
while LASTBR#0 do begin  {SWAP(CODEBUF[LASRBR+1],NEXTBR,LASTBR)}
  TEMP:=CODEBUF[LASTBR+1]; CODEBUF[LASTBR+1]:=NEXTBR;
  NEXTBR:=LASTBR; LASTBR:=TEMP end;
  {set up first relocation 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
		begin TEMPBR:=BRINV[BRTYPE]; EMIT5(TEMPBR,2) end;
            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 {sob reg,target})
        else begin
          EMIT0(2752+REG {dec reg});
          if ADJUST=2
          then EMIT5(3,TARGET-2 {bne target})
          else begin
            EMIT0(119 {jmp target(pc)});
            EMIT0((TARGET-2)*2)
            end
          end;
        OLDCP:=OLDCP+4
        end  {branch on count section}
      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 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
OPTIMIZEBRANCHES;  {get ready for final code generation}
MAXCP:=CP; CP:=CD; MAXRLP:=RLP; RLP:=0;
if LEXLEV=1   {generate code for procedure entry}
then begin  {outermost procedure}
  EMIT0(5574 {mov #.STCK.,sp});
  EMITADDR(0,RELPAIR(CHR(0),GLOBA));
  EMIT0(4485 {mov sp,r5});
  EMIT0(5568 {mov #heap,r0});
  EMITADDR(0,RELPAIR(CHR(0),HEAPA));
  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}) end;
ADJUSTSTACK(LOCALSIZE);  {allocate local variables in stack}
OLDCP:=CD+11;  {11 words were reserved for procedure entry}
GENERATEBRANCHES;
EMIT0(4422 {mov r5,sp});  {generate code for procedure exit}
if LEXLEV=1
then GENCALL(FALSE,1 {jsr pc,$$$001})  {outermost procedure}
else begin
  EMIT0(5508 {mov (sp)+,r4});
  EMIT0(5509 {mov (sp)+,r5});
  if PARAMSIZE=0
  then {no parameters} EMIT0(135 {rts pc})
  else begin  {shrink stack to purge parameters}
    EMIT0(5507 {mov (sp)+,r3});
    ADJUSTSTACK(PARAMSIZE);
    EMIT0(75 {jmp (r3)})
    end
  end
end;  {FINALGENERATION}



procedure PRINTCODE;
const HT=CHR(9); NL=CHR(10);
type ITABFORM=array[0..122] of packed record
  CLASS: INTEGER;
  MNEMONIC: array[0..4] 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 '),(13,'stf  '),(13,'divf '),
  (14,'stexp'),(14,'stcfi'),(14,'stcfd'),(14,'ldexp'),
  (12,'ldcif'),(13,'ldcfd'));
const  {indices into the 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;



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..3] 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
WRITE(OLS,'('); GREG(I); WRITE(OLS,')')
end;  {BREG}


begin
if ODD(I/8) then WRITE(OLS,'@');
case (I/8) mod 8 of
0: if ISFLOAT then FREG(I) else GREG(I);
1: GREG(I);
2,3: if (I mod 8)=7
  then begin WRITE(OLS,'#'); WRITE(OLS,CODEBUF[LCP]); LCP:=LCP+1 end
  else begin BREG; WRITE(OLS,'+') end;
4,5: begin WRITE(OLS,'-'); BREG end;
6,7: begin
  if (I mod 8)=7
  then WRITEOCTAL((LCP-CD)*2+CODEBUF[LCP])
  else begin WRITE(OLS,CODEBUF[LCP]); BREG end;
  LCP:=LCP+1
  end
end  {of case}
end;  {SRCDST}


begin  {PRINTCODE starts here}
WRITE(OLS,';procedure ',NAME:NAMESIZE,NL);
LCP:=CD;
while LCP<CP do begin
  WRITEOCTAL((LCP-CD)*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;  {iolegal}
    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-CD+T)*2) end;
  6: GREG(INST);
  7: SRCDST(INST,FALSE);
  8: SRCDST(INST,TRUE);
  9: begin GREG(INST/64); WRITE(OLS,',');
     WRITEOCTAL((LCP-CD-(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); WRITE(OLS,','); SRCDST(INST,TRUE) end;
  15: begin SRCDST(INST/64,FALSE); WRITE(OLS,','); SRCDST(INST,FALSE) end
  end;  {end of case}
  WRITE(OLS,NL);
  while LCS<LCP do begin
    WRITE(OLS,HT); WRITEOCTAL(CODEBUF[LCS]); WRITE(OLS,NL);
    LCS:=LCS+1
    end
  end;  {end of outer while statement}
WRITE(OLS,FF)
end;  {PRINTCODE}



procedure WRITERECORD(FINISHED: BOOLEAN; S,F: INTEGER);
var SS:INTEGER;
begin
SS:=S+2;  {skip over format indicator and byte count for RSX-11}
while SS<F do begin
  OBJ@:=CODEBUF[SS];
  PUT(OBJ); SS:=SUCC(SS)
  end;
if FINISHED then BREAK(OBJ)  {Write out this record keeping correct byte counts}
end;  {WRITERECORD}

procedure WRITEBODY(FINISHED: BOOLEAN; S,F: INTEGER);
var SS:INTEGER;
begin
  SS:=S-2;  WRITERECORD(FINISHED, SS, F)
end;  {WRITEBODY}

procedure OUTHEADER;
const W=MAXCODE+1;  {start of workspace}
  GSDREC=1;
  ABSFLAGS=1356;
  BLKFLAGS=1388; BLKLENGTH=140;
  HEAPFLAGS=1388;
  HEADERLENGTH=19;
  STACKLEN=100;
begin
CODEBUF[W+0]:=1;  {indicates formatted binary record}
CODEBUF[W+1]:=HEADERLENGTH*2;  {length of record in bytes}
CODEBUF[W+2]:=GSDREC;  {type = GSD}
{module name entry}
CODEBUF[W+3]:=-31211; CODEBUF[W+4]:=8441;
CODEBUF[W+5]:=0; CODEBUF[W+6]:=0;
{.abs .  psect entry}
CODEBUF[W+7]:=-20735; CODEBUF[W+8]:=3988;
CODEBUF[W+9]:=ABSFLAGS; CODEBUF[W+10]:=0;
{pas$$$  psect entry}
CODEBUF[W+11]:=25659; CODEBUF[W+12]:=-21229;
CODEBUF[W+13]:=BLKFLAGS; CODEBUF[W+14]:=BLKLENGTH;
{.heap.  psect entry}
CODEBUF[W+15]:=-19588; CODEBUF[W+16]:=-19588;
CODEBUF[W+17]:=HEAPFLAGS; CODEBUF[W+18]:=8;
WRITERECORD(TRUE,W,W+HEADERLENGTH);
CODEBUF[W+0]:=1; {indicates formatted binary record}
CODEBUF[W+1]:=14; {length of record in bytes}
CODEBUF[W+2]:=GSDREC; {type = GSD}
{pas$$  psect entry}
CODEBUF[W+3]:=25659;
CODEBUF[W+4]:=-21256;
CODEBUF[W+5]:=BLKFLAGS;
CODEBUF[W+6]:=STACKLEN;
WRITERECORD(TRUE,W,W+7)
end;  {OUTHEADER}


procedure OUTTRAILER;
const W=MAXCODE+1; ENDGSDREC=2; ENDMODREC=6; TRAILERLENGTH=3;
begin
CODEBUF[W+1]:=TRAILERLENGTH*2;
CODEBUF[W+2]:=ENDGSDREC;  {type = ENDGSD}
WRITERECORD(TRUE,W,W+TRAILERLENGTH);
CODEBUF[W+2]:=ENDMODREC;  {type = ENDMOD}
WRITERECORD(TRUE,W,W+TRAILERLENGTH)
end;  {OUTTRAILER}



procedure OUTPROCEDURE;
const W=MAXCODE+1; GSDREC=1; TXTREC=3; RLDREC=4;
      GLBSYM=4; GLBSYMDEF=8;
  PSECTENTRY=5; FASTMEM=1; LIBRARY=2; OVERLAY=4; KLUDGE=8;
  READONLY=16; RELOCATE=32; GLOBAL=64; DATAREF=128;
  INSTENTRY=PSECTENTRY*256+RELOCATE+GLOBAL+READONLY+KLUDGE;
  DATAENTRY=PSECTENTRY*256+RELOCATE+GLOBAL+READONLY+KLUDGE;
  INSTDEF=GLBSYM*256+RELOCATE+GLBSYMDEF;
  TRAENTRY=3*256;
  INSTPREFIX=14769;  {RAD50('III')}
  DATAPREFIX=6564;  {RAD50('DDD')}
  SYSTPREFIX=-21229;  {RAD50('$$$')}
  HEAPPREFIX=-19588;  {RAD50('...')}
  GLOBPREFIX=25659;  {RAD50('PAS')}
var SUFFIX,GX: INTEGER;


procedure RADCVT(N: INTEGER): INTEGER;
begin
RADCVT:=(((N/100)*40+((N mod 100)/10))*40+(N mod 10))-16306
end;  {RADCVT}


procedure OUTTXTANDRLD(PREFIX,S,F: INTEGER);
const LCENTRY=7; MAXTXT=42; MAXRLD=W+7+42;
type RELTYPETAB=array[RELTYPES] of packed record
        PREFIX: INTEGER;
        ZERO: 0..255; NONZERO: 0..255
        end;
const RELOC=RELTYPETAB(
  (0,0,0) {NONEA}, (0,0,0) {NONER},
  (HEAPPREFIX,10,13) {HEAPA}, (HEAPPREFIX,12,14) {HEAPR},
  (GLOBPREFIX,10,13) {GLOBA}, (GLOBPREFIX,12,14) {GLOBR},
  (DATAPREFIX,10,13) {DATAA}, (DATAPREFIX,12,14) {DATAR},
  (INSTPREFIX,10,13) {INSTA}, (INSTPREFIX,12,14) {INSTR},
  (SYSTPREFIX, 2, 5) {SYSTA}, (SYSTPREFIX, 4, 6) {STSTR});
type RELSIZETAB = array [0..14] of INTEGER;
const RELENTSIZE = RELSIZETAB(0,2,3,2,3,4,4,4,2,1,3,0,3,4,4);
var RELENT,TXTADDR,LRLP,LCP,RCP,TCP,RX: INTEGER;
begin
{*** create TXT record header and RLD record header ***}
CODEBUF[W+2]:=TXTREC;
CODEBUF[W+4]:=1;
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}
CODEBUF[W+5]:=14;  {length if initial RLD record in bytes}
WRITERECORD(TRUE,W+4,W+11);

{write out a TXT record followed by a RLD record (if required)}
{until all text has been processed}
LRLP:=0; LCP:=S;
if RLP>0 then RCP:=RELTAB[0].CIX else RCP:=F;  {first relocated word}
while LCP<F do begin  {TCP:=MIN(LCP+MAXTXT,F)}
  TCP:=LCP+MAXTXT; if TCP>F then TCP:=F;
  RX:=W+7; TXTADDR:=(LCP-S)*2;
  while (RCP<TCP) &{and} (RX<MAXRLD-4) do begin  {build RLD entries}
    with RELTAB[LRLP] do begin
      {with RELOC[RS.RELTYPE] do} begin
        if CODEBUF[CIX]=0 then RELENT:=RELOC[RS.RELTYPE].ZERO
           else RELENT:=RELOC[RS.RELTYPE].NONZERO;
        CODEBUF[RX]:=((RCP-S)*2-TXTADDR+4)*256+RELENT;
        CODEBUF[RX+1]:=RELOC[RS.RELTYPE].PREFIX;
        if RS.RELTYPE>GLOBR
        then CODEBUF[RX+2]:=RADCVT(ORD(RS.SEGNR))
	else if RS.RELTYPE>HEAPR then
	CODEBUF[RX+2]:=SYSTPREFIX
        else CODEBUF[RX+2]:=RELOC[RS.RELTYPE].PREFIX
        end;
      CODEBUF[RX+3]:=CODEBUF[RCP];  {not always needed}
      RX:=RX+RELENTSIZE[RELENT];
      end;
    LRLP:=LRLP+1;
    if LRLP<RLP then RCP:=RELTAB[LRLP].CIX else RCP:=CP;
    end;
  {TCP:=MIN(TCP,RCP)}  {may have run out of space in RLD record}
  if RCP<TCP then TCP:=RCP;
  {write out text header}
  CODEBUF[W+1]:=(TCP-LCP)*2+8;  {length of TXT record in bytes}
  CODEBUF[W+3]:=TXTADDR;        {load address of text}
  WRITERECORD(FALSE,W,W+4);
  {write out body of text record}
  WRITEBODY(TRUE,LCP,TCP);
  {if any relocation entries, write out RLD record}
  if RX>W+7 then begin
    CODEBUF[W+5]:=(RX-(W+4))*2;  {size of RLD record in bytes}
    WRITERECORD(TRUE,W+4,RX)
    end;
  {bump up text index and continue}
  LCP:=TCP
  end
end;  {OUTTXTANDRLD}



begin
SUFFIX:=RADCVT(PROCNR);
{create GSD record for this procedure}
CODEBUF[W+2]:=GSDREC;
{create entry for psect containing instructions}
CODEBUF[W+3]:=INSTPREFIX; CODEBUF[W+4]:=SUFFIX;  {psect name}
CODEBUF[W+5]:=INSTENTRY;  {entry type and flags}
CODEBUF[W+6]:=(CP-CD)*2;  {size in bytes}
CODEBUF[W+7]:=INSTPREFIX;  CODEBUF[W+8]:=SUFFIX; {entry name}
CODEBUF[W+9]:=INSTDEF;     CODEBUF[W+10]:=0;
{if any data, then create entry for psect containing it}
if CD>CS
then begin
  CODEBUF[W+11]:=DATAPREFIX; CODEBUF[W+12]:=SUFFIX;
  CODEBUF[W+13]:=DATAENTRY; CODEBUF[W+14]:=(CD-CS)*2;
  GX:=W+15
  end
else GX:=W+11;
{if this is outermost procedure, then generate transfer address entry}
if PROCNR=0 then begin
  CODEBUF[GX]:=INSTPREFIX; CODEBUF[GX+1]:=SUFFIX;
  CODEBUF[GX+2]:=TRAENTRY; CODEBUF[GX+3]:=0;  {start at location zero}
  GX:=GX+4 
  end;
CODEBUF[W+1]:=(GX-W)*2;  {length of GSD record in bytes}
WRITERECORD(TRUE,W,GX);
{now output the text and relocation records, first for data (if any)}
if CD>CS then OUTTXTANDRLD(DATAPREFIX,CS,CD);
OUTTXTANDRLD(INSTPREFIX,CD,CP)
end;  {OUTPROCEDURE}



begin  {PASCAL pass2 starts here}
RESET(INT,'PASCAL.TMP ');
IX:=1; while IX<7 do begin
  FILENAMES[IX]:=INT@; GET(INT);
  if FILENAMES[IX]#CHR(32) then KX:=IX;
  IX:=SUCC(IX) end;
JX:=0;
IX:=1; while IX<6 do begin
  FILENAMES[IX+KX]:=CHR(CODEEXT[JX]); IX:=SUCC(IX); JX:=SUCC(JX) end;
  REWRITE(LST,FILENAMES);
IX:=1; while IX<6 do begin
  FILENAMES[IX+KX]:=CHR(CODEEXT[JX]); IX:=SUCC(IX); JX:=SUCC(JX) end;
{  REWRITE(DBG,FILENAMES);}
IX:=1; while IX<6 do begin
  FILENAMES[IX+KX]:=CHR(CODEEXT[JX]); IX:=SUCC(IX); JX:=SUCC(JX) end;
  REWRITE(OLS,FILENAMES);
IX:=1; while IX<6 do begin
  FILENAMES[IX+KX]:=CHR(CODEEXT[JX]); IX:=SUCC(IX); JX:=SUCC(JX) end;
  REWRITE(OBJ,FILENAMES);
{set debug switch status according to user needs}
{WRITE(OUT,NL,'Do you want debug output?(Y/N)');BREAK(OUT);}
{READ(INP,CH);}
{if (CH='Y') ! (CH='y') then DEBUG:=TRUE else DEBUG:=FALSE;}
{initialize object module output}
OUTHEADER;
{initialize code buffer indices}
CP:=0; DP[0]:=0; LEXLEV:=0; PROCNR:=-1;
while ~EOF(INT) do begin
  MARK;
  BUILDTREE;
  CS:=CS/2; CD:=(CP+1)/2; CP:=CD;  {round up from bytes to words}
  RLP:=0; LASTBR:=0;
{  if DEBUG then begin
    WRITE(OUT,NL,NAME:NAMESIZE,' ':18-NAMESIZE,'Turn on DEBUGS?');
    BREAK(OUT);
    READ(INP,CH);
    if (CH='Y') ! (CH='y') then DEBUGS:=TRUE else DEBUGS:=FALSE
  end; }
  GENCODE(TREE,[],NOLOAD);         {generate code in code buffer}
  FINALGENERATION;                 {finish code generation of branches}
  {output code and data}
  WRITE(LST,PROCNR:3,' ':2,NAME:NAMESIZE,' ':18-NAMESIZE,CD-CS:6,CP-CD:6,NL);
  WRITE(OUT,NL,PROCNR:3,' ':2,NAME:NAMESIZE,' ':18-NAMESIZE,CD-CS:6,CP-CD:6);
  BREAK(OUT);
  PRINTCODE;
  OUTPROCEDURE;
  LEXLEV:=LEXLEV-1;
  CP:=DP[LEXLEV]; CS:=DP[LEXLEV-1];
  RELEASE
  end;
OUTTRAILER;
WRITE(OUT,NL,'PASS2 has finished...',NL); BREAK(OUT)
end.