!* modified 12/03/86                                               gcode8
!*
!*
!* This module contains support procedures for generating Gould object code
!*
!*
%include "ftn_ht"
%include "ebits_ecodes2"
%include "gbits_gcodes1"
!*
!***********************************
!* Put Interface Massing of Data   *
!***********************************
%externalroutinespec   Mcbytes(%integer Disp,Len,Ad)
%externalroutinespec   MDBYTES   (%integer area, Disp, len, ad)
%externalroutinespec   MD        (%integer area, Disp, Databyte)
%externalroutinespec   MD2       (%integer area, Disp, DataDoublebyte)
%externalroutinespec   MD4       (%integer area, Disp, DataQuadbyte)
%externalroutinespec   MDPATTERN (%integer area, Disp, ncopies, len, ad)
!**********************************************
!* Put Interface RELOCATION and REFERENCES    *
!**********************************************
%externalintegerfnspec MXname (%integer type,%string(255)%name  s)
%externalroutinespec   Mfix   (%integer area,disp, tgtarea,tgtdisp)
%externalroutinespec   MDxref (%integer area,disp,id)
!**********************************
!* Put Interface - Miscellaneous  *
!**********************************
%externalroutinespec   Mreversebytes (%integer  area,disp,len)
%externalintegerfnspec Mcommon       (%string(255)%name Name)
%externalroutinespec   MendCommon    (%integer id,length)
%externalintegerfnspec MnextSymbol
%externalroutinespec   Mproc (%string(255)%name name, %integer props,codead,
                              %integername id)
%externalintegerfnspec Mentry(%integer Index,Codedisp,%string(255) %name name)
%externalroutinespec   Mprocend
!%externalroutinespec   Mdataentry(%string(255)%name name, %integer area, maxlen, disp)
%externalroutinespec   Minitialise   (%integer version,release,language)
%externalroutinespec   Mterminate    (%integer adareasizes)
%externalroutinespec   Mlinestart   (%integer lineno,codead)
%externalroutinespec   Mfaulty
%externalroutinespec   Mvar(%integer strwad,type, area, disp, bytesize,nels)
%externalroutinespec   Mmonon
%externalroutinespec   Mmonoff
!*
%recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg,
                                  Base,Modbase,Scale,Modform,
                      (%integer Offset %or %integer Intval),
                      (%integer Modoffset %or %integer Modintval),
                      %integer Size,Adid)
!*
%externalintegerfnspec Get Space(%integer Bytes) {via Mput to Malloc}
%externalstringfnspec EGiveName(%integer Key)
%externalintegerfnspec Egiveareaid(%integer Area)
%externalroutinespec Enote CC(%integer Cond)
%externalroutinespec EPushOperand(%record(Stkfmt)%name Stk)
%externalroutinespec Stackr(%integer Reg)
%externalroutinespec Stackfr(%integer Reg,Bytes)
!*
!*
%constinteger YES = 1
%constinteger NO  = 0
!*
%if HOST=PERQPNX %thenstart
   %constinteger FRAGMIN = 16
%finishelsestart
   %constinteger FRAGMIN = 28
%finish
!*
!***********************************************************************
!*
%constinteger LitVal         =  0        {  lit        }
%constinteger ConstVal       =  1        {  const      }
%constinteger RegVal         =  2        {  (reg)      }
%constinteger FregVal        =  3        {  (freg)     }
%constinteger TempVal        =  4        {  (temp)     }
%constinteger DirVal         =  5        {  (dir)      }
%constinteger IndRegVal      =  6        { ((reg))     }
%constinteger IndTempVal     =  7        { ((temp))    }
%constinteger IndDirVal      =  8        { ((dir))     }
%constinteger AddrConst      =  9        {  @const     }
%constinteger AddrDir        = 10        {  @dir       }
%constinteger RegAddr        = 11        {  (reg) is @ }
%constinteger TempAddr       = 12        {  (temp) is @}
%constinteger DirAddr        = 13        {  (dir) is @ }
%constinteger AddrDirMod     = 14        {  @dir+M     }
%constinteger RegModAddr     = 15        {  (reg)+M    }
%constinteger TempModAddr    = 16        {  (temp)+M   }
%constinteger DirModAddr     = 17        {  (dir)+M    }
%constinteger IndRegModVal   = 18        { ((reg)+M)   }
%constinteger IndTempModVal  = 19        { ((temp)+M)  }
%constinteger IndDirModVal   = 20        { ((dir)+M)   }
%constinteger AddrDirModVal  = 21        { (@dir+M)    }
%constinteger RegBitAddr     = 22        {  (reg) is @ }
%constinteger RegBitModAddr  = 23        {  (reg)+M    }
%constinteger TopOfStack     = 31        {  TOS        }
!*
%constinteger Regflag       = 32  {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:31) =  %c
  "LitVal        ","ConstVal      ","RegVal        ","FregVal       ",
  "TempVal       ","DirVal        ","IndRegVal     ","IndTempVal    ",
  "IndDirVal     ","ConstAddr     ","AddrDir       ","RegAddr       ",
  "TempAddr      ","DirAddr       ","AddrDirMod    ","RegModAddr    ",
  "TempModAddr   ","DirModAddr    ","IndRegModVal  ","IndTempModVal ",
  "IndDirModVal  ","AddrDirModVal ","RegBitAddr    ","RegBitModAddr ",
  ""              ,""              ,""              ,""              ,
  ""              ,""              ,""              ,"TopOfStack    "
!*
%constinteger r0=0
%constinteger r1=1
%constinteger r2=2
%constinteger r3=3
%constinteger r4=4
%constinteger r5=5
%constinteger r6=6
%constinteger r7=7
%constinteger br0=8
%constinteger br1=9
%constinteger br2=10
%constinteger br3=11
%constinteger br4=12
%constinteger br5=13
%constinteger br6=14
%constinteger br7=15
!*
%constinteger Addr at = 1
%constinteger Addr of = 2
%constinteger Data at = 1
!*
!*
%conststring(3)%array Rtext(0:15) = %c
   "r0","r1","r2","r3","r4","r5","r6","r7",
   "br0","br1","br2","br3","br4","br5","br6","br7"
!*
%constbyteintegerarray HEX(0:15) = %c
   '0','1','2','3','4','5','6','7',
   '8','9','a','b','c','d','e','f'
!*
!*
%constinteger Stack  = 0
%constinteger Code   = 1
%constinteger Gla    = 2
%constinteger Plt    = 3
%constinteger Sst    = 4
%constinteger Ust    = 5
%constinteger Diags  = 6
%constinteger Params = 7
%constinteger Iotab  = 8
%constinteger Zust   = 9
%constinteger Cnst   =10
!*
%constbyteintegerarray Invcc(0:5)  = 1,0,2,3,5,4       {LT GT EQ NE LE GE}
!*
%constbyteintegerarray Litop(0:15) = %c
   0,LI,0,LI,0,0,0,ADI,0,SUI,MPI,DVM,0,0,0,CI
!*
!*
%if HOST=ICL2900 %or HOST=PERQPNX %thenstart
%recordformat fragfmt(%halfinteger labindex,size,%integer ca,base,fix,labs,
                      (%integer labrefkey %or %halfinteger labrefindex,jsize),
                      %integer chain,
                      %halfintegerarray h(0:511))
%finishelsestart
%recordformat fragfmt(%shortinteger labindex,size,%integer ca,base,fix,labs,
                      (%integer labrefkey %or %shortinteger labrefindex,jsize),
                      %integer chain,
                      %shortintegerarray h(0:511))
%finish
%recordformat lrecfmt(%integer key,addr,chain)
!*
%recordformat fixrecfmt(%integer base,offset)
!*
%recordformat areckeyfmt(%integer key,offset)
!*
%recordformat constfmt(%integer Val,Offset)
!*
%ownrecord(constfmt)%array constinfo(0:255)        { a temporary mechanism }
!*
%ownrecord(fragfmt)%name frag
!*
%ownintegerarray fixrecheads(0:255)
%ownintegerarray linerecheads(0:255)
%ownintegerarray labrecheads(0:255)
%ownintegerarray swrecheads(0:31)
%ownintegerarray exrecheads(0:31)
%ownintegerarray retframekeys(0:31)
%ownrecord(areckeyfmt)%array areakey(0:31)
!*
%recordformat Swrecfmt(%integer key,tab)
!*
%recordformat Swtabfmt(%integer Mode,Ref frag,Refad,Base,Entries,
                     %integerarray R(0:4095))
!*
%recordformat Exdatafmt(%string(31) Name,%integer Id,Ca)
!*
%owninteger nextlab
%owninteger basefrag
%owninteger curbasefrag
%owninteger nextfrag
%owninteger curfrag
%owninteger fragfixindex
%owninteger fraglineindex
%owninteger fixedfrag
%owninteger fragoffset
%owninteger fragoffsetlim
%owninteger maxcodeca
%owninteger fixedca
%owninteger NoteArea
%owninteger NoteOffset
%owninteger PLToffset
%owninteger callparsize
%owninteger framesize
%owninteger localstacksize
%owninteger CC
!*
%owninteger Numexnames
%owninteger Numexrefs
%owninteger Numswkeys
%owninteger Numretframes
%owninteger Numareakeys
%owninteger Numconstrecs
!*
%owninteger primeclist,clist
%owninteger Startinstr
!*
%owninteger proc count
!*
%owninteger Proclevel
%owninteger Procbaseca
%owninteger frozenca
%owninteger OldProcbaseca
%owninteger NextParamOffset
%ownintegerarray Noteprocca(0:15)
!*
%ownintegerarray reguse(0:7)
%ownintegerarray regdata(0:7)
%ownintegerarray regpair(0:7)
%ownintegerarray breguse(8:15)
%owninteger Lastbreg
!*
%ownstring(31) S1,S2,S3     { for instruction text }
!*
!*
%routinespec Ophex(%integer Val)
%routinespec Mcode label(%integer Label)
%routinespec New Frag
%routinespec break frag(%integer label)
%integerfnspec Tidy Frags(%integer Mode)
%stringfnspec Itos(%integer N)
%routinespec TextS1(%integer Op)
!*
%integerfnspec Get Reg(%integer use,area,offset)
%integerfnspec claim reg
%integerfnspec checkregkey(%integer use,area,offset)
%routinespec Lock Reg(%integer Reg)
%routinespec Unlock Reg(%integer Reg)
%routinespec codew(%integer h0,h1)
%routinespec Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%routinespec Gop RR(%integer Op,Dreg,Sreg)
%routinespec Gop RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%routinespec Gop RI(%integer Op,Reg,Lit)
%routinespec Gop(%integer Op)
%routinespec Gop Shift Lit(%integer Op,Reg,Lit)
!*
%routinespec Dump(%integer Ad,Len)
!*
!*
%routine Abortm(%string(31) S)
   printstring("
*** Mcode abort - ".S)
   printstring(" ***
")
   %monitor
   %stop
%end;! Abortm
!*
%integerfn Malloc Space(%integer bytes)
%integer J
      J=Get Space(bytes)
      %if Host=PERQPNX %then J=J//2
      %result=J
%end
!*
%integerfn fixrecad(%integer index)
%integer Scale,I,J
      %if Host=PERQPNX %thenstart
         Scale = 2
      %finishelsestart
         Scale = 3
      %finish
      I=index>>9;! units of 512 entries (4K bytes)
      J=fixrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         fixrecheads(I)=J
      %finish
      %result=J+(index&x'1ff')<<Scale
%end;! fixrecad
!*
%integerfn linerecad(%integer index)
%integer Scale,I,J
      %if Host=PERQPNX %thenstart
         Scale = 1
      %finishelsestart
         Scale = 2
      %finish
      I=index>>10;! units of 1024 entries (4K bytes)
      J=linerecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         linerecheads(I)=J
      %finish
      %result=J+(index&x'3ff')<<Scale
%end;! linerecad
!*
%integerfn labrecad(%integer index)
%integer Scale,I,J
      %if Host=PERQPNX %thenstart
         Scale = 6
      %finishelsestart
         Scale = 12
      %finish
      I=index>>10;! units of 1024 entries (12K bytes)
      J=labrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(x'3000')
         labrecheads(I)=J
      %finish
      %result=J+(index&x'3ff')*Scale
%end;! labrecad
!*
%integerfn swrecad(%integer index)
%integer Scale,I,J
      %if Host=PERQPNX %thenstart
         Scale = 2
      %finishelsestart
         Scale = 3
      %finish
      I=index>>9;! units of 512 entries (4K bytes)
      J=swrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         swrecheads(I)=J
      %finish
      %result=J+(index&x'1ff')<<Scale
%end;! swrecad
!*
%integerfn exrecad(%integer index)
%integer Scale,I,J
      %if Host=PERQPNX %thenstart
         Scale = 20
      %finishelsestart
         Scale = 40
      %finish
      I=index>>6;! units of 64 entries (2560 bytes)
      J=exrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(2560)
         exrecheads(I)=J
      %finish
      %result=J+(index&x'3f')*Scale
%end;! exrecad
!*
!*
!***************************************************************************
!*            initialisation                                               *
!***************************************************************************
!*
!*
%externalroutine Clear Regs
%integer I
   %cycle I=r0,1,r7
      reguse(I)=0
      regdata(I)=0
   %repeat
   %cycle I=br6,1,br7
      breguse(I)=0
   %repeat
   Lastbreg=0
%end;! Clear Regs
!*
%externalroutine Dump Regs
%integer I,J,K
      %cycle I=r0,1,r7
         J=reguse(I)
         %if J#0 %thenstart
            printsymbol('r')
            printsymbol('0'+I&7)
            %if J<0 %thenstart
               write(J,3)
            %finishelsestart
              %if J<3 %thenstart
               %if J=1 %then printstring("   data at  ")  %c
                       %else printstring("   addr of  ")
               K=regdata(I)
               printstring(Egivename(K&X'1FF'))
               %if K<0 %thenstart
                  K=(K>>9)!X'FF800000'
               %finishelsestart
                  K=K>>9
                 printstring("+")
               %finish
               write(K,0)
             %finish
            %finish
            newline
         %finish
      %repeat
      %cycle I=br6,1,br7
         J=breguse(I)
         %if J#0 %thenstart
            printstring("br")
            printsymbol('0'+I&7)
            printstring("   addr at  ")
            printstring(Egivename(J&X'1FF'))
            printstring("+")
            write(J>>9,0)
            newline
         %finish
      %repeat
%end;! Dump Regs
!*
%externalroutine mcodeon
      PrimeClist=YES
%end;! mcodeon
!*
%externalroutine init mcode(%integer codelist,lang,options)
%integer I
%record(lrecfmt)%name lrec
   %if codelist#0 %then PrimeClist=YES { %else PrimeClist=NO }
  PrimeClist=YES 
   %if lang=IMP %then Clist=NO %else Clist=PrimeClist
   %cycle I=0,1,255
      fixrecheads(I)=0
      linerecheads(I)=0
      labrecheads(I)=0
   %repeat
   lrec==record(labrecad(0))
   lrec_key=-1;! to avoid use of this entry
   lrec_chain=0
   %cycle I=1,1,31
      lrec==record(labrecad(I))
      lrec_key=0
      swrecheads(I)=0
      exrecheads(I)=0
   %repeat
   PLToffset=64
   nextlab=32
   maxcodeca=0
   fixedca=0
   basefrag=Malloc Space(4096)
   curbasefrag=basefrag
   nextfrag=curbasefrag
   fragoffsetlim=2000
   fixedfrag=nextfrag   {start of fragments not fixed up}
   curfrag=0
   fraglineindex=1
   fragfixindex=1
   Numexnames=0
   Numexrefs=0
   Numswkeys=0
   Numareakeys=0
   Numconstrecs=0
   proc count=0
   New Frag
%end;! init mcode
!*
%externalintegerfn Tidy Mcode(%integer Level,%integername PLTsize)
%integer I
      I=Tidy Frags(1)
      PLTsize=PLToffset
      %result=I
%end;! Tidy Mcode
!*
!*
!***************************************************************************
!*            label and switch processing                                  *
!***************************************************************************
!*
!*
%integerfn new label(%integer key)
%integer I,J
%record(lrecfmt)%name lrec
   I=key&31
   lrec==record(labrecad(I))
   J=lrec_key
   %if J#0 %thenstart
      %if J=key %then %result=I
      %while lrec_chain#0 %cycle
         I=lrec_chain
         lrec==record(labrecad(I))
         %if lrec_key=key %then %result=I
      %repeat
      lrec_chain=nextlab
      I=nextlab
      lrec==record(labrecad(I))
      nextlab=nextlab+1
   %finish
   lrec_key=key
   lrec_addr=maxcodeca
   lrec_chain=0
   %result=I
%end;! new label
!*
%integerfn locate label(%integer key,mode)
%record(lrecfmt)%name lrec
%integer I
   I=key&31
   lrec==record(labrecad(I))
   %while lrec_key#key %cycle
      %if lrec_chain#0 %thenstart
         I=lrec_chain
         lrec==record(labrecad(I))
      %finishelsestart
         %if mode=0 %then %result=-new label(key)
         abortm("missing label definition")
      %finish
   %repeat
   %result=I
%end;! locate label
!*
%externalroutine Mswitch(%integer Mode,Refad,Base,Entries,Switchid,Errlab)
%integer Ad,I,J
%record(swtabfmt)%name Tab
%record(Stkfmt) Stk1,Stk2
%record(swrecfmt)%name swrec
      Numswkeys=Numswkeys+1
      swrec==record(swrecad(Numswkeys))
      swrec_key=Switchid
      Ad=Malloc Space(Entries*4+20)
      Tab==record(Ad)
      swrec_tab=Ad
      Tab_Ref frag=curfrag
      Tab_Mode=Mode
      Tab_Refad=Refad
      %if Mode=1 %thenstart;! Fortran computed GOTO
         Md4(SST,Refad,X'10000'!Entries);! for bound check
         Base=Refad+4
         Entries=Entries-1
      %finish
      Tab_Base=Base
      Tab_Entries=Entries
      %if Errlab>0 %thenstart
         J=Locate Label(Errlab,0)
         %if J<0 %then J=-J
      %finishelse J=-1
      %cycle I=0,1,Entries-1
         Tab_R(I)=J
      %repeat
      Stk1_Form=addrdirmodval
      Stk1_Base=SST
      Stk1_Offset=Tab_Refad
      Stk1_Modform=Regval
!!      Stk1_Modreg=d1
      Stk1_Scale=2
      Stk1_Size=4
      Stk2_Form=Regval
!!      Stk2_Reg=d1
      Stk2_Size=4
!!      Op Move(Stk1,Stk2)    { (SST+table start)(d1<<2) => d1 }
!!      fragh(X'4EFB')
!!      fragh(X'1000')
!!      %if Clist=0 %then %return
!!      S1="0(PC,d1)"
!!      TextS1(JMP)
%end;! Mswitch
!*
%externalroutine Mswitchentry(%integer Switchid,Entry)
%record(swrecfmt)%name swrec
%integer I
%record(swtabfmt)%name Tab
      break frag(0)
      %cycle I=1,1,Numswkeys
         swrec==record(swrecad(I))
         %if swrec_key=Switchid %thenstart
            Tab==record(swrec_tab)
            Entry=Entry-(Tab_Base-Tab_Refad)//4
            Tab_R(Entry)=curfrag!X'01000000' {to diff. from label ref}
            %return
         %finish
      %repeat
      abortm("invalid switchid")
%end;! Mswitchentry
!*
%externalroutine Mswitchlabel(%integer Switchid,Entry,Labelid)
%record(swrecfmt)%name swrec
%integer I
%record(swtabfmt)%name Tab
      break frag(0)
      %cycle I=1,1,Numswkeys
         swrec==record(swrecad(I))
         %if swrec_key=Switchid %thenstart
            Tab==record(swrec_tab)
            Entry=Entry-(Tab_Base-Tab_Refad)>>2
            Tab_R(Entry)=Locate Label(Labelid,0)
            %return
         %finish
      %repeat                                                                                                                                  
      abortm("invalid switchid")
%end;! Mswitchlabel
!*
!*
!***************************************************************************
!*            code fragment processing                                     *
!***************************************************************************
!*
!*
%externalroutine Mcode label(%integer label)
%integer save,saved
   label=label+proc count
   %if Clist#0 %thenstart
      printstring("L")
      printstring(Itos(Label))
      printstring(":
")
   %finish
   %if Frag_labindex#0 %or fragoffset#0 %then break frag(0)
   frag_labindex=new label(label)
   save=reguse(7)
   saved=regdata(7)
   clear regs
   %if save=addr at %or save=addr at-255 %thenstart
      reguse(7)=save
      regdata(7)=saved
   %finish
%end;! Mcode label
!*
%externalroutine Mline(%integer Lineno)
   %if Lineno#0 %thenstart
      Clist=PrimeClist
      %if Clist#0 %thenstart
         printstring("line ")
         printstring(Itos(Lineno))
         newline
      %finish
   %finish
   integer(linerecad(fraglineindex))=(Lineno<<12)!fragoffset
   fraglineindex=fraglineindex+1
%end;! Mline
!*
%routine new frag
%integer balance
   %if Host=PERQPNX %thenstart
      balance=curbasefrag+2048-nextfrag
   %finishelsestart
      balance=curbasefrag+4096-nextfrag
   %finish
   %if balance<128 %thenstart
      curbasefrag=Malloc Space(4096)
      nextfrag=curbasefrag
   %finish
   %if curfrag#0 %thenstart
      frag_chain=nextfrag
   %finish
   frag==record(nextfrag)
   curfrag=nextfrag
   frag_labindex=0
   frag_ca=maxcodeca
   frag_base=0
   frag_size=0
   frag_fix=0;! index into fixups vector
   frag_labs=fraglineindex;! index into lineno vector
   frag_labrefkey=0
   frag_chain=0
   fragoffset=0
   Startinstr=0
   fragoffsetlim=balance>>1
%end;! new frag
!*
%routine break frag(%integer label)
%integer addon
%record(fixrecfmt)%name fix
{printstring("}
{break frag")}
{write(label,4);newline}
   %if label#0 %thenstart
      frag_labrefkey=label
   %finish
   maxcodeca=maxcodeca+(fragoffset)<<1
   frag_size=fragoffset
   %if frag_fix#0 %thenstart;! set terminator
      fix==record(fixrecad(fragfixindex))
      fix_base=0
      fragfixindex=fragfixindex+1
   %finish
   Mline(0);! to set terminator
   %if Host=PERQPNX %thenstart
      addon=fragoffset
   %finishelsestart
      addon=fragoffset<<1
   %finish
   nextfrag=curfrag+FRAGMIN+addon
   new frag
{dump(basefrag,256)}
%end;! break frag
!*
%integerfn tidy frags(%integer mode)
!* mode = 0  fix frags so far
!*        1  complete generation of code
!*
%integer lref,ca,refca,reflabca,reach,fragaddr,fragstart,I,J,K,fixstart
%integer tgtarea,offset,key
%owninteger procbaseca
%owninteger Nops=X'4e714e71'
%record(fixrecfmt)%name fix
%record(Swtabfmt)%name Tab
%record(lrecfmt)%name Lrec
%record(exdatafmt)%name Exdata
%record(swrecfmt)%name swrec
!*
   %if fragoffset#0 %then break frag(0)
!*
!* first pass - fixing sizes of all jumps
!*
   fragstart=basefrag
   fragaddr=fixedfrag  {first one not yet fixed}
{printstring("}
{fragarea}
{")}
{dump(fragstart,256)}
{printstring("}
{fragfixups}
{")}
{dump(fixstart,fragfixindex<<2+8)}
{%cycle I=0,1,40}
{   dump(labrecad(I),12)}
{%repeat}
   ca=fixedca
   %while fragaddr#0 %cycle
      frag==record(fragaddr)
      %if frag_base=1 %then procbaseca=ca
      frag_ca=ca
      I=frag_fix
      %if I#0 %thenstart
         fix==record(fixrecad(I))
         %while fix_base#0 %cycle
            Tgtarea=fix_base&x'ffff'
            Offset=fix_offset
            %if Tgtarea=0 %and Offset>=0 %thenstart
               Fix_Offset=Offset+Callparsize;! local stack
            %finish
            %if Tgtarea=7 %then Fix_Offset=Offset+Framesize+32
            I=I+1
            fix==record(fixrecad(I))
         %repeat
      %finish
      %if frag_labindex#0 %thenstart;! label on front of fragment
         lrec==record(labrecad(frag_labindex))
         lrec_addr=ca-procbaseca
      %finish
      ca=ca+frag_size<<1
      %if frag_labrefkey#0 %thenstart;! ref to labl in last instruction
         lref=locate label(frag_labrefkey,mode);! returns index
         %if lref<0 %thenstart
            frag_labrefindex=-lref
         %finishelsestart
            frag_labrefindex=lref
         %finish
      %finish
      fragaddr=frag_chain
   %repeat
   fixedca=ca
   %if mode=0 %then %result=ca  { only current address was required }
!*
!* second pass - fill in all the jumps and request fixups
!*
{printstring("}
{fragarea}
{")}
{dump(fragstart,256)}
{%cycle I=0,1,160}
{   write(i,3);space}
{   dump(labrecad(I),12)}
{%repeat}
   fragaddr=basefrag
   %while fragaddr#0 %cycle
      frag==record(fragaddr)
       %if frag_base=1 %thenstart
         procbaseca=frag_ca
      %finish
{write(fragaddr,8);newline}
{dump(fragaddr,frag_size<<1+32)}
      %if frag_labrefindex#0 %thenstart
         lrec==record(labrecad(frag_labrefindex))
         reach=lrec_addr {-Procbaseca }
         frag_h(frag_size-1)<-reach
      %finish
      I=frag_fix
      %if I#0 %thenstart
         fix==record(fixrecad(I))
         %while fix_base#0 %cycle
            Tgtarea=fix_base&x'ffff'
            Offset=fix_offset
            %if Tgtarea=Code %and Offset<0 %thenstart;! relative code fixup
               frag_h(fix_base>>16+1)=frag_ca+(fix_base>>16)<<1-offset-procbaseca
            %finishelsestart
!!               %if Tgtarea=0 %then Offset=Offset+Callparsize;! local stack
!!               %if Tgtarea=7 %then Offset=Offset+Framesize+32
               K=fix_base>>16
               %if Offset#0 %thenstart
                  frag_h(K+1)=frag_h(K+1)+Offset
                  Offset=0
               %finish
               %unless Tgtarea=0 %or Tgtarea=7 %thenstart
                  Mfix(1,frag_ca+K<<1,Tgtarea,Offset)
               %finishelse frag_h(K)=frag_h(K)!2
            %finish
            I=I+1
            fix==record(fixrecad(I))
         %repeat
      %finish
      %if frag_size#0 %then Mcbytes(frag_ca,frag_size<<1,fragaddr+FRAGMIN)
      fragaddr=frag_chain
   %repeat
!*
   %if Numswkeys>0 %thenstart
      %cycle I=1,1,Numswkeys
         swrec==record(swrecad(I))
         Tab==record(swrec_tab)
         frag==record(Tab_Reffrag)
         %cycle J=0,1,Tab_Entries-1
            K=Tab_R(J)
            %if K>>24=1 %thenstart;! IMP switch
               frag==record(K&X'ffffff')
               Tab_R(J)=frag_ca-Procbaseca
            %finishelsestart
               Lrec==record(labrecad(K&X'ffffff'))
               Tab_R(J)=Lrec_addr-Procbaseca
            %finish
         %repeat
         mdbytes(SST,Tab_Base,Tab_Entries<<2,addr(Tab_R(0)))
      %repeat
   %finish
!*
   %cycle I=1,1,Numexnames
      Exdata==record(exrecad(I))
      %if Exdata_Id=0 %thenstart
         Exdata_Id=Mxname(0,Exdata_Name)
         Mfix(Plt,Exdata_ca,Exdata_Id,0)
      %finish
   %repeat
!*
{printstring("}
{fragarea}
{")}
{dump(fragstart,256)}
   %result=ca
%end;! tidy frags
!*
%externalintegerfn mgetca
{ force fixing of the size of all jumps to this point so that ca can be noted}
%integer ca
      ca=tidy frags(0)
      frozenca=ca
      fixedfrag=curfrag
      %result=ca
%end;! mgetca
!*
%externalintegerfn Mmarker
      %result=addr(frag_h(fragoffset))
%end;! Mmarker
!*
%externalroutine Msetopd(%integer Markerid,New Value)
      %if HOST=PERQPNX %thenstart
         halfinteger(Markerid+1)<-New Value&X'FFFF'
      %finishelsestart
         shortinteger(Markerid+2)=New Value
      %finish
%end;! Msetopd
!*
%externalroutine Mprecall
      NextParamOffset=32
%end
!*
%externalroutine Mstartproc
      proc count = proc count + 1000000
      Numretframes=0
      Procbaseca=frozenca
      Proclevel=Proclevel+1
      Noteprocca(Proclevel)=frozenca
      frag_base=1
      codew(0,0)
      %if Clist#0 %then newline
      Gop RXB(SUABR,br2,0,0,0,0)
      CallParSize=32
%end;! Mstartproc
!*
%externalroutine Mtidyproc(%integer Markerid,Localsize)
%integer I
      localstacksize=(localsize+7)&(-8)
      Callparsize=(Callparsize+7)&(-8)
      Framesize=localstacksize+callparsize
      Msetopd(Markerid,Framesize)
      Msetopd(Markerid+4,Framesize)
      %while Numretframes>0 %cycle
         Msetopd(Retframekeys(Numretframes),Framesize)
         Numretframes=Numretframes-1
      %repeat
   Proclevel=Proclevel-1
   OldProcbaseca=Procbaseca
   Procbaseca=Noteprocca(Proclevel)
%end;! Mtidyproc
!*
%externalintegerfn Get Prockey(%stringname S)
%record(exdatafmt)%name exdata
%integer I
!printstring("
!Get Prockey  ")
!printstring(S)
      %if Numexnames>0 %and S#"" %thenstart
         %cycle I=1,1,Numexnames
            Exdata==record(exrecad(I))
            %if Exdata_Name=S %thenstart
!write(I,4)
!newline
               %result=I
            %finish
         %repeat
      %finish
      Numexnames=Numexnames+1
      Exdata==record(exrecad(Numexnames))
      Exdata_Name=S
      Exdata_Ca=PLToffset
      PLToffset=PLToffset+4
      Exdata_Id=0    {MXname(0,S)}
{      Mfix(Plt,Exdata_Ca,Exdata_Id,0)}
!write(Numexnames,4)
!newline
      %result=Numexnames
%end;! Get Prockey
!*
%externalintegerfn Note Entry(%stringname S,%integer Key,Ca)
%record(exdatafmt)%name Exdata
%integer I
!printstring("
!Note Entry  ")
!printstring(S)
!write(Key,4)
!write(Ca,4)
!newline
      %if Clist#0 %thenstart
         printstring(S)
         printstring(":
")
      %finish
      %if Key<=0 %thenstart
         %if Numexnames>0 %thenstart
            %cycle I=1,1,Numexnames
               Exdata==record(exrecad(I))
               %if Exdata_Name=S %then ->Exist 
            %repeat
         %finish
         Numexnames=Numexnames+1
         I=Numexnames
         Exdata==record(exrecad(I))
         Exdata_Ca=PLToffset
         PLToffset=PLToffset+4
      %finishelsestart
         I=Key
         Exdata==record(exrecad(I))
      %finish
Exist:Exdata_Name=S
      %if ca#0 %then Md4(Plt,Exdata_Ca,ca)
      Mfix(Plt,Exdata_Ca,1,0)
      Exdata_Id=-1
      %result=I
%end;! Note Entry
!*
!*
!***************************************************************************
!*            procedures for generating fragments of code                  *
!***************************************************************************
!*
!*
%routine codeh(%integer val)
!write(fragoffset,1)
   frag_h(fragoffset)<-val
   fragoffset=fragoffset+1
   %return %if clist=NO
   spaces(8)
   ophex(val)
   spaces(8)
%end;! codeh
!*
%routine codew(%integer h0,h1)
!write(fragoffset,1)
   %if fragoffset&1#0 %thenstart
      frag_h(fragoffset)=x'0002'      {NOP}
      fragoffset=fragoffset+1
      %if clist=YES %thenstart
         spaces(8)
         printstring("0002        NOP")
         newline
      %finish
   %finish
   frag_h(fragoffset)<-h0
   frag_h(fragoffset+1)<-h1
   fragoffset=fragoffset+2
   %return %if clist=NO
   spaces(8)
   ophex(h0&X'ffff')
   ophex(h1&X'ffff')
   spaces(4)
%end;! codew
!*
%routine eafix(%integer area,offset)
%record(fixrecfmt)%name fix
   NoteArea=area
   NoteOffset=offset
   %if frag_fix=0 %then frag_fix=fragfixindex
   fix==record(fixrecad(fragfixindex))
   fix_base=fragoffset<<16!area
   fix_offset=offset
   fragfixindex=fragfixindex+1
%end;! eafix
!*
!*
!***************************************************************************
!*            procedures for generating pseudo-assembler text              *
!***************************************************************************
!*
!*
%routine dump(%integer ad,len)
%integer I,J,K,Val
      I=0
      %while Len >0 %cycle
         Val=integer(ad)
         %cycle K=28,-4,0
            J=(val>>K)&15
            printsymbol(HEX(J))
         %repeat
         space
         %if HOST=PERQPNX %thenstart
            ad=ad+2
         %finishelsestart
            ad=ad+4
         %finish
         len=len-4
         i=i+1
         %if I=4 %thenstart
            newline
            i=0
         %finish
      %repeat
      %if i#0 %then newline
%end
!*
%routine mhex(%integer val)
%integer I,J,K
   %if val=0 %thenstart
      printstring("0")
      %return
   %finish
   K=0
   %cycle I=28,-4,0
      J=(val>>I)&15
      %if J#0 %or K#0 %thenstart
         printsymbol(HEX(J))
         K=1
      %finish
   %repeat
%end;! mhex
!*
%routine ophex(%integer val)
%integer I
   %cycle I=12,-4,0
      printsymbol(HEX((val>>I)&15))
   %repeat
%end;! ophex
!*
%stringfn Htos(%integer N)
%string(8) S
%string(3) T
      %if N<0 %thenstart
         N=-N
         T="-"
      %finishelse T=""
      %if N<10 %thenstart
         S=tostring('0'+N)
      %finishelsestart
         T=T."x"
         S = ""
        %while N#0 %cycle
            S = tostring(Hex(N&15)).S
            N = N>>4
         %repeat
      %finish
      %result = T.S
%end   { of Htos }
!*
%string (255) %fn Itos(%integer N)
      %string (255) S
      %integer Sign
      S = ""
      %if N<0 %thenstart
         N = -N
         Sign = 1
      %finishelse Sign = 0
      %cycle
         S = Tostring((N-(N//10*10))+'0').S
         N = N//10
      %repeatuntil N=0
      %if Sign=1 %then S = "-".S
      %result = S
%end { of Itos }
!*
%routine TextS1S2(%integer Op,Size)
%conststring(1)%array Szlett(0:8)="","B","H","","W","","","","D"
%string(7) S
%string(2) St
      S=Mnem(Op)
      %if Size#0 %then S=S.Szlett(Size)
      printstring(S)
      spaces(6-length(S))
      %unless Op=ZM %thenstart
         printstring(S1)
         printstring(",")
      %finish
      printstring(S2)
      newline
%end;! TextS1S2
!*
%routine TextS1(%integer Op)
%string(7) S
      S=Mnem(Op)
      printstring(S)
      spaces(6-length(S))
      printstring(S1)
      newline
%end;! TextS1
!*
%routine Text(%integer Op)
%string(7) S
      S=Mnem(Op)
      printstring(S)
      newline
%end;! Text
!*
%routine TextLab(%integer Op,Label)
%string(7) S
      S=Mnem(Op)
      printstring(S)
      spaces(6-length(S))
      printstring("L")
      printstring(itos(Label))
      newline
%end;! TextS1
!*
%stringfn TextArea(%integer Area,Offset)
%string(31) S
      S=EGiveName(Area)
      %if Offset#0 %thenstart
         %if Offset>0 %then S=S."+"
         S=S.Htos(Offset)
      %finish
      %result=S
%end;! Textarea
!*
!*
!***************************************************************************
!*            code generation procedures                                   *
!***************************************************************************
!*
!*
%integerfn areakeyref(%integer area,offset)
%integer I,J
      J=(Offset&x'ff0000')!area
      %if Numareakeys>0 %thenstart
         %cycle I=1,1,Numareakeys
            %if areakey(I)_key=J %then %result=areakey(I)_offset
         %repeat
      %finish
      Numareakeys=Numareakeys+1
      I=PLToffset
      PLToffset=I+4
      Md4(Plt,I,Offset&x'ff0000')
      Mfix(Plt,I,Egiveareaid(Area),0)
      areakey(Numareakeys)_key=J
      areakey(Numareakeys)_offset=I
      %result=I
%end;! areakeyref
!*
%routine Locate(%integer Area,%integername Offset,Index,Base)
%integer RegOffset,Reg
%switch A(0:10)
      %if Area>10 %thenstart
         RegOffset=areakeyref(Area,Offset)
         Reg=checkregkey(addr at,Plt,RegOffset)
         %if Reg<=0 %thenstart
            %if Area=11 %then Reg=7 %else Reg=claim reg
            %if Reg=0 %thenstart;! claim another
               Reg=claim reg
               reguse(0)=0
            %finish
            Locate(Plt,RegOffset,Index,Base)
            Gop RXB(L,Reg,Base,Index,RegOffset,4)
            reguse(Reg)=addr at
            regdata(Reg)=(RegOffset<<9)!Plt
         %finish
         Base=0
         Index=Reg
!         %if Index#0 %then unlock reg(Index)
         Regoffset=Offset&x'ffff'
         %return
      %finishelse ->A(Area)
!*
A(Stack):
A(Gla):
A(Plt):
A(Params):
A(Iotab):
      %if fragoffset&1#0 %then Gop(NOP)
      Eafix(Area,0)
      Index=0
      Base=0
      %return
!*
A(Code):
A(Sst):
A(Diags):
      %monitor;%stop
!*
A(*): 
      %monitor;%stop
%end;! Locate
!*
%externalroutine Note Reguse(%integer Reg,Use,Size)
      reguse(Reg)=Use
      %if Size=8 %thenstart
         reguse(Reg+1)=Use
         %if Use#0 %then Use=-1
         regpair(Reg)=Use
         regpair(Reg+1)=Use
      %finish
%end;! Note Reguse
!*
%externalroutine Reset Reguse(%integer Old,New)
%integer I
      %cycle I=r0,1,r7
         %if reguse(I)=-Old %thenstart
            reguse(I)=-New
            %return
         %finish
      %repeat
%end;! Reset Reguse
!*
%externalroutine lock reg(%integer Reg)
      reguse(Reg)=-255
%end;! lock reg
!*
%externalroutine unlock reg(%integer Reg)
      %if reguse(Reg)<=-250 %thenstart
         reguse(Reg)=reguse(Reg)+255
      %finishelse reguse(Reg)=0
%end;! unlock reg
!*
%externalroutine lock reg pair(%integer Reg)
      reguse(Reg)=-255
      reguse(Reg+1)=-255
      regpair(Reg)=-1
      regpair(Reg+1)=-1      
%end;! lock reg pair
!*
%externalroutine unlock reg pair(%integer Reg)
      %if reguse(Reg)<=-250 %thenstart
         reguse(Reg)=reguse(Reg)+255
         reguse(Reg+1)=reguse(Reg)+255
         regpair(Reg)=1
         regpair(Reg+1)=1      
      %finishelsestart
         reguse(Reg)=0
         reguse(Reg+1)=0
         regpair(Reg)=0
         regpair(Reg+1)=0     
      %finish
%end;! unlock reg pair
!*
%routine release reg(%integer Reg)
%end;! release reg
!*
%routine release reg pair(%integer Reg)
%end;! release reg pair
!*
%externalroutine Freeregs
!***********************************************************************
!* dump any regs which will not survive a procedure call               *
!***********************************************************************
%end;! Freeregs
!*
%externalintegerfn claim reg
%integer reg
      %cycle reg=r0,1,r7
         %if reguse(reg)=0 %thenstart
note:       reguse(reg)=-255
            regdata(reg)=0
            %result=reg
         %finish
      %repeat
!*
      %cycle reg=r0,1,r7
         %if reguse(reg)>0 %then ->note
      %repeat
!*
      %cycle reg=r0,1,r7
         %if reguse(reg)>-250 %then release reg(Reg) %and ->note
      %repeat
!*
      abortm("all regs locked")
   %result=0
%end;! claim reg
!*
%externalintegerfn claim freg
      %result=claim reg
%end;! claim freg
!*
%externalintegerfn claim reg pair(%integer Mode)
!***********************************************************************
!* Mode = 0  provide a register pair only if completely free           *
!***********************************************************************
%integer I
      %cycle I=0,2,6
         %if reguse(I)=0 %and reguse(I+1)=0 %thenstart
Set:        Reguse(I)=-255
            Reguse(I+1)=-255
            %result=I
         %finish
      %repeat
      %cycle I=0,2,6
         %if reguse(I)>=0 %and reguse(I+1)>=0 %then ->Set
      %repeat
      %if Mode=0 %then %result=-1
      %cycle I=0,2,6
         %if reguse(I)>=-250 %and reguse(I+1)>=-250 %thenstart
            %if reguse(I)<0 %then release reg(I)
            %if reguse(I+1)<0 %then release reg(I+1)
            ->Set
         %finish
      %repeat
      abortm("cannot claim reg pair")
%end;! claim reg pair
!*
%integerfn Checkregkey(%integer use,area,offset)
!***************************************************************************
!* result >= 0  a register with the right info to use                      *
!*        = -1  no suitable register                                       *
!* use   1  data    held at (area+offset)                                  *
!*       2  address of area + offset                                       *
!* attempts are made to exploit existing content                           *
!* allocated registers are locked with reguse = use-255                    *
!***************************************************************************
%integer reg,info
%record(Stkfmt) Stk
      info=(offset<<9)!area
      %cycle reg=0,1,7
         %if regdata(reg)=info %thenstart
            %if reguse(reg)=use %or reguse(reg)=use-255 %thenstart
               reguse(reg)=use-255
               %result=reg
            %finish
         %finish
      %repeat
      %result=-1
%end;! Checkregkey
!*
%externalintegerfn Load Reg(%integer Reg,%record(Stkfmt)%name Stk)
!***********************************************************************
!* Stk describes an integer value (1,2 or 4 bytes)                     *
!* if Reg is >= 0 then this register must be loaded                    *
!* result is the general register to which the value has been loaded   *
!***********************************************************************
%integer Bytes,Reg1,Form,Value
      Form=Stk_Form&31
      Bytes=Stk_Size
      %unless 0<Bytes<=4 %then Abortm("Size error")
      %if Form=RegVal %or Form=FregVal %thenstart
         %if Reg<0 %or Reg=Stk_Reg %thenstart
            reguse(Stk_Reg)=-255
            %result=Stk_Reg
         %finishelsestart;! prescribed register
            Reg1=Stk_Reg
Rcopy:      Gop RR(TRR,Reg,Reg1)
            unlock reg(Reg1)
            Reguse(Reg)=-255
            %result=Reg
         %finish
      %finish
      %if Form=LitVal %thenstart
         Value=Stk_Intval
         Reg1=checkregkey(3,Value,0)
         %if Reg1>=0 %thenstart
            %if Reg<0 %or Reg=Reg1 %then %result=Reg1 %else ->Rcopy
         %finish
         %if -32768<=Value<=32767 %thenstart
            %if Reg<0 %then Reg=claim reg
            Gop RI(LI,Reg,Value)
            reguse(Reg)=-252
            regdata(Reg)=Value
            %result=Reg
        %finish
      %finish
      %if Form=DirVal %and Reg#-2 %thenstart
         Reg1=checkregkey(data at,Stk_Base,Stk_Offset)
         %if Reg1>=0 %thenstart
            %if Reg<0 %or Reg=Reg1 %then %result=Reg1 %else ->Rcopy
         %finish
      %finish
      %if Reg<0 %then Reg=claim reg
      Gop RX(L,Reg,Stk)
      %if Form=DirVal %thenstart
         reguse(Reg)=-254
         regdata(Reg)=(Stk_Offset<<9)!Stk_Base
      %finishelse reguse(Reg)=-255
      %result=Reg
%end;! Load Reg
!*
%externalintegerfn Load Dreg(%integer Reg,%record(Stkfmt)%name Stk)
%monitor;%stop
      %result=2
%end;! Load Dreg
!*
%externalintegerfn Load Int(%record(Stkfmt)%name Stk,%integer Reg)
            %result=Load Reg(Reg,Stk)
%end
!*
%externalintegerfn Load Real(%record(Stkfmt)%name Stk,%integer Reg,Newsize)
      %if Newsize=4 %thenstart
         %result=Load Reg(Reg,Stk)
      %finishelsestart
         %result=Load Dreg(Reg,Stk)
      %finish
%end
!*
%externalintegerfn get reg(%integer use,area,offset)
!***************************************************************************
!* result = address register prepared according to use                     *
!* use = 0  no initialisation                                              *
!*       1  address held at (area+offset)                                  *
!*       2  address of area + offset                                       *
!* attempts are made to exploit existing content                           *
!* allocated registers are locked with areguse = use-255                   *
!***************************************************************************
%integer reg,info
%record(Stkfmt) Stk
   info=(offset<<9)!area
   %if use#0 %thenstart;! check if a suitable register is already loaded
      %cycle reg=0,1,7
         %if regdata(reg)=info %thenstart
            %if reguse(reg)=use %or reguse(reg)=use-255 %thenstart
               reguse(reg)=use-255
               %result=reg
            %finish
         %finish
      %repeat
   %finish
!*
   %cycle reg=0,1,7
      %if reguse(reg)=0 %thenstart
load:    reguse(reg)=use-255
         regdata(reg)=info
         %if use=0 %then %result=reg
         %if use=2 %thenstart;! area address required
            %if Area=Stack %thenstart
               %result=reg
            %finish
            %result=reg %if Clist=0
            S1=Textarea(area,offset)
         %finishelsestart
            %if area=Stack %thenstart
            %finishelsestart
               %result=reg %if Clist=0
               S1="(".Textarea(area,offset).")"
            %finish
         %finish
         S2=Rtext(Reg)
!!         TextS1S2(Move,2)
         %result=reg
      %finish
   %repeat
!*
   %cycle reg=0,1,7
      %if reguse(reg)>0 %then ->load
   %repeat
   abortm("all aregs locked")
   %result=0
%end;! get reg
!*
%integerfn Load Breg(%integer Area,Offset)
%integer I,Key
%record(Stkfmt) Stk
      Key=(Offset<<9)!Area
      %cycle I=br6,1,br7
         %if breguse(I)=Key %then Lastbreg=I %and %result=I
      %repeat
!*
      %cycle I=br6,1,br7
         %if breguse(I)=0 %then ->Load
      %repeat
!*
      %if Lastbreg=br6 %then I=br7 %else I=br6
Load: Stk_Form=DirVal
      Stk_Base=Area
      Stk_Offset=Offset
      Stk_Size=0
      Gop RX(LWBR,I,Stk)
      breguse(I)=Key
      Lastbreg=I
      %result=I
%end;! Get Breg
!*
%externalroutine Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%constintegerarray szadj1(0:8) = 0,0,1,0,0,0,0,0,2
%integer h0,h1
      h0=((Reg&7)<<7)!(Index<<4)!(Base&7)!Mask(Op)
      %if Size=1 %then h0=h0!8
      h1=offset!szadj1(Size)
      codew(h0,h1)
      %return %if Clist=NO
      S1=Rtext(Reg)
      S2=Htos(Offset)."("
      %if Index#0 %then S2=S2.Rtext(Index).","
      %if Base=0 %then S3="0)"   %c
                 %else S3=Rtext(Base).")"
      S2=S2.S3
      TextS1S2(Op,Size)
%end;! Gop RXB
!*
%externalroutine Gop RI(%integer Op,Reg,Lit)
%integer h0,h1
      h0=Reg<<7!Mask(Op)
      h1=Lit&X'FFFF'
      codew(h0,h1)
      %return %if Clist=NO
      S1=Rtext(Reg)
      S2=Htos(Lit)
      TextS1S2(Op,0)
%end;! Gop RI
!*
%externalroutine Gop RR(%integer Op,Dreg,Sreg)
      codeh(((Dreg&7)<<3!(Sreg&7))<<4!Mask(Op))
      %return %if Clist=NO
      S1=Rtext(Dreg)
      S2=Rtext(Sreg)
      TextS1S2(Op,0)
%end;! Gop RR
!*
%integerfn Litoffset(%integer Value)
%integer I,J
      %if Numconstrecs>0 %thenstart
         %cycle I=1,1,Numconstrecs
            %if Constinfo(I)_Val=Value %thenstart
               %result=Constinfo(I)_Offset
            %finish
         %repeat
      %finish
      I=PLToffset
      PLToffset=I+4
      Md4(Plt,I,Value)
      %if Numconstrecs<255 %thenstart
         Numconstrecs=Numconstrecs+1
         Constinfo(Numconstrecs)_Val=Value
         Constinfo(Numconstrecs)_Offset=I
      %finish
      %result=I
%end;! Litoffset
!*
%externalroutine Gop RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%constintegerarray szadj1(0:8) = 0,0,1,0,0,0,0,0,2
%integer h0,h1,Size
%integer Form,Lit,Index,Base,Offset,Val
%record(Stkfmt) Modstk
%switch F(0:31)
%switch G(0:31)
      Size=Stk_Size
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      Val=Stk_IntVal
      %if -32768<=Val<=32767 %thenstart
         %if Op<=CAM %and Litop(Op)#0 %thenstart
            %if Op=LN %then Val=-Val
            Gop RI(Litop(Op),Reg,Val)
            %return
         %finish
      %finish
      Stk_Base=Plt
      Stk_Offset=Litoffset(Val)
      Size=4
!*
F(ConstVal):              {  const      }
RXB:  Offset=Stk_Offset
      Locate(Stk_Base,Offset,Index,Base)
      h0=((Reg&7)<<7)!(Index<<4)!(Base&7)!Mask(Op)
      %if Size=1 %then h0=h0!8
      h1=offset!szadj1(Size)
      codew(h0,h1)
      %return %if Clist=NO
      S1=Rtext(Reg)
      S2=TextArea(Stk_Base,Stk_Offset)
!      S2=Htos(Offset)."("
!      %if Index#0 %then S2=S2.Rtext(Index).","
!      %if Base=0 %then S3="0)"   %c
!                 %else S3=Rtext(Base).")"
!      S2=S2.S3
      TextS1S2(Op,Size)
      %return
!*
F(RegAddr):               {  (reg) is @ }
F(RegVal):                { (reg)       }
      %monitor;%stop
      %return
!*
F(FregVal):               { (freg)      }
      %monitor;%stop
      %return
!*
F(TempAddr):              {  (temp) is @}
F(TempVal):               {  (temp)     }
      %return
!*
F(DirAddr):               {  (dir) is @ }
F(DirVal):                {  (dir)      }
      ->RXB
!*
F(IndRegVal):             { ((reg))     }
      Index=Stk_Reg
      ->Ind
!*
F(IndTempVal):            { ((temp))    }
!*
F(IndDirVal):             { ((dir))     }
      Stk_Form=DirVal
      Stk_Size=4
      Index=Load Reg(-1,Stk)
Ind:  Gop RXB(Op,Reg,0,Index,0,Size)
      unlock reg(Index)
      %return
!*
F(AddrConst):             {  @const     }
      %monitor;%stop
      %return
!*
F(AddrDir):               {  @dir       }
      %if Op=L %thenstart
         Op=LA
         Size=0
         ->RXB
      %finish
      %monitor;%stop
      %return
!*
F(TopOfStack):            {  TOS        }
      %monitor;%stop
      %return
!*
F(AddrDirMod):            {  @dir+M     }
!*
F(RegModAddr):            {  (reg)+M    }
!*
F(TempModAddr):           {  (temp)+M   }
!*
F(DirModAddr):            {  (dir)+M    }
!*
F(IndRegModVal):          { ((reg)+M)   }
!*
F(IndTempModVal):         { ((temp)+M)  }
!*
F(IndDirModVal):          { ((dir)+M)   }
!*
F(AddrDirModVal):         { (dir+M)     }
      %unless Stk_Modform=LitVal %and 0<=Stk_Modintval<=x'ffff' %thenstart
         Modstk=0
         Modstk_Form=Stk_Modform
         Modstk_Base=Stk_Modbase
         Modstk_Offset=Stk_Modoffset
         Modstk_Reg=Stk_Modreg
         Modstk_Size=4
         %if Modstk_Form=Dirval %and Stk_Scale=2 %thenstart
            Index=checkregkey(4,modstk_Base,Modstk_offset)
            %if Index>0 %thenstart
                Form=Regval
                offset=0
                ->G(Stk_Form&31)
            %finish
         %finish
         Index=Load Reg(-1,Modstk)
         %if Index=0 %thenstart
            Index=claim reg
            Gop RR(TRR,Index,r0)
            reguse(0)=0
         %finish
         %if Stk_Scale#0 %thenstart
            Gop Shift Lit(SLL,Index,Stk_Scale)
!!            %if Modstk_form=dirval %and Stk_Scale=2 %thenstart
printstring("$$$$$");write(index,4)
               reguse(Index)=-251
               regdata(Index)=(Modstk_Offset<<9)!Modstk_Base
write(regdata(index),4);newline
!!            %finish
         %finish
         Form=RegVal
         Offset=0
      %finishelsestart
         Offset=Stk_Modintval
         Index=0
         Form=LitVal
      %finish
      ->G(Stk_Form&31)
!*
G(AddrDirMod):            {  @dir+M     }
      %return
!*
G(RegModAddr):            {  (reg)+M    }
      %return
!*
G(TempModAddr):           {  (temp)+M   }
G(DirModAddr):            {  (dir)+M    }
      %return
!*
G(IndRegModVal):          { ((reg)+M)   }
      %return
!*
G(IndTempModVal):         { ((temp)+M)  }
      %return
!*
G(IndDirModVal):          { ((dir)+M)   }
      Base=Load Breg(Stk_Base,Stk_Offset)
      Gop RXB(Op,Reg,Base,Index,Offset,Stk_Size)
      %if Index#0 %thenstart
!!         %if Stk_Scale#0 %then reguse(Index)=0 %else unlock reg(Index)
      %finish
      %return
!*
G(AddrDirModVal):         { (dir+M)     }
      %return
!*
%end;! Gop RX
!*
%externalroutine Gop R(%integer Op,Reg)
      codeh((Reg&7)<<7!Mask(Op))
      %return %if Clist=NO
      S1=Rtext(Reg)
      TextS1(Op)
%end;! Gop R
!*
%externalroutine Gop X(%integer Op,%record(Stkfmt)%name Stk)
%integer Form,Reg
      %if Op=TST %thenstart
         Form=Stk_Form&31
         %if Form=RegVal %or Form=FregVal %thenstart
            Reg=Stk_Reg
!!##            Gop RR(TRR,Reg,Reg)
         %finishelsestart
            Reg=Load Reg(-2,Stk);! must ensure it is loaded
         %finish
         unlock reg(Reg)
         %return
      %finish
%monitor
%end;! Gop X
!*
%externalroutine Gop(%integer Op)
      codeh(Mask(Op))
      Text(Op)
%end;! Gop
!*
%externalroutine Gop Shift Lit(%integer Op,Reg,Lit)
      codeh(Mask(Op)!(Reg<<7)!Lit)
      %if Clist=YES %thenstart
         S1=Rtext(Reg)
         S2=Itos(Lit)
         TextS1S2(Op,0)
      %finish
%end;! Gop Shift
!*
%externalroutine Gop Shift(%integer Op,Reg,%record(Stkfmt)%name Stk)
%integer Instr,Shiftreg,Lit,Size
      %if Clist=YES %thenstart
         S2=Rtext(Reg)
         TextS1S2(Op,Size)
      %finish
%end;! Gop Shift
!*
%externalroutine Gop Jump(%integer Op,Label)
%integer Instr
      label=label+proc count
      codew(Mask(op)!1,0)
      %if Clist=YES %thenstart
         TextLab(Op,Label)
      %finish
      Break Frag(Label)
%end;! Gop Jump
!*
%externalroutine Gop Call(%integer Id,Paramsize)
%record(exdatafmt)%name Exdata
%integer Instr
      Clear Regs
      %if NextParamOffset>CallParSize %then CallParSize=NextParamOffset
      eafix(1,-16);! relative fixup (to *+16)
      Gop RXB(LA,r2,br1,0,0,0)
      Exdata==record(exrecad(Id))
      Eafix(3,Exdata_ca)
      codew(Mask(LWBR)!X'80',0)
      %if Clist=YES %thenstart
         S1=Rtext(br1)
         S2=Exdata_Name
         TextS1S2(LWBR,0)
      %finish
      Gop RXB(ST,r2,br2,0,0,4)
      Gop RXB(BU,0,br1,0,4,0)
      eafix(1,Procbaseca)
      codew(Paramsize<<6,0)
      %if Clist#0 %thenstart
         printstring("@curproc")
         newline
      %finish
%end;! Gop Call
!*
%routine Retframe
      Numretframes=Numretframes+1
      retframekeys(Numretframes)=addr(frag_h(fragoffset-2))
%end;! Retframe
!*
%externalroutine Gop Return
      Gop RXB(L,r2,br2,0,0,4)
      Retframe
      Gop RXB(LWBR,br1,0,r2,0,0)
      Gop RXB(LABR,br2,br2,0,0,0)
      Retframe
      Gop RXB(BU,0,0,r2,4,0)
%end;! Gop Return
!*
!*
%externalroutine Push Param(%record(Stkfmt)%name Stk)
!***********************************************************************
!* the value or address in Stk is added to the parameter list          *
!***********************************************************************
%integer Reg,Size,Op
      Size=Stk_Size
      %if Size>8 %then %monitor %and %stop
      %if Stk_Form=LitVal %and Stk_Intval=0 %thenstart
         Op=ZM
         Reg=0
      %finishelsestart
         Op=ST
         %if Size<=4 %thenstart
            Reg=Load Reg(-1,Stk)
            unlock reg(Reg)
            Size=4
         %finishelsestart
            Reg=Load Dreg(-1,Stk)
         %finish
      %finish
      Gop RXB(Op,Reg,br2,0,NextParamOffset,Size)
      NextParamOffset=NextParamOffset+Stk_Size
%end;! Push Param
!*
%routine Check Conflict(%integer Base,Offset,Size)
%integer I,Key
      Key=(Offset<<9)!Base
      %cycle I=r0,1,r7
         %if reguse(I)=Data at %thenstart
            %if regdata(I)=Key %thenstart
               reguse(I)=0
               regdata(I)=0
            %finish
         %finish
      %repeat
%end;! Check Conflict
!*
%externalintegerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
!***********************************************************************
!* value defined by RHS is assigned to LHS. If Dup is non-zero then    *
!* value must be retained in a reg (4-byte integers only)              *
!* result is the reg used for retaining the value                      *
!***********************************************************************
%integer Bytes,Reg,Lform,Rform,Key,Op,I
%record(Stkfmt) Regstk
Start:Rform=RHS_Form&31
      Bytes=RHS_Size
!#      %if Bytes # LHS_Size %thenstart;! IMP concat and resolution code
!#         %if Rform=Litval %thenstart
!#            Bytes=LHS_Size
!#            RHS_Size=Bytes
!#         %finishelsestart
!#            Elevel=Elevel+2
!#            Epromote(2)
!#            Estklit(RHS_Size);! since top 2 have been swapped
!#            Eop(CVTII)
!#            Epromote(2)
!#            Elevel=Elevel-2
!#            ->Start
!#         %finish
!#      %finish
      Lform=LHS_Form&31
      %if Bytes<=4 %thenstart
         %if RHS_Form=LitVal %and RHS_IntVal=0 %thenstart
            Op=ZM
            Reg=0
         %finishelsestart
            Op=ST
            Reg=Load Reg(-1,RHS)
         %finish
         Gop RX(Op,Reg,LHS)
         %if Lform =DirVal %thenstart
            Check Conflict(LHS_Base,LHS_Offset,LHS_Size)
         %finish
         %if Op=ZM %then %result=-1
         %if Dup#0 %then %result=Reg
         unlock reg(Reg)
         %if Lform =DirVal %thenstart
            Key=(LHS_Offset<<9)!LHS_Base
            reguse(Reg)=Data at
            regdata(Reg)=Key
         %finish
      %finishelsestart
!#
!#
         %monitor
         %stop
      %finish
      %result=Reg
%end;! Storeop
!*
%externalroutine Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports IADD,ISUB,IMULT,IDIV,IGT,ILT,IEQ,INE,IGE,ILE,IAND,IOR,IXOR *
!* descriptor to result on Estack                                      *
!***********************************************************************
%constbyteintegerarray RRop(0:11) = 0,
   ADR,SUR,MPR,DVR,0,0,0,ANR,ORR,0,EOR
%constbyteintegerarray RXop(0:11) = 0,
   ADM,SUM,MPM,DVM,0,0,0,ANM,ORM,0,EOM
%constintegerarray Shiftval(0:8)=-1,0,1,-1,2,-1,-1,-1,3
%integer Lform,Rform,Reg,Lreg,Rreg,Shift,I
%switch Opcode(0:ILE)
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      %if Lform=DirVal %thenstart
         Reg=Checkregkey(data at,LHS_Base,LHS_Offset)
         %if Reg>=0 %thenstart
            Lform=RegVal
            LHS_Form=RegVal
            LHS_Reg=Reg
         %finish
      %finish
      %if Rform=DirVal %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %thenstart
            Rform=RegVal
            RHS_Form=RegVal
            RHS_Reg=Reg
         %finish
      %finish
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      ->Opcode(Op)
!*
Opcode(IADD):
Opcode(IAND):
Opcode(IOR):
Opcode(IXOR):
      %if Lform=RegVal %thenstart
A:       %if Rform=RegVal %thenstart
B:          Gop RR(RRop(Op),Lreg,Rreg)
            unlock reg(Rreg)
         %finishelsestart
            reguse(Lreg)=-255
            Gop RX(RXop(op),Lreg,RHS)
         %finish
         Reg=Lreg
      %finishelsestart
         %if Rform=RegVal %thenstart
            reguse(Rreg)=-255
            Gop RX(RXop(Op),Rreg,LHS)
            Reg=Rreg
         %finishelsestart
            %if Lform=Litval %thenstart
               Reg=Load Reg(-1,RHS)
               Gop RX(RXop(Op),Reg,LHS)
            %finishelsestart
C:             Reg=Load Reg(-1,LHS)
               Gop RX(RXop(Op),Reg,RHS)
            %finish
         %finish
      %finish
      Stackr(Reg)
      %return
!*
Opcode(ISUB):
      %if Lform=RegVal %then ->A
      %if Rform=RegVal %thenstart
         %if reguse(Rreg)>=0 %thenstart
            reguse(Rreg)=reguse(Rreg)-255 
         %finishelsestart
            %if reguse(Rreg)>-250 %then reguse(Rreg)=-255
         %finish
         Lreg=Load Reg(-1,LHS)
         ->B
      %finishelse ->C
!*
Opcode(IGT):
Opcode(ILT):
Opcode(IEQ):
Opcode(INE):
Opcode(IGE):
Opcode(ILE):
      CC=Op-IGT
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            Gop RR(CAR,Lreg,Rreg)
            unlock reg(Rreg)
         %finishelse Gop RX(CAM,Lreg,RHS)
         Reg=Lreg
      %finishelsestart
         %if Rform=RegVal %thenstart
            Reg=Rreg
            CC=Invcc(CC)
            Gop RX(CAM,Rreg,LHS)
         %finishelsestart
            %if Lform=Litval %thenstart
               Reg=Load Reg(-1,RHS)
               CC=Invcc(CC)
               Gop RX(RXop(Op),Reg,LHS)
            %finishelsestart
               Reg=Load Reg(-1,LHS)
               Gop RX(RXop(Op),Reg,RHS)
            %finish
         %finish
          unlock reg(Reg)
      %finish
      unlock reg(Reg)
      Enote cc(CC)
      %return
!*
Opcode(IMULT):
      %if Lform=LitVal %thenstart
         %if 0<=LHS_Intval<=8 %thenstart
            Shift=Shiftval(LHS_Intval)
            %if Shift=0 %thenstart
               Epush Operand(RHS)
               %return
            %finish
            %if Shift>0 %thenstart
               Reg=Load Reg(-1,RHS)
D:             Gop Shift Lit(SLA,Reg,Shift)
               Stackr(Reg)
               %return
            %finish
         %finish
      %finish
      %if Rform=LitVal %thenstart
         %if 0<=RHS_Intval<=8 %thenstart
            Shift=Shiftval(RHS_Intval)
            %if Shift=0 %thenstart
               Epush Operand(LHS)
               %return
            %finish
            %if Shift>0 %thenstart
               Reg=Load Reg(-1,LHS)
               ->D
            %finish
         %finish
      %finish
!*
      %if Lform=RegVal %thenstart
         %if Rform=Regval %thenstart
            %if Rreg=Lreg!!1 %thenstart
               Reg=Lreg&6
               Gop RR(MPR,Reg,Reg)
E:             reguse(Reg)=0
               Stackr(Reg+1)
               %return
            %finish
         %finish
         %if reguse(Lreg!!1)>=0 %thenstart;! use this pair
G:          %if Lreg&1=0 %then Gop RR(TRR,Lreg+1,Lreg)
            Reg=Lreg&6
F:          %if Rform=RegVal %thenstart
               Gop RR(MPR,Reg,Rreg)
               unlock reg(Rreg)
               ->E
            %finishelsestart
               reguse(Reg)=-255
               reguse(Reg+1)=-255
               Gop RX(MPM,Reg,RHS)
               ->E
            %finish
         %finishelsestart;! find a suitable pair
            Reg=claim reg pair(0);! only if a pair is free
            %if Reg>=0 %thenstart
               Gop RR(TRR,Reg+1,Lreg)
               unlock reg(Lreg)
               ->F
            %finishelsestart;! use the Lreg pair
               release reg(Lreg!!1)
               ->G
            %finish
         %finish
      %finishelsestart
         %if Rform=RegVal %thenstart
            %if reguse(Rreg!!1)>=0 %thenstart;! use this pair
H:             %if Rreg&1=0 %then Gop RR(TRR,Rreg+1,Rreg)
               Reg=Rreg&6
               reguse(Reg)=-255
               reguse(Reg+1)=-255
K:             Gop RX(MPM,Reg,LHS)
               ->E
            %finishelsestart;! find a suitable pair
               Reg=claim reg pair(0);! only if a pair is free
               %if Reg>=0 %thenstart
                  Gop RR(TRR,Reg+1,Rreg)
                  unlock reg(Rreg)
                  ->K
               %finishelsestart;! use the Rreg pair
                  release reg(Rreg!!1)
                  ->H
               %finish
            %finish
         %finishelsestart;! nothing in a register
            Reg=claim reg pair(1)
            %if Lform=LitVal %thenstart
               I=Load Reg(Reg+1,RHS)
               reguse(Reg)=-255
               reguse(Reg+1)=-255
               Gop RX(MPM,Reg,LHS)
            %finishelsestart
               I=Load Reg(Reg+1,LHS)
               reguse(Reg)=-255
               reguse(Reg+1)=-255
               Gop RX(MPM,Reg,RHS)
            %finish
            ->E
         %finish
      %finish
!*
Opcode(IDIV):
      %if Rform=LitVal %thenstart
         %if 0<=RHS_Intval<=8 %thenstart
            Shift=Shiftval(RHS_Intval)
            %if Shift=0 %thenstart
               Epush Operand(LHS)
               %return
            %finish
            %if Shift>0 %thenstart
               Reg=Load Reg(-1,LHS)
               Gop Shift Lit(SRA,Reg,Shift)
               Stackr(Reg)
               %return
            %finish
         %finish
      %finish
!*
Opcode(IREM):
      %if Lform=RegVal %thenstart
         reguse(Lreg)=-255
         %if Rform=Regval %thenstart
            %if Rreg=Lreg!!1 %thenstart
               reguse(Rreg)=-255
               Reg=claim reg
               Gop RR(TRR,Reg,Rreg)
               reguse(Rreg)=0
            %finish
         %finish
         %if reguse(Lreg!!1)>=0 %thenstart;! use this pair
I:          %if Lreg&1=0 %then Gop RR(TRR,Lreg+1,Lreg)
            Reg=Lreg&6
J:          Gop R(EX,Reg)
            %if Rform=RegVal %thenstart
               Gop RR(DVR,Reg,Rreg)
               unlock reg(Rreg)
               ->E
            %finishelsestart
               reguse(Reg)=-255
               reguse(Reg+1)=-255
               Gop RX(DVM,Reg,RHS)
               ->E
            %finish
         %finishelsestart;! find a suitable pair
            Reg=claim reg pair(0);! only if a pair is free
            %if Reg>=0 %thenstart
               Gop RR(TRR,Reg+1,Lreg)
               unlock reg(Lreg)
               ->J
            %finishelsestart;! use the Lreg pair
               release reg(Lreg!!1)
               ->I
            %finish
         %finish
      %finishelsestart
         %if Rform=RegVal %then reguse(Rreg)=-255
         Reg=claim reg pair(1)
         I=Load Reg(Reg+1,LHS)
         %if Rform=RegVal %thenstart
            Gop RR(DVR,Reg,Rreg)
            reguse(Rreg)=0
         %finishelsestart
            reguse(Reg)=-255
            reguse(Reg+1)=-255
            Gop RX(DVM,Reg,RHS)
         %finish
         ->E
      %finish
%end;! Int Binary Op
!*
%externalroutine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports INEG,IABS                                                  *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,I
      %if RHS_form=DirVal %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %thenstart
            RHS_Form=RegVal
            RHS_Reg=Reg
         %finish
      %finish
      %if Op=INEG %thenstart
          %if RHS_form=RegVal %thenstart
             Reg=RHS_Reg
             Gop RR(TRN,Reg,Reg)
          %finishelsestart
             Reg=Claim Reg
             Gop RX(LN,Reg,RHS)
          %finish
      %finishelsestart
         %if Op=INOT %thenstart
            %monitor;%stop
         %finishelsestart
            %unless Op=IABS %then Abortm("illegal Unary OP")
            %monitor;%stop
         %finish
      %finish
      Stackr(Reg)
%end;! Int Unary Op
!*
%externalroutine Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports RADD,RSUB,RMULT,RDIV,RGT,RLT,REQ,RNE,RGE,RLE               *
!* descriptor to result on Estack                                      *
!***********************************************************************
%constbyteintegerarray RReop(RADD:RDIV) = ADRFW,SURFW,MPRFW,DVRFW
%constbyteintegerarray RRdop(RADD:RDIV) = ADRFD,SURFD,MPRFD,DVRFD
%constbyteintegerarray RXop(RADD:RDIV) = ADF,SUF,MPF,DVF
%integer Lform,Rform,Reg,Lreg,Rreg,Bytes,CC
%switch Opcode(RADD:RLE)
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      %if Lform=DirVal %thenstart
         Reg=Checkregkey(data at,LHS_Base,LHS_Offset)
         %if Reg>=0 %thenstart
            Lform=FregVal
            LHS_Form=FregVal
            LHS_Reg=Reg
         %finish
      %finish
      %if Rform=DirVal %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %thenstart
            Rform=FregVal
            RHS_Form=FregVal
            RHS_Reg=Reg
         %finish
      %finish
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      Bytes=LHS_Size
      ->Opcode(Op)
!*
Opcode(RADD):
!*
Opcode(RMULT):
      %if Lform=FregVal %thenstart
A:       %if Rform=FregVal %thenstart
B:          Gop RR(RReop(Op),Lreg,Rreg)
            unlock reg(Rreg)
         %finishelsestart
            reguse(Lreg)=-255
            Gop RX(RXop(op),Lreg,RHS)
         %finish
         Reg=Lreg
      %finishelsestart
         %if Rform=FregVal %thenstart
            reguse(Rreg)=-255
            Gop RX(RXop(Op),Rreg,LHS)
            Reg=Rreg
         %finishelsestart
C:          Reg=Load Reg(-1,LHS)
            Gop RX(RXop(Op),Reg,RHS)
         %finish
      %finish
      Stackfr(Reg,4)
      %return
!*
Opcode(RSUB):
!*
Opcode(RDIV):
      %if Lform=FregVal %then ->A
      %if Rform=FregVal %thenstart
         %if reguse(Rreg)>=0 %thenstart
            reguse(Rreg)=reguse(Rreg)-255  
         %finishelsestart
             %if Reguse(Rreg)>-250 %then reguse(Rreg)=-255
         %finish
         Lreg=Load Reg(-1,LHS)
         ->B
      %finishelse ->C
!*
Opcode(RGT):
Opcode(RLT):
Opcode(REQ):
Opcode(RNE):
Opcode(RGE):
Opcode(RLE):
      CC=Op-RGT
      %if Lform=FregVal %thenstart
         %if Rform=FregVal %thenstart
            Gop RR(CAR,Lreg,Rreg)
            unlock reg(Rreg)
         %finishelse Gop RX(CAM,Lreg,RHS)
         Reg=Lreg
      %finishelsestart
         %if Rform=FregVal %thenstart
            Reg=Rreg
            CC=Invcc(CC)
            Gop RX(CAM,Rreg,LHS)
         %finishelsestart
            Reg=Load Reg(-1,LHS)
            Gop RX(CAM,Reg,RHS)
         %finish
          unlock reg(Reg)
      %finish
      unlock reg(Reg)
      Enote cc(CC)
      %return
%end;! Real Binary Op
!*
%externalroutine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports RNEG,RABS                                                  *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Bytes,I
      Bytes=RHS_Size
      %if RHS_form=DirVal %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %thenstart
            RHS_Form=FregVal
            RHS_Reg=Reg
         %finish
      %finish
      %if Op=RNEG %thenstart
          %if RHS_form=FregVal %thenstart
             Reg=RHS_Reg
             Gop RR(TRN,Reg,Reg)
          %finishelsestart
             Reg=Claim Reg
             Gop RX(LN,Reg,RHS)
          %finish
      %finishelsestart
         %unless Op=RABS %then Abortm("illegal Unary OP")
         %monitor;%stop
      %finish
      Stackfr(Reg,Bytes)
%end;! Real Unary Op
!*
%endoffile