! 20/11/87 - TRVE only if  in Vector loop                       gcode67i3
!          - Replace SUI by ADI
! 10/aug/87 - Plant gla ad for diagnostics if imp               gcode67i2
!
! 06/Aug/87 - Fix Check conflict to watch for byte access        gcode67i
!             Make profiling conditional on IMP. 
!                                                                gcode67
! 25/04/87 - revise Gop Bit
!                                                                gcode66
! 18/04/87 - update Gop Bit for Concept
!                                                                gcode65
! 17/04/87 - reduce PLT min space to 16
!                                                                gcode64
! 16/04/87 - version change to allign with ggen
!                                                                gcode61
! 14/04/87 - upgrade for C
! 01/04/87 - add Gop Bit
! 17/03/87 - Alter V release reg pair  Alan Ft.L.                gcode60
!
!                                                                gcode59
! 28/02/87 - incorporate integer*8 changes (ex gcode36u)
!          - incorporate C changes (ex gcode53b)
!                                                                gcode58
! 19/02/87 - allow for -f in Msideentry and Gopcall
! 12/02/87 - Load Real incorporates GCF001 change
!          - call Release V Loop Regs from Freeregs
! 11/02/87 - avoid use of br7. use br4,br5,br6
!                                                                gcode57
! 08/01/87 - vector updates
!                                                                gcode56
! 29/12/86 - Add Vector operations 
!                                                                gcode55
! 27/12/86 - allow for -f in profiling and diags code
!          - preserve and restore r6,r7 at all times in Imp procs
! 24/12/86 - C dev version ex Ft. L.
!                                                                gcode53
!                                                                gcode51
! 09/12/86 - add Push Struct
!                                                                gcode50
!                                                                gcode46
! 03/12/86 - replace CAR by SURFD in Real Binary Op compare
!                                                                gcode45
! 01/12/86 - add Mset Procref
!          - avoid mult on NP1 for 1/a
!                                                                gcode44
! 01/12/86 - save first arg on entry
!          - remember initial regs at Fortran prologue
! 29/11/86 - incorporate changes in F77 1.0 final (gcode34)
!                                                                gcode42
! 20/11/86 - merge gcode38 (C dev) and gcode41 (NP1 dev)
!                                                                gcode41
! 25/10/86 - reduce STD to STW prior to call when possible (NP1)
!                                                                gcode40
! 25/10/86 - changes for improved Whetstone performance (experimental)
!                                                                gcode39
! 21/10/86 - Egivename is now a routine
!                                                                gcode38
! 14/11/86 - release reg to cope with odd reg of pair
!          - Eafix made external
! 06/11/86 - incorporate offset with r7 in Dir ModAddr
! 01/11/86 - avoid saving regs on entry to C routines
! 17/10/86 - avoid copying gla address to display in C
!                                                                gcode37
! 16/10/86 - avoid use of BIW on emulator for NP1
! 15/10/86 - allow for 32 bit addresses in areakeyref
!          - clear regs in Msideentry
! 13/10/86 - Gop X correction for INCMB
!                                                                gcode36
! 10/10/86 - save regs r6,r7 if necessary at call
!          - remember br3. Add Fprologue
!          - code for INCMB etc in Gop RX and Gop X
! 09/10/86 - align procstart on 8 byte boundary for NP1
! 08/10/86 - integer mult uses only single reg on NP1
! 07/10/86 - no paramsize in code address at call
!          - use r7 for IMP display
!          - avoid use of BIB on NP1 due to emulator bug
! 06/10/86 - load first arg to r2
!          - avoid saving of regs on entry
!                                                                gcode35
! 30/09/86 - Gop RX to allow CAM with RegVal operand
! 29/09/86 - save regs 4,5 as well as 6,7
!          - select regs 1-3,0,4-7
! 27/09/86 - add NP1 code
!          - correct calls to Mlinestart for dbx
! 26/09/86 - ADM => ADR for RegVar
!                                                                gcode30
! 24/09/86 - correct return link for call at >64k
! 21/09/86 - ensure that an index register is not active before scaling
!                                                                gcode29
! 13/09/86 - use SLL instead of SLA for small int mult
! 12/09/86 - support C regvars
!                                                                gcode27
! 12/09/86 - allow for >64K when setting return links
! 09/09/86 - add Get Paradjust for dbx records
!          - generate call to mcount if profiling
! 05/09/86 - Mmarker to lose register memory
!* Alan. Experiment with long jump code. (Tidy frags) 26/8/86
!                                                                  gcode26
! 18/08/86 - remember address modified by reg7
!          - load only 2 bregs in a loop
!          - Locate to use common base with zero offset
! 17/08/86 - remember indexes scaled by 1 and 3 as well as 2
! 16/08/86 - call Check Conflict in Gop RX for ARM
!                                                                  gcode25
! 30/07/86 - allow >64k routines
!                                                                  gcode24
!*
!*
!* This module contains support procedures for generating Gould object code
!*
!*
%constinteger Concept = 0
%constinteger NP1     = 1
!*
%constinteger Cpu     = NP1
!*
%include "gbits_gcodes8"
!*
%include "ebits_ecodes18"
!*
!*
%constinteger hardoptions=1;     ! to disable divide code
%constinteger IMP     =  1
%constinteger fortran =  2
%constinteger ccomp   = 11
%constinteger pascal  = 14
!*
%externalintegermapspec comreg(%integer n)
!***********************************
!* Put Interface Massing of Data   *
!***********************************
%externalroutinespec Mcodesize(%integer bytes)
%externalroutinespec   Mcbytes(%integer Disp,Len,Ad)
%externalroutinespec   MDBYTES   (%integer area, Disp, len, ad)
%externalroutinespec   MD        (%integer area, Disp, Databyte)
%externalroutinespec   MD4       (%integer area, Disp, DataQuadbyte)
!**********************************************
!* Put Interface RELOCATION and REFERENCES    *
!**********************************************
%externalintegerfnspec MXname (%integer type,%string(255)%name  s)
%externalroutinespec   Mfix   (%integer area,disp, tgtarea,tgtdisp)
!**********************************
!* Put Interface - Miscellaneous  *
!**********************************
%externalroutinespec   Mlinestart   (%integer lineno,codead)
!*
%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}
%externalroutinespec EGiveName(%integer Key,%stringname S)
%externalintegerfnspec Egiveareaid(%integer Area)
%externalroutinespec Enote CC(%integer Cond)
%externalroutinespec EPushOperand(%record(Stkfmt)%name Stk)
%externalroutinespec Stackr(%integer Reg,Bytes)
%externalroutinespec Stackfr(%integer Reg,Bytes)
%externalroutinespec Estklit(%integer Val)
%externalintegerfnspec Estackspace(%integer bytes)
%externalintegerfnspec Eglaspace(%integer bytes)
%externalintegerfnspec Estkrecad(%integer level)
%externalroutinespec Free V temps
%externalintegerfnspec Vtempspace(%integer reg,elsize)
%externalroutinespec Unlock Vr1
%externalroutinespec Release V Loop Regs
%extrinsicinteger Vloopreg    { -1 or R7 marks in/out of V loop }
!*
!*
%constinteger YES = 1
%constinteger NO  = 0
!*
%constinteger FRAGMIN = 28
!*
!***********************************************************************
!*
%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 VRegVal        = 24        {  (Vreg)     }
%constinteger VFregval       = 25
%constinteger RegVar         = 29        {  var in reg }
%constinteger RegPtr         = 30        {  ptr in reg }
!*
%constinteger Regflag       = 32  {used to speedup search for reguse}
!*
%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 vr1=17
%constinteger vr2=18
%constinteger vr3=19
%constinteger vr4=20
%constinteger vr5=21
%constinteger vr6=22
%constinteger vr7=23
!*
%constinteger Addr at = 5
%constinteger Addr of = 2
%constinteger Data at = 1
%constinteger Scale1 = 6
%constinteger Scale2 = 7
%constinteger Scale3 = 8
!*
!*
%conststring(3)%array Rtext(0:23) = %c
   "r0","r1","r2","r3","r4","r5","r6","r7",
   "br0","br1","br2","br3","br4","br5","br6","br7",
   "***","vr1","vr2","vr3","vr4","vr5","vr6","vr7"
!*
%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
!*
%externalintegerfnspec GetVLoopreg(%integer size)
%externalbyteintegerarray 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,ADI,MPI,DVI,0,0,0,CI
!*
!*
%recordformat fragfmt(%shortinteger labindex,size,%integer ca,base,fix,labs,
                      (%integer labrefkey %or %shortinteger labrefindex,jsize),
                      %integer chain,
                      %shortintegerarray h(0:2033))
%recordformat lrecfmt(%integer key,addr,procbase,chain)
%recordformat linefmt(%integer fragad,adj)
!*
%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 fixadjheads(0:255)
%ownintegerarray linerecheads(0:255)
%ownintegerarray labrecheads(0:255)
%ownintegerarray swrecheads(0:31)
%ownintegerarray exrecheads(0:31)
%ownintegerarray exfixrecheads(0:31)
%ownintegerarray Retframekeys(0:63)
%ownrecord(areckeyfmt)%array areakey(0:511)
!*
%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,Ep)
!*
%recordformat Exfixfmt(%integer id,area,offset)
!*
%ownintegerarray labtag(0:15)
!*
%owninteger language
!*
%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 setlineno
%owninteger setdbx
%owninteger diagoffset
!*
%owninteger Numexnames
%owninteger Numexrefs
%owninteger Numfixexrefs
%owninteger Numswkeys
%owninteger Numretframes
%owninteger Numareakeys
%owninteger Numconstrecs
!*
%owninteger primeclist,clist,reglist
%owninteger Startinstr
%owninteger Nextlabtag,Labadjust,Procdepth
%owninteger Nextplabel
%owninteger Noteoptions
%owninteger unsafeproc
%owninteger notesave1,notesave2
%owninteger noterestore1,noterestore2
%owninteger saveoffset1,saveoffset2,regs saved
%owninteger Usefardata
%owninteger New Parstart = 8     {offset from br3 of first actual param loc}
!*
%owninteger br3set
!*
%owninteger Proclevel
%owninteger Procbaseca
%owninteger frozenca
%owninteger OldProcbaseca
%owninteger NextParamOffset
%ownintegerarray Noteprocca(0:15)
%ownintegerarray Noteretframes(0:15)
%ownintegerarray Notecallparsize(0:15)
%ownintegerarray Noteparsize(0:15)
%ownintegerarray Notefixadj(0:15)
%owninteger Fixadjstart
%owninteger Save Basead
%owninteger Nextfixadj
%owninteger clevel
%ownintegerarray coffset(0:15)
%ownintegerarray csavespace(0:15)
%ownintegerarray codeaddress(0:15)
!*
%externalintegerarray reguse(0:23)
%externalintegerarray regdata(0:23)
%ownintegerarray regpair(0:23)
%ownintegerarray breguse(8:15)
%ownintegerarray regsused(0:23)
%ownintegerarray r6load(0:31)
%ownintegerarray r6store(0:31)
%owninteger Lastbreg
%owninteger r6locked,r7locked,keycommon,r6used,r7saved,r6stcount,r6ldcount
%owninteger lastlineout,saveparamptr,paramptrset,paramregset
%owninteger f77basefrag,f77baseoffset
!*
%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)
%routinespec eafix(%integer area,offset)
%routinespec V release reg(%integer reg)
%routinespec V release reg pair(%integer reg)
!*
%integerfnspec Get Reg(%integer use,area,offset)
%integerfnspec claim reg
%integerfnspec claim pos reg
%integerfnspec checkregkey(%integer use,area,offset)
%integerfnspec Get Prockey(%stringname S)
%routinespec Lock Reg(%integer Reg)
%routinespec Unlock Reg(%integer Reg)
%routinespec Check Conflict(%integer Base,Offset,Size)
%routinespec codew(%integer h0,h1)
%routinespec Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%routinespec Gop RR(%integer Op,Dreg,Sreg)
%routinespec Gop R(%integer Op,Reg)
%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 Gop Call(%integer Id,Paramsize,numpars,Xlevel)
%routinespec Gop Jump(%integer Op,Label)
%integerfnspec areakeyref(%integer area,offset)
%routinespec Mretframe
%integerfnspec Load Dreg(%integer reg, %record(stkfmt) %name stk)
%externalroutinespec spcall(%integer i)
!*
%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)
      %result=J
%end
!*
%integerfn fixrecad(%integer index)
%integer Scale,I,J
      Scale = 3
      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 fixadjad(%integer index)
%integer Scale,I,J
      Scale = 2
      I=index>>10;! units of 1024 entries (4K bytes)
      J=fixadjheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         fixadjheads(I)=J
      %finish
      %result=J+(index&x'3ff')<<Scale
%end;! fixadjad
!*
%integerfn linerecad(%integer index)
%integer Scale,I,J
      Scale = 3
      I=index>>9;! units of 512 entries (4K bytes)
      J=linerecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         linerecheads(I)=J
      %finish
      %result=J+(index&x'1ff')<<Scale
%end;! linerecad
!*
%integerfn labrecad(%integer index)
%integer Scale,I,J
      Scale = 16
      I=index>>10;! units of 1024 entries (16K bytes)
      J=labrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(x'4000')
         labrecheads(I)=J
      %finish
      %result=J+(index&x'3ff')*Scale
%end;! labrecad
!*
%integerfn swrecad(%integer index)
%integer Scale,I,J
      Scale = 3
      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
      Scale = 44
      I=index>>6;! units of 64 entries (2816 bytes)
      J=exrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(2816)
         exrecheads(I)=J
      %finish
      %result=J+(index&x'3f')*Scale
%end;! exrecad
!*
%integerfn exfixrecad(%integer index)
%integer Scale,I,J
      Scale =16 
      I=index>>8;! units of 256 entries (4096 bytes)
      J=exfixrecheads(I)
      %if J=0 %thenstart
         J=Malloc Space(4096)
         exfixrecheads(I)=J
      %finish
      %result=J+(index&x'ff')*Scale
%end;! exfixrecad
!*
!*
!***************************************************************************
!*            initialisation                                               *
!***************************************************************************
!*
!*
%externalroutine Clear Regs
%integer I,lim
   %if r6locked#0 %then lim=r5 %else lim=r7
   %cycle I=r0,1,lim
      reguse(I)=0
      regdata(I)=0
   %repeat
   br3set=0  
   %cycle I=br3,1,br7
      breguse(I)=0
   %repeat
   Lastbreg=0
%end;! Clear Regs
!*
%externalroutine Dump Regs(%integer dlevel)
%integer I,J,K
%string(31) S
      %if reglist#0 %then Dlevel=1
      %cycle I=r0,1,Vr7
         J=reguse(I)
         %if J#0 %thenstart
            !%if dlevel=0 %and J>0 %then %continue
            %if i >=vr1 %start
               printstring("vr")
            %finishelsestart
               printsymbol('r')
            %finish
            printsymbol('0'+I&7)
            %if J<0 %thenstart
               write(J,3)
               %if regpair(I)<0 %then printstring("**")
            %finishelsestart
               %if J=3 %thenstart
                  printstring("   lit val ")
                  write(regdata(I),1)
               %finishelsestart
                  K=regdata(I)
                  %if J=1 %thenstart
                     printstring("   data at  ")  
                   %finishelsestart
                      %if J>5 %thenstart
                         printstring("   scale")
                         write(J-5,1)
                         spaces(2)
                         %if K&X'1FF'=0 %and K>>9<=7 %thenstart
                            printstring("reg")
                            write(K>>9,1)
                            ->next
                         %finish
                      %finishelsestart
                         %if J=5 %then printstring("   addr at  ")  %c
                                 %else printstring("   addr of  ")
                      %finish
                  %finish
                  Egivename(K&X'1FF',S)
                  printstring(S)
		  %if K<0 %thenstart
                     K=(K>>9)!X'FF800000'
                  %finishelsestart
                     K=K>>9
                    printstring("+")
                  %finish
                  write(K,0)
               %finish
            %finish
next:       newline
         %finish
      %if i=r7 %then i=vr1   { skip to vector regs }
      %repeat
      %cycle I=br3,1,br7
         J=breguse(I)
         %if J#0 %thenstart
            printstring("br")
            printsymbol('0'+I&7)
            printstring("  addr at  ")
            Egivename(J&X'1FF',S)
            printstring(S)
	    printstring("+")
            write(J>>9,0)
            newline
         %finish
      %repeat
%end;! Dump Regs
!*
%externalroutine mcodeon
      PrimeClist=YES
%end;! mcodeon
!*
%externalroutine mregon
      reglist=1
%end
!*
%externalroutine mregoff
      reglist=0
%end
!*
%externalintegerfn Pltspace(%integer Len)
%integer I
      I=PLToffset
      PLToffset=I+Len
      %result=I
%end
!*
%externalroutine init mcode(%integer codelist,lang,options)
%integer I
%record(lrecfmt)%name lrec
   language=lang
   Noteoptions=options
   setlineno=0
   setdbx=0
   %if options&X'40'#0 %then Usefardata=1 %else Usefardata=0
   I=options&x'18'
   %if I=x'10' %then setlineno=1 %elsestart
      %if I=x'18' %then setdbx=1
   %finish

   %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
      fixadjheads(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
      exfixrecheads(I)=0
   %repeat
   %cycle I=0,1,15
      codeaddress(I)=0
   %repeat
   PLToffset=16
   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
   nextfixadj=1
   Numexnames=0
   Numexrefs=0
   Numfixexrefs=0
   Numswkeys=0
   Numareakeys=0
   Numconstrecs=0
!!   proc count=0
   New Frag
   Nextlabtag=1000000
   Nextplabel=200000
   Labadjust=0
   Procdepth=0
   r6locked=0
   r7locked=0
   keycommon=-1
   lastlineout=0
%end;! init mcode
!*
%externalintegerfn Tidy Mcode(%integer Level,%integername PLTsize)
%integer I
      I=Tidy Frags(1)
      PLTsize=PLToffset
      %result=I
%end;! Tidy Mcode
!*
%externalroutine Minnerproc(%integer M)
   %if M=0 %thenstart
      Procdepth=Procdepth+1
      Labtag(Procdepth)=Labadjust
      Labadjust=Nextlabtag
      Nextlabtag=Nextlabtag+1000000
   %finishelsestart
      Labadjust=Labtag(Procdepth)
      Procdepth=Procdepth-1
   %finish
%end;! Mnewinnerproc
!*
!*
!***************************************************************************
!*            label and switch processing                                  *
!***************************************************************************
!*
!*
%externalintegerfn Mprivatelabel
%integer I
      I=Nextplabel
      Nextplabel=Nextplabel+1
      %result=I
%end;! Mprivatelabel
!*
%integerfn new label(%integer key,mode)
!* mode = 0  reference
!*        1  definition
%integer I,J
%record(lrecfmt)%name lrec
   I=key&31
   lrec==record(labrecad(I))
   J=lrec_key
   %if J#0 %thenstart
      %if J=key %thenstart
         %if mode=1 %then lrec_addr=maxcodeca
         %result=I
      %finish
      %while lrec_chain#0 %cycle
         I=lrec_chain
         lrec==record(labrecad(I))
         %if lrec_key=key %thenstart
            %if mode=1 %then lrec_addr=maxcodeca
            %result=I
         %finish
      %repeat
      lrec_chain=nextlab
      I=nextlab
      lrec==record(labrecad(I))
      nextlab=nextlab+1
   %finish
   lrec_key=key
   %if mode=1 %then lrec_addr=maxcodeca %else lrec_addr=0
   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,0)
         abortm("missing label definition")
      %finish
   %repeat
   %if lrec_addr=0 %then %result=-I %else %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
      %if Language=Fortran %then Switchid=Switchid+Labadjust
      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
      %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
      Gop Shift Lit(SLL,r1,2)
      Eafix(Plt,0)
      I=Pltoffset
      Pltoffset=I+4
      Md4(Plt,I,Tab_Refad)
      Mfix(Plt,I,4,0)
      Gop RXB(ADM,r1,0,0,I,4)
      Gop RXB(L,r1,0,r1,0,0)
      Gop RXB(BU,0,br1,r1,0,0)
      reguse(r1)=0
%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'10000000' {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
      %if Language=Fortran %then Switchid=Switchid+Labadjust
      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+Labadjust,0)
            %return
         %finish
      %repeat                                                                                                                                  
      abortm("invalid switchid")
%end;! Mswitchlabel
!*
!*
!***************************************************************************
!*            code fragment processing                                     *
!***************************************************************************
!*
!*
%externalroutine Mcode label(%integer label)
%integer save,saved
   %if Clist#0 %thenstart
      printstring("L")
      printstring(Itos(Label+Labadjust))
      printstring(":
")
   %finish
   %if Frag_labindex#0 %or fragoffset#0 %then break frag(0)
   frag_labindex=new label(label+Labadjust,1)
   %if r6locked#0 %and maxcodeca-procbaseca<X'10000' %thenstart
      save=reguse(6)
      saved=regdata(6)
      clear regs
      %if save=addr at %or save=addr at-255 %thenstart
         reguse(6)=save
         regdata(6)=saved
      %finish
   %finishelsestart
      clear regs
   %finish
!*
   %if Language=Fortran %and (label=100001 %or label=100000) %thenstart {remember entry regs}
      %unless label=100001 %and paramregset=0 %then paramregset=1
             {except start of proc with a prologue}
      paramptrset=1
      br3set=1
      reguse(r2)=6 {first param is held here}
   %finishelsestart
      paramregset=0
      paramptrset=0
   %finish
%end;! Mcode label
!*
%externalroutine Mcode Plabel(%integer label)
%integer save,saved
   %if Clist#0 %thenstart
      printstring("L")
      printstring(Itos(Label+Labadjust))
      printstring(":
")
   %finish
   %if Frag_labindex#0 %or fragoffset#0 %then break frag(0)
   frag_labindex=new label(label+Labadjust,1)
%end;! Mcode Plabel
!*
%externalroutine Mline(%integer Lineno)
%record(linefmt)%name linerec
   %if Lineno#0 %thenstart
      Clist=PrimeClist
      %if Clist#0 %thenstart
         printstring("line ")
         printstring(Itos(Lineno))
         newline
      %finish
   %finish
   linerec==record(linerecad(fraglineindex))
   linerec_fragad=curfrag
   linerec_adj=(Lineno<<12)!fragoffset
   fraglineindex=fraglineindex+1
   %if setlineno#0 %and Lineno#0 %thenstart
      Gop RI(LI,r0,Lineno)
      Gop RXB(ST,r0,br2,0,6,2)
      reguse(r0)=0
   %finish
   Free V Temps
%end;! Mline
!*
%routine new frag
%integer balance
{printstring("new frag ");write(nextfrag-curbasefrag,7);write(nextfrag,7);newline}
   balance=curbasefrag+4096-nextfrag
   %if balance<128 %thenstart
      curbasefrag=Malloc Space(4096)
      nextfrag=curbasefrag
      balance=4096
   %finish
   %if curfrag#0 %thenstart
      frag_chain=nextfrag
   %finish
   frag==record(nextfrag)
   curfrag=nextfrag
   frag_labindex=0
   frag_ca=maxcodeca
   frag_base=Procbaseca
   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-32
%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
      frag_h(fragoffset)=X'0002'   {NOOP}
      frag_h(fragoffset+1)=X'0002'   {NOOP}
      fragoffset=fragoffset+2  {allowing space for base load}
      breguse(br6)=0
   %finish
   maxcodeca=maxcodeca+(fragoffset)<<1
   frag_size=fragoffset
   %if frag_fix#0 %thenstart;! set terminator
      fix==record(fixrecad(fragfixindex))
      fix_base=-1
      fragfixindex=fragfixindex+1
   %finish
   Mline(0);! to set terminator
   %if fragoffset&1#0 %thenstart {force alignment}
      frag_h(fragoffset)=X'0002'
      fragoffset=fragoffset+1
      frag_size=fragoffset
      maxcodeca=maxcodeca+2
      %if clist=YES %thenstart
         spaces(8)
         printstring("0002        NOP
")
      %finish
   %finish
   addon=fragoffset<<1
   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,fixad
%integer tgtarea,offset,key
%owninteger procbaseca
%owninteger Nops=X'4e714e71'
%record(fixrecfmt)%name fix
%record(exfixfmt)%name exfix
%record(Swtabfmt)%name Tab
%record(lrecfmt)%name Lrec
%record(linefmt)%name linerec
%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)
      procbaseca=frag_base
      frag_ca=ca
      I=frag_fix
      %if I#0 %thenstart
         fixad=fixrecad(I)
         fix==record(fixad)
         %while fix_base#-1 %cycle
            Tgtarea=fix_base&x'fff'
            Offset=fix_offset
{printstring("tidy ")}
{write(fixad,4);write(tgtarea,4);write(offset,4);newline}
            %if (Tgtarea=0 %and Offset>=0) %or Tgtarea=7 %thenstart
               integer(fixadjad(nextfixadj))=fixad
{printstring("noted ");write(nextfixadj,4);newline}
               nextfixadj=nextfixadj+1
            %finish
            I=I+1
            fixad=fixrecad(I)
            fix==record(fixad)
         %repeat
      %finish
      %if frag_labindex#0 %thenstart;! label on front of fragment
         lrec==record(labrecad(frag_labindex))
         lrec_addr=ca-procbaseca
      %finish
      %if frag_labrefkey#0 %thenstart;! ref to labl in last instruction
         lref=locate label(frag_labrefkey,mode);! returns index
         %if lref<0 %thenstart   {label not yet defined - assume long jump}
            frag_labrefindex=-lref
            frag_jsize=1
         %finishelsestart
            frag_labrefindex=lref
            lrec==record(labrecad(lref))
            %if lrec_addr<X'10000' %thenstart;! standard base is OK
               frag_size=frag_size-2
               frag_jsize=0
            %finishelse frag_jsize=1
         %finish
      %finish
      ca=ca+frag_size<<1
      fragaddr=frag_chain
   %repeat
   fixedca=ca
   %if mode=0 %then %result=ca  { only current address was required }
   Mcodesize(ca)
!*
!* 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)
      procbaseca=frag_base
{write(fragaddr,8);newline}
{dump(fragaddr,frag_size<<1+32)}
      %if frag_labrefindex#0 %thenstart
         lrec==record(labrecad(frag_labrefindex))
         reach=lrec_addr 
         %if reach<X'10000' %thenstart
            %if frag_jsize=0 %then I=1 %else I=3
            frag_h(frag_size-I)<-reach
         %finishelsestart
            J=((reach+procbaseca)>>16)&15  {multiple of 64K from start of code}
            %if codeaddress(J)=0 %thenstart {first such reference}
               codeaddress(J)=PLToffset
               Md4(PLT,PLToffset,J<<16)
               Mfix(PLT,PLToffset,1,0)
               PLToffset=PLToffset+4
            %finish
            I=frag_size-4
            frag_h(I+2)<-(frag_h(I)&X'FFF8')!6
            frag_h(I+3)<-(reach+procbaseca-(J<<16))&X'FFFF'
            frag_h(I)=X'5F00'
            frag_h(I+1)<-codeaddress(J)
            Mfix(1,frag_ca+I<<1,PLT,0)
         %finish
      %finish
      I=frag_fix
      %if I#0 %thenstart
         fix==record(fixrecad(I))
         %while fix_base#-1 %cycle
            Tgtarea=fix_base&x'fff'
            Offset=fix_offset
            %if Tgtarea=x'fff' %thenstart;! relative code fixup
               Tgtarea=Code
               frag_h(fix_base>>12+1)<-frag_ca+(fix_base>>12)<<1+offset-procbaseca
            %finishelsestart
               K=fix_base>>12
               %if Offset#0 %thenstart
                  frag_h(K+1)<-frag_h(K+1)+Offset
                  %if Offset>>16#0 %then frag_h(k)<-frag_h(k)+(Offset>>16)
                  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)
         Procbaseca=frag_base
         %cycle J=0,1,Tab_Entries-1
            K=Tab_R(J)
            %if K>>28=1 %thenstart;! IMP switch
               frag==record(K&X'fffffff')
               Tab_R(J)=frag_ca-Procbaseca
            %finishelsestart
               %unless K=-1 %thenstart
                  %if K<0 %then K=-K
                  Lrec==record(labrecad(K&X'fffffff'))
                  Tab_R(J)=Lrec_addr
                %finish
             %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
         J=0
         %if Exdata_Name="#mcount" %thenstart
            Exdata_Name="mcount"
            J=1
         %finish
         %if Exdata_Name="#udiv" %thenstart
            Exdata_Name="udiv"
            J=1
         %finish
         %if Exdata_Name="#urem" %thenstart
            Exdata_Name="urem"
            J=1
         %finish
         Exdata_Id=Mxname(J,Exdata_Name)
         Mfix(Plt,Exdata_ca,Exdata_Id,0)
      %finish
   %repeat
!*
   %if numfixexrefs>0 %thenstart
      %cycle I=1,1,numfixexrefs
         exfix==record(exfixrecad(I))
         exdata==record(exrecad(exfix_id))
         %if exdata_id=-1 %thenstart
            Md4(exfix_area,exfix_offset,exdata_ep)
            Mfix(exfix_area,exfix_offset,1,0)
         %finishelsestart
            Md4(exfix_area,exfix_offset,0)
            Mfix(exfix_area,exfix_offset,exdata_id,0)
         %finish
      %repeat
   %finish
 !*
{printstring("}
{fragarea}
{")}
{dump(fragstart,256)}
   %result=ca
%end;! tidy frags
!*
%externalintegerfn Mmarker
      Clear Regs {to ensure that a load instruction is generated}
      %result=addr(frag_h(fragoffset))
%end;! Mmarker
!*
%externalintegerfn mgetca(%integer mode)
!* mode = 0   start of proc
!*        1   end of proc or entry
{ force fixing of the size of all jumps to this point so that ca can be noted}
%integer ca
      ca=tidy frags(0)
      %if mode=0 %thenstart
         %if language=Fortran %thenstart
            codew(X'4637',X'3720')
            %if clist#0 %then newline
            diagoffset=Mmarker
            codew(0,0)
            %if clist#0 %then newline
            ca=ca+8
         %finish
         %if language=IMP %thenstart
            codew(X'494D',X'5020')
            %if clist#0 %then newline
            codew(0,0)
            %if clist#0 %then newline
            ca=ca+8
         %finish
      %finish
      frozenca=ca
      fixedfrag=curfrag
      %result=ca
%end;! mgetca
!*
%externalroutine Msetopd(%integer Markerid,New Value)
      shortinteger(Markerid+2)=New Value
%end;! Msetopd
!*
%externalroutine Mprecall
%integer I,J,ad
      clevel=clevel+1
      coffset(clevel)=NextParamOffset
      %if NextParamOffset>32 %thenstart
         I=NextParamOffset-32
         ad=Estackspace(I)
         csavespace(clevel)=ad
         %cycle J=0,4,I-4
            Gop RXB(L,r0,br2,0,32+J,4)
            Eafix(Stack,0)
            Gop RXB(ST,r0,br2,0,ad+J,4)
         %repeat
         reguse(r0)=0
      %finish
      NextParamOffset=32
%end
!*
%externalroutine Mprivatecall
      unsafeproc=1
%end
!*
%externalroutine NP1 Parstart(%integer Offset)
      New Parstart = Offset
%end;! NP1 Parstart
!*
%externalroutine Mstartproc(%integer Props,Level,Paramsize)
!***********************************************************************
!*                                                                     *
!*    PDS thinks props is as follows:?                                 *
!*    2**0     Set if external                                         *
!*    2**1     Set if main entry       (2**31 is used by Fortran!)     *
!*   2**2     Set if display not required (Implied for Fortran & C)    *
!*    2**3      Set if there are no local variables                    *
!*    2**4     Set if ??    PDS has vague memories this was used on PNX*
!*    2**5     Set if there are no internal blocks or procedures       *
!*    2**14    Set if first param is a word                            *
!*    2**15    Set if first param a Dword   Used if Numpars = 1?       *
!*    2**16-2**23   Byte giving nesting level of procedure             *
!***********************************************************************
%integer I,disp
%string(31) S
      %cycle I=0,1,7
         regsused(I)=0
      %repeat
      r6locked=0
      r7locked=0
      saveparamptr=0
      unsafeproc=0;! will be non-zero if there is a call that may corrupt r6,r7
      keycommon=-1
      Numretframes=0
      Procbaseca=frozenca
      Proclevel=Proclevel+1
      Noteprocca(Proclevel)=frozenca
      Noteretframes(Proclevel)=Numretframes
      Notecallparsize(Proclevel)=Callparsize
      Noteparsize(Proclevel)=Paramsize
      Notefixadj(Proclevel)=Fixadjstart
      Fixadjstart=Nextfixadj
{printstring("startproc ");write(fixadjstart,4);newline}
      frag_base=Procbaseca
      codew(0,0)
      %if Clist#0 %then newline
      %if Cpu=NP1 %thenstart
         codew(0,0)
         %if clist#0 %then newline
      %finish
      Gop RXB(SUABR,br2,0,0,0,0)
      %if Cpu=NP1 %thenstart
         br3set=1  {br3 addresses the parameter list}
         paramregset=1  {r2 contains first param}
         Gop RXB(ST,r1,br2,0,8,4)  {save link}
         %if (Language=Fortran %and Paramsize#0) %or Language=Ccomp %thenstart
            Gop RXB(ST,r2,br3,0,New Parstart,4)  {save first param - may be possible to delete}
         %finish
         Gop RXB(STWBR,br3,br2,0,12,0)  {save address of arguments even for Imp (ADB)}
      %finish
      CallParSize=32
      %if Noteoptions&32#0 %or (language=IMP %and comreg(1)=1) %thenstart;! profiling
         I=Eglaspace(8)
         Md4(PLT,PLToffset,I)
         Mfix(PLT,PLToffset,Gla,0)
         Eafix(PLT,PLToffset)
         Gop RXB(L,r1,0,0,0,4)
         PLToffset=PLToffset+4
         Gop RXB(ST,r1,br2,0,32,4)
         S="#mcount"
         I=Get Prockey(S)
         Gop Call(I,4,0,0)
         CallParSize=36
      %finish
      %if Cpu=Concept %thenstart
         %if Language=Fortran %thenstart
            notesave1=Mmarker
            saveoffset1=18;! includes +2 for doubleword ops
            Gop RXB(ST,r4,br2,0,16,8)
            notesave2=Mmarker
            saveoffset2=26
            Gop RXB(ST,r6,br2,0,24,8)
            regs saved=1
         %finishelsestart
            %if Language=Imp %thenstart
               Gop RXB(ST,r6,br2,0,24,8)
            %finish
         %finish
      %finish
      F77basefrag=curfrag
      F77baseoffset=fragoffset
      %if (Language=Fortran %and Noteoptions&X'18'#0) %orc
          ( Language=Imp %and comreg(27)&x'44'=0) %thenstart
         %if Cpu=Concept %thenstart
            I=8
         %finishelsestart    {NP1}
            I=20       {use static link location for gla pointer}
         %finish
         Mfix(PLT,PLToffset,Gla,0)
         Eafix(PLT,PLToffset)
         Gop RXB(L,r0,0,0,0,4)
         PLToffset=PLToffset+4
         Gop RXB(ST,r0,br2,0,I,4)
      %finish
      %if Language=Ccomp %then %return
      %if Language=IMP %and Paramsize#0 %and Props&2****5=0 %thenstart {copy params to frame}
         I=0
         %while I<Paramsize %cycle
            %if Cpu=Concept %thenstart
               Eafix(Params,0)
               Gop RXB(L,r0,br2,0,I,4)
            %finishelsestart  {NP1}
               Gop RXB(L,r0,br3,0,I+8,4)
            %finish
            Eafix(Stack,0)
            Gop RXB(ST,r0,br2,0,I,4)
            I=I+4
         %repeat
      %finish
      %if Props&4=0 %thenstart  { display required }
         disp=4
         %cycle I=2,1,Level
            %if Cpu=Concept %thenstart
               Gop RXB(L,r0,0,r1,disp,4)
            %finishelsestart
               Gop RXB(L,r0,0,r7,disp,4)
            %finish
            eafix(Stack,0)
            Gop RXB(ST,r0,br2,0,Paramsize+disp,4)
            disp=disp+4
         %repeat
         %if Props&2****5 =0 %Start;     ! Add this frame to display for inners
            Eafix(Stack,0)
            Gop RXB(LA,r0,br2,0,0,0)
            Eafix(Stack,0)
            Gop RXB(ST,r0,br2,0,Paramsize+disp,0)
         %finish
      %finish
%end;! Mstartproc
!*
%externalroutine Msideentry(%integer ca)
%integer I
      codew(0,0)
      %if Clist#0 %then newline
      %if Cpu=NP1 %thenstart
         codew(0,0)
         %if clist#0 %then newline
      %finish
      Gop RXB(SUABR,br2,0,0,0,0)
      mretframe
      %if Cpu=NP1 %thenstart
         Gop RXB(ST,r1,br2,0,8,4)  {save link}
         Gop RXB(STWBR,br3,br2,0,12,0)  {save address of arguments}
      %finishelsestart
         Gop RXB(ST,r4,br2,0,16,8)
         Gop RXB(ST,r6,br2,0,24,8)
      %finish
      Eafix(PLT,0)
      Gop RXB(LWBR,br1,0,0,Save Basead,0)
      %if Language=Fortran %and Noteoptions&X'18'#0 %thenstart
         %if Cpu=Concept %thenstart
            I=8
         %finishelsestart    {NP1}
            I=4       {use exception handler location for gla pointer}
         %finish
         Mfix(PLT,PLToffset,Gla,0)
         Eafix(PLT,PLToffset)
         Gop RXB(L,r0,0,0,0,4)
         PLToffset=PLToffset+4
         Gop RXB(ST,r0,br2,0,I,4)
      %finish
      clear regs
%end;! Msideentry
!*
%externalroutine Mtidyproc(%integer Markerid,Localsize,Diagdisp,
                           %integername noteca)
%integer I,J,Saveretframes,ca,tgtarea,mask
%record(linefmt)%name linerec
%record(fixrecfmt)%name fix
      New Parstart = 8  {reset for next Fortran proc}
      %if language=Fortran %thenstart
         %if diagoffset#0 %then Msetopd(Diagoffset,Diagdisp)
      %finish
      %if Cpu=Concept %thenstart
         mask=-8
      %finishelsestart  {NP1}
         mask=-16
      %finish
      localstacksize=(localsize-mask+1)&(mask)
      Callparsize=(Callparsize-mask+1)&(mask)
      Framesize=localstacksize+callparsize
      Msetopd(Markerid,Framesize)
      %if Cpu=Concept %thenstart
         Msetopd(Markerid+4,Framesize)
      %finishelsestart
         Msetopd(Markerid+8,Framesize)  {allowing for additional pointer}
      %finish
 %if Cpu=Concept %thenstart
     %if Language=Fortran %thenstart
         %if notesave1>0 %then Msetopd(notesave1,Framesize+saveoffset1)
         %if noterestore1>0 %then Msetopd(noterestore1,Framesize+saveoffset1)
         %if notesave2>0 %then Msetopd(notesave2,Framesize+saveoffset2)
         %if noterestore2>0 %then Msetopd(noterestore2,Framesize+saveoffset2)
      %finish
 %finish
      Saveretframes=Noteretframes(Proclevel)
      %while Numretframes>Saveretframes %cycle
         Msetopd(Retframekeys(Numretframes),Framesize)
         Numretframes=Numretframes-1
      %repeat
      ca=mgetca(1)
      noteca=ca
      OldProcbaseca=Procbaseca
      I=Fixadjstart
{printstring("tidyproc ");write(fixadjstart,4);write(nextfixadj,4)}
{newline}
      %while i<Nextfixadj %cycle
         fix==record(integer(fixadjad(I)))
         tgtarea=fix_base&x'fff'
         %if tgtarea=0 %thenstart
            Fix_Offset=Fix_Offset+Callparsize
         %finishelsestart
            %if tgtarea=7 %then Fix_Offset=Fix_Offset+Framesize+32
         %finish
{write(i,4);write(tgtarea,4);write(fix_offset,4);newline}
         I=I+1
      %repeat
      Nextfixadj=Fixadjstart
      Fixadjstart=Notefixadj(Proclevel)
      Callparsize=Notecallparsize(Proclevel)
      Numretframes=Saveretframes
      Proclevel=Proclevel-1
      Procbaseca=Noteprocca(Proclevel)
      frag_base=Procbaseca
      %if Language=Fortran %and setdbx#0 %thenstart
         I=lastlineout+1
         lastlineout=fraglineindex-1
         %while I<fraglineindex %cycle
            linerec==record(linerecad(I))
            frag==record(linerec_fragad)
            J=linerec_adj
            Mlinestart(J>>12,frag_ca+(J&x'fff')<<1)
            I=I+1
         %repeat
      %finish
%end;! Mtidyproc
!*
%externalintegerfn Get Paradjust
!* returns adjustment required for parameter offset in dbx records
      %result=(Callparsize+7)&(-8) + 32
%end;! Get Paradjust
!*
%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 Get Procref(%integer Id)
%record(exdatafmt)%name exdata
%integer Reg
      exdata==record(exrecad(Id))
      Reg=claim reg
      Eafix(Plt,0)
      Gop RXB(L,Reg,0,0,exdata_ca,4)
      %result=Reg
%end;! Get procref
!*
%externalroutine Mset Procref(%integer Area,Offset,%string(255)%name S)
%record(exfixfmt)%name exfix
%integer Id
      Id=Get Prockey(S)
      numfixexrefs=numfixexrefs+1
      exfix==record(exfixrecad(numfixexrefs))
      exfix_id=Id
      exfix_area=Area
      exfix_offset=Offset
%end;! Mset Procref
!*
%externalintegerfn Note Entry(%stringname S,%integer Key,Ca,Main)
%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_Ep=ca
      Exdata_Id=-1
      %if Main#0 %then Savebasead=Exdata_ca
      %result=I
%end;! Note Entry
!*
%externalroutine Msetconst(%integer Ad,Len,%integername Area,Offset)
      Area=Plt
      %if Len=8 %and Pltoffset&4#0 %then Pltoffset=Pltoffset+4
      Offset=PLToffset
      Mdbytes(Plt,PLToffset,Len,Ad)
      PLToffset=PLToffset+((Len+3)>>2)<<2
%end;! Msetconst
!*
!*
!***************************************************************************
!*            procedures for generating fragments of code                  *
!***************************************************************************
!*
!*
%externalroutine 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
!*
%externalroutine codew(%integer h0,h1)
!write(fragoffset,1)
   %if fragoffset>=fragoffsetlim %then break frag(0)
   %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
!*
%externalroutine eafix(%integer area,offset)
%record(fixrecfmt)%name fix
%integer tracefix,fragdisp
   %if fragoffset>=fragoffsetlim %then break frag(0)
   tracefix=0
   %if tracefix#0 %thenstart
      printstring("eafix")
      write(fragoffset,1)
      write(area,4)
      write(offset,4)
      newline
   %finish
   NoteArea=area
   NoteOffset=offset
   fragdisp=fragoffset
   %if fragdisp&1#0 %then fragdisp=fragdisp+1  {next inst will be aligned}
   %if frag_fix=0 %then frag_fix=fragfixindex
   fix==record(fixrecad(fragfixindex))
   fix_base=fragdisp<<12!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
         ad=ad+4
         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(7-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(7-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(7-length(S))
      printstring("L")
      printstring(itos(Label))
      newline
%end;! TextLab

%routine TextRegLab(%integer op,reg,label)
%string(7) s
      s=mnem(op)
      printstring(s)
      spaces(7-length(s))
      printstring(rtext(reg))
      printstring(" , L")
      printstring(itos(label))
      newline
%end

!*
%stringfn TextArea(%integer Area,Offset)
%string(31) S
      EGiveName(Area,S)
      %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'ffff0000')!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'ffff0000')
      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
A(Zust):
A(Ust):
A(Sst):  RegOffset=areakeyref(Area,Offset)
         Reg=checkregkey(addr at,Plt,RegOffset)
         %if Reg>0 %and Reg#6 %and Area=Keycommon %and Offset=0 %thenstart
            reguse(Reg)=0
            Reg=-1
         %finish
         %if Reg<=0 %thenstart
            %if Area=Keycommon %and reguse(6)>=0 %then Reg=6 %else Reg=claim pos reg
            Locate(Plt,RegOffset,Index,Base)
            Gop RXB(L,Reg,Base,Index,RegOffset,4)
            %if Index#0 %then unlock reg(Index)
            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(Params):
      %if Cpu=NP1 %thenstart
         %if br3set=0 %thenstart
            Gop RXB(LWBR,br3,br2,0,12,0)
            br3set=1
         %finish
         %if paramptrset=0 %then saveparamptr=1 {to avoid elimination of store}
         Offset=Offset+New Parstart
         Index=0
         Base=br3
         %return
      %finish
A(Stack):
A(Plt):
Near: %if fragoffset&1#0 %then Gop(NOP)
      Eafix(Area,0)
      Index=0
      Base=0
      %return
!*
A(Gla):
A(Iotab):
      %if Usefardata#0 %then ->A(UST)
      ->Near
!*
A(Code):
A(Diags):
      %monitor;%stop
!*
A(*): 
      %monitor;%stop
%end;! Locate
!*
%externalroutine Fprologue
      br3set=1
%end;! Fprologue
!*
%externalroutine Mr7updated
%integer I
      R7saved=0
      %cycle I=r1,1,r6
         %if Scale1<=reguse(I)<=Scale3 %thenstart
            %if regdata(I)=r7<<9 %or regdata(I)=4 %then reguse(I)=0
         %finish
      %repeat
%end;! Mr7updated
!*
%externalroutine Moptreguse(%integer reg,use)
%integer index,base,I
      R7saved=0
      %if reg=r7 %thenstart
         r7locked=use
         reguse(reg)=0
         regdata(reg)=0
         regsused(7)=1
         Mr7updated
         %return
      %finish
      %if reg=r6 %thenstart
         %if use>0 %and reguse(r6)>=0 %and maxcodeca-frag_base<X'10000' %thenstart
            keycommon=use
            locate(use,0,index,base)
            r6locked=1
            regsused(6)=1
            r6used=0
         %finishelsestart
            keycommon=-1
            reguse(r6)=0
            regdata(r6)=0
            %if r6used=0 %thenstart
               %if r6stcount>0 %thenstart
                  %cycle I=0,1,r6stcount-1
                     shortinteger(r6store(I))<-x'd782'
                     shortinteger(r6store(I)+2)=x'14'
                  %repeat
               %finish
               %if r6ldcount>0 %thenstart
                  %cycle I=0,1,r6ldcount-1
                     shortinteger(r6load(I))<-x'b782'
                     shortinteger(r6load(I)+2)=x'14'
                  %repeat
               %finish
            %finish
         %finish
         r6stcount=0
         r6ldcount=0
         %return
      %finish
       %monitor
%end;! Moptreguse
!*
%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
      %finishelse regpair(Reg)=0
%end;! Note Reguse
!*
%externalroutine Reset Reguse(%integer Old,New)
%integer I,lim
      %if r7locked#0 %thenstart
         {%if r6locked#0 %then} lim=r5 {%else lim=r6} 
      %finishelse lim=r7
      %cycle I=r0,1,lim
         %if reguse(I)=-Old %thenstart
            reguse(I)=-New
            %if regpair(I)<0 %and reguse(I+1)=-Old %thenstart
               reguse(I+1)=-New
            %finish
            %return
         %finish
      %repeat
      %cycle I=vr1,1,vr7
         %if reguse(I)=-Old %start
            reguse(I)=-New
            %if regpair(I)<0 %and reguse(I+1)=-Old %then reguse(I+1)=-New
            %return
         %finish
      %repeat
%end;! Reset Reguse
!*
%externalroutine lock reg(%integer Reg)
      reguse(Reg)=-255
%end;! lock reg
!*
%externalroutine unlock reg(%integer Reg)
%integer I
      %if reg=Vr1 %then Unlock Vr1
      I=reguse(Reg)
      %if I<0 %thenstart
         %if I<=-240 %thenstart
            reguse(Reg)=I+255
         %finishelse reguse(Reg)=0
      %finish
{printstring("Unlock: ");write(Reg,4);write(I,4);newline}
%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)
      reguse(Reg)=0
      reguse(Reg+1)=0
      regpair(Reg)=0
      regpair(Reg+1)=0     
%end;! unlock reg pair
!*
%externalroutine release reg pair(%integer Reg)
!***********************************************************************
!* store the content of register pair Reg in temp space, modifying     *
!* Estack entries as necessary                                         *
!***********************************************************************
%integer I,disp,Form
%record(Stkfmt)%name Lstk
      %if reg>=Vr1 %then V release reg pair(reg) %and %return
      I=-reguse(Reg);! was held as -Elevel
      disp=Estackspace(8)
      Lstk==record(Estkrecad(I))
      %if Lstk_Reg=Reg %thenstart
         Form=Lstk_Form&31
         %if Form=RegVal %or Form=FregVal %thenstart
            Lstk_Form=DirVal
         %finish
         Lstk_Offset=disp
         Lstk_Base=Stack
Store:   Eafix(Stack,0)
         Gop RXB(ST,Reg,br2,0,disp,8)
         unlock reg pair(Reg)
         %return
      %finish
abort:abortm("release reg pair")
%end;! release reg pair
!*
%externalroutine V release reg pair(%integer Reg)
!***********************************************************************
!* store the content of register pair Reg in temp space, modifying     *
!* Estack entries as necessary                                         *
!***********************************************************************
%integer I,disp,Form
%record(Stkfmt)%name Lstk
      I=-reguse(Reg);! was held as -Elevel
      disp=VTempspace(reg,8)
      %if reguse(reg)<=0 %and reguse(reg+1)<=0 %start
	 reguse(reg)=0
	 reguse(reg+1)=0
	 %return
      %finish
      Lstk==record(Estkrecad(I))
       %if Lstk_Reg=Reg %thenstart
         Form=Lstk_Form&31
         %if Form=V RegVal %or Form=V FregVal %thenstart
            Lstk_Form=DirVal
         %finish
         Lstk_Offset=disp
         Lstk_Base=Stack
Store:   Eafix(Stack,0)
         Gop RXB(STV,Reg,br2,0,disp,8)
         unlock reg pair(Reg)
         %return
      %finish
abort:abortm("V release reg pair")
%end;! V release reg pair
!*
%externalroutine release reg(%integer Reg)
!***********************************************************************
!* store the content of general register Reg in temp space, modifying  *
!* Estack entries as necessary                                         *
!***********************************************************************
%integer I,disp,Form
%record(Stkfmt)%name Lstk
      %if reg>=Vr1 %then V release reg(reg) %and %return
      I=-reguse(Reg);! was held as -Elevel
      %if I<=0 %thenstart
         reguse(Reg)=0
         %return
      %finish
      disp=Estackspace(4)
      %if Reg&1#0 %and regpair(Reg)<0 %then Reg=Reg-1
      Lstk==record(Estkrecad(I))
      %if Lstk_Reg=Reg %thenstart
         %if Lstk_Size=8 %and regpair(Reg)<0 %thenstart
            release reg pair(Reg)
            %return
         %finish
         Form=Lstk_Form&31
         %if Form=RegVal %or Form=Fregval %thenstart
            Lstk_Form=DirVal
         %finishelsestart
            %if Form=IndRegVal %or Form=RegAddr %or Form=RegModAddr  %c
                            %or Form=IndRegModVal %thenstart
               Lstk_Form=Form+1
            %finishelse ->Chkmod
         %finish
         Lstk_Offset=disp
         Lstk_Base=Stack
Store:   Eafix(Stack,0)
         Gop RXB(ST,Reg,br2,0,disp,4)
         reguse(Reg)=0
         %return
      %finishelsestart
Chkmod:  %if Lstk_Modreg=Reg %thenstart
            Form=Lstk_Modform&31
            %if Form=RegVal %thenstart
               Lstk_Modform=DirVal
            %finishelsestart
               %if Form=IndRegVal %thenstart
                  Lstk_Modform=IndTempVal
               %finishelse ->abort
            %finish
            Lstk_Modoffset=disp
            Lstk_Modbase=Stack
            ->Store
         %finish
      %finish
abort:abortm(" release reg")
%end;!  release reg
!*
%externalroutine V release reg(%integer Reg)
!***********************************************************************
!* store the content of general register Reg in temp space, modifying  *
!* Estack entries as necessary                                         *
!***********************************************************************
%integer I,disp,Form
%record(Stkfmt)%name Lstk
      %if reg=Vr1 %and reguse(VR1)#0 %start
         disp=Vtempspace(Vr1,4)
         ->store
      %finish
      I=-reguse(Reg);! was held as -Elevel
      %if I<=0 %thenstart
         reguse(Reg)=0
         %return
      %finish
      disp=Vtempspace(reg,4)
      %if Reg&1#0 %and regpair(Reg)<0 %then Reg=Reg-1
      Lstk==record(Estkrecad(I))
      %if Lstk_Reg=Reg %thenstart
         %if Lstk_Size=8 %and regpair(Reg)<0 %thenstart
            V release reg pair(Reg)
            %return
         %finish
         Form=Lstk_Form&31
         %if Form=V RegVal %or Form=V Fregval %thenstart
            Lstk_Form=DirVal
         %finish
         Lstk_Offset=disp
         Lstk_Base=Stack
Store:   Eafix(Stack,0)
         Gop RXB(STV,Reg,br2,0,disp,4)
         reguse(Reg)=0
         %return
      %finish
abort:abortm("V release reg")
%end;! V release reg
!*
%externalroutine Freeregs
!***********************************************************************
!* dump any regs which will not survive a procedure call               *
!***********************************************************************
%integer reg

      Release V Loop Regs

      %if Vloopreg>=0 %start   { in a vector Loop }
         %cycle reg=vr1,1,vr7
           %if reguse(reg)<0 %start
               %if regpair(reg)<0 %then V release reg pair(reg) %c
                                  %else V release reg(reg)
            %finish
         %repeat

         %if Vloopreg>=0 %start
            { Save vector length ( VE ). }
            release reg(R6)
            Gop R(TRVER,R6)     { put it in r6 so STD will save r6 and r7}
        %finish
      %finish

      %cycle reg=r0,1,r7
         %if reguse(reg)<0 %thenstart
            %if regpair(reg)<0 %then release reg pair(reg)  %c
                               %else release reg(reg)
         %finish
      %repeat
%end;! Freeregs
!*
%externalintegerfn V Claim reg
%integer reg

   %cycle reg=vr2,1,vr7
      %if reguse(reg)=0 %start 
   note: reguse(reg)=-255
         regdata(reg)=0
         regsused(reg)=1
         %result=reg
      %finish
   %repeat

   %cycle reg=vr2,1,vr7
     %if reguse(reg)>0 %then ->note
  %repeat

  %cycle reg=vr2,1,vr7
      %if reguse(reg)>-240 %then V release reg(reg) %and ->note
  %repeat
   abortm("all Vector regs locked")
%end
!*
%externalintegerfn claim reg
%integer reg,lim
      %if r7locked#0 %thenstart
         {%if r6locked#0 %then} lim=r5 {%else lim=r6} 
      %finishelse lim=r7
      %cycle reg=r1,1,r3
         %if reguse(reg)=0 %then ->Note
      %repeat
!*
      %if reguse(0)=0 %thenstart
         reg=0
note:    reguse(reg)=-255
         regdata(reg)=0
         regsused(reg)=1
         %result=reg
      %finish
!*
      %cycle reg=r4,1,lim
         %if reguse(reg)=0 %then ->Note
      %repeat
!*
      %cycle reg=r0,1,lim
         %if reguse(reg)>0 %then ->note
      %repeat
!*
      %cycle reg=r0,1,lim
         %if reguse(reg)>-240 %then release reg(Reg) %and ->note
      %repeat
!*
      abortm("all regs locked")
   %result=0
%end;! claim reg
!*
%externalintegerfn claim pos reg
%integer reg,lim
      %if r7locked#0 %thenstart
         {%if r6locked#0 %then} lim=r5 {%else lim=r6} 
      %finishelse lim=r7
      %cycle reg=r1,1,r3
         %if reguse(reg)=0 %thenstart
note:       reguse(reg)=-255
            regdata(reg)=0
            regsused(reg)=1
            %result=reg
         %finish
      %repeat
!*
      %cycle reg=r1,1,r3
         %if reguse(reg)=1 %and regdata(reg)&x'1ff'=7 %then ->note  {param}
      %repeat
!*
      %cycle reg=r4,1,lim
         %if reguse(reg)=0 %then ->note
      %repeat
!*
      %cycle reg=r1,1,lim
         %if reguse(reg)>0 %then ->note
      %repeat
!*
      %cycle reg=r1,1,lim
         %if reguse(reg)>-240 %then release reg(Reg) %and ->note
      %repeat
!*
      abortm("all regs locked")
   %result=0
%end;! claim pos 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,lim
      %if r7locked#0 %or r6locked#0 %then lim=4 %else lim=6
      %cycle I=0,2,lim
         %if reguse(I)=0 %and reguse(I+1)=0 %thenstart
Set:        Reguse(I)=-255
            Reguse(I+1)=-255
            regsused(I)=1
            regsused(I+1)=1
            %result=I
         %finish
      %repeat
      %cycle I=0,2,lim
         %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)>-240 %and reguse(I+1)>-240 %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
!*
%externalintegerfn V Claim reg pair(%integer mode)
!************************************************************
!*  Mode =0  Provide a vector reg pair only if completely free
!*************************************************************
%integer i
   %cycle i=vr2,2,vr6
      %if reguse(i)=0 %and reguse(i+1)=0 %start
set:     reguse(i)=-255
         reguse(i+1)=-255
         regsused(i)=1
         regsused(i+1)=1
         %result=i
     %finish
   %repeat
   %cycle i=vr2,2,vr6
      %if reguse(i)>=0 %and reguse(i+1)>=0 %then ->set
   %repeat
   %if mode=0 %then %result=-1
   %cycle i=vr2,2,vr6
      %if reguse(i)>-240 %and reguse(i+1)>-240 %start
         %if reguse(i)<0 %then release reg(i)
         %if reguse(i+1)<0 %then release reg(i+1)
         ->set
      %finish
   %repeat
   abortm(" Cannot claim vector register pair ")
%end

!*
!*
%externalintegerfn 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                                       *
!*       6  first argument (NP1)                                           *
!* attempts are made to exploit existing content                           *
!* allocated registers are locked with reguse = use-255                    *
!***************************************************************************
%integer reg,info
%record(Stkfmt) Stk
      %if Cpu=NP1 %thenstart
         %if use=Data at %and area=7 %and offset=0 %thenstart
            %if reguse(2)=6 %and paramregset#0 %thenstart
               reguse(2)=-249
              %result=2
            %finish
         %finish
      %finish
      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
               %if reg=r6 %and r6locked#0 %then r6used=1
               %result=reg
            %finish
         %finish
      %repeat
      %result=-1
%end;! Checkregkey
!*
%externalintegerfn V 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                                       *
!*       6  first argument (NP1)                                           *
!* attempts are made to exploit existing content                           *
!* allocated registers are locked with reguse = use-255                    *
!***************************************************************************
%integer reg,info
%record(Stkfmt) Stk
      %if Cpu=NP1 %thenstart
         %if use=data at %and area=7 %and offset=0 %thenstart
            %if reguse(vr2)=6 %and paramregset#0 %thenstart
               reguse(vr2)=-249
              %result=vr2
            %finish
         %finish
      %finish
      info=(offset<<9)!area
      %cycle reg=vr2,1,vr7
         %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,4 or 8 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<=8 %then Abortm("Size error")
   %if bytes<=4 %thenstart
      %if Form=RegVal %or Form=RegAddr %or Form=FregVal %thenstart
         %if Reg<0 %or Reg=Stk_Reg %thenstart
            %if Stk_Reg=r7 %and Reg<0 %and r7locked#0 %thenstart
               Reg=claim reg
               Gop RR(TRR,Reg,r7)
               unlock reg(r7)
               Stk_Reg=Reg
            %finish
            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 Bytes=4 %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 %thenstart
         %if Reg=-3 %then Reg=claim pos reg %else Reg=claim reg
      %finish
      Gop RX(L,Reg,Stk)
   %finishelsestart   { I*8 }
      Reg=Load Dreg(reg,stk)
      reguse(Reg+1)=-255
   %finish
   %if Form=DirVal %and Bytes=4 %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)
!***********************************************************************
!* Stk describes an 8 byte integer or real value                       *
!* if Reg is >= 0 then this register must be loaded                    *
!* result is the register pair to which the value has been loaded      *
!***********************************************************************
%integer Bytes,Reg1,Form,Value
      Form=Stk_Form&31
      Bytes=Stk_Size
      %if Form=RegVal %or Form=FregVal %thenstart
         %if Reg<0 %or Reg=Stk_Reg %thenstart
            lock reg pair(Stk_reg)
            %result=Stk_Reg
         %finishelsestart;! prescribed register
            Reg1=Stk_Reg
Rcopy:      Gop RR(TRR,Reg,Reg1)
            Gop RR(TRR,Reg+1,Reg1+1)
            unlock reg pair(Reg1)
            lock reg pair(Reg)

            %result=Reg
         %finish
      %finish
      %if Reg<0 %then Reg=claim reg pair(1)
      Gop RX(L,Reg,Stk)
      %result=Reg
%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)
%integer Reg1
      %if Stk_Size=4 %thenstart
         %if Newsize=8 %and Reg=-1 %and Stk_Form&31=Fregval %thenstart
            Reg=Stk_Reg
            %if Reg&1=0 %and reguse(Reg+1)>=0 %thenstart
               Gop R(ZR,Reg+1)
               Note Reguse(Reg,-255,8)
               %result=Reg
            %finishelsestart
               %if Reg&1=1 %and reguse(Reg-1)>=0 %thenstart
                  Gop RR(TRR,Reg-1,Reg)
                  Gop R(ZR,Reg)
                  Note Reguse(Reg-1,-255,8)
                  %result=Reg-1
               %finish
            %finish
         %finish
         %if Newsize=8 %thenstart
            Reg1=claim reg pair(1)
            Reg=Load Reg(Reg,Stk)
            Gop RR(TRR,Reg1,Reg)
            unlock reg(Reg)
            Gop R(ZR,Reg1+1)
            %result=Reg1
         %finish
         Reg=Load Reg(Reg,Stk)
      %finishelsestart
         Reg=Load Dreg(Reg,Stk)
         %if Newsize=4 %thenstart
            %if Cpu = NP1 %thenstart
               Gop RR(CFPDS,Reg,Reg)
            %finishelsestart
               %unless Language=Fortran %then Gop R(RND,Reg)
            %finish
            unlock reg pair(Reg)
            reguse(Reg)=-255
         %finish
      %finish
      %result=Reg
%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,mode)
%integer I,Key,j
%constintegerarray available baseregs(0:2)=br4,br5,br3
%record(Stkfmt) Stk
      Key=(Offset<<9)!Area
      %if Key#0 %thenstart
         %cycle j=0,1,2
            I=available baseregs(j)
            %if breguse(I)=Key %then ->set
         %repeat
      %finish
!*
      %cycle j=0,1,2
         I=available baseregs(j)
         %if breguse(I)=0 %then ->Load
      %repeat
!*
      %if mode=0 %then %result=-1 ;! avoiding multiple loading of bregs on 9000
!*
     %cycle j=0,1,2    { choose least recently used base reg }
        %if lastbreg=available baseregs(j) %start
           j=j+1
           %if j=3 %then j=0
           I = available baseregs(j)
           %exit
        %finish
     %repeat

Load: Stk_Form=DirVal
      Stk_Base=Area
      Stk_Offset=Offset
      Stk_Size=0
      Gop RX(LWBR,I,Stk)
      breguse(I)=Key
set:  Lastbreg=I
      %if I=br3 %then saveparamptr=1 %and Br3set=0
      %result=I
%end;! Get Breg
!*
%externalroutine Gop RegJump(%integer op,reg,label)
      codew(mask(op)!(reg<<7)!1,0)
      %if clist=Yes %then TextRegLab(op,reg,label+labadjust)
      breakfrag(label+labadjust)
%end

%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(Sreg)
      S2=Rtext(Dreg)
      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,loopreg
%integer Form,Lit,Index,Base,Offset,Val,Areg,Noteoffset
%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 %or Op=SUM %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
      %if Op=ARM %or Op=ST %thenstart
         Check Conflict(Stk_Base,Offset,Stk_Size)
      %finish
      %if Cpu=NP1 %thenstart
         %if INCMB<=Op<=INCMD %thenstart
            Check Conflict(Stk_Base,Offset,Stk_Size)
         %finish
      %finish
      Locate(Stk_Base,Offset,Index,Base)
Genop:h0=((Reg&7)<<7)!(Index<<4)!(Base&7)!Mask(Op)
      %if Index>0 %then unlock reg(Index)
      %if Cpu=NP1 %thenstart
         %if INCMB<=Op<=INCMD %thenstart
            codew(h0,offset)
            %return %if clist=0
            S1=TextArea(Stk_Base,Stk_Offset)
            TextS1(Op)
            %return
         %finish
      %finish
      %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)
      TextS1S2(Op,Size)
      %return
!*
F(RegAddr):               {  (reg) is @ }
F(RegVal):                { (reg)       }
      %if Op=CAM %thenstart
         Gop RR(CAR,Reg,Stk_Reg)
         unlock reg(Stk_Reg)
         %return
      %finish
      %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
      Offset=0
      ->Ind
!*
F(IndTempVal):            { ((temp))    }
!*
F(IndDirVal):             { ((dir))     }
      Stk_Form=DirVal

     %if op>=LV %start      { If loading a Vector start address }
!
!******  Access to vector by L Grn  ;  ADR loopreg  ; LVW (GRn)
!
!         { Be careful to avoid ADR of vector loop reg following }
!         { if reg memory holds index. }
!         { Note. reg mem is being used to remember index, but     }
!         { contents are really index + loop reg. }
!
!         index=checkregkey(dataat,Stk_base,stk_offset)
!         %if index>0 %then -> ok
!     %finish
!
!****** Now access is by base register indexed by loopreg
!
         Base=load breg(stk_base,stk_offset,1)  { 1 allows breg re-use}
         loopreg = Get V Loop Reg(stk_size)
         Gop RXB(Op,reg,base,loopreg,0,size)
         %return
     %finish 
     stk_size=4

      Index=Load Reg(-3,Stk)
!      %if op>=LV %then Gop RR(ADR,Index,loopreg)
ok:   Offset=0
Ind:  %if Index=r0 %thenstart
         Index=claim pos reg
         Gop RR(TRR,Index,r0)
         unlock reg(r0)
      %finish
      Gop RXB(Op,Reg,0,Index,Offset,Size)
      unlock reg(Index)
      %return
!*
F(AddrConst):             {  @const     }
!*
F(AddrDir):               {  @dir       }
      %if Op=L %thenstart
         Op=LA
         Size=0
         ->RXB
      %finish
      %if Op=LWBR %thenstart
         Op=LABR
         Size=0
         ->RXB
      %finish
Cmpad:%if Op=CAM %thenstart
         Op=CAR
Regop:   Index=Load Reg(-1,Stk)
         Gop RR(Op,Reg,Index)
         Unlock Reg(Index)
         %return
      %finish
      %if Op=ADM %thenstart
         Op=ADR
         ->Regop
      %finish
      %if Op=SUM %thenstart
         Op=SUR
         ->Regop
      %finish
      %monitor;%stop
      %return
!*
F(RegVar):
      %if Op=L %then Op=TRR
      %if Op=ADM %then Op=ADR
      Gop RR(Op,Reg,Stk_Reg)
      %return
!*
F(RegPtr):
      Gop RXB(Op,Reg,0,Stk_Reg,0,Size)
      %return
!*
F(AddrDirMod):            {  @dir+M     }
!*
F(RegModAddr):            {  (reg)+M    }
!*
F(TempModAddr):           {  (temp)+M   }
!*
F(DirModAddr):            {  (dir)+M    }
      %if Op=CAM %then ->Cmpad
      %unless Language=Imp %or Language=Ccomp %or Op=L %or Op=ADM %or Op=SUM  %thenstart
         %monitor;%stop
      %finish
!*
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'7fff' %thenstart
         Modstk=0
         Modstk_Form=Stk_Modform
         Modstk_Base=Stk_Modbase
         Modstk_Offset=Stk_Modoffset
         Modstk_Reg=Stk_Modreg
         Modstk_Size=4
         Noteoffset=Modstk_Offset
         %if Modstk_Form=Dirval %and 1<=Stk_Scale<=3 %thenstart
            Index=checkregkey(5+Stk_Scale,modstk_Base,Modstk_offset)
            %if Index>0 %thenstart
                Form=Regval
                offset=0
                ->G(Stk_Form&31)
            %finish
         %finish
         %if Modstk_Form&31=Regval %and Modstk_Reg=r7 %and r7locked#0 %thenstart
            Index=r7
         %finishelsestart
            Index=Load Reg(-3,Modstk)
            %if Index=0 %thenstart
               Index=claim reg
               Gop RR(TRR,Index,r0)
               reguse(0)=0
            %finish
            Modstk_Offset=0
         %finish
         %if Stk_Scale#0 %thenstart
            %if Index=r7 %and r7locked#0 %thenstart
               %if 1<=Stk_Scale<=3 %thenstart
                  Index=checkregkey(5+Stk_Scale,0,r7)
               %finishelse Index=-1
               %if Index<=0 %thenstart
                  Index=claim pos reg
                  Gop RR(TRR,Index,r7)
                  Gop Shift Lit(SLL,Index,Stk_Scale)
                  %if 1<=Stk_Scale<=3 %thenstart
                     reguse(Index)=-250+Stk_Scale
                     regdata(Index)=r7<<9
                  %finishelse reguse(Index)=-255
               %finish
               Form=Regval
               Offset=Modstk_Offset
               unlock reg(r7)
               ->G(Stk_Form&31)
            %finish
            %if Index=Reg %thenstart
               Index=claim pos reg
               Gop RR(TRR,Index,Reg)
            %finish
            Gop Shift Lit(SLL,Index,Stk_Scale)
            %if Modstk_form=dirval %and 1<=Stk_Scale<=3 %thenstart
               reguse(Index)=-250+Stk_Scale
               regdata(Index)=(Noteoffset<<9)!Modstk_Base
            %finishelse reguse(Index)=-255
         %finish
         Form=RegVal
         Offset=Modstk_Offset
      %finishelsestart
         Offset=Stk_Modintval
         Index=0
         Form=LitVal
      %finish
      ->G(Stk_Form&31)
!*
G(AddrDirMod):            {  @dir+M     }
      %if Form=Litval %thenstart
         Stk_Offset=Stk_Offset+Offset
         ->F(AddrDir)
      %finishelsestart
         Stk_Form=AddrDir
         Gop RX(Op,Reg,Stk)
         Gop RR(ADR,Reg,Index)
         unlock reg(Index)
      %finish
      %return
!*
G(RegModAddr):            {  (reg)+M    }
      %if Form=Litval %thenstart
         %unless Offset=0 %then Gop RI(ADI,Stk_Reg,Offset)
      %finishelsestart
         Gop RR(ADR,Stk_Reg,Index)
         Reguse(Reg)=-255
         unlock reg(Index)
      %finish
      %if Op=L %thenstart
         Gop RR(TRR,Reg,Stk_Reg)
      %finishelsestart
         %if Op=SUM %then Op=SUR %else Op=ADR
         Gop RR(Op,Reg,Stk_Reg)
      %finish
      unlock reg(Stk_Reg)
      %return
!*
G(TempModAddr):           {  (temp)+M   }
G(DirModAddr):            {  (dir)+M    }
      Stk_Form=Dirval
      Gop RX(Op,Reg,Stk)
      %if Form=Litval %thenstart
         %unless Offset=0 %then Gop RI(ADI,Reg,Offset)
      %finishelsestart
         Gop RR(ADR,Reg,Index)
         %if index=r7 %and r7locked#0 %thenstart
            %unless offset=0 %then Gop RI(ADI,Reg,Offset)
         %finish
         unlock reg(Index)
      %finish
      Reguse(Reg)=-255
      %return
!*
G(IndRegModVal):          { ((reg)+M)   }
      %if Form=Litval %thenstart
         Base=0
         Index=Stk_Reg
         reguse(Stk_Reg)=0
      %finishelsestart
         Gop RR(ADR,Index,Stk_Reg)
         Reguse(Stk_Reg)=0
         Base=0
         Reguse(Index)=0
      %finish
      ->ind
!*
G(IndTempModVal):         { ((temp)+M)  }
G(IndDirModVal):          { ((dir)+M)   }
      %if Form=Litval %thenstart
         Areg=Checkregkey(addr at,Stk_Base,Stk_Offset)
         %if Areg<=0 %thenstart
            Areg=claim pos reg
            Size=Stk_Size
            Stk_Size=4
            Stk_Form=Dirval
            Gop RX(L,Areg,Stk)
            Reguse(Areg)=addr at
            Regdata(Areg)=Stk_Offset<<9!Stk_Base
         %finish
         Gop RXB(Op,Reg,0,Areg,Offset,Size)
         unlock reg(Areg)
         %return
      %finish
      Base=Load Breg(Stk_Base,Stk_Offset,0)
      %if Base>0 %thenstart
         Gop RXB(Op,Reg,Base,Index,Offset,Stk_Size)
      %finishelsestart
         %if Index=r7 %and r7locked#0 %thenstart
            Areg=checkregkey(4,Stk_Base,Stk_offset)
            %if Areg>0 %thenstart
               Gop RXB(Op,Reg,0,Areg,Offset,Size)
               unlock reg(Areg)
               reguse(r7)=0
               %return
            %finish
         %finish
         Size=Stk_Size
         Stk_Size=4
         Stk_Form=Dirval
         %if 0<Index<r7 %thenstart
            Areg=Index
            Index=0
            Gop RX(ADM,Areg,Stk)
         %finishelsestart
            Areg=claim pos reg
            Gop RX(L,Areg,Stk)
            Gop RR(ADR,Areg,Index)
         %finish
         Gop RXB(Op,Reg,0,Areg,Offset,Size)
         %if Index=r7 %and r7locked#0 %thenstart
            reguse(Areg)=4
            regdata(Areg)=Stk_Offset<<9!Stk_Base
         %finishelse reguse(Areg)=0
      %finish
      %if Index#0 %thenstart
         {%if Stk_Scale#0 %then reguse(Index)=0 %else} unlock reg(Index)
      %finish
      %return
!*
G(AddrDirModVal):         { (dir+M)     }
      Stk_Form=Dirval
      %if Form=Litval %thenstart
         Stk_Intval=Stk_Intval+Offset
         ->F(DirVal)
      %finishelsestart
         Stk_Form=AddrDir
         Gop RX(LWBR,br6,Stk)
         breguse(br6)=0
         base=br6
         unlock reg(Index)
         ->Genop
      %finish
!*
%end;! Gop RX
!*
%externalroutine Gop R(%integer Op,Reg)
%integer Reg2
      Reg=Reg&7
      %if Op=ZR %then Reg2=Reg %else Reg2=0
      codeh((Reg<<7)!(Reg2<<4)!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,I,Inst,Size
      Size=Stk_Size;              ! Can get changed while loading
      %if Op=TST %thenstart
         Form=Stk_Form&31
         %if Form=RegVal %or Form=FregVal %thenstart
            Reg=Stk_Reg
            %if fragoffset>=2 %thenstart
               I=frag_h(fragoffset-2)&X'ffff'
               %if I=Mask(ADI)!(reg<<7) %then ->rel
            %finish
Test:       Gop RR(TRR,Reg,Reg)  {*** try to avoid this if possible}
         %finishelsestart
            %if Size=8 %thenstart
               Reg=Load Dreg(-1,Stk)
            %finishelsestart
               Reg=Load Reg(-2,Stk);! must ensure it is loaded
               %if Stk_Form=AddrDir %then ->Test
            %finish
         %finish
Rel:     %if Size=8 %thenstart
            unlock reg pair(Reg)
         %finishelsestart
            unlock reg(Reg)
         %finish
         %return
      %finish
      %if Cpu=NP1 %thenstart
         %if INCMB<=Op<=INCMD %thenstart
            Gop RX(Op,0,Stk)
            %return
         %finish
      %finish
%monitor
%end;! Gop X
!*
%externalroutine Gop(%integer Op)
      codeh(Mask(Op))
      %return %if Clist=NO
      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 Maskreg,Exreg,Gopcode,places
      %if Stk_Form=Litval %thenstart
         places=stk_intval
         %if (op=SLAD %or op=SLLD %or op=SRAD %or op=SRLD) %and places>31 %start
             Gop Shift Lit(Op,Reg,31)
             Gop Shift Lit(Op,Reg,places-31)  { Mysteriously breaks m/c }
         %finishelse Gop Shift Lit(Op,Reg,stk_intval&31)
         %return
      %finish
      Exreg=Load Reg(-1,Stk)
      %if Cpu = Np1 %thenstart
         %if op = SLL %or op = SLA %thenstart
            Gop RR(TRN,Exreg,Exreg)
         %finish
         %if op = SRA %then op=SDA %else op=SDL
         Gop RR(op,Reg,Exreg)
      %finishelsestart
         Maskreg=claim reg
         Gop RI(LI,Maskreg,31)
         Gop RR(ANR,Exreg,Maskreg)
         Gop RI(LI,Maskreg,Mask(Op)!(Reg<<7))
         Gop RR(ORR,Exreg,Maskreg)
         Gopcode = EXRR
         codew(Mask(Gopcode)!(Exreg<<7),2)
         reguse(Maskreg)=0
     %finish
     reguse(Exreg)=0
      %unless cpu=NP1 %Start
         %if Clist=YES %thenstart
            S1=Rtext(Reg)
            TextS1(Gopcode)
         %finish
      %finish
%end;! Gop Shift
!*
%externalroutine Gop Bit(%integer Op,mode,treg,%record(Stkfmt) loc,adj)
%integer offset,base,index,reg,reg1,bitno,ref,Lab1,Lab2
      %if Cpu=Concept %thenstart
         base=br6
      %finishelsestart
         base=br5
      %finish
      %if adj_form=Litval %thenstart
         offset=loc_offset+adj_intval
         bitno=offset&7
         offset=offset>>3
         %if Op=SBM %thenstart
            %if mode=0 %thenstart   {litval}
               Locate(loc_base,offset,index,base)
               %if treg=0 %thenstart
                  Gop RXB(ZBM,bitno,base,index,offset,0)
               %finishelsestart
                  Gop RXB(SBM,bitno,base,index,offset,0)
               %finish
               %if index#0 %then unlock reg(index)
            %finishelsestart
               Lab1=Mprivatelabel
               Lab2=Mprivatelabel
               Gop Jump(BNE,Lab1)
               Locate(loc_base,offset,index,base)
               Gop RXB(ZBM,bitno,base,index,offset,0)
               %if index#0 %then unlock reg(index)
               Gop Jump(BU,Lab2)
               Mcode Plabel(Lab1)
               Locate(loc_base,offset,index,base)
               Gop RXB(SBM,bitno,base,index,offset,0)
               %if index#0 %then unlock reg(index)
               Mcode Plabel(Lab2)
            %finish
         %finishelsestart  {TBM}
            Locate(loc_base,offset,index,base)
            Gop RXB(TBM,bitno,base,index,offset,0)
            %if index#0 %then unlock reg(index)
         %finish
      %finishelsestart
         reg=claim reg pair(1)
         reg1=load reg(reg+1,adj)
         offset=loc_offset
         %if offset&7=0 %and offset<=x'ffff0' %thenstart
            offset=offset>>3
         %finishelsestart
            adj_form=Litval
            adj_intval=offset
            Gop RX(ADM,reg1,adj)
            offset=0
         %finish
         Gop RR(TRR,reg,reg1)
         Gop Shift Lit(SRAD,reg,3)
         Gop R(ZR,reg)
         Gop Shift Lit(SLAD,reg,3)     {reg holds bit offset}
         Gop Shift Lit(SRL,reg+1,3)    {reg+1 holds byte offset}
         ref=areakeyref(loc_base,0)
         %unless breguse(base)=(ref<<9)!PLT %thenstart
            Eafix(PLT,ref)
            Gop RXB(LWBR,base,0,0,0,0)
            breguse(base)=(ref<<9)!PLT
         %finish
         unlock reg pair(reg)
         index=reg+1
         %if Cpu=Concept %thenstart
            %if bitmaskad=0 %thenstart
               bitmaskad=PLToffset
               Md4(PLT,PLToffset,X'7FBFDFEF')
               Md4(PLT,PLToffset+4,X'F7FBFDFE')
               PLToffset=PLToffset+8
            %finish
            Eafix(PLT,bitmaskad)
            Gop RXB(L,reg,0,reg,0,1)   {mask byte}
            %if Op=SBM %thenstart
               %if mode=0 %thenstart   {litval}
                  %if treg=0 %thenstart
                     Gop RXB(ANM,reg,base,index,offset,1)
                  %finishelsestart
                     Gop RR(TRC,reg,reg)
                     Gop RXB(ORM,reg,base,index,offset,1)
                  %finish
               %finishelsestart
                  Lab1=Mprivatelabel
                  Lab2=Mprivatelabel
                  Gop RR(TRR,treg,treg)
                  Gop Jump(BNE,Lab1)
                  Gop RXB(ANM,reg,base,index,offset,1)
                  Gop Jump(BU,Lab2)
                  Mcode Plabel(Lab1)
                  Gop RR(TRC,reg,reg)
                  Gop RXB(ORM,reg,base,index,offset,1)
                  Mcode Plabel(Lab2)
               %finish
               Gop RXB(ST,reg,base,index,offset,1)
            %finishelsestart  {TBM}
               Gop RR(TRC,reg,reg)  {SBM or TBM}
               Gop RXB(ANM,reg,base,index,offset,1)
            %finish
         %finishelsestart  {NP1}
            Locate(loc_base,offset,index,base)
            %if Op=SBM %and mode=0 %thenstart
               %if treg=0 %then Op=ZBM %else Op=SBM
            %finishelsestart
               Op=Op-SBM+SBMD
            %finish
            Gop RXB(Op,reg,base,index,offset,0)
            %if index#0 %then unlock reg(index)
         %finish
      %finish
%end;! Gop Bit
!*
%externalroutine Gop Jump(%integer Op,Label)
%integer Instr
      codew(Mask(op)!1,0)
      %if Clist=YES %thenstart
         TextLab(Op,Label+Labadjust)
      %finish
      Break Frag(Label+Labadjust)
      paramregset=0 {protect against corruption in a prologue}
%end;! Gop Jump
!*
%externalroutine Gop Short Jump(%integer Op,Lit,Offset)
      eafix(x'fff',offset)
      codew(Mask(op)!(Lit<<7)!1,0)
      %return %if Clist=NO
      %if op=BIB %thenstart
         S1=Rtext(Lit)
         S2=Htos(Offset)
         TextS1S2(Op,0)
      %finishelsestart
         S1=Htos(Offset)
         TextS1(Op)
      %finish
%end;! Gop Short Jump
!*
%routine Gop PC(%integer reg)
!* establish current @ in reg
%integer lab
      %if Cpu = NP1 %thenstart
         lab = Mprivatelabel
         codew(Mask(BRLNK)!(reg<<7)!1,0)
         %if Clist = YES %thenstart
            Textlab(BRLNK,lab+Labadjust)
         %finish
         Break Frag(lab+Labadjust)
      %finish
%end;! Gop PC
!*
%externalroutine Gop Floor(%integer Reg,Size,Cnsts)
!***********************************************************************
!*    Truncate to - infinity. If +ve same as to zero                   *
!*    I-ve abdd 2**32(or)64 fix the subtract the const                 *
!***********************************************************************
%integer lab1,lab2,i
      Lab1=Mprivatelabel
      Lab2=Mprivatelabel
      Gop RR(TRR,Reg,Reg)
      Gop Jump(BLT,Lab1)
      Gop RR(FIXD,Reg,Reg);           ! Reg always a pair      Gop Jump(BU,Lab2)
      Gop Jump(BU,Lab2)
      Mcode Plabel(lab1)
      Eafix(Plt,0)
      %if Size=4 %then I=Cnsts %else I=cnsts+8
      Gop RXB(ADF,Reg,0,0,I,8);         !  2**32 or 2**64 put in place by cvtri
      Gop RR(FIXD,Reg,Reg)
      %if Size=4 %then i=reg+1 %else i=reg
      Eafix(Plt,0)
      Gop RXB(EOM,i,0,0,Cnsts+4,4);    ! Flip sign bit to add back -2**32 (or64)
      Mcode Plabel(lab2)
%end;! Gop Floor
%externalroutine Gop Rnd(%integer Reg,Size,Half)
%integer lab1,lab2
      Lab1=Mprivatelabel
      Lab2=Mprivatelabel
      Gop RR(TRR,Reg,Reg)
      Gop Jump(BLT,Lab1)
      Eafix(Plt,0)
      Gop RXB(ADF,Reg,0,0,Half,Size)
      Gop Jump(BU,Lab2)
      Mcode Plabel(lab1)
      Eafix(Plt,0)
      Gop RXB(SUF,Reg,0,0,Half,Size)
      Mcode Plabel(lab2)
%end;! Gop Rnd
!
%owninteger newpad=0
%owninteger firstparlen=4
!*
%externalroutine NP1 Parmode(%integer pad,arg1len)
      %unless pad =-1 %then newpad = pad
      %unless arg1len=-1 %then firstparlen=arg1len
%end
!*
%owninteger dofastcall=0
!*
%externalroutine NP1 Fastcall
      dofastcall=1
%end
%externalroutine Gop Call(%integer Id,Paramsize,numpars,Xlevel)
!***********************************************************************
!*    Xlevel is the level of the called procedure                      *
!*    Needed to optimise display copies                                *
!***********************************************************************
%record(exdatafmt)%name Exdata
%integer Instr,I,J,ad,base,index,offset
      saveparamptr=1 {prevent elimination of save on entry}
      Clear Regs
      %if NextParamOffset>CallParSize %then CallParSize=NextParamOffset
      %if Language=IMP %or Language=Pascal %thenstart
         %if Cpu=Concept %then I=r1 %else I=r7
         %if Language=IMP %start
            %if Xlevel>1 %Start
               eafix(Stack,0)
               Gop RXB(LA,I,br2,0,Noteparsize(Proclevel),0)  { for display copy }
            %finish
         %else
            %if Xlevel>2 %start;     ! Pascal Globals mean no display needed at level 1
            eafix(Stack,0)
               Gop RXB(LA,I,br2,0,0,0)
               %finish
         %finish
      %finish
      %if Cpu=Concept %thenstart
         %if maxcodeca-procbaseca<X'10000' %thenstart
            eafix(x'fff',16);! relative fixup (to *+16)
            Gop RXB(LA,r2,br1,0,0,0)
         %finishelsestart
            %if fragoffset&1=0 %then codeh(Mask(NOP))
            Gop R(TPCBR,br7)
            Gop RXB(LA,r2,br7,0,18,0)
         %finish
      %finishelsestart
         %if Paramsize#0 %or Language=Ccomp %thenstart
            %if newpad#0 %Start
               offset=newpad
               Locate(Gla,offset,Index,Base)
               GopRXB(LWBR,br3,base,index,offset,0)
               Clear Regs
            %finishelsestart
               Gop RXB(LABR,br3,br2,0,24,0)
            %finish
            %unless paramsize = numpars<<2 %then i=8 %else i=firstparlen
            %if dofastcall=0 %thenstart
               Gop RXB(L,r2,br3,0,8,firstparlen)   {first param expected in r2}
            %finishelse dofastcall=0
         %finish
         newpad=0
         firstparlen=4   {resetting default}
         %if r7locked#0 %and r7saved=0  %thenstart
            %if r6stcount<32 %thenstart
               r6store(r6stcount)=addr(frag_h(fragoffset))
               r6stcount=r6stcount+1
            %finish
            Gop RXB(ST,r6,br2,0,16,8)  {use the static link save area}
            R7saved=1
         %finish
      %finish
      %if Id>0 %thenstart
         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
      %finishelsestart
         Gop RR(TRBR,br1,r0)
         Gop(NOP)
      %finish
      %if Cpu=Concept %thenstart
         Gop RXB(ST,r2,br2,0,0,4)
         Gop RXB(BU,0,br1,0,4,0)
      %finishelsestart  {NP1}
         Gop RXB(BRLNK,r1,br1,0,8,0)
      %finish
      eafix(1,Procbaseca)
      %if Cpu=Concept %thenstart
         codew(Paramsize<<6,0)
      %finishelsestart
         codew(0,0)
      %finish
      %if Clist#0 %thenstart
         printstring("@curproc")
         newline
      %finish
      %if Cpu=NP1 %thenstart
         %if r7locked#0 %thenstart
            %if r6ldcount<32 %thenstart
               r6load(r6ldcount)=addr(frag_h(fragoffset))
               r6ldcount=r6ldcount+1
            %finish
            Gop RXB(L,r6,br2,0,16,8)
         %finish
      %finish
      %if clevel=0 %then %return
      NextParamOffset=coffset(clevel)
      %if NextParamOffset>32 %thenstart
         I=NextParamOffset-32
         ad=csavespace(clevel)
         %cycle J=0,4,I-4
            Eafix(Stack,0)
            Gop RXB(L,r3,br2,0,ad+J,4)
            Gop RXB(ST,r3,br2,0,32+J,4)
         %repeat
      %finish
      clevel=clevel-1
      %if Vloopreg>=0 %start  { in a vector loop }
         %if reguse(Vr1)#0 %then Gop RXB(LV,Vr1,br2,0,Vtempspace(Vr1,4),4)
         Gop R(TRRVE,R6)
      %finish
%end;! Gop Call
!*
%externalroutine Mretframe
      Numretframes=Numretframes+1
      retframekeys(Numretframes)=addr(frag_h(fragoffset-2))
%end;! Mretframe
!*
%routine regsave
%integer I,J,reg,offset,size,code,save45
%record(fragfmt)%name fr
      %if regs saved=0 %then %return
      regs saved=0;! to avoid attempt to delete stores more than once {C - temp}
      fr==record(F77basefrag)
!*
      %if Cpu=NP1 %thenstart
         %if saveparamptr=0 %thenstart
            %if fr_size=f77baseoffset %thenstart
               f77baseoffset=f77baseoffset-2
               fr_size=f77baseoffset
            %finish
         %finish
         %return
      %finish
%if Cpu=Concept %thenstart
      noterestore1=-1
      save45=1
      I=(regsused(4)<<1)!regsused(5)
      %if unsafeproc#0 %then I=3
      J=F77baseoffset
      %if I#0 %thenstart
         offset=16
         reg=r4
         %if I=3 %thenstart
            size=8
         %finishelsestart  { one only }
            %if I=1 %thenstart
               reg=r5
               offset=20
               code=X'D682'
            %finishelsestart
               code=X'D602'
            %finish
            fr_h(J-4)<-code
            size=4
         %finish
         saveoffset1=offset
         noterestore1=Mmarker
         Gop RXB(L,reg,br2,0,offset,size)
      %finishelsestart { eliminate store }
         %if fr_size=J %thenstart
            fr_h(J-4)<-fr_h(J-2)
            fr_h(J-3)<-fr_h(J-1)
            notesave2=notesave1
            J=J-2
            fr_size=J
            F77baseoffset=J
         %finishelsestart
            fr_h(J-4)=x'0002'   { NOP }
            fr_h(J-3)=X'0002'
            save45=0
         %finish
         notesave1=-1
      %finish
!*
      noterestore2=-1
      I=(regsused(6)<<1)!regsused(7)
      %if unsafeproc#0 %then I=3
      %if I#0 %thenstart
         offset=24
         reg=r6
         %if I=3 %thenstart
            size=8
         %finishelsestart  { one only }
            %if I=1 %thenstart
               reg=r7
               offset=28
               code=X'D782'
            %finishelsestart
               code=X'D702'
            %finish
            fr_h(J-2)<-code
            size=4
         %finish
         saveoffset2=offset
         noterestore2=Mmarker
         Gop RXB(L,reg,br2,0,offset,size)
      %finishelsestart { eliminate store }
         J=F77baseoffset
         %if fr_size=J %thenstart
            fr_size=J-2
         %finishelsestart
            fr_h(J-2)=x'0002'   { NOP }
            fr_h(J-1)=X'0002'
            %if save45=0 %and fr_labrefkey#0 %and fr_size=J+4 %thenstart
               fr_h(J-4)<-fr_h(J)
               fr_h(J-3)<-fr_h(J+1)
               fr_size=J
            %finish
         %finish
         notesave2=-1
      %finish
%finish
%end;! regsave
!*
%externalroutine Gop Return
%record(fragfmt)%name fr
      noterestore1=-1
      noterestore2=-1
      %if Language=Fortran %thenstart
         regsave
      %finish
      %if Cpu=Concept %thenstart
         %if Language=Imp %thenstart;! r6,r7 protected at all times
            Gop RXB(L,r6,br2,0,24,8)
         %finish
         Gop RXB(L,r2,br2,0,0,4)
         Mretframe
         Gop RXB(LWBR,br1,0,r2,0,0)
         Gop RXB(LABR,br2,br2,0,0,0)
         Mretframe
         Gop RXB(BU,0,0,r2,4,0)
      %finishelsestart  {NP1}
         Gop RXB(L,r1,br2,0,8,0)
         Gop RXB(LWBR,br1,0,r1,0,0)
         Gop RXB(LABR,br2,br2,0,0,0)
         Mretframe
         Gop RXB(BU,0,0,r1,4,0)
      %finish
%end;! Gop Return
!*
%externalroutine Gop Mvlong(%record(Stkfmt)%name Len,From,To,%integer units)
%integer rcount,rcopy,size,adj,reg,Op,loop,offset,breg1,breg2,breg3
      %if Cpu=Concept %thenstart
         breg1=br6
         breg2=br7
         breg3=br5
      %finishelsestart  {NP1}
         breg1=br4
         breg2=br5
         breg3=br3
      %finish
      loop=1   {default is to use a tight loop}
      Rcount=claim pos reg
      rcopy=claim pos reg
      %if Len_Form=Litval %thenstart
         size=Len_Intval
         %if Language=Ccomp %and units=4 %and size<=64 %then loop=0  {multiple L,ST}
         Len_Intval=-size
         %if From_Form=AddrDir %thenstart
            %if loop#0 %then From_Offset=From_Offset+size
            Gop RX(LWBR,breg1,From)
         %finishelsestart
            %if From_Form&31=RegVal %or From_Form&31=RegAddr %thenstart
               reg=From_Reg
               reguse(reg)=0
            %finishelsestart
               reg=rcopy
               Gop RX(L,rcopy,From)
            %finish
            %if loop#0 %then Gop RI(ADI,reg,size)
            Gop RR(TRBR,breg1,reg)
         %finish
         breguse(breg1)=-1
         lastbreg=breg1
         %if To_Form=AddrDir %thenstart
            %if loop#0 %then To_Offset=To_Offset+size
            Gop RX(LWBR,breg2,To)
         %finishelsestart
            %if To_Form&31=RegVal %or To_Form&31=RegAddr %thenstart
               reg=To_Reg
               reguse(reg)=0
            %finishelsestart
               reg=rcopy
               Gop RX(L,rcopy,To)
            %finish
            %if loop#0 %then Gop RI(ADI,reg,size)
            Gop RR(TRBR,breg2,reg)
         %finish
         %if loop=0 %thenstart
            %cycle offset=0,4,size-4
               Gop RXB(L,rcopy,breg1,0,offset,4)
               Gop RXB(ST,rcopy,breg2,0,offset,4)
            %repeat
            ->rel
         %finish
         Gop RX(L,rcount,Len)
      %finishelsestart
         rcount=load reg(rcount,Len)
         %if From_Form&31=Regval %or From_Form&31=Regaddr %thenstart
            reg=From_Reg
            reguse(reg)=0
         %finishelsestart
            reg=rcopy
            Gop RX(L,rcopy,From)
         %finish
         Gop RR(ADR,reg,rcount)
         Gop RR(TRBR,breg1,reg)
         breguse(breg1)=-1
         lastbreg=breg1
         %if To_Form&31=Regval %or To_Form&31=Regaddr %thenstart
            reg=To_Reg
            reguse(reg)=0
         %finishelsestart
            reg=rcopy
            Gop RX(L,rcopy,To)
         %finish
         Gop RR(ADR,reg,rcount)
         Gop RR(TRBR,breg2,reg)
         Gop RR(TRN,rcount,rcount)
      %finish
      %if units=4 %then Op=BIW %elsestart
         %if units=2 %then Op=BIH %else Op=BIB
      %finish
      %if maxcodeca-procbaseca<X'10000' %thenstart
         %unless Len_Form=Litval %and size#0 %thenstart
            Gop Short Jump(BEQ,0,16);! if rcount is zero
         %finish
         Gop RXB(L,rcopy,breg1,rcount,0,units)
         Gop RXB(ST,rcopy,breg2,rcount,0,units)
         Gop Short Jump(Op,rcount,-8)
      %finishelsestart
         reguse(r0)=0
         Gop RR(TBRR,r0,breg3)
         %if Cpu = NP1 %thenstart
            reg = claim pos reg
            Gop PC(reg)
            Gop RR(TRBR,breg3,reg)
            reguse(reg)=0
            adj = 2
         %finishelsestart
            Gop R(TPCBR,breg3)
         %finish
         %if fragoffset&1#0 %then adj=2 %else adj=0
         Gop RXB(BEQ,0,breg3,0,18+adj,0);! if rcount is zero
         Gop RXB(L,rcopy,breg1,rcount,0,1)
         Gop RXB(ST,rcopy,breg2,rcount,0,1)
         Gop RXB(BIB,rcount,breg3,0,6+adj,0)
         Gop RR(TRBR,breg3,r0)
         breguse(breg3)=0
      %finish
rel:  reguse(rcopy)=0
      reguse(rcount)=0
      breguse(breg1)=0
      breguse(breg2)=0
      saveparamptr=1
%end;! Gop Mvlong
!*
%externalroutine Gop Mvb(%record(Stkfmt)%name Len,From,To)
      Gop Mvlong(Len,From,To,1)
%end;! Gop Mvb
!*
%externalroutine Gop Cpb(%integer Op,%record(Stkfmt)%name Len,At,With)
%integer rcount,rcopy,size,reg,adj,breg1,breg2,breg3
      %if Cpu=Concept %thenstart
         breg1=br6
         breg2=br7
         breg3=br5
      %finishelsestart  {NP1}
         breg1=br4
         breg2=br5
         breg3=br3
      %finish
      Rcount=claim pos reg
      rcopy=claim pos reg
      %if Len_Form=Litval %thenstart
         size=Len_Intval
         Len_Intval=-size
         %if At_Form=AddrDir %thenstart
            At_Offset=At_Offset+size
            Gop RX(LWBR,breg1,At)
         %finishelsestart
            %if At_Form&31=RegVal %or At_Form&31=RegAddr %thenstart
               reg=At_Reg
               reguse(reg)=0
            %finishelsestart
               reg=rcopy
               Gop RX(L,rcopy,At)
            %finish
            Gop RI(ADI,reg,size)
            Gop RR(TRBR,breg1,reg)
         %finish
         breguse(breg1)=-1
         lastbreg=breg1
         %if With_Form=AddrDir %thenstart
            With_Offset=With_Offset+size
            Gop RX(LWBR,breg2,With)
         %finishelsestart
            %if With_Form&31=RegVal %or With_Form&31=RegAddr %thenstart
               reg=With_Reg
               reguse(reg)=0
            %finishelsestart
               reg=rcopy
               Gop RX(L,rcopy,With)
            %finish
            Gop RI(ADI,reg,size)
            Gop RR(TRBR,breg2,reg)
         %finish
         Gop RX(L,rcount,Len)
      %finishelsestart
         rcount=load reg(rcount,Len)
         %if At_Form&31=Regval %or At_Form&31=RegAddr %thenstart
            reg=At_Reg
            reguse(reg)=0
         %finishelsestart
            reg=rcopy
            Gop RX(L,rcopy,At)
         %finish
         Gop RR(ADR,reg,rcount)
         Gop RR(TRBR,breg1,reg)
         breguse(breg1)=-1
         lastbreg=breg1
         %if With_Form&31=Regval %or With_Form&31=RegAddr %thenstart
            reg=With_Reg
            reguse(reg)=0
         %finishelsestart
            reg=rcopy
            Gop RX(L,rcopy,With)
         %finish
         Gop RR(ADR,reg,rcount)
         Gop RR(TRBR,breg2,reg)
         Gop RR(TRN,rcount,rcount)
      %finish
      breguse(breg1)=0
      breguse(breg2)=0
      %if maxcodeca-procbaseca<X'10000' %thenstart
         %if Cpu=NP1 %thenstart {avoiding emulator bug}
            Gop Short Jump(BEQ,0,24)
         %finishelsestart
            Gop Short Jump(BEQ,0,20);! if rcount is zero
         %finish
         Gop RXB(L,rcopy,breg1,rcount,0,1)
         Gop RXB(CAM,rcopy,breg2,rcount,0,1)
         %if Cpu=NP1 %thenstart
            Gop Short Jump(BNE,0,12)
            Gop RI(ADI,rcount,1)
            Gop Short Jump(BNE,0,-16)
         %finishelsestart
            Gop Short Jump(BNE,0,8)
            Gop Short Jump(BIB,rcount,-12)
         %finish
      %finishelsestart
         reguse(r0)=0
         Gop RR(TBRR,r0,breg3)
         %if Cpu = NP1 %thenstart
            reg = claim pos reg
            Gop PC(reg)
            Gop RR(TRBR,breg3,reg)
            adj = 2
         %finishelsestart
            Gop R(TPCBR,breg3)
         %finish
         %if fragoffset&1#0 %then adj=2 %else adj=0
         Gop RXB(BEQ,0,breg3,0,22+adj,0);! if rcount is zero
         Gop RXB(L,rcopy,breg1,rcount,0,1)
         Gop RXB(ST,rcopy,breg2,rcount,0,1)
         Gop RXB(BNE,0,breg3,0,22+adj,0)
         Gop RXB(BIB,rcount,breg3,0,6+adj,0)
         Gop RR(TRBR,breg3,r0)
      %finish
      reguse(rcount)=0
      reguse(rcopy)=0
      saveparamptr=1
%end;! Gop Cpb
!*
%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 size=8 %then nextparamoffset=(nextparamoffset+7)&X'fffff8'
      %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)
            unlock reg pair(Reg)
         %finish
      %finish
      Gop RXB(Op,Reg,br2,0,NextParamOffset,Size)
      NextParamOffset=NextParamOffset+Size
%end;! Push Param
!*
%externalroutine Push Struct(%record(Stkfmt)%name Stk,%integer Size)
!***********************************************************************
!* push structure (a multiple of 4 bytes) to the stack on a double     *
!* word boundary                                                       *
!***********************************************************************
%integer Offset,Reg,Reg1,I
      Reg=claim pos reg
      Reg1=claim reg
      Gop RX(LA,Reg,Stk)
      I=0
      Offset=0
      NextParamOffset=(NextparamOffset+7)&X'fffff8'
      %while Offset<Size %cycle
         Gop RXB(L,Reg1,0,Reg,Offset,4)
         Gop RXB(ST,Reg1,br2,0,NextParamOffset,4)
         NextParamOffset=NextParamOffset+4
         Offset=Offset+4
      %repeat
      reguse(Reg)=0
      reguse(Reg1)=0
%end;! Push Struct
!*
%externalroutine Check Conflict(%integer Base,Offset,Size)
%integer I,Key,Memoffset
      Key=(Offset<<9)!Base
      %cycle I=r0,1,r7
         Memoffset = Regdata(i)>>9
         %if reguse(I)>0 %and regdata(I)&X'1FF'=Base %and %c
            Memoffset<=offset<=Memoffset+3 %thenstart
            reguse(I)=0
            regdata(I)=0
         %finish
      %repeat
!*
      %cycle I=br3,1,br7
         %if breguse(I)=Key %then breguse(I)=0
      %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 Language=Ccomp %thenstart
         %if RHS_Form&31=Regval %and LHS_Size<4 %then Bytes=LHS_Size
         LHS_Size=Bytes
      %finish
      Lform=LHS_Form&31
      %if Bytes<=4 %thenstart
         %if RHS_Form=LitVal %and RHS_IntVal=0 %and Dup=0 %thenstart
            %if Lform=RegVar %then Gop R(ZR,LHS_Reg) %and %result=-1
            Op=ZM
            Reg=0
         %finishelsestart
            %if Lform=RegVar %thenstart
               Reg=Load Reg(LHS_Reg,RHS)
               %result=-1
            %finish
            %if RHS_Form=RegVar %thenstart
               Gop RX(ST,RHS_Reg,LHS)
               %result=-1
            %finish
            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
            %if LHS_Size=4 %thenstart
               Key=(LHS_Offset<<9)!LHS_Base
               reguse(Reg)=Data at
               regdata(Reg)=Key
            %finish
         %finishelsestart
            %cycle I=r0,1,r7
               %if reguse(I)>0 %and regdata(I)&X'1FF'>2 %thenstart
                  reguse(I)=0
                  regdata(I)=0
               %finish
            %repeat
         %finish
      %finishelsestart
         Reg=Load Dreg(-1,RHS)
         %if LHS_size<8 %then Gop RX(ST,reg+1,LHS) %c
                        %else Gop RX(ST,Reg,LHS)
         Unlock Reg Pair(Reg)
      %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,Lval,Rval,Res,bytes
%switch Opcode(0:ILE)
%switch DOpcode(0:ILE)
%switch Sop(0:IXOR)
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      bytes=LHS_size
      %if (bytes=8 %or rhs_size=8) %and bytes#RHS_size %then  %c
                                abortm("Unequal sizes in Int Binary Op")
      %unless r7locked=0 %or IGT<=Op<=ILE %thenstart;! ensure it is not changed
         %if Lform=Regval %and LHS_Reg=7 %thenstart
            Reg=claim reg
            Gop RR(TRR,Reg,r7)
            unlock reg(r7)
            LHS_Reg=Reg
         %finish
         %if Rform=Regval %and RHS_Reg=7 %thenstart
            Reg=claim reg
            Gop RR(TRR,Reg,r7)
            unlock reg(r7)
            RHS_Reg=Reg
         %finish
      %finish
      %if Lform=DirVal %and LHS_Size=4 %thenstart
         Lreg=Checkregkey(data at,LHS_Base,LHS_Offset)
         %if Lreg>=0 %thenstart
            Lform=RegVal
            LHS_Form=RegVal
            LHS_Reg=Lreg
         %finish
      %finishelse Lreg=-1
      %if Rform=DirVal %and RHS_Size=4 %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %and Reg#Lreg %thenstart
            Rform=RegVal
            RHS_Form=RegVal
            RHS_Reg=Reg
         %finish
      %finish
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      %if bytes=8 %then -> DOpcode(Op) %else ->Opcode(Op)
!*
Opcode(IADD):
Opcode(IAND):
Opcode(IOR):
Opcode(IXOR):
      %if Lform=Litval %and Rform=Litval %thenstart
Simple:  Lval=LHS_Intval
         Rval=RHS_Intval
         ->Sop(Op)
!*
Sop(IADD):Res=Lval+Rval
Set:     Estklit(Res)
         %return
Sop(IAND):Res=Lval&Rval
         ->Set
Sop(IOR):Res=Lval!Rval
         ->Set
Sop(IXOR):Res=Lval!!Rval
         ->Set
Sop(ISUB):Res=Lval-Rval
         ->Set
Sop(IMULT):Res=Lval*Rval
         ->Set
      %finish
!*
L:    %if Lform=RegVal %or Lform=Regaddr %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,4)
      %return
!*
Opcode(ISUB):
      %if Lform=Litval %and Rform=Litval %then ->Simple
      %if Lform=RegVal %then ->A
      %if Rform=RegVal %thenstart
         %if reguse(Rreg)>=0 %thenstart
            reguse(Rreg)=reguse(Rreg)-255 
         %finishelsestart
            %if reguse(Rreg)>-240 %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)
               %if -X'8000'<=LHS_Intval<=X'7FFF' %thenstart
                  Gop RI(CI,Reg,LHS_Intval)
               %finishelsestart
                  Gop RX(CAM,Reg,LHS)
               %finish
            %finishelsestart
               Reg=Load Reg(-1,LHS)
               Gop RX(CAM,Reg,RHS)
            %finish
         %finish
          unlock reg(Reg)
      %finish
      unlock reg(Reg)
      Enote cc(CC)
      %return
!*
Opcode(IMULT):
      %if Lform=LitVal %thenstart
         %if Rform=LitVal %thenstart
            %if -X'7FFF'<=LHS_Intval<=X'7FFF' %thenstart
               %if -X'7FFF'<=RHS_Intval<=X'7FFF' %then ->Simple
            %finish
         %finish
         %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(SLL,Reg,Shift)
               Stackr(Reg,4)
               %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 Cpu=NP1 %thenstart  {reg pair not needed for NP1}
         ->L
      %finish
!*
      %if Lform=RegVal %thenstart
         %if Rform=Regval %thenstart
            %if Rreg=Lreg!!1 %thenstart
               Reg=Lreg&6
               Gop RR(MPR,Reg,Reg)
E:             %if Op=IREM %thenstart
                  reguse(Reg+1)=0
                  Stackr(Reg,4)
               %finishelsestart
                  reguse(Reg)=0
                  Stackr(Reg+1,4)
               %finish
               %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):
!*
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
               Rreg=Reg
            %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:          %if Cpu = NP1 %thenstart
               Gop RR(EXS,Reg,Reg+1)
            %finishelsestart
               Gop R(ES,Reg)
            %finish
            %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 Cpu = NP1 %thenstart
            Gop RR(EXS,Reg,Reg+1)
         %finishelsestart
            Gop R(ES,Reg)
         %finish
         %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
      %return

DOpcode(IAND):     { These can be done as two RR ops }
DOpcode(IOR):
DOpcode(IXOR):
!*
      %if Lform=RegVal %or Lform=Regaddr %thenstart
         %if Rform=RegVal %thenstart
            Gop RR(RRop(Op),Lreg,Rreg)
            Gop RR(RRop(op),Lreg+1,Rreg+1)
            unlock reg pair(Rreg)
         %finishelsestart
            reguse(Lreg)=-255
            reguse(Lreg+1)=-255
            Gop RX(RXop(op),Lreg,RHS)
         %finish
         Reg=Lreg
      %finishelsestart
         %if Rform=RegVal %thenstart
            reguse(Rreg)=-255
            reguse(Rreg+1)=-255
            Gop RX(RXop(Op),Rreg,LHS)
            Reg=Rreg
         %finishelsestart
            Reg=Load Reg(-1,LHS)
            Gop RX(RXop(Op),Reg,RHS)
         %finish
      %finish
      Stackr(Reg,8)
      %return


DOpcode(IADD):

      %if Lform=RegVal %or Lform=Regaddr %thenstart
         %if Rform=RegVal %then Release reg pair(Rreg)
         reguse(Lreg)=-255
         reguse(Lreg+1)=-255
         Gop RX(RXop(op),Lreg,RHS)
         Reg=Lreg
      %finishelsestart
         %if Rform=RegVal %thenstart
            reguse(Rreg)=-255
            reguse(Rreg+1)=-255
            Gop RX(RXop(Op),Rreg,LHS)
            Reg=Rreg
         %finishelsestart
            Reg=Load Reg(-1,LHS)
            Gop RX(RXop(Op),Reg,RHS)
         %finish
      %finish
      Stackr(Reg,8)
      %return
!*
DOpcode(ISUB):
      %if Lform=RegVal %then -> DOpcode(IADD)
      %if Rform=RegVal %then Release reg pair(RReg)
      Reg=Load Reg(-1,LHS)
      Gop RX(SUM,REg,RHS)
      Stackr(Reg,8)
      %return
!*
DOpcode(IEQ):
DOpcode(INE):
DOpcode(IGT):
DOpcode(ILT):
DOpcode(IGE):
DOpcode(ILE):
      CC=Op-IGT
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %then Release reg Pair(Rreg)
         Gop RX(CAM,Lreg,RHS)
         Reg=Lreg
      %finishelsestart
         %if Rform=RegVal %thenstart
            Reg=Rreg
            CC=Invcc(CC)
            Gop RX(CAM,Rreg,LHS)
         %finishelsestart
            Reg=Load Reg(-1,LHS)
            Gop RX(CAM,reg,RHS)
          %finish
      %finish
      unlock reg pair(Reg)
      Enote cc(CC)
      %return
!*


!*
DOpcode(IREM):
       abortm(" IREM not implememented ")
%end;! Int Binary Op
!*
%externalroutine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports INEG,IABS                                                  *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Reg1,I,lab1,bytes

      bytes=RHS_size
      %if RHS_form=DirVal %and bytes=4 %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&31=RegVal %thenstart
             Reg=RHS_Reg
             %if bytes<=4 %start
                Gop RR(TRN,Reg,Reg)
             %finishelsestart
                Release Reg Pair(Reg)           { Force to store }
                Reg=Claim reg pair(1)
                Gop R(Zr,reg); Gop R(Zr,reg+1)  { reg = 0 }
                Gop RX(SUM,Reg,RHS)            { 0 - reg = -reg }
             %finish
          %finishelsestart
             %if bytes<=4 %then Reg=Claim Reg %c
                          %else reg = Claim reg pair(1)
             Gop RX(LN,Reg,RHS)
          %finish
      %finishelsestart
         %if Op=INOT %thenstart
            Reg=Load Reg(-1,RHS)
            I=Litoffset(-1)

            Eafix(Plt,0)
            Gop RXB(EOM,Reg,0,0,I,4)
             %if Bytes=8 %then Eafix(PLT,0) %and Gop RXB(EOM,Reg+1,0,0,I,4)
         %finishelsestart
            %if Op=BNOT %thenstart
               Reg=Load Reg(-2,RHS)
               Reg1=claim reg
               Gop RI(LI,Reg1,1)
               %if bytes<=4 %then Gop RR(EOR,Reg,Reg1) %c
                            %else Gop RR(EOR,Reg+1,Reg1)
               unlock reg(Reg1)
            %finishelsestart
               %unless Op=IABS %then Abortm("illegal Unary OP")
!* N.B. on NP1 use TRABS in the following when it works
               %if bytes=8 %start
                  %if RHS_form&31=regval %start
                    Release reg pair(rhs_reg)
                    Gop RR(TRR,RHS_reg,RHS_Reg) {to set condition}
                  %finishelsestart  { load to set CC bits }
                    reg=Claim reg
                    Gop RX(L,-1,RHS)
                    Unlock reg(reg)
                  %finish
               %finishelsestart   { I*4 }
                  Reg=Load Reg(-2,RHS)
                  RHS_form=regval
                  %if RHS_Form&31=Regval %then Gop RR(TRR,Reg,Reg) {to set condition}
               %finish
               lab1=Mprivatelabel
               Gop Jump(BGT,lab1)
               %if bytes<=4 %start
                  Gop RR(TRN,Reg,Reg)
               %finishelsestart
                  reg = Claim reg pair(1)
                  Gop r(Zr,reg); Gop R(zr,reg+1)
                  Gop RX(SUM,reg,RHS)
               %finish
               Mcode Plabel(lab1)
            %finish
         %finish
      %finish
      Stackr(Reg,bytes)
%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                                      *
!***********************************************************************
%if Cpu = NP1 %thenstart
   %constbyteintegerarray RReop(RADD:RDIV) = ADRFW,SURFW,MPRFW,DVRFW
   %constbyteintegerarray RRdop(RADD:RDIV) = ADRFD,SURFD,MPRFD,DVRFD
   %constbyteintegerarray RXop(RADD:RDIV) = ADF,SUF,MPF,DVF
%finishelsestart
   %constbyteintegerarray RReop(RADD:RDIV) = ADRFW,SURFW,MPRFW,DVRFW
   %constbyteintegerarray RRdop(RADD:RDIV) = ADRFD,SURFD,MPRFD,DVRFD
   %constbyteintegerarray RXop(RADD:RDIV) = ADF,SUF,MPF,DVF
%finish
%integer Lform,Rform,Reg,Lreg,Rreg,Bytes,CC
%switch Opcode(RADD:RLE)
%switch Dopcode(RADD:RLE)
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      Bytes=LHS_Size
      %if Bytes=8 %thenstart
         Lreg=LHS_Reg
         Rreg=RHS_Reg
        ->Dopcode(Op)
      %finish
!*
      %if Lform=DirVal %thenstart
         Lreg=Checkregkey(data at,LHS_Base,LHS_Offset)
         %if Lreg>=0 %thenstart
            Lform=FregVal
            LHS_Form=FregVal
            LHS_Reg=Lreg
         %finish
      %finishelse Lreg=-1
      %if Rform=DirVal %thenstart
         Reg=Checkregkey(data at,RHS_Base,RHS_Offset)
         %if Reg>=0 %and Reg#Lreg %thenstart
            Rform=FregVal
            RHS_Form=FregVal
            RHS_Reg=Reg
         %finish
      %finish
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      ->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(RDIV):
      %if Cpu = NP1 %thenstart
         %if Hardoptions&1=0 %start
            %if Lform=Fregval %then ->A
            %if Rform=Fregval %then %Start
               %if reguse(Rreg)>=0 %then reguse(Rreg)=reguse(Rreg)-255 %else %c
                  %if reguse(Rreg)>-240 %then reguse(Rreg)=-255
               Lreg=Load reg(-1,LHS)
               ->B
            %finish
            ->C
         %finish
         %if Rform=FregVal %thenstart
            Gop R(RRFW,Rreg)
            reguse(rreg)=0
         %finishelsestart
            Rreg=claim reg
            Gop RX(RF,Rreg,RHS)
            Rform=FregVal
         %finish
         %if Lform=Litval %and LHS_Intval=X'41100000' %thenstart
            Stackfr(Rreg,4)
            %return
         %finish
         Op = RMULT
         ->Opcode(RMULT)
      %finish
!*
Opcode(RSUB):
      %if Lform=FregVal %then ->A
      %if Rform=FregVal %thenstart
         %if reguse(Rreg)>=0 %thenstart
            reguse(Rreg)=reguse(Rreg)-255  
         %finishelsestart
             %if Reguse(Rreg)>-240 %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
!*
Dopcode(RADD):
!*
Dopcode(RMULT):
      %if Lform=FregVal %thenstart
AA:      %if Rform=FregVal %thenstart
BB:         Gop RR(RRdop(Op),Lreg,Rreg)
            unlock reg pair(Rreg)
         %finishelsestart
            lock reg pair(Lreg)
            Gop RX(RXop(op),Lreg,RHS)
         %finish
         Reg=Lreg
      %finishelsestart
         %if Rform=FregVal %thenstart
            lock reg pair(Rreg)
            Gop RX(RXop(Op),Rreg,LHS)
            Reg=Rreg
         %finishelsestart
CC:         Reg=Load Dreg(-1,LHS)
            Gop RX(RXop(Op),Reg,RHS)
         %finish
      %finish
      Stackfr(Reg,8)
      %return
!*
Dopcode(RDIV):
      %if Cpu = NP1 %thenstart
         %if Hardoptions&1=0 %start
            %if Lform=Fregval %then ->AA
            %if Rform=Fregval %then %Start
               %if Usefardata#0 %and IndRegModVal<=Lform<=IndDirModVal %then %c
                   Release Reg Pair(Rreg) %and ->CC
               Lock Reg Pair(Rreg)
               Lreg=Load Dreg(-1,LHS)
               ->BB
            %finish
            ->CC
         %finish
         %if Rform=FregVal %thenstart
            Gop RR(RRFD,Rreg,Rreg)
            Reguse(rreg)=0
            Reguse(rreg+1)=0
         %finishelsestart
            Rreg=claim reg pair(1)
            Gop RX(RF,Rreg,RHS)
            Rform=FregVal
         %finish
         Op = RMULT
         ->Dopcode(RMULT)
      %finish
!*
Dopcode(RSUB):
      %if Lform=FregVal %then ->AA
      %if Rform=FregVal %thenstart
         lock reg pair(Rreg)
         Lreg=Load Dreg(-1,LHS)
         ->BB
      %finishelse ->CC
!*
Dopcode(RGT):
Dopcode(RLT):
Dopcode(REQ):
Dopcode(RNE):
Dopcode(RGE):
Dopcode(RLE):
      CC=Op-RGT
      %if Lform=FregVal %thenstart
         %if Rform=FregVal %thenstart
            Gop RR(SURFD,Lreg,Rreg)
            unlock reg pair(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 Dreg(-1,LHS)
            Gop RX(CAM,Reg,RHS)
         %finish
      %finish
      unlock reg pair(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,lab1
      Bytes=RHS_Size
      %if RHS_form&31=DirVal %and Bytes=4 %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&31=FregVal %thenstart
             Reg=RHS_Reg
             %if Bytes=4 %thenstart
                 Gop RR(TRN,Reg,Reg)
             %finishelsestart
                %if Cpu = NP1 %thenstart
                   Gop RR(TRND,Reg,Reg)
                %finishelsestart
                   Gop RR(TRC,Reg,Reg)
                   Gop RR(TRC,Reg+1,Reg+1)
                %finish
             %finish
          %finishelsestart
             %if Bytes=4 %thenstart
                Reg= Claim Reg
             %finishelsestart
                Reg=Claim Reg Pair(1)
             %finish
             Gop RX(LN,Reg,RHS)
          %finish
      %finishelsestart
         %unless Op=RABS %then Abortm("illegal Unary OP")
         !%unless Cpu = NP1 %thenstart
            lab1=Mprivatelabel
         !%finish
         %if Bytes=4 %thenstart
            Reg=Load Reg(-2,RHS)
            !%if Cpu = NP1 %thenstart
               !Gop RR(TRABS,Reg,Reg)
            !%finishelsestart
               %if RHS_Form&31=Fregval %then Gop RR(TRR,Reg,Reg) {to set condition}
               Gop Jump(BGT,lab1)
               Gop RR(TRN,Reg,Reg)
            !%finish
         %finishelsestart
            Reg=Load Dreg(-2,RHS)
            !%if Cpu = NP1 %thenstart
               !Gop RR(TRABSD,Reg,Reg)
            !%finishelsestart
               %if RHS_Form&31=Fregval %then Gop RR(TRR,Reg,Reg) {to set condition}
               Gop Jump(BGT,lab1)
               Gop RR(TRC,Reg,Reg)
               Gop RR(TRC,Reg+1,Reg+1)
            !%finish
         %finish
         !%unless Cpu = NP1 %thenstart
            Mcode Plabel(lab1)
         !%finish
      %finish
      Stackfr(Reg,Bytes)
%end;! Real Unary Op
!*
%endoffile