!* modified 16/07/86
!*
%ownstring(31) Versiontext="Fortran77 Compiler Version 0.1"
%owninteger Report=0
%owninteger Decode
%owninteger Language
!*
%constinteger IMP      =  1
%constinteger FORTRAN  =  2
%constinteger CCOMP    = 11
%constinteger PASCAL   = 14
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec Einitialise(%integer Lang, Avertext, Astackca,
                                                    Aglaca, Options)
%routinespec Eterminate(%integer adareasizes)
%routinespec Ecommon(%integer area, %stringname Name)
%routinespec Eendcommon(%integer area, Length)
%routinespec Elinestart(%integer lineno)
%routinespec Elinedecode
%routinespec Emonon
%routinespec Emonoff
%routinespec Efaulty
%integerfnspec Estkmarker
%routinespec Esetmarker(%integer Markerid, New Value)
%integerfnspec Eswapmode
!*
%routinespec Estklit(%integer Val)
%routinespec Estkconst(%integer Len, Ad)
%routinespec Estkdir(%integer Area, Offset, Adid, Bytes)
%routinespec Estkind(%integer Area, Offset, Adid, Bytes)
%routinespec Estkglobal(%integer Level, Offset, Adid, Bytes)
%routinespec Estkglobalind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkpar(%integer Level, Offset, Adid, Bytes)
%routinespec Estkparind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkresult(%integer Class, Type, Bytes)
%routinespec Erefer(%integer Offset, Bytes)
%routinespec Epromote(%integer Level)
%routinespec Edemote(%integer Level)
%routinespec Estkaddr(%integer Area, Offset, Adid, Bytes)
!*
%routinespec Elabel(%integer id)
%routinespec Ediscardlabel(%integer id)
%routinespec Ejump(%integer Opcode, Labelid)
%routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3)
%routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                     %integername SSTad)
%routinespec EswitchJump(%integer Switchid)
%routinespec EfswitchJump(%integer Switchid)
%routinespec Eswitchentry(%integer Switchid, Entry)
%routinespec Eswitchdef(%integer Switchid)
%routinespec EswitchLabel(%integer Switchid, Entry, Labelid)
!*
%routinespec Ed1(%integer area, Disp, Val)
%routinespec Ed2(%integer area, Disp, Val)
%routinespec Ed4(%integer area, Disp, Val)
%routinespec Edbytes(%integer area, Disp, len, ad)
%routinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%routinespec Efix(%integer area, disp, tgtarea, tgtdisp)
!*
%integerfnspec EXname(%integer type, %string(255)%name Xref)
%routinespec Eprecall(%integer Id)
%routinespec Ecall(%integer Id, Numpars, Paramsize)
%routinespec Eprocref(%integer Id, Level)
%routinespec Esave(%integer Asave, %integername Key)
%routinespec Erestore(%integer Asave, Key, Existing)
!*
%integerfnspec Enextproc
%routinespec Eproc(%stringname Name, %integer Props, Numpars, Paramsize,
                                                 Astacklen, %integername Id)
%routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen)
%routinespec Eentry(%integer Index,Numpars,Paramsize, Localsize, Diagdisp,
                                                       %stringname Name)
!*
%routinespec Edataentry(%integer Area, Offset, Length,
                                                       %stringname Name)
%routinespec Edataref(%integer Area, Offset, Length,
                                                       %stringname Name)
!*
%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
!*
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%include "ercs01:cfort_xaspecs1"
!%include "ercs01:cfort_xaspecs"
%include "ercs01:ebits_ecodes9"
%include "ercs01:ebits_enames6"
%include "ercs01:cfort_xamnem"
!*
!*
!***********************************************************************
!*        Common declarations                                          *
!***********************************************************************
!*
!*
!*
!***********************************************************************
!*
%constinteger Stack = 0
!*
%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 Regflag       = 32  {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:21) =  %c
  "LitVal        ","ConstVal      ","RegVal        ","FregVal       ",
  "TempVal       ","DirVal        ","IndRegVal     ","IndTempVal    ",
  "IndDirVal     ","ConstAddr     ","AddrDir       ","RegAddr       ",
  "TempAddr      ","DirAddr       ","AddrDirMod    ","RegModAddr    ",
  "TempModAddr   ","DirModAddr    ","IndRegModVal  ","IndTempModVal ",
  "IndDirModVal  ","AddrDirModVal "
!*
%recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg,
                                  Base,Modbase,Scale,Modform,
                      (%integer Offset %or %integer Intval),
                      (%integer Modoffset %or %integer Modintval),
                      %integer Size,Adid)
!*
%ownrecord(Stkfmt)%array Stk(0:15)
%ownrecord(Stkfmt) LitZero
%ownrecord(Stkfmt) LitOne
!*
%owninteger Elevel
%owninteger ProgFaulty
%owninteger ProcProps
%owninteger NestedProcs
!*
%recordformat LabsFmt(%integer LabId, GlaAd)
%constinteger MaxLabs = 100
%ownrecord(LabsFmt)%array Labs(1:MaxLabs)
!*
%recordformat CaseFmt(%integer CaseID,SSTAd)
%constinteger CaseDepth = 100
%ownrecord(CaseFmt)%array Cases(1:CaseDepth)
!
%recordformat swfmt(%integer id,sstad,glaad,upper,lower,proclevel)
%constinteger swmax=40
%ownrecord(swfmt)%array switches(1:swmax)
%ownrecord(swfmt)%name Curswitch
!*
%conststring(9)%array Expprocs(0:14)=  %c                     
      "f_powii"  ,"f_powri"  ,"f_powdi" ,"f_powqi"  ,"f_powci"   ,   
      "f_powzi"  ,"f_powzzi" ,""        ,""         ,"f_powrr"   ,
      "f_powdd"  ,"f_powqq"  ,"f_powcc" ,"f_powzz"  ,"f_powzzz"    
!*
%constintegerarray Expprocpdesc(0:14)= %c
      X'20008',X'20008',X'2000C',X'20008',X'3000C',
      X'3000C',X'3000C',0       ,0       ,X'20008',
      X'20010',X'20008',X'3000C',X'3000C',X'3000C'
!*
%constintegerarray Expproctype(0:14)= %c
      X'10401',X'10402',X'10802',X'11002',X'10000',
      X'10000',X'10000',       0,       0,X'10402',
      X'10802',X'11002',X'10000',X'10000',X'10000'
!*
%ownintegerarray Expprocref(0:14)
!*
%conststring(9)%array Spprocs(0:14)= %c
      "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv"  ,
      "f_cddiv"  ,"f_cqdiv"  ,"f_index"  ,"f_concat",
      "p_stop"   ,""         ,""         ,"p_eoft",
      "p_eof"    ,"p_eol"    ,"p_lazy"
!*
%constintegerarray Spprocpdesc(0:14)= %c
      X'3000C',X'3000C',X'3000C',X'3000C',
      X'3000C',X'3000C',X'40010',X'40010',
      0       ,0       ,0       ,X'10004',
      X'10004',X'10004',X'10004'
!*
%constintegerarray Spproctype(0:14)= %c
      X'10000',X'10000',X'10000',X'10000',
      X'10000',X'10000',X'10000',X'10000',
      0       ,0       ,0       ,X'10001',
      X'10001',X'10001',X'10001'
!*
%ownintegerarray Spprocref(0:14)
!*
%constbyteintegerarray minelevel(0:202)=0,2(4),1(2),2(3),1,2(11),1,0,2(6),1(7){itwb},
                                       0(6),1,1,0,2,1,1,0(2){to 50},
                                       2(4),3,3,3,2,0(3),3(6){to 67},
                                       0(12){unused},
                                       2(14),1(6),2{to 100},
                                       2(5),0(2),2(4),0{to 112},
                                       2(4),1(2),0(17),2(8){to 143},
                                       2(6),2(6),1(7),0(2){to 164},
                                       0(12),1,0(6),2(2),{ to 185}
                                       1(2),0(2),1(4),3,3,2,1,0,1,1,0,3;
%owninteger Unasslab,Bounderr
!*
!*
!***********************************************************************
!*        Amdahl-specific declarations                                 *
!***********************************************************************
!*
!*
%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 R8  =  8
%constinteger R9  =  9
%constinteger R10 = 10
%constinteger R11 = 11
%constinteger R12 = 12
%constinteger R13 = 13
%constinteger R14 = 14
%constinteger R15 = 15
!*
%constbyteintegerarray Setcc(0:5)=2,4,8,6,10,12   {GT LT EQ NE GE LE}
%constbyteintegerarray Invcc(0:15)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15
!*
%constinteger Stack Offset=64
%constinteger Param Offset=64
%ownintegerarray Display Offset(0:16)
%owninteger Gla Offset
!*
%constinteger bytesofic=72
%constintegerarray Cnstinit(0:(bytesofic-1)>>2)= 0,0,
 X'4E000000', X'80000000',
 X'4E000001', X'00000000',
 X'4F000000', X'08000000',
 X'81818181', X'81818181',
 X'40800000', X'00000000',
 X'00000000', X'00000000',
 x'48800000', X'00000000',
 X'4E000000', X'00000000'
%constinteger TWO31 =  8
%constinteger TWO32 = 16
%constinteger TWO31R= 24
%constinteger RHALF = 40
%constinteger maxiasr=56,zerononstd=64
!*
!***********************************************************************
!*
%owninteger SSTOffset
%ownintegerarray Areabase(0:255)
%ownintegerarray Areaprops(0:255)
%ownintegerarray Ruse(0:15)
%ownintegerarray Fruse(0:6)
!*
%owninteger Addrstackca, Addrglaca
%owninteger Upperlineno
%owninteger UsingR14, UsingR15, Lastreg, Lastbreg, Lastfreg, Max4k
%owninteger Lockedb1
%owninteger CC, CCset
%owninteger Glaf77regs,Glawork,Curdiagca, OuterLNBDisp
%owninteger CurCnst
%owninteger Next Param Offset
%ownintegerarray Save Param Offset(0:16)
%owninteger Active Calls
%constinteger elabbase=199999
%owninteger Einternallab
%ownintegerarray Procmark(1:15)
%owninteger Proclevel
!*
!*
!***********************************************************************
!*        Code generation procedure specs                              *
!***********************************************************************
!*
!*
%routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Address(%record(Stkfmt)%name Stk)
%integerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg)
%integerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg,
                                                  %integername Bytes)
%integerfnspec Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize)
%routinespec Push Operand(%record(Stkfmt)%name Operand)
%routinespec Stackr(%integer R)
%routinespec Stackfr(%integer FR,Bytes)
%routinespec Establish Logical
%routinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%routinespec U Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%routinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%routinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%routinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%routinespec Convert RR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode)
%integerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
%routinespec Push Param(%integer Mode,%record(Stkfmt)%name Stk)
%integerfnspec Load address(%record(Stkfmt)%name Stk)
%routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%routinespec Expcall(%integer Proc)
%routinespec Spcall(%integer Proc)
!*
%routinespec Referp(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue)
!*
%routinespec Clear Regs
%routinespec Dropall
%routinespec Freeup Freg(%integer R)
%routinespec Freeup Reg(%integer R)
%routinespec Freeregs
%routinespec Reset Reguse(%integer Old,New)
%integerfnspec Claimfr(%integer Curreg)
%integerfnspec Claimfrpair(%integer Curreg)
%integerfnspec Claimr(%integer Curreg)
%integerfnspec Claimrpair(%integer Curreg)
%integerfnspec Claimbr
%integerfnspec New Temp(%integer Bytes)
%routinespec Setint(%integer Val,Size,%integername B2,D2)
%integerfnspec Basereg(%integer Area)
%integerfnspec SetX2(%integername D2)
%routinespec Range(%integername B,D)
%integerfnspec Indbase(%integer Area,Disp)
%routinespec Do Rx(%integer Op,Reg,Base,Offset)
%integerfnspec Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg)
%routinespec OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2)
%routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
%routinespec Set BD(%record(Stkfmt)%name Stk,%integername B,D)
!*
!***********************************************************************
!*
%ownstring(8)%array Areas(0:255)=  %c
   "Stack  ","Code   ","Gla    ","","Ust    ","Gst    ","Diags  ","Scalars",
   "Ioarea ","","Consts ",""(245)
!*
%externalstringfnspec itos %alias "S#ITOS" (%integer N)
%externalintegermapspec comreg %alias "S#COMREGMAP" (%integer n)
%routine Phex(%integer Val)
%conststring(1)%array C(0:15)=  %c
   "0","1","2","3","4","5","6","7",
   "8","9","A","B","C","D","E","F"
%integer I
      %cycle I=28,-4,0
         printstring(C((Val>>I)&15))
      %repeat
%end
!*
%integerfn Glaspace(%integer bytes)
%integer I
      bytes=((bytes+3)>>2)<<2
      I=integer(Addrglaca)+Gla offset
      integer(addrglaca)=integer(addrglaca)+bytes
      %result=I
%end;! Glaspace
!*
%routine Dump StkRec(%record(Stkfmt)%name E)
%integer I,J,K
%routine Pform(%integer Form,Reg,Base,Offset)
      printstring(Eform(Form&31))
      %if Form&Regflag#0 %then write(Reg,1) %and %return
      %if Form=Litval %thenstart
         write(Offset,4)
         %return
      %finish
!      %if Base#0 %thenstart
         printstring(Areas(Base))
!      %finish
!      %if Offset#0 %thenstart
         printstring(" + ")
         write(Offset,3)
!      %finish
%end;! Pform
         Pform(E_Form,E_Reg,E_Base,E_offset)
         %if (E_Form&31)>=AddrDirMod %thenstart
            printstring("  mod by:")
            Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset)
            %if E_Scale>1 %thenstart
               printstring("  scaled by:")
               write(E_Scale,1)
            %finish
         %finish
         printstring("  size:")
         write(E_Size,1)
         newline
%end;! Dump Estack
!*
%routine Dump Estack
%record(Stkfmt)%name E
%integer I,J,K
%routine Pform(%integer Form,Reg,Base,Offset)
      printstring(Eform(Form&31))
      %if Form&Regflag#0 %then write(Reg,1) %and %return
      %if Form=Litval %thenstart
         write(Offset,4)
         %return
      %finish
!      %if Base#0 %thenstart
         printstring(Areas(Base))
!      %finish
!      %if Offset#0 %thenstart
         printstring(" + ")
         write(Offset,3)
!      %finish
%end;! Pform
      %if Elevel<=0 %then %return
write(ruse(1),1);write(ruse(2),1);write(ruse(3),1);newline
      printstring("Estack:
")
      I=Elevel
      %while I>0 %cycle
         J=addr(Stk(I))
!         %cycle K=0,4,16
!            Phex(integer(J+K))
!            space
!         %repeat
         E==record(J)
         write(I,1);printstring(":")
         Pform(E_Form,E_Reg,E_Base,E_offset)
         %if (E_Form&31)>=AddrDirMod %thenstart
            printstring("  mod by:")
            Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset)
            %if E_Scale>1 %thenstart
               printstring("  scaled by:")
               write(E_Scale,1)
            %finish
         %finish
         printstring("  size:")
         write(E_Size,1)
         newline
         I=I-1
      %repeat
%end;! Dump Estack
!*
!**********************************************************************
!**********************************************************************
!**                      Error reporting                             **
!**********************************************************************
!**********************************************************************
!*
!*
%routine Low Estack(%integer Opcode,Reqlevel)
      printstring("******* Estack error ******
  Op = ".Eopname(Opcode)."  actual/required levels:")
      write(Elevel,4)
      write(Reqlevel,4)
      newline
%monitor
%stop
      Elevel=0
%end;! Low Estack
!*
%routine Abort
      Dump Estack
       %monitor
       %stop
%end;! Abort
!*
%routine abortm(%string(31) S)
      printstring("
*** Xgen abort - ".S." ***
")
      Dump Estack
      %monitor
      %stop
%end;! abortm
!*
%routine Unsupported Opcode(%integer Opcode)
%string(15) S
      %if Opcode<=255 %then S=Eopname(Opcode) %elseif %c
	Opcode<511 %then S=Ef77opname(Opcode) %else S=Epasopname(Opcode)
      printstring("******* Unsupported Opcode ****** ".S)
      newline
%end;! Unsupported Opcode
!*
!*
!***********************************************************************
!***********************************************************************
!**             Externally visible procedures                         **
!***********************************************************************
!***********************************************************************
!*
!*
!*                    *********************
!*                    *  Administration   *
!*                    *********************
!*
!*
%externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options)
!***********************************************************************
!* called once at the start of compilation to initialise Eput          *
!***********************************************************************
%integer I,Flags
%String(63) Verss
      ProgFaulty=0
!      Report=options&1;     ! options go into gla+19 and can not be used as this frig uses them!
      Decode=Options&X'4000'
      Language=Lang
      %if Report#0 %thenstart
         printstring("Einitialise 
")
      %finish
      Addrstackca=Astackca
      Addrglaca=Aglaca
      Upperlineno=-1
      UsingR14=0
      UsingR15=0
      Clear Regs
      CCset=0
      Elevel=0
      OuterLNBDisp = -1
      %cycle I=0,1,255
         Areabase(I)=0
         Areaprops(I)=0
      %repeat
      %for I=1,1,CaseDepth %cycle
         Cases(I)_CaseId = -1
      %repeat
      switches(i)=0 %for i=1,1,swmax
      curswitch==switches(1)
      Einternallab=elabbase-2
      %for I = 1,1,MaxLabs %cycle
         Labs(I)_LabId = -1
      %repeat
      %cycle I=4,1,10
         Areabase(I)=I<<2+64
      %repeat
      %cycle I=0,1,14
         Expprocref(I)=0
      %repeat
      %cycle I=0,1,14
         Spprocref(I)=0
      %repeat
!*
      %if Language=PASCAL %then %STart
         Gla Offset=48
         SSTOffset = 0
         Verss="Pascal version ".itos(aver)
         aver=addr(Verss)
         report=comreg(27)>>14&1
      %finish %else Gla Offset=0
!*
      %if Language=FORTRAN %then Flags=3 %else Flags=1
      Pinitialise(-1,Flags,Aver)
!*
      Pfix(Gla,4,Code,0);! initialise first six words of gla 
      Pfix(Gla,8,Ust,0)
      Areabase(ust)=8
      Pfix(Gla,12,SST,0)
      areabase(sst)=12
      %if Lang=PASCAL %then Lang=15     {a communication problem}
      Pd4(Gla,16,(Lang<<24)!Options)
      Pfix(Gla,20,Diags,0)
      %if Language=PASCAL %thenstart
         I=32
      %finishelsestart
         I=Glaspace(16)
      %finish
      Glaf77regs=I
      Pfix(Gla,I,Static,0)
      Pfix(Gla,I+4,Cnst,0)
      Glawork=I+8
!*
      Pdbytes(Cnst,0,bytesofic,addr(Cnstinit(0)))
      Curcnst=bytesofic
      Max4k=0
      Lockedb1=0
      Active Calls=0
!*
      LitZero=0; LitZero_Size=4; LitZero_Form=LitVal
      LitOne=0; LitOne_Size=4; LitOne_Form=LitVal; LitOne_IntVal=1
      Proclevel=0
      PIX RX(LA,0,0,0,0);! to avoid PUT problem with internal Pascal procs
%end;! Einitialise
!*
%externalroutine Eglaoffset(%integer Offset)
!***********************************************************************
!* modify gla offset                                                   *
!***********************************************************************
%return
      %if Report#0 %thenstart
         printstring("Eglaoffset ")
         write(Offset,8)
         newline
      %finish
      Gla Offset = Gla Offset + Offset
%end;! Gla Offset
!*
%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator         *
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J
      %if Report#0 %thenstart
         printstring("Eterminate 
")
      %finish
      %if ProgFaulty#0 %then %return
      J=0
!newline
      %cycle I=1,1,9
         S(I)=integer(Adareasizes+J)
!write(s(i),4)
         J=J+4
      %repeat
!newline
      %if Language=PASCAL %thenstart
         S(2)=S(2)+Gla Offset
         S(4) = SSTOffset
      %finish
      S(10)=CurCnst
      %if language#Fortran %Then pminmultiples(max4k+1)
      I=Pterminate(addr(S(1)), 0)
      integer(adareasizes)=S(1)
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255)                              *
!***********************************************************************
%integer Prop
      %if Report#0 %thenstart
         printstring("Ecommon   ");Write(Area,1);spaces(4);printstring(Name) 
         Newline
      %finish
      %if ProgFaulty#0 %then %return
      Area=Area+256
      %if Name="F#BLCM" %then Prop=1 %else Prop=2
      Areaprops(Area-256)=Prop
      Pnewarea(Name,Area,Prop)
%end;! Ecommon
!*
%externalroutine Eendcommon(%integer area,Length)
!***********************************************************************
!* define length of previously defined common                          *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eendcommon   ");write(Area,1);write(Length,6) 
         Newline
      %finish
      %if ProgFaulty#0 %then %return
      Area=Area+256
      Pendarea(Area,Length,Areaprops(Area-256))
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line                                            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Decode#0 %then Plinedecode
      Plinestart(Lineno)
      PIX SI(MVI, lineno&X'FF', R10, 3)
      %if lineno & X'FF00' # Upperlineno %thenstart
         PIX SI(MVI, lineno>>8, R10, 2)
         Upperlineno = lineno & X'FF00'
      %finish
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart        *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Elinedecode 
");
      %finish
      %if ProgFaulty#0 %then %return
      Plinedecode
%end;! Elinedecode
!*
%externalintegerfn Estkmarker
!***********************************************************************
!*    Stacks a literal(<=16bits) whose exact value will be given later *
!*    via a call of esetmarker. The result is an identifier which is   *
!*    returned when the value is specified. Pmarker supplies the       *
!*    facility                                                         *
!***********************************************************************
%integer reg,markval
      %if Report#0 %thenstart
         printstring("Estkmarker  
")
      %finish
      markval=pmarker(4);                  ! reserve 4 halfwords
      reg=claimr(0);                        ! zero wont work
      psetopd(markval,0,x'580C'!reg<<4)
      psetopd(markval,2,x'4100'!reg<<4!reg)
      stackr(reg)
      %result=markval
%end;! Estkmarker
!*
%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!*    Nominate the value of the literal stacked by estkmarker(above)   *
!***********************************************************************
%integer j
      %if Report#0 %thenstart
         printstring("Esetmarker  ");write(Markerid,4)
         write(New Value,4)
         newline
      %finish
      j=newvalue>>12
       %if j>Max4k %then Max4k=j
      psetopd(markerid,1,j<<2);         ! Fill the 4k multiple
      psetopd(markerid,3,newvalue&4095);! file the load address offset
%end;! Esetmarker
!*
%externalintegerfn Eswapmode
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswapmode  
")
      %finish
      %result=0
%end;! Eswapmode
!*
%externalroutine Emonon
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      Report=1
%end;! Emonon
!*
%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing                                           *
!***********************************************************************
      Report=0
%end;! Emonoff
!*
%externalroutine Efaulty
!***********************************************************************
!* compilation has a fault - no object file to be generated            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Efaulty 
");
      %finish
      ProgFaulty=1
      Pfaulty
%end;! Efaulty
!*
!*
!*
!*                 *********************
!*                 * Stack operations  *
!*                 *********************
!*
!*
%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal                              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estklit  ");write(Val,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=LitVal
      Stk(Elevel)_Intval=Val
      Stk(Elevel)_Size=4
%end;! Estklit
!*
%externalroutine Estkconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary           *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkconst     ")
         write(Len,4)
         space; phex(integer(ad))
         %if len>4 %then space %and phex(integer(ad+4))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Pdbytes(Cnst,CurCnst,Len,Ad)
      Estkdir(Cnst,CurCnst,0,Len)
      CurCnst=Curcnst+((Len+3)>>2)<<2
%end;! Estkconst
!*
%externalroutine Estkrconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary           *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("EstkRconst     ")
         write(Len,4)
         %if Len=4 %then Print(real(Ad),8,12) %else Print(longreal(Ad),8,12)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Pdbytes(Cnst,CurCnst,Len,Ad)
      Estkdir(Cnst,CurCnst,0,Len)
      CurCnst=Curcnst+((Len+3)>>2)<<2
%end;! Estkrconst
!*
%externalroutine Estkdir(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand                                             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkdir   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCSet#0 %then Establish Logical
      %if Area=0 %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=DirVal
      Stk(Elevel)_Size=Bytes
      Stk(Elevel)_Base=Area
      Stk(Elevel)_Offset=Offset
      Stk(Elevel)_Adid=Adid
%end;! Estkdir
!*
%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand                                          *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkind   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area=0 %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=IndDirVal
      Stk(Elevel)_Size=Bytes
      Stk(Elevel)_Base=Area
      Stk(Elevel)_Offset=Offset
      Stk(Elevel)_Adid=Adid
%end;! Estkind
!*
%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand local to an enclosing level                 *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkglobal ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Offset = Offset + StackOffset
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      %if Level=Proclevel %thenstart
         Stk(Elevel)_Form = DirVal
         Stk(Elevel)_Offset = Offset
      %finishelsestart   { Global }
         Stk(Elevel)_Form=IndDirModVal
        Stk(Elevel)_Modform=LitVal
        Stk(Elevel)_Offset=DisplayOffset(proclevel)+(Level*4)
        Stk(Elevel)_ModIntVal=Offset
      %finish
      Stk(Elevel)_Size = Bytes
      Stk(Elevel)_Base = 0
      Stk(Elevel)_Adid=Adid
%end;! Estkglobal
!*
%externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes)
%end
!*
%externalroutine Estkgind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand local to an enclosing level              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkgind ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Offset=Offset+Param Offset
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      %if Level=Proclevel %thenstart
         Stk(Elevel)_Form=IndDirVal
         Stk(Elevel)_Base = 0
      %finishelsestart
         Stk(Elevel)_Form = IndRegModVal
         Stk(Elevel)_Reg = ClaimBR
         PIX RX(L,Stk(Elevel)_Reg,0,R10,DisplayOffset(proclevel)+Level<<2)
         Stk(Elevel)_Modform = LitVal
         Stk(Elevel)_Modintval = Offset
      %finish
      Stk(Elevel)_Size=Bytes
      Stk(Elevel)_Adid=Adid
%end;! Estkgind
!*
%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct parameter operand                                   *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkpar   ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Offset=Offset+Param Offset
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      %if Level=ProcLevel %thenstart      { Local parameter }
         Stk(Elevel)_Form=DirVal
         Stk(Elevel)_Offset=Offset
      %finishelsestart      { Global parameter }
         Stk(Elevel)_Form=IndDirModVal
         Stk(Elevel)_Modform=LitVal
         Stk(Elevel)_Offset=DisplayOffset(proclevel)+(Level*4)
         Stk(Elevel)_ModIntVal=Offset
      %finish
      Stk(Elevel)_Size = Bytes
      Stk(Elevel)_Base = 0
      Stk(Elevel)_Adid=Adid
%end;! Estkpar
!*
%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect parameter operand                                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkparind ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Offset=Offset+Param Offset
      %if Elevel=15 %then %monitor %and %stop
      %if CCSet#0 %then Establish Logical
      Elevel=Elevel+1
      Stk(Elevel)=0
      %if Level=Proclevel %thenstart
         Stk(Elevel)_Form=IndDirVal
         Stk(Elevel)_offset=offset
         Stk(Elevel)_Base = 0
      %finishelsestart
         Stk(Elevel)_Form = IndRegModVal
         Stk(Elevel)_Reg = ClaimBR
         PIX RX(L,Stk(Elevel)_Reg,0,R10,DisplayOffset(proclevel)+Level<<2)
         Stk(Elevel)_Modform = LitVal
         Stk(Elevel)_Modintval = Offset
      %finish
      Stk(Elevel)_Size=Bytes
      Stk(Elevel)_Adid=Adid
%end;! Estkparind
!*
%externalroutine Estkresult(%integer Class,Type,Bytes)
!***********************************************************************
!* defines the result stacked by a function call                       *
!* Type = 1  int                                                       *
!*      = 2  real                                                      *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkresult ")
         write(Class,4);write(Type,4);write(Bytes,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Type=2 %thenstart;! real
         Stackfr(0,Bytes)
      %finishelse %if Type=3 %thenstart
         Elevel = Elevel + 1
         %if Elevel>15 %then %monitor %and %stop
         Stk(Elevel) = 0
         Stk(Elevel)_Form = IndRegVal
         Stk(Elevel)_Reg = R1
         Ruse(R1) = -Elevel
         Stk(Elevel)_Size = Bytes
      %finishelsestart
         Stackr(R1)
      %finish
%end;! Estkresult
!*
%externalroutine Erefer(%integer Offset,Bytes)
!***********************************************************************
!* stacks the address of a direct operand                              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Erefer   ");write(Offset,1);write(Bytes,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel<1 %then Abort %and %return
      Refer(Stk(Elevel),Offset)
      Stk(Elevel)_Size=Bytes
%end;! Erefer
!*
%externalroutine Epromote(%integer Level)
!***********************************************************************
!* move the entry at Level in Estack to the top of the Estack          *
!*  - the top entry is at level 1                                      *
!***********************************************************************
%record(Stkfmt) E 
%integer I
      %if Report#0 %thenstart
         printstring("Epromote ");write(Level,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %unless 0<Level<=Elevel %then abort
      %if Level=1 %then %return
      Level=Elevel-Level+1
      E=Stk(Level)
      Reset Reguse(Level,Elevel+1);! to avoid problems
      %cycle I=Level,1,Elevel-1
         Stk(I)=Stk(I+1)
         Reset Reguse(I+1,I)
      %repeat
      Stk(Elevel)=E
      Reset Reguse(Elevel+1,Elevel)
      %if Report#0 %then DumpEstack
%end;! Epromote
!*
%externalroutine Edemote(%integer Level)
!***********************************************************************
!* move the entry at the top of the Estack to Level in Estack          *
!*  - the top entry is at level 1                                      *
!***********************************************************************
%record(Stkfmt) E 
%integer I
      %if Report#0 %thenstart
         printstring("Edemote ");write(Level,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %unless 0<Level<=Elevel %then abort
      %if Level=1 %then %return
      Level=Elevel-Level+1
      E=Stk(Elevel)
      Reset Reguse(Elevel,Elevel+1);! to avoid problems
      %cycle I=Elevel,-1,Level+1
         Stk(I)=Stk(I-1)
         Reset Reguse(I-1,I)
      %repeat
      Stk(Level)=E
      Reset Reguse(Elevel+1,Level)
%end;! Edemote
!*
%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand                              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkaddr   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCSet#0 %then Establish Logical
      %if Area=0 %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=AddrDir
      Stk(Elevel)_Size=4;! always 4 bytes for an address
      Stk(Elevel)_Base=Area
      Stk(Elevel)_Offset=Offset
      Stk(Elevel)_Adid=Adid
%end;! Estkaddr
!*
%externalroutine Estkgaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a global operand                              *
!***********************************************************************
 %record(Stkfmt)%name Lstk
     %if Report#0 %thenstart
         printstring("Estkgaddr   ")
         write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      Offset=Offset+Param Offset
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      %if Level=ProcLevel %thenstart
         Lstk_Form = AddrDir
         Lstk_Offset = Offset
         Lstk_Base=0
      %finishelsestart   { Global }
         Lstk_Form=DirModaddr
         Lstk_Offset=Display Offset(proclevel) + (Level<<2)
         Lstk_Modform=Litval
         Lstk_Modoffset=Offset
      %finish
      LStk_Size = 4   { Always 4 for an address }
      LStk_Base = 0
      Lstk_Adid=Adid
%end;! Estkgaddr
!*
%externalroutine Estkpaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a parameter operand                           *
!***********************************************************************
 %record(Stkfmt)%name Lstk
     %if Report#0 %thenstart
         printstring("Estkpaddr   ")
         write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      Offset=Offset+Param  Offset
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      %if Level=ProcLevel %thenstart
         Lstk_Form = AddrDir
         Lstk_Offset = Offset
      %finishelsestart   { Global parameter }
         Lstk_Form = IndDirModVal
         Lstk_Offset = DisplayOffset(proclevel) + Level<<2
         Lstk_Modform = LitVal
         Lstk_Modoffset = Offset
      %finish
      Lstk_Size=4;! always 4 bytes for an address
      Lstk_Base=0
      Lstk_Adid=Adid
%end;! Estkpaddr
!*
%externalroutine Epsave(%integername Base)
!***********************************************************************
!* Saves the base address held in (Etos)                               *
!***********************************************************************
%integer I
%record(Stkfmt) S
      %if Report#0 %thenstart
         printstring("Epsave
")
      %finish
      %if ProgFaulty#0 %then Base=0 %and %return
      %if Elevel<1 %then Abortm("Epsave")
      S=0
      I=base; %if i<=0 %then abort
      S_Form=DirVal
      S_Base=stack
      S_Offset=I+paramoffset
      S_Size=4
!      Push Operand(Stk(Elevel))
      Push Operand(S)
      Eop(Estore)
      Base=I
%end;! Epsave
!*
%externalroutine Eprestore(%integer Base)
!***********************************************************************
!* Restores the saved base address into (Etos)                         *
!***********************************************************************
%record(Stkfmt) S
      %if Report#0 %thenstart
         printstring("Eprestore "); write(Base,1); newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCSet#0 %then EstablishLogical
      S=0
      S_Form=DirAddr
      S_Base=stack
      S_Offset=Base+paramoffset
      S_Size=4
      Push Operand(S)
%end;! Eprestore
!*
%externalroutine Epdiscard(%integer Base)
{dummy to satisfy pascal reference}
%end;! Epdiscard
!*
%externalroutine Evsave(%integername Base)
!***********************************************************************
!* Saves the value held in (Etos)                               *
!***********************************************************************
%integer I, Reg
%record(Stkfmt) S
      %if Report#0 %thenstart
         Printstring("Evsave
")
      %finish
      %if ProgFaulty#0 %then Base=0 %and %return
      %if Elevel<1 %then Abortm("Evsave")
      Reg = LoadInt(Stk(Elevel),-1,0)
      Stk(Elevel) = 0
      Stk(Elevel)_Form = RegVal
      Stk(Elevel)_Reg = Reg
      Stk(Elevel)_Size = 4
      S=0
      I=New Temp(4)
      S_Form=DirVal
      S_Base=Stack
      S_Offset=I
      S_Size=4
      Push Operand(Stk(Elevel))
      Push Operand(S)
      Eop(Estore)
      Base=I
%end;! Evsave
!*
%externalroutine Evrestore(%integer Base)
!***********************************************************************
!* Pushes the saved value as (Etos)                                    *
!***********************************************************************
%record(Stkfmt) S
      %if Report#0 %thenstart
         printstring("Evrestore "); write(Base,1); newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCSet#0 %then Establish Logical
      S=0
      S_Form=DirVal
      S_Base=Stack
      S_Offset=Base
      S_Size=4
      Push Operand(S)
%end;! Evrestore
!*
%externalroutine Evdiscard(%integer Temp)
{dummy to satisfy pascal reference}
%end;! Evdiscard
!*
!*
!*
!*                 *********************
!*                 *  Labels, Jumps    *
!*                 *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label                                                    *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Elabel ");write(Id,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel>0 %then Abort
      Upperlineno = -1
      Dropall
      Plabel(id)
%end;! Elabel
!*
%externalroutine Eplabel(%integer Id)
!***********************************************************************
!* register a private label                                            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eplabel ");write(Id,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
!?      Dropall
      Plabel(id)
%end;! Eplabel
!*
%externalroutine Ediscardlabel(%integer Id)
!***********************************************************************
!* advise that  a label can now be discarded - i.e. no future ref       *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ediscardlabel ");write(Id,4)
         newline
      %finish
%end;! Ediscardlabel
!*
%externalroutine Euchecklab(%integer Labid)
      Unasslab=Labid
%end
!*
%externalroutine Eboundlab(%integer Labid)
      Bounderr=Labid
%end;! Eboundlab
!*
%externalroutine Ejump(%integer Opcode, Labelid)
!***********************************************************************
!* generate specified conditional or unconditional jump                *
!***********************************************************************
%switch Op(0:164)
%integer Reg1,Freg1,XAop,Bytes
      %if Report#0 %thenstart
         printstring("Ejump ".Eopname(Opcode));write(Labelid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      ->Op(Opcode)
!*
Op(*):%monitor
      %stop
!*
Op(JIGT):
Op(JILT):
Op(JIEQ):
Op(JINE): 
Op(JIGE): 
Op(JILE):
      CC=Setcc(Opcode-JIGT)
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2))
      CCset=0
      Pjump(BC,Labelid,CC,R14)
      %return
!*
Op(JUGT):
Op(JULT):
Op(JUEQ):
Op(JUNE): 
Op(JUGE): 
Op(JULE):
      CC = Setcc(Opcode-JUGT)
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      U Int Binary Op(UGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2))
      CCset = 0
      PJump(BC,Labelid,CC,R14)
      %return
!*
Op(JINTGZ):
Op(JINTLZ):
Op(JINTZ):
Op(JINTNZ):
Op(JINTGEZ):
Op(JINTLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      PIX RR(LTR,Reg1,Reg1)
      Pjump(BC,Labelid,Setcc(Opcode-JINTGZ),R14)
      %return
!*
Op(JUGTZ):
Op(JULTZ):
Op(JUEQZ):
Op(JUNEZ):
Op(JUGEZ):
Op(JULEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      PIX RR(LTR,Reg1,Reg1)
      Pjump(BC,Labelid,Setcc(Opcode-JUGTZ),R14)
      %return
!*
Op(JUMP):
      Pjump(BC,Labelid,15,R14)
      %return
!*
Op(JRGT):
Op(JRLT):
Op(JREQ): 
Op(JRNE): 
Op(JRGE):
Op(JRLE): 
      CC=Setcc(Opcode-JRGT)
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Real Binary Op(RGT+Opcode-JRGT,Stk(Elevel+1),Stk(Elevel+2))
      CCset=0
      Pjump(BC,Labelid,CC,R14)
      %return
!*
Op(JRGZ):  
Op(JRLZ):
Op(JRZ): 
Op(JRNZ):
Op(JRGEZ):
Op(JRLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
      %if Bytes=4 %then XAop=LTER %else XAop=LTDR
      PIX RR(XAop,Freg1,Freg1)
      Pjump(BC,Labelid,Setcc(Opcode-JRGZ),R14)
      %return
!*
Op(JTRUE):
      %if CCset=0 %thenstart
         %if Elevel<1 %then Low Estack(Opcode,1) %and %return
         Elevel=Elevel-1
         Reg1=Load Int(Stk(Elevel+1),-1,0)
         PIX RR(LTR,Reg1,Reg1)
         Pjump(BC,Labelid,6,R14)
         %return
      %finish
      CCset=0
      Pjump(BC,Labelid,CC,R14)
      %return
!*
Op(JFALSE):
      %if CCset=0 %thenstart
         %if Elevel<1 %then Low Estack(Opcode,1) %and %return
         Elevel=Elevel-1
         Reg1=Load Int(Stk(Elevel+1),-1,0)
         PIX RR(LTR,Reg1,Reg1)
         Pjump(BC,Labelid,8,R14)
         %return
      %finish
      CCset=0
      Pjump(BC,Labelid,14-CC,R14)
      %return
%end;! Ejump
!*
%externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3)
!***********************************************************************
!* generate the code for a Fortran three-way jump                      *
!* opcode = ITWB or RTWB for integer or real expression on Estack      *
!* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0           *
!*  - if Labi <= 0 that jump is not required                           *
!***********************************************************************
%integer Op,Reg1,Freg1,Bytes
      %if Report#0 %thenstart
         printstring("Etwjump  ".Eopname(Opcode))
         write(Lab1,4);write(Lab2,4);write(Lab3,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      %if Opcode=ITWB %thenstart
         Reg1=Load Int(Stk(Elevel+1),-1,0)
         PIX RR(LTR,Reg1,Reg1)
      %finishelsestart
         Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
         %if Bytes=4 %then Op=LTER %else Op=LTDR
         PIX RR(Op,Freg1,Freg1)
      %finish
      %if Lab1>0 %then Pjump(BC,Lab1,4,R14);! if < 0
      %if Lab2>0 %then Pjump(BC,Lab2,8,R14);!    = 0
      %if Lab3>0 %then Pjump(BC,Lab3,2,R14);!   > 0
%end;! Etwjump
!*
%routine locate switch(%integer switchid)
!***********************************************************************
!*      Locates a switch and maps the global record Curswitch          *
!***********************************************************************
%integer i
      %for i=1,1,swmax %cycle
         %if switches(i)_id=switchid %then curswitch==switches(i) %and %return
      %repeat
      abortm("Can not locate switch defn")
%end
%externalroutine Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                %integername SSTad)
!***********************************************************************
!* define a switch Switchid to be indexed in the range (Lower:Upper)   *
!* space may be claimed from SST fotr the switch table                 *
!***********************************************************************
%integer Ad,J
      %if Report#0 %thenstart
         printstring("Eswitch ")
         write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Ad=SSTad
      SSTad=SSTad+(Upper-Lower+1)<<2
      Pswitch(Ad,Lower,Upper,4)
      locate switch(0);               ! an empty entry
      curswitch_sstad=ad
      curswitch_id=switchid
      curswitch_lower=lower
      curswitch_upper=upper
      curswitch_Proclevel=proclevel
      j=glaspace(4)
      curswitch_glaad=j
      pfix(gla,j,sst,ad-4*lower)
%end;! Eswitch
!*
%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds defined for Switchid then error     *
!***********************************************************************
%integer reg1,reg2
      %if Report#0 %thenstart
         printstring("EswitchJump ");write(switchid,4)
         newline
      %finish
      %If curswitch_id#switchid %then locate switch(switchid)
      %if elevel<1 %then low estack(jump,1) %and %return
      elevel=elevel-1
      reg1=load int(stk(elevel+1),-1,0)
      reg2=indbase(gla,curswitch_glaad)
      pix rs(sll,reg1,0,0,2)
      pix rx(l,reg1,reg1,reg2,0)
      pix rx(bc,15,reg1,r12,0)
%end;! EswitchJump
!*
%externalroutine EfswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds the jump has no effect. Note that   *
!* in this case Switchid(Lower) addresses the next instruction         *
!***********************************************************************
%integer Reg1,Reg2,Adtable
      %if Report#0 %thenstart
         printstring("EfswitchJump ");write(switchid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %If curswitch_id#switchid %then locate switch(switchid)
      %if Elevel<1 %then Low Estack(JUMP,1) %and %return
      Elevel=Elevel-1
      Adtable=curswitch_glaad
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
      Reg2=Indbase(GLA,Adtable)
      PIX RR(BASR,R14,0)
      PIX RR(LTR,Reg1,Reg1)
      PIX RX(BC,12,0,R14,28)
      PIX RX(LA,0,0,0,curswitch_upper)
      PIX RR(CR,Reg1,0)
      PIX RX(BC,2,0,R14,28)
      PIX RS(SLL,Reg1,0,0,2)
      PIX RX(L,R15,Reg1,Reg2,0)
      PIX RX(BC,15,R12,R15,0)
%end;! EfswitchJump
!*
%externalroutine Eswitchentry(%integer Switchid, Entry)
!***********************************************************************
!* define the current code address as Switchid(Entry)                  *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswitchentry ");write(Switchid,4);write(Entry,4)
         newline
      %finish
      %If curswitch_id#switchid %then locate switch(switchid)
      Pslabel(curswitch_sstad,entry)
      drop all
%end;!Eswitchentry
!*
%externalroutine Eswitchdef(%integer Switchid)
!***********************************************************************
!* define the current code address as Switchid(*) - the default        *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswitchdef ");write(Switchid,4)
         newline
      %finish
      %If curswitch_id#switchid %then locate switch(switchid)
      Einternallab=Einternallab-1
      plabel(Einternallab)
      psdefault(curswitch_sstad,Einternallab)
%end;!Eswitchdef
!*
%externalroutine EswitchLabel(%integer Switchid, Entry, Labelid)
!***********************************************************************
!* define Labelid as Switchid(Entry)                                   *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("EswitchLabel ");write(switchid,4);write(entry,4)
         write(labelid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %If curswitch_id#switchid %then locate switch(switchid)
      Pswitchval(curswitch_sstad,Entry,Labelid)
%end;! EswitchLabel
!*
%externalroutine EcaseJump(%integer MinLab, MaxLab, ErrLab, WFlag, CaseId)
!************************************************************************
!* Plant a case jump-table for the case-statement ideintified by CaseId *
!************************************************************************
%integer Ad,Reg1,Reg2,Reg3,I,AdTable
      %if Report#0 %thenstart
         printstring("EcaseJump")
         write(MinLab,4); write(MaxLab,4); write(ErrLab,4); write(WFlag,4);
         write(CaseId,4); newline
      %finish
      %if ProgFaulty#0 %then %return
      Ad=SSTOffset
      SSTOffset=SSTOffset+(MaxLab-MinLab+1)<<2
      Pswitch(Ad,0,MaxLab-MinLab,4)
      %for I = 1,1,CaseDepth %cycle   { Locate a free case record }
         %if Cases(I)_CaseId=-1 %then -> Found
      %repeat
      %monitor
      %stop
Found:
      Cases(I)_CaseId = CaseId
      Cases(I)_SSTAd = Ad
      %if Elevel<1 %then Low Estack(JUMP,1) %and %return
      Adtable=Glaspace(4)
      Pfix(GLA,Adtable,SST,Ad)
      %if Stk(Elevel)_Form#RegVal %then Reg1=Load Int(Stk(Elevel),-1,0) %c
         %else Reg1 = Stk(Elevel)_Reg
      %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
      Reg2=Indbase(GLA,Adtable)
      PIX RR(BASR,R14,0)
      PUsing(R14)
      PIX RX(LA,R0,0,0,MaxLab)
      PIX RR(CR,Reg1,R0)
      PJump(BC,ErrLab,2,R14)
      %if MinLab#0 %thenstart
         PIX RX(LA,R0,0,0,MinLab)
         PIX RR(SR,Reg1,R0)
      %finish
      PIX RR(LTR,Reg1,Reg1)
      PJump(BC,ErrLab,4,R14)
      PIX RS(SLL,Reg1,0,0,2)
      PIX RX(L,R15,Reg1,Reg2,0)
      PIX RX(BC,15,R12,R15,0)
      %if Elevel<1 %then Abortm("Ecasejump")
      %if Report#0 %then Dump Estack
      PDrop(R14)
      Elevel=Elevel-1
%end;! EcaseJump
!*
%externalroutine EcaseEntry(%integer Entry, LabelId, CaseId)
!************************************************************************
!* Enter the code-address of the case-label defined by LabelId into the *
!* case-table entry defined by Entry. Entry is measured relative to the *
!* start of the case-table and is >= 0.                                 *
!************************************************************************
      %integer SSTAd,I
      %if Report#0 %thenstart
         printstring("EcaseEntry")
         write(Entry,4); write(LabelId,4); write(CaseId,4); newline
      %finish
      %if ProgFaulty#0 %then %return
      %for I = 1,1,CaseDepth %cycle
         %if Cases(I)_CaseId=CaseId %then -> Found
      %repeat
      AbortM("Missing case definition")
Found:
      SSTAd = Cases(I)_SSTAd
      PSwitchVal(SSTAd,Entry,LabelId)
      Drop all
%end;! EcaseEntry
!*
%externalroutine EcaseEnd(%integer ErrLab, CaseId)
!************************************************************************
!* Fill blank entries in the case-table denoted by CaseId with the      *
!* address of the error-label ErrLab.                                   *
!************************************************************************
      %integer SSTAd,I
      %if Report#0 %thenstart
         printstring("EcaseEnd")
         write(ErrLab,4); write(CaseId,4); newline
      %finish
      %if ProgFaulty#0 %then %return
      %for I = 1,1,CaseDepth %cycle
         %if Cases(I)_CaseId=CaseId %then -> Found
      %repeat
      AbortM("Missing case definition")
Found:
      SSTAd = Cases(I)_SSTAd
      PSDefault(SSTAd,ErrLab)
      Drop all
%end;! EcaseEnd
!*
%externalroutine EnewLab(%integer Labid, Offset)
!************************************************************************
!* Declare a new statement label Labid at Offset within the stack-frame.*
!************************************************************************
      %integer Ad, I
      %if Report#0 %thenstart
         printstring("EnewLab"); write(Labid,4); write(Offset,4)
         newline
      %finish
      %if NestedProcs=0 %thenstart

         %if Proclevel=1 %thenstart
            %if OuterLNBDisp=-1 %then OuterLNBDisp=GlaSpace(4)
            PIX RX(ST,R10,0,R13,OuterLNBDisp)
         %finish
         PIX RX(ST,R11,0,R10,DisplayOffset(proclevel)+4)
         NestedProcs=1
      %finish
         %for I = 1,1,MaxLabs %cycle
            %if Labs(I)_LabId=-1 %then -> Found
         %repeat
         AbortM("Too many labels")
Found:
         Ad = GlaSpace(4)
         Labs(I)_LabId = LabId
         Labs(I)_GlaAd = Ad
         Offset = Offset + ParamOffset
         PIX RX(ST,IndBase(Gla,Ad),0,R10,Offset)
%end;! EnewLab
!*
%externalroutine Egjump(%integer Level, Offset)
!************************************************************************
!* Jump to a label in a global stack-frame. The label address is held   *
!* at Offset within the stack-frame for the given textual Level.        *
!************************************************************************
%integer Reg
      %if Report#0 %thenstart
         printstring("Egjump"); write(Level,4); write(Offset,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Level=1 %thenstart      { Outermost level }
         %if OuterLNBDisp=-1 %then OuterLNBDisp = GlaSpace(4)
         PIX RX(L,R10,0,R13,OuterLNBDisp)   { Loads LNB from Gla }
      %finishelsestart         { Inner level }
         PIX RX(L,R10,0,R10,Display Offset(proclevel)+Level<<2)   { Loads LNB }
      %finish
      PIX RX(L,R15,0,R10,Offset+ParamOffset)   { Loads PC }
      PIX RR(BCR,15,R15)
%end;! Egjump
!*
%externalroutine EstmtLabel(%integer Labid,Offset)
!************************************************************************
!* Define a statement-label.                                            *
!************************************************************************
      %integer I
      %if Report#0 %thenstart
         printstring("Estmtlabel"); write(Labid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if NestedProcs#0 %thenstart
         %for I = 1,1,MaxLabs %cycle
            %if Labs(I)_LabId=LabId %then -> Found
         %repeat
         AbortM("Label not found")
   Found:
         PFix(Gla,Labs(I)_GlaAd,Code,PMarker(0))
         PIX RX(L,R11,0,R10,DisplayOffset(proclevel)+4)
      %finish
      ELabel(LabId)
%end;! Estmtlabel
!*
!*
!*
!*                *******************************
!*                * Data initialisation, fixups *
!*                *******************************
!*
!*
%externalroutine Ed1(%integer area, Disp, Val)
!***********************************************************************
!* intialise an 8-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed1   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area>=11 %thenstart
         Areaprops(Area)=Areaprops(Area)!X'400'
         Area=Area+256
      %finish
      Pdbytes(area, Disp, 1, addr(Val)+3)
%end;! Ed1
!*
%externalroutine Ed2(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 16-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed2   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area>=11 %thenstart
         Areaprops(Area)=Areaprops(Area)!X'400'
         Area=Area+256
      %finish
      Pdbytes(area, Disp, 2, addr(Val)+2)
%end;! Ed2
!*
%externalroutine Ed4(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 32-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed4   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area>=11 %thenstart
         Areaprops(Area)=Areaprops(Area)!X'400'
         Area=Area+256
         Pdpattern(Area,Disp,1,4,addr(Val))
      %finishelsestart
         Pd4(area, Disp, Val)
      %finish
%end;! Ed4
!*
%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data                                           *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edbytes 
")
      %finish
      %if ProgFaulty#0 %then %return
%if Area=10 %then %monitor;! should not be allocated any more
      %if len=8 %thenstart
         Ed4(area,disp,integer(ad))
         Ed4(area,disp+4,integer(ad+4))
         %return
      %finish
      %if Area>=11 %thenstart
         Areaprops(Area)=Areaprops(Area)!X'400'
         Area=Area+256
      %finish
      %if area<=10 %thenstart
         Pdbytes(area, disp, len, ad)
      %finishelsestart
         Pdpattern(area, Disp, 1, len, ad)
      %finish
%end;! Edbytes
!*
%externalroutine Edpattern(%integer area, Disp, ncopies, len, ad)
!***********************************************************************
!* initialise using a 1,2,4 or 8 byte pattern                          *
!***********************************************************************
%integer I
      %if Report#0 %thenstart
         printstring("Edpattern ")
         printstring(areas(area)." ");write(disp,1);write(ncopies,8)
         write(len,8);write(ad,8)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area>=11 %thenstart
         Areaprops(Area)=Areaprops(Area)!X'400'
         Area=Area+256
      %finish
      %if Area<=10 %thenstart
         %cycle I=1,1,ncopies
            Pdbytes(Area,Disp,Len,Ad)
            Disp=Disp+Len
         %repeat
      %finishelsestart
         Pdpattern(area, Disp, ncopies, len, ad)
      %finish
%end;!Edpattern
!*
%externalroutine Efix(%integer area,disp, tgtarea,tgtdisp)
!***********************************************************************
!* relocate area+disp to tgtarea+tgtdisp  (all are byte addresses)     *
!***********************************************************************
      Area=Area&X'FFF';! in case 'byte' marker had been set (historic)
      %if Report#0 %thenstart
         printstring("Efix  ".Areas(Area)." +");write(Disp,1)
         printstring(" => ".Areas(Tgtarea)." +");write(Tgtdisp,1)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area=Gla %then Disp=Disp+Gla Offset
      %if Tgtarea=Gla %then Tgtdisp=Tgtdisp+Gla Offset
      %if Tgtarea>=11 %thenstart
         %if Area=2 %and Tgtdisp=0 %then Areabase(Tgtarea)=Disp
         Tgtarea=Tgtarea+256
      %finish
      PD4(Area,Disp,Tgtdisp)
      Tgtdisp=0
      Pfix(area,disp, tgtarea,0)
%end;! Efix
!*
!*
!*
!*                 *********************
!*                 * Procedure call    *
!*                 *********************
!*
!*
%externalintegerfn EXname(%integer type,%string(255)%name Xref)
!***********************************************************************
!* generate an external reference, returning an Id for future reference*
!***********************************************************************
%integer Refad,I
      %if Report#0 %thenstart
         printstring("EXname  ".Xref);write(Type&15,4);write(Type>>4,4)
         newline
      %finish
      Refad=Glaspace(16)
      %if ProgFaulty#0 %then %result=Refad
      %if Language=Pascal %or language=Imp %then PD4(Gla,RefAd+12,-1)
      I=PXname(0,Xref,Refad)
      %result=Refad
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprecall "); write(id,4); write(active calls,3)
         newline
      %finish
      Active Calls = Active Calls + 1
      %if Active Calls>1 %thenstart
         Save Param Offset(Active Calls) = Next Param Offset
         PIX RX(LA,R11,0,R11,Next Param Offset) %if Next Param Offset>64
      %finish
      Next Param Offset=64
%end;! Eprecall
!*
%externalroutine Ecall2(%integer Id,Extlev,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id                                    *
!***********************************************************************
%integer X2
      %if Report#0 %thenstart
         printstring("Ecall2    "); write(Id,4); write(Extlev,4)
         write(Numpars,6); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Freeregs
      PIX RS(STM, R4, R14, R11, 16)
      PIX RX(LA,r1,0,R10,DisplayOffset(proclevel)) %unless extlev=1
      %if Id>0 %then %Start
         Pd4(GLA,Id+12,(Numpars<<16)!Paramsize);! for loader check
         %if Id>=4096 %thenstart
            X2=Id>>12
            %if x2>Max4k %then Max4k=X2
            PIX RX(A,13,0,R12,x2<<2)
            Id=Id&x'FFF'
         %finish
         PIX RS(LM, R12, R14, R13, id)
         PIX RR(BASR, R15, R14)
      %finish %else pjump(BAS,Id+elabbase,15,r15)
      Pusing(R15)
      UsingR15 = 1
      %if Active Calls>1 %thenstart
         Next Param Offset = Save Param Offset(Active Calls)
         %if next Param Offset>64 %start
            PIX RX(LA,R0,0,0,Next Param Offset)
            PIX RR(SR,R11,R0)
         %finish
      %finish
      Active Calls = Active Calls - 1
%end;! Ecall2
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id                                    *
!***********************************************************************
%integer X2
      %if Report#0 %thenstart
         printstring("Ecall    "); write(Numpars,6); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if language=fortran %then x2=1 %else x2=99
      ecall2(id,x2,numpars,paramsize)
%end;! Ecall
!*
!*
%externalroutine Eprocref(%integer Id, Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %integer Ad, I
      %if Report#0 %thenstart
         printstring("Eprocref ");write(Id,4)
         newline
      %finish
      Ad = GlaSpace(16)   { Make a copy of the entry descriptor }
                                       ! PDS considers this unsound since a recursive
                                       ! situation can be devised
      %if Ruse(R2)#0 %then Freeup Reg(R2)
      %if id<0 %Start
         pjump(LA,Id+elabbase,r2,r1)
         pix rr(lr,r0,r12)
         pix rr(lr,r1,r13)
      %finish %else %if Id>4095 %thenstart
         %for I=R0,1,R2 %cycle
            DoRX(L,I,R13,Id+(I<<2))

         %repeat
      %finishelse PIX RS(LM,R0,R2,R13,Id)
      %if Ad>=4096 %thenstart
         %for I=R0,1,R2 %cycle
            DoRX(ST,I,R13,Ad+(I<<2))
         %repeat
      %finishelse PIX RS(STM,R0,R2,R13,Ad)
      PIX RX(LA,R0,0,R10,DisplayOffset(proclevel))   { Environment pointer }
      Do RX(ST,R0,R13,Ad+12)
      Estkaddr(Gla,Ad-GlaOffset,0,4);! Ad is gla offset of local copy of entry block
%end;! Eprocref
!*
%externalroutine Eprocenv(%integer Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocenv ");write(Level,4)
         newline
      %finish
      {%if Level>1 %thenstart}
         {Estkdir(0,Display Offset(proclevel)+Level<<2,0,4)}
      {%finishelse} Estklit(0)      { Dummy on Amdahl }
%end;! Eprocenv
!*
%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Esave ");write(Asave,4)
         newline
      %finish
%end;! Esave
!*
%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Erestore ");write(Asave,4)
         newline
      %finish
%end;! Erestore
!*
!*
!*
!*               **********************************
!*               * Procedure definition and entry *
!*               **********************************
!*
!*
%externalintegerfn Enextproc
!***********************************************************************
!* result is an Id to be used for a procedure first encountered as an  *
!* internal spec                                                       *
!***********************************************************************
%integer Refad,I
      %if Report#0 %thenstart
         printstring("Enextproc 
")
      %finish
      Einternallab=Einternallab-1
      Refad=Einternallab-elabbase
      %if Report#0 %thenstart
         printstring("  key ="); write(Refad,1)
         newline
      %finish
      %result=Refad
%end;! Enextproc
!*
%externalroutine Eproclevel(%integer Level)
!***********************************************************************
!* record static nesting level of the current procedure                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eproclevel ");write(Level,3)
         newline
      %finish
      ProcLevel = Level
%end;! Eproclevel
!*
%externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize,
                                      Astacklen, %integername Id)
!***********************************************************************
!* define the start of a procedure body                                *
!* if Id > 0 this is the Id returned by a previous call of Enextproc   *
!* Astacklen is the address of the word noting the current local       *
!* stack-frame size                                                    *
!***********************************************************************
%integer Refad
      %if Report#0 %thenstart
         printstring("Eproc ");printstring(Name)
         write(Numpars,4); write(Paramsize,4); write(Id,4); write(props,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Drop all
      %unless Language=PASCAL %then Proclevel=Proclevel+1
      %if language=Pascal %and  ProcLevel=1 %then Props=2
      %if Language=PASCAL %or language=IMP %thenstart
         DisplayOffset(proclevel) = (ParamOffset + ParamSize + 3) & (\3)
      %finish
      Upperlineno = -1
      ProcProps=Props
      %if Props&2#0 %then Props=X'80000001' %else Props=Props&1
      %if Id=-1 %then Einternallab=Einternallab-1 %and Id=Einternallab-elabbase
      %if Id>0 %then %Start
         Pfix(Gla,Id,1,0)
         Pfix(Gla,Id+4,Gla,0)
         Pfix(Gla,Id+8,1,Pmarker(0))
      Abortm("Old proc entry code reqd");      ! pds thinks this is redundant
      %finish %else Plabel(Id+elabbase)
      NestedProcs = 0
      Pproc(Name,Props,Numpars<<16!Paramsize,Id)
      Curdiagca=-1
      %if Language#FORTRAN %thenstart
         %if Astacklen#-1 %then Addrstackca=Astacklen
         integer(addrstackca) = (integer(addrstackca)+3)&(\3)
         PIX RX(ST,R15,0,R11,60)
         PIX RR(LR,R10,R11)
         Procmark(proclevel)=PMarker(2)
         %if (Language=Pascal %or language=IMP) %and ProcProps&4=0 %thenstart   { Copy display }
         pix ss(mvc,0,4*proclevel,r10,display offset(proclevel),r1,0) %unless proclevel=1
            PIX RX(ST,R10,0,R10,DisplayOffset(proclevel)+Proclevel<<2)
            PIX RX(ST,R13,0,R10,DisplayOffset(proclevel)) {%if proclevel=1 %or props&1#0}
         %finish
         PIX RS(LM,R8,R9,R13,Glaf77regs) {%if proclevel=1 %or props&1#0}   { @ statics and const area }
         %if ProcProps&2#0 %thenstart;! main entry
            PIX RX(LA,R1,0,0,8)
            PIX RS(SLL,R1,0,0,24)
            PIX RR(SPM,R1,0)
         %finish
      %finish %else max4k=0;     ! Start count again for fortran
%end;! Eproc
!*
%externalroutine Eprocend(%integer Localsize,Diagdisp,Astacklen)
!***********************************************************************
!* called at procedure end                                             *
!* Localsize is the total stack-frame requirement (excluding red tape) *
!* Astacklen is the address of the word noting the current local       *
!* stack-frame size of th enclosing procedure                          *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocend ");write(Localsize,6)
         Write(DiagDisp,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language#Fortran %thenstart
         LocalSize = LocalSize+3
         LocalSize = (LocalSize+3)&(\3)
         %if LocalSize>integer(AddrStackCa) %then localsize = LocalSize + ParamOffset %c
            %else localsize = integer(AddrStackCa) + ParamOffset
         localsize=(localsize+15)&(-16)
         %if localsize<=4095 %Start
            PSetOpd(ProcMark(proclevel),0,X'41B0')
            PSetOpd(Procmark(proclevel),1,X'B000'!localsize) 
         %else
            localsize=localsize>>12+1
            psetopd(procmark(proclevel),0,x'5ab0')
            psetopd(procmark(proclevel),1,x'c000'+4*localsize)
            %if localsize>max4k %then max4k=localsize
         %finish
         %if Astacklen#-1 %then Addrstackca=Astacklen
      %finish
      PDrop(R14)
      DropAll
      PDrop(R15)
      upperlineno=-1
      FreeRegs
      Proclevel=Proclevel-1
      PMinMultiples(Max4k+1) %if language=Fortran
      Pprocend
%end;! Eprocend
%externalroutine Eentry(%integer Index,Numpars,Paramsize,
                           Localsize,Diagdisp,%stringname Name)
!***********************************************************************
!* defines a side entry within the current procedure (used by Fortran) *
!* Localsize is the total stack-frame requirement (excluding red tape) * 
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eentry  ".Name);write(Index,4)
         write(Numpars,4);write(Paramsize,4); write(LocalSize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %unless Index=0 %then Pentry(Index,Name);! Amdahl put handles 0 incorrectly
      Dropall
      %if Language=Fortran %thenstart
         PIX RX(ST,R15,0,R11,60)
         PIX RR(LR,R10,R11)
         Localsize=Localsize+64
         %if Localsize>=4096 %thenstart
            PIX RX(LA,1,0,0,Localsize>>12)
            PIX RS(SLL,1,0,0,12)
            PIX RX(LA,R11,1,R11,Localsize&X'FFF')
         %finishelse PIX RX(LA,11,0,11,Localsize)
         PIX RS(LM,8,9,R13,Glaf77regs)
         %if ProcProps&2#0 %thenstart;! main entry
            PIX RX(LA,R1,0,0,8)
            PIX RS(SLL,R1,0,0,24)
            PIX RR(SPM,R1,0)
         %finish
      %finish
      PIX SI(MVI,Diagdisp>>8,R10,0)
      PIX SI(MVI,(Diagdisp&X'FF'),R10,1)
%end;! Eentry
!*
!*
!*
!*               *********************************
!*               * Data definition and reference *
!*               *********************************
!*
!*
%externalroutine Edataentry(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* defines a data entry Name starting at Offset in Area                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edataentry  ".Name);write(Area,4)
         write(Offset,4);write(Length,4)
         newline
      %finish
      PDataEntry(Name,Area,(Length+3)&(\3),Offset)
%end;! Edataentry
!*
%externalroutine Edataref(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* requests a data ref to Name (with at least Length)at Offset in Area *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edataref  ".Name);write(Area,4)
         write(Offset,4);write(Length,4)
         newline
      %finish
      PDXRef((Length+3)&(\3),Area,Offset,Name)
%end;! Edataref
!*
!*
!*
!*                  ********************
!*                  * Ecode operations *
!*                  ********************
!*
!*
%externalroutine Eop(%integer Opcode)
!***********************************************************************
!* opcodes with general applicability                                  *
!***********************************************************************
%constintegerarray ChOp(MVB:CPBLE) = MVCL<<16!MVC, 0(5), clcl<<16!CLC(6)
%owninteger depth=0
%integer Reg1,Freg1,Bytes,B1,D1,B2,D2,XAop,Form,I,J
%switch Op(0:255)
      %if Report#0 %thenstart
         %if depth>0 %then printstring("recursive ")
         printstring("Eop    ".Eopname(Opcode))
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
      j=minelevel(opcode)
      %if j>0 %and elevel<j %then low estack(opcode,j) %and %return
      depth=depth+1
      ->Op(Opcode)
!*
Op(*):%monitor
!*
Op(HALT):
      Unsupported Opcode(Opcode)
      depth=depth-1; %return    
!*
Op(IADD):
Op(ISUB):
Op(IMULT):
Op(IDIV): 
!*
Op(IAND):
Op(IOR): 
Op(IXOR): 
!*
Op(IGT): 
Op(ILT): 
Op(IEQ): 
Op(INE):  
Op(IGE):  
Op(ILE):  
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      depth=depth-1; %return
!*
Op(INEG): 
Op(IABS): 
Op(INOT):
Op(BNOT):
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      depth=depth-1; %return
!*
Op(UADD):
Op(USUB):
!*
Op(UGT): 
Op(ULT): 
Op(UEQ): 
Op(UNE):  
Op(UGE):  
Op(ULE):  
      Elevel=Elevel-2
      U Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      depth=depth-1; %return
!*
Op(IADDST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST): 
!*
Op(IANDST):
Op(IORST): 
Op(IXORST): 
      Epromote(2)
!!      Erefer(0,4)
      Eop(DUPL)
      Epromote(3)
      Eop(IADD+Opcode-IADDST)
      Epromote(2)
      Eop(Estore)
!!      Elevel=Elevel-2
!!      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      depth=depth-1; %return
!*
Op(INEGST): 
Op(INOTST):
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      depth=depth-1; %return
!*
Op(IREM): 
      Eop(IDIV);! result will be in an odd register
      Reg1=Stk(Elevel)_Reg;! remainder will be in the even one
      PIX RR(LR,Reg1,Reg1-1)
      depth=depth-1; %return
!*
Op(ISHLL):
!*
Op(ISHRL):
!*
Op(ISHLA):
!*
Op(ISHRA):
      %begin
      %constbyteintegerarray shop(ishll:ishra)=SLL,SRl,SLA,SRA;
      %integer rreg,lreg
      %record(stkfmt) shifted,shifter
      shifter=stk(elevel)
      shifted=stk(elevel-1)
      elevel=elevel-2
      %if shifter_form&31=litval %Start
         rreg=load int(shifted,-1,-1)
         pix rs(shop(opcode),rreg,0,0,shifter_intval)
      %else
         lreg=load int(shifter,-1,0)
         rreg=load int(shifted,-1,lreg)
         pix rx(shop(opcode),rreg,0,lreg,0)
      %finish
      stackr(rreg)
      %end
      depth=depth-1; %return    
!*
Op(RETURN): 
      PIX RS(LM,R4,R15,R10,16)
      PIX RR(BCR,15,R15)
      depth=depth-1; %return
!*
Op(SFA):
!*
Op(ASF):
!*
Op(IPUSH):
!*
Op(IPOP):  
      Unsupported Opcode(Opcode)
      depth=depth-1; %return    
!*
Op(EXCH):
      Epromote(2)
      depth=depth-1; %return
!*
Op(DUPL):
      Form=Stk(Elevel)_Form&31
      %if addrdirmod<=form<=indregmodval %Start
         reg1=loadint(stk(elevel),-1,-1)
         elevel=elevel-1
         stackr(reg1)
         %if form=indregmodval %then form=regval %else form=regaddr
         stk(elevel)_form=form
      %finish
      Stk(Elevel+1)=Stk(Elevel)
      Elevel=Elevel+1
      %if Form=RegVal %or Form=RegAddr %thenstart
         Reg1=Claimr(Stk(Elevel)_Reg)
         PIX RR(LR,Reg1,Stk(Elevel)_Reg)
         Stk(Elevel)_Reg=Reg1
         Ruse(Reg1)=-Elevel
->dupexit
      %finish
      %if Form=FregVal %thenstart
         Freg1=Claimfr(Stk(Elevel)_Reg)
         %if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR
         PIX RR(XAop,Freg1,Stk(Elevel)_Reg)
         Stk(Elevel)_Reg=Freg1
         Fruse(Freg1)=-Elevel
         ->dupexit
         %finish
      %if Form=TempVal %then Stk(Elevel)_Form=DirVal %and ->dupexit
dupexit:
         %if report#0 %then %Start
            printstring("After   ".eopname(opcode))
         newline; dump estack
         %finish
      depth=depth-1; %Return
!*
Op(DISCARD):
      %if Stk(Elevel)_Form&31=RegVal %thenstart
         Ruse(Stk(Elevel)_Reg)=0
      %finishelsestart
         %if Stk(Elevel)_Form&31=Fregval %then Fruse(Stk(Elevel)_Reg)=0
      %finish
      Elevel=Elevel-1
      depth=depth-1; %return
!*
Op(INDEX1): 
!*
Op(INDEX2):
!*
Op(INDEX4):
!*
Op(INDEX8):
      Elevel=Elevel-1
      I=Opcode-INDEX1
NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1))
      depth=depth-1; %return
!*
Op(INDEX):
      Elevel=Elevel-2
      %if Stk(Elevel+2)_Form=LitVal %thenstart
         I=Stk(Elevel+2)_Intval
         %if I=16 %or I=32 %thenstart
            I=I>>5+4
            ->NoteI
         %finish
      %finish
      Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2))
      Elevel=Elevel-1
      I=0
      ->NoteI
!*
Op(CHK):  
      Elevel=Elevel-3
      Reg1=Load Int(Stk(Elevel+1),-1,-1)
      Op RX(C,Reg1,Stk(Elevel+2))
      Pjump(BC,Bounderr,4,R14)
      Op RX(C,Reg1,Stk(Elevel+3))
      Pjump(BC,Bounderr,2,R14)
      Stackr(Reg1)
      depth=depth-1; %return
!*
Op(CPBGT):
!*
Op(CPBLT):
!*
Op(CPBEQ):
!*
Op(CPBNE):
!*
Op(CPBGE):
!*
Op(CPBLE):
      CC = SetCC(OpCode-CPBGT)
!*
Op(MVB):
!*
      %begin
      %record(stkfmt)%name dest,srce,len
      %if opcode=MVB %then %Start;      ! mvb op wrong way round!
         srce==stk(elevel-2)
         dest==stk(elevel-1)
      %else
         srce==stk(elevel-1)
         dest==stk(elevel-2)
      %finish
      d1=0; d2=0
       %if language=imp %then B1=loadint(dest,-1,0) %else SetBD(dest,B1,D1)
      Ruse(B1) = -255
       %if language=imp %then B2=loadint(srce,-1,0) %else SetBD(srce,B2,D2)
      Ruse(b2)=-255
      len==stk(elevel)
      Bytes = len_IntVal
      %if len_form&31=litval %Start; ! move by literal use mvc
         %if bytes>256 %Start
             %if d1=0 %then pix rr(lr,r0,b1) %else pix rx(la,r0,0,b1,d1)
            ruse(b1)=0
            %if b2#r2 %and ruse(b2)#0 %then freeup reg(r2)
            %if d2=0 %Start
               pix rr(lr,r2,b2) %unless r2=b2
            %finish %else pix rx(la,r2,0,b2,d2)
            ruse(b2)=0
            %if ruse(r1)#0 %then free up reg(r1)
            %if ruse(r3)#0 %then free up reg (r3)
           reg1=load int(len,r1,0)
            pix rr(lr,r3,r1)
            pix rr(chop(opcode)>>16,r0,r2)
         %finish %else PIX SS(ChOp(OpCode)&255,0,Bytes,B1,D1,B2,D2)
      %else;                              ! need execute of mvc or mvcl
         %if language=imp %Start
            i=Chop(opcode)<<24!b1<<12!d1
            j=b2<<28!d2<<16
            reg1=load int(len,-1,0);   ! not gr0 for EX
            ruse(reg1)=-255
            estkconst(6,addr(i));                ! target of EX into const table
            pix rr(bctr,reg1,0)
            op rx(ex,reg1,stk(elevel))
            elevel=elevel-1
            ruse(reg1)=0
         %finish %else abort
      %finish
      Elevel = Elevel - 3
      Ruse(B1) = 0
      Ruse(b2)=0
      CCSet = 1 %unless opcode=MVB
      %end
      depth=depth-1; %return    
!*
Op(TMASK):
      unsupported opcode(opcode)
      depth=depth-1; %return
Op(RADD): 
Op(RSUB): 
Op(RMULT):
Op(RDIV): 
!*
Op(RGT):  
Op(RLT):  
Op(REQ): 
Op(RNE):  
Op(RGE):   
Op(RLE): 
      Elevel=Elevel-2
      Real Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      depth=depth-1; %return
!*
Op(RNEG): 
Op(RABS):
      Elevel=Elevel-1
      Real Unary Op(Opcode,Stk(Elevel+1))
      depth=depth-1; %return
!*
Op(UCVTII):
      Elevel=Elevel-2
      Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      depth=depth-1; %return
!*
Op(CVTII):
      Elevel=Elevel-2
      Bytes=Stk(Elevel+2)_Intval
      Convert II(Stk(Elevel+1),Bytes)
      Stk(Elevel)_Size=Bytes
      depth=depth-1; %return
!*
Op(CVTRR):
      Elevel=Elevel-2
      Convert RR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      depth=depth-1; %return
!*
Op(TNCRI): 
Op(RNDRI):
Op(EFLOOR):
      Elevel=Elevel-2
      Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI)
      depth=depth-1; %return
!*
Op(CVTIR):  
      Elevel=Elevel-2
      Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      depth=depth-1; %return
!*
Op(UCHECK):
      %if Stk(Elevel)_Form=DirVal %thenstart
         Set BD(Stk(Elevel),B1,D1)
      %finishelsestart
         Reg1=Claimr(-1)
         Address(Stk(Elevel))
         Op RX(L,Reg1,Stk(Elevel))
         Stk(Elevel)_Form=IndRegVal!Regflag
         Stk(Elevel)_Reg=Reg1
         Ruse(Reg1)=-Elevel
         B1=Reg1
         D1=0
      %finish
      PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32)
      Pjump(BC,Unasslab,8,R14)
      depth=depth-1; %return    
!*
Op(ESTORE):
      Elevel=Elevel-2
      Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0)
      depth=depth-1; %return
!*
Op(EDUPSTORE):
      Elevel=Elevel-2
      Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),1)
      Stackr(Reg1)
      depth=depth-1; %return
!*
Op(PUSHVAL):
!*
Op(PUSHADDR):
      Elevel=Elevel-1
      Push Param(Opcode-PUSHVAL,Stk(Elevel+1))
      depth=depth-1; %return
!*
Op(EVAL):
!*
Op(EVALADDR):
      depth=depth-1; %return
!*
Op(EADDRESS):
      Address(Stk(Elevel))
      Stk(Elevel)_Size=4
      depth=depth-1; %return
!*
Op(EPOWER):       
!*
Op(EPOWERI):     
      %if Stk(Elevel)_Form#Litval %then Abort
      Elevel=Elevel-1
      Expcall(Stk(Elevel+1)_Intval)
      depth=depth-1; %return
!*
Op(EINTRES):    
      Elevel=Elevel-1
      %if CCSet#0 %then Establish Logical
      Reg1=Load Int(Stk(Elevel+1),R1,-1)
      depth=depth-1; %return
!*
Op(EREALRES):    
      Elevel=Elevel-1
      Reg1=Load Real(Stk(Elevel+1),R0,-1,Bytes)
      depth=depth-1; %return
!*
Op(ESIZE):    
      Elevel=Elevel-1
      Stk(Elevel)_Size=Stk(Elevel+1)_Intval
      depth=depth-1; %return
!*
Op(Argproc):
      Elevel=Elevel-1
      %if language=pascal %then elevel=elevel-1;! Pascal apparently has xtra parm
      Free regs
      Op RX(L,R1,Stk(Elevel))
      ELevel = ELevel - 1
      PIX RS(STM,R4,R14,R11,16)
      PIX RS(LM,R12,R15,R1,0)
      PIX RR(LR,R1,R15)
      PIX RR(BASR,R15,R14)
      %if active calls>1 %Start
         next param offset=save param offset(active calls)
         %if Next Param Offset>64 %Start
            pix rx(la,0,0,0,Next param offset)
             pix rr(sr,r11,r0)
         %finish
      %finish
      active calls=active calls-1
      Pusing(R15)
      UsingR15=1
      depth=depth-1; %return
!*
op(pushbytes):
      bytes=stk(elevel)_intval
      abort %unless stk(elevel)_form=litval %and bytes <=256
      reg1=loadint(stk(elevel-1),-1,0)
      pix ss(mvc,0,bytes,r11,next param offset,reg1,0)
      next param offset=next param offset+(bytes+3)&(-4)
      elevel=elevel-2
      depth=depth-1; %Return
Op(EAUXSF):
      reg1=claimr(-1)
      pix rr(lr,reg1,r11)
      stackr(reg1)
      depth=depth-1; %return
!
Op(EAUXADD):
      elevel=elevel-1
      %if stk(elevel+1)_form&31=litval %and stk(elevel+1)_intval<4095 %c
         %then pix rx(la,r11,0,r11,stk(elevel+1)_intval) %and depth=depth-1 %and %Return
      reg1=loadint(stk(elevel+1),-1,-1)
      pix rr(ar,r11,reg1)
      depth=depth-1; %return
!
Op(EAUXRES):
      elevel=elevel-1
      reg1=loadint(stk(elevel+1),r11,-1)
      ruse(r11)=255
      depth=depth-1; %Return
Op(EFILL):
      b1=stk(elevel)_intval
      bytes=stk(elevel-1)_intval
      abort %unless stk(elevel)_form=litval %and stk(elevel-1)_form=litval %c
         %and b1<=255
      elevel=elevel-3
      reg1=load int(stk(elevel+1),-1,0)
      %if bytes <=512 %Start
         pix si(MVI,b1,reg1,0)
         j=0
         %if bytes>256 %then %start
            pix ss(mvc,0,256,reg1,1,reg1,0)
            j=256; bytes=bytes-256
         %finish
         pix ss(mvc,0,bytes-1,reg1,j+1,reg1,j)
      %else                           ;! MVCL neede
         abort
      %finish
      depth=depth-1
      %return
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran                     *
!***********************************************************************
%integer Reg1,Reg2,Freg1,Freg2,XAop1,XAop2,XAop3,XAop4,XAop5,Bytes,Relop
%integer B1,D1,Flags
%switch F77op(256:320)
      %if Report#0 %thenstart
         printstring("Ef77op  ".Ef77opname(Opcode))
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
!*
      %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
      ->F77op(Opcode)
!*
F77op(*):Abort
!*
F77op(CXADD):       
!*
F77op(CXSUB):      
!*
F77op(CXMULT):     
!*
F77op(CXDIV):      
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Opcode=Opcode&X'FF'
      Flags=Stk(Elevel+4)_Intval
Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3))
      %return
!*
F77op(CXNEG):       
!*
F77op(CXASGN):     
!*
F77op(CXEQ):       
!*
F77op(CXNE):       
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Opcode=Opcode&X'FF'
      Flags=Stk(Elevel+3)_Intval
      ->Cxop
!*
F77op(EM1EXP):      
      Unsupported Opcode(Opcode)
      %return
!*
F77op(EISIGN):
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      PIX RR(LPR,Reg1,Reg1)
      Reg2=Load Int(Stk(Elevel+2),-1,Reg1)
      PIX RR(BASR,R14,0)
      PIX RR(LTR,Reg2,Reg2)
      PIX RX(BC,10,0,R14,8)
      PIX RR(LNR,Reg1,Reg1)
      Stackr(Reg1)
      %return
!*
F77op(ESIGN):      
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
      %if Bytes=4 %thenstart
         XAop1=LPER
         XAop2=LNER
         XAop3=LTER
      %finishelsestart
         XAop1=LPDR
         XAop2=LNDR
         XAop3=LTDR
      %finish
      PIX RR(XAop1,Reg1,Reg1)
      Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
      PIX RR(BASR,R14,0)
      PIX RR(XAop3,Reg2,Reg2)
      PIX RX(BC,10,0,R14,8)
      PIX RR(XAop2,Reg1,Reg1)
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMOD):        
      Elevel=Elevel-2
      %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
      OpRX(L,R15,Stk(Elevel+2))
      Reg1=Claimr(R1)
      Freeup Reg(R1)
      OpRX(L,R0,Stk(Elevel+1))
      PIX RR(LR,Reg1,R0)
      PIX RX(SRDA,0,0,0,32)
      PIX RR(DR,R0,R15)
      PIX RR(MR,R0,R15)
      PIX RR(SR,Reg1,R1)
      Stackr(Reg1)
      %return
!*
F77op(ERMOD):       
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
      %if Bytes=4 %thenstart
         XAop1=LER
         XAop2=ME
         XAop3=DE
         XAop4=SER
         XAop5=STE
      %finishelsestart
         XAop1=LDR
         XAop2=MD
         XAop3=DD
         XAop4=SDR
         XAop5=STD
      %finish
      Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
      PIX RX(XAop5,Reg2,0,R11,0);! STE
      PIX RR(XAop1,Reg2,Reg1);! LER
      PIX RX(XAop3,Reg2,0,R11,0);! DE
      Stackfr(Reg2,Bytes)
      Elevel=Elevel-1
      Convert RI(Stk(Elevel+1),4,0);! Truncate
      Elevel=Elevel-1
      Lastfreg=Reg1;! to ensure it is not used
      Convert IR(Stk(Elevel+1),Bytes)
      Elevel=Elevel-1
      Reg2=Load Real(Stk(Elevel+1),-1,Reg1,Bytes)
      PIX RX(XAop2,Reg2,0,R11,0);! ME
      PIX RR(XAop4,Reg1,Reg2);! SER
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIDIM):       
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      OpRX(S,Reg1,Stk(Elevel+2))
      PIX RR(LTR,Reg1,Reg1)
      PIX RR(BASR,R14,0)
      PIX RX(BC,10,0,R14,6)
      PIX RR(SR,Reg1,Reg1)
      Stackr(Reg1)
      %return
!*
F77op(ERDIM):       
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
      %if Bytes=4 %thenstart
         XAop1=SE
         XAop2=LTER
         XAop3=SER
      %finishelsestart
         XAop1=SD
         XAop2=LTDR
         XAop3=SDR
      %finish
      OpRX(XAop1,Reg1,Stk(Elevel+2))
      PIX RR(XAop2,Reg1,Reg1)
      PIX RR(BASR,R14,0)
      PIX RX(BC,10,0,R14,6)
      PIX RR(XAop3,Reg1,Reg1)
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMIN):        
      Relop=12
Iminmax:
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1,0)
      Reg2=Load Int(Stk(Elevel+2),-1,Reg1)
      PIX RR(CR,Reg1,Reg2)
      PIX RR(BASR,R14,0)
      PIX RX(BC,Relop,0,14,6)
      PIX RR(LR,Reg1,Reg2)
      Stackr(Reg1)
      %return
!*
F77op(ERMIN):       
      Relop=12
Rminmax:
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
      %if Bytes=4 %thenstart
         XAop1=CER
         XAop2=LER
      %finishelsestart
         XAop1=CDR
         XAop2=LDR
      %finish
      Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
      PIX RR(XAop1,Reg1,Reg2)
      PIX RR(BASR,R14,0)
      PIX RX(BC,Relop,0,14,6)
      PIX RR(XAop2,Reg1,Reg2)
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMAX):       
      Relop=10
      ->Iminmax
!*
F77op(ERMAX):       
      Relop=10
      ->Rminmax
!*
F77op(EDMULT):      
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Real Binary Op(RMULT,Stk(Elevel+1),Stk(Elevel+2))
      Stk(Elevel)_Size=8
      %return
!*
F77op(ECONJG):     
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Opcode=9
      Flags=Stk(Elevel+3)_Intval
      ->Cxop
!*
F77op(ECHAR):      
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      %if Stk(Elevel+2)_Form=LitVal %thenstart
         Set BD(Stk(Elevel+1),B1,D1)
         PIX SI(MVI,Stk(Elevel+2)_Intval&X'FF',B1,D1)
      %finishelsestart
         Reg1=Load Int(Stk(Elevel+2),-1,-1)
         Set BD(Stk(Elevel+1),B1,D1)
         Do RX(STC,Reg1,B1,D1)
         {Op RX(STC,Reg1,Stk(Elevel+1))}
      %finish
      %return
!*
F77op(EICHAR):     
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      %if Stk(Elevel)_Form =LitVal %thenstart
         Stk(Elevel)_Size=4
         %return
      %finish
      Elevel=Elevel-1
      Reg1=Claimr(-1)
      PIX RR(SR,Reg1,Reg1)
      ruse(reg1)=-255
      Set BD(Stk(Elevel+1),B1,D1)
      Do RX(IC,Reg1,B1,D1)
      {Op RX(IC,Reg1,Stk(Elevel+1))}
      Stackr(Reg1)
      %return
!*
F77op(EINDEXCHAR):  
      %if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3))
      %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
      {for Unix compatibility call requires A1,A2,L1,L2}
      {Epromote(3)}
      {Epromote(2)}
      {but for Amdahl we must have L1,A1,L2,A2}
      Epromote(4)
      Epromote(2)
      Epromote(3)
      Spcall(6)
      Stackr(R1)
      %return
!*
F77op(ECONCAT):    
      Spcall(7)
      %return
!*
F77op(EASGNCHAR):  
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
      %return
!*
F77op(ECOMPCHAR):  
      %if Elevel<5 %then Low Estack(Opcode,5) %and %return
      CC=Setcc(Stk(Elevel)_Intval)
      Elevel=Elevel-5
      Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
      CCset=1
      %return
!*
F77op(ECMPLX1):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Flags=Stk(Elevel+3)_Intval
      ->Cx1
!*
F77op(ECMPLX2):     
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Flags=Stk(Elevel+4)_Intval
Cx1:  %if Flags=0 %then XAop1=STE %else XAop1=STD
      Reg1=Claimr(-1)
      OpRX(L,Reg1,Stk(Elevel+1))
      Freg1=Load Real(Stk(Elevel+2),-1,-1,Bytes)
      PIX RX(XAop1,Freg1,0,Reg1,0)
      %if Opcode=ECMPLX1 %thenstart
         Freg2=Freg1
         PIX RR(SDR,Freg2,Freg2)
      %finishelsestart
         Freg2=Load Real(Stk(Elevel+3),-1,-1,Bytes)
      %finish
      PIX RX(XAop1,Freg2,0,Reg1,Bytes)
      %return
!*
F77op(EISHFT):      
!*
F77op(EIBITS):       
!*
F77op(EIBSET):      
!*
F77op(EIBTEST):     
!*
F77op(EIBCLR):      
!*
F77op(EISHFTC):      
      Unsupported Opcode(Opcode)
      %return
!*
F77op(PROCARG):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      D1=Stk(Elevel+1)_Intval
      Pd4(GLA,D1+12,-1)
      Do RX(LA,R0,R13,D1)
      PIX RX(ST,R0,0,R11,Next Param Offset)
      Next Param Offset=Next Param Offset+4
      %return
!*
F77op(IPROCARG):   
!*
F77op(CHARARG):    
      %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
      Estklit(X'20000');! Amdahl string type
      Eop(IADD)
      Eop(PUSHVAL)
      Eop(PUSHVAL)
      %return
!*
F77op(IPROCCALL):   
      Unsupported Opcode(Opcode)
      %return
!*
F77op(ARGPROCCALL):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Op RX(L,R1,Stk(Elevel+1))
      PIX RS(STM,R4,R14,R11,16)
      PIX RS(LM,R12,R14,R1,0)
      PIX RR(BASR,R15,R14)
      Pusing(R15)
      UsingR15=1
      Active calls=Active calls-1
      %return
!*
F77op(NOTEIORES):  
      {no special action required here on Amdahl - result will stay in R1}
      %return
!*
F77op(STKIORES):    
      Stackr(R1)
      %return
!*
F77op(CALLTPLATE): 
      %return    
!*
F77op(EFDVACC):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-1
      { on Amdahl the two entries still on Estack will usually be in regs}
      Reg2=Load Int(Stk(Elevel-1),-1,-1)
      Stk(Elevel-1)_Form=RegVal!Regflag
      Stk(Elevel-1)_Reg=Reg2
      Reg1=Load Int(Stk(Elevel),-1,Reg2)
      Stk(Elevel)_Form=RegVal!Regflag
      Stk(Elevel)_Reg=Reg1
      %if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
      %if UsingR15#0 %then Pdrop(R15) %and UsingR15=0
      PIX RR(LR,R15,Reg1)
      Ruse(Reg1)=-Elevel
      Ruse(Reg2)=-Elevel+1
      OpRX(M,R14,Stk(Elevel+1))
      PIX RR(AR,Reg2,R15)
      %return
!*
F77op(EARGLEN):
      {on Amdahl it may be necessary to mask out the upper half of char len }
      Stk(Elevel)_Offset=Stk(Elevel)_Offset+2
      Stk(Elevel)_Size=2
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),-1,-1)
      Stackr(Reg1)
      %return
!*
F77op(EFNOTEVR):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),R1,-1)
      %return
!*
F77op(EFSETVR):
      Stackr(R1)
      %return
%end;! Ef77op
!*
!*
%externalroutine EPasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal                      *
!***********************************************************************
%switch Pasop(511:645)
%integer Bytes,Reg
      %if Report#0 %thenstart
         printstring("Epasop  ".Epasopname(Opcode))
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
!*
      %if CCset # 0 %then Establish Logical; ! estsblish logical value 0 or 1
!*
      ->Pasop(Opcode)
!*
Pasop(*): %monitor
!*
Pasop(STRGT):
Pasop(STRLT):
Pasop(STREQ):
Pasop(STRNE):
Pasop(STRGE):
Pasop(STRLE):
!!      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
!!      %if Stk(Elevel)_Form#LitVal %then Abortm("Epasop: string length")
!!      Bytes=Stk(Elevel)_IntVal
!!      Elevel=Elevel-3
!!      String Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),Bytes)
      Eop(CPBGT+Opcode-STRGT)
      %return
!*
Pasop(PTREQ):
Pasop(PTRNE):
      Eop(IEQ+Opcode-PTREQ)
      %return
!*
Pasop(SETI):
Pasop(SETU):
Pasop(SETD):
!*
Pasop(SETEQ):
Pasop(SETNE):
Pasop(SETIN):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
!!      Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),0)
      %return
!*
Pasop(SETLE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Eop(DUPL)
      Epromote(3)
      Epasop(SETU)
      Epasop(SETEQ)
      %return
!*
Pasop(SETSING):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Stk(Elevel)_Form#LitVal %then Abortm("SETSING: size?")
      Elevel= Elevel-2
!!      Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+1),Stk(Elevel+2)_IntVal)
      %return
!*
Pasop(SETRANGE):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      %if Stk(Elevel)_Form#LitVal %then Abortm("SETRANGE: size?")
      Elevel= Elevel-3
!!      Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3)_IntVal)
      %return
!*
Pasop(CAPMOVE):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Unsupported Opcode(Opcode)
      %return
!*
Pasop(INDEXP):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-2
      Bit Index(Stk(Elevel+2),Stk(Elevel),Stk(Elevel+1))
      %return
!*
Pasop(EOFOP):
Pasop(EOLOP):
      Spcall(Opcode-EOFOPT+10)
      %return
!*
Pasop(LAZYOP):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Spcall(14)
      %return
!*
Pasop(ISQR):
      Eop(DUPL)
      Eop(IMULT)
      %return
!*
Pasop(IODD):
Pasop(UODD):
      Push Operand(LitOne)
      Eop(IAND)
      %return
!*
Pasop(ISUCC):
Pasop(USUCC):
      Push Operand(LitOne)
      Eop(IADD)
      %return
!*
Pasop(IPRED):
Pasop(UPRED):
      Push Operand(LitOne)
      Eop(ISUB)
      %return
!*
Pasop(RSQR):
      Eop(DUPL)
      Eop(RMULT)
      %return
!*
Pasop(CHKLT):
Pasop(CHKGT):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-2
      Unsupported Opcode(Opcode)
      %return
!*
Pasop(CHKRNG):
Pasop(CHKSETGT):
Pasop(CHKSETRNG):
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-3
      Unsupported Opcode(Opcode)
      %return
!*
Pasop(UCHKLT):
Pasop(UCHKGT):
Pasop(UCHKNE):
Pasop(UCHKRNG):
Pasop(CHKNE):
      Unsupported Opcode(Opcode)
!*
Pasop(CHKNEW2):
Pasop(CHKUNDEF):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Unsupported Opcode(Opcode)
      %return
!*
Pasop(SETUNDEF):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Unsupported Opcode(Opcode)
      %return
!*
Pasop(TRAP):
!      Unsupported Opcode(Opcode)
      Elevel=Elevel-1
      %return
!*
Pasop(ICLPSH):
Pasop(ICLPROT):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Unsupported Opcode(Opcode)
      %return
Pasop(ICLCPTR):
Pasop(ICLWPTR):
      %if Elevel<1 %then LowEstack(Opcode,1) %and %return
      Elevel = Elevel - 1
      %if Stk(Elevel+1)_Form&31<TempVal %then %monitor %and %stop
      Reg = ClaimR(0)
      %if Stk(Elevel+1)_Form&31<AddrConst %then Op RX(LA,Reg,Stk(Elevel+1)) %c
                                          %else Op RX(L,Reg,Stk(Elevel+1))
      StackR(Reg)
      %return
%end;! EPasop
!*
%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C                           *
!***********************************************************************
      %monitor
%end;! Eccop
!*
%routine Expcall(%integer Proc)
!***********************************************************************
!* call an exponentiation routine                                      *
!***********************************************************************
%integer I,J,T
%string(31) S
      T=Expproctype(Proc)
      J=Expprocref(Proc)
      %if J=0 %thenstart
         S=Expprocs(Proc)
         J=Exname(T,S)
         Expprocref(Proc)=J
      %finish
      Eprecall(J)
      I=Expprocpdesc(Proc)>>16
      %while I>0 %cycle
         Epromote(I)
         Eop(PUSHVAL)
         I=I-1
      %repeat
      I=Expprocpdesc(Proc)
      Freeregs
      Ecall(J,I>>16,I&X'FF')
      %if T&7#0 %thenstart;! function
         Estkresult(0,T&7,(T>>8)&255)
      %finish
%end;! Expcall
!*
%routine Spcall(%integer Proc)
!***********************************************************************
!* call a support procedure                                            *
!***********************************************************************
%integer I,J,T
%string(31) S
      T=Spproctype(Proc)
      J=Spprocref(Proc)
      %if J=0 %thenstart
         S=Spprocs(Proc)
         J=Exname(T,S)
         Spprocref(Proc)=J
      %finish
      Eprecall(J)
      I=Spprocpdesc(Proc)>>16
      %while I>0 %cycle
         Epromote(I)
         Eop(PUSHVAL)
         I=I-1
      %repeat
      I=Spprocpdesc(Proc)
      Freeregs
      Ecall(J,I>>16,I&X'FF')
      %if T&7#0 %thenstart;! function
         Estkresult(0,T&7,(T>>8)&255)
      %finish
%end;! Spcall
!*
!*
!*
!*
!***********************************************************************
!***********************************************************************
!**             Code generation support procedures                    **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Refer(%record(Stkfmt)%name Stk,%integer Offset)
%integer Reg
%switch F(0:21)
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(RegVal):                {  (reg)      }
      %if Offset#0 %thenstart
         Stk_Form=IndRegModVal!Regflag
Setoff:  Stk_Modform=Litval
         Stk_Modintval=Offset
         Stk_Scale=0
         %return
      %finish
      Stk_Form=IndRegVal!Regflag
      Ruse(Stk_Reg)=-Elevel
      %return
!*
F(TempVal):               {  (temp)     }
      %if Offset#0 %thenstart
         Stk_Form=IndTempModVal
         ->Setoff
      %finish
      Stk_Form=IndTempVal
      %return
!*
F(DirVal):                {  (dir)      }
      %if Offset#0 %thenstart
         Stk_Form=IndDirModVal
         ->Setoff
      %finish
      Stk_Form=IndDirVal
      %return
!*
F(IndRegVal):             { ((reg))     }
      PIX RX(L,Stk_Reg,0,Stk_Reg,0)
      ->F(RegVal)
!*
F(AddrDirMod):            {  @dir+M     }
      %if Offset=0 %thenstart
         Stk_Form=AddrDirModVal
         %return
      %finish
      ->Loadr
!*
F(IndTempVal):            { ((temp))    }
F(IndDirVal):             { ((dir))     }
F(AddrDirModVal):         { (dir+M)     }
F(IndRegModVal):          { ((reg)+M)   }
F(IndTempModVal):         { ((temp)+M)  }
F(IndDirModVal):          { ((dir)+M)   }
Loadr:Reg=Claimr(0)
      OpRX(L,Reg,Stk)
      Stk_Reg=Reg
      Ruse(Stk_Reg)=-Elevel
      ->F(RegVal)
!*
F(AddrConst):             {  @const     }
      Stk_Form=ConstVal
      Stk_Offset=Stk_Offset+Offset
      %return
!*
F(AddrDir):               {  @dir       }
      Stk_Form=DirVal
      Stk_Offset=Stk_Offset+Offset
      %return
!*
F(RegAddr):               {  (reg) is @ }
      ->F(RegVal)
!*
F(TempAddr):              {  (temp) is @}
      %if Offset#0 %thenstart
         Stk_Form=IndTempModVal
         ->Setoff
      %finish
      Stk_Form=IndTempVal
      %return
!*
F(DirAddr):               {  (dir) is @ }
      %if Offset#0 %thenstart
         Stk_Form=IndDirModVal
         ->Setoff
      %finish
      Stk_Form=IndDirVal
      %return
!*
F(RegModAddr):            {  (reg)+M    }
      %if Offset=0 %thenstart
         Stk_Form=IndRegModVal!Regflag
         %return
      %finish
      ->Loadr
!*
F(TempModAddr):           {  (temp)+M   }
      %if Offset=0 %thenstart
         Stk_Form=IndTempModVal
         %return
      %finish
      ->Loadr
!*
F(DirModAddr):            {  (dir)+M    }
      %if Offset=0 %thenstart
         Stk_Form=InddirModVal
         %return
      %finish
      ->Loadr
!*
F(LitVal):                {  lit        }
F(ConstVal):              {  const      }
F(FregVal):               {  (freg)     }
      printstring("
Invalid attempt to Refer 
")
      Abort
!*
%end;! Refer
!*
%routine Address(%record(Stkfmt)%name Stk)
%integer I,J,Reg,Op
%switch F(0:21)
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      Setint(Stk_Intval,Stk_Size,I,J)
      Stk_Base=Cnst
      Stk_Offset=J
F(ConstVal):              {  const      }
      Stk_Form=AddrConst
Size: Stk_Size=4
      %return
!*
F(RegVal):                {  (reg)      }
      I=New Temp(4)
      Op=ST
      RUse(Stk_Reg) = 0
Store:Do RX(Op,Stk_Reg,R10,I)
      Stk_Base=0
      Stk_Offset=I
      Stk_Form=AddrDir
      ->Size
!*
F(FregVal):               {  (freg)     }
      I=New Temp(Stk_Size)
      %if Stk_Size=4 %then Op=STE %else Op=STD
      FRUse(Stk_Reg) = 0
      ->Store
!*
F(TempVal):               {  (temp)     }
      Stk_Form=AddrDir
      %return
!*
F(DirVal):                {  (dir)      }
      Stk_Form=AddrDir
      %return
!*
F(IndRegVal):             { ((reg))     }
      Stk_Form=RegAddr!Regflag
      %return
!*
F(IndTempVal):            { ((temp))    }
      Stk_Form=TempAddr
      %return
!*
F(IndDirVal):             { ((dir))     }
      Stk_Form=DirAddr
      %return
!*
F(AddrDirModVal):             { (dir+M)     }
      Stk_Form=AddrDirMod!(Stk_Form&Regflag)
      %return
!*
F(IndRegModVal):          { ((reg)+M)   }
      Stk_Form=RegModAddr!Regflag
      %return
!*
F(IndTempModVal):         { ((temp)+M)  }
      Stk_Form=TempModAddr!(Stk_Form&Regflag)
      %return
!*
F(IndDirModVal):          { ((dir)+M)   }
      Stk_Form=DirModAddr!(Stk_Form&Regflag)
      %return
!*
F(AddrConst):             {  @const     }
F(RegAddr):          {  (reg) is @  }
F(TempAddr):              {  (temp) is @      }
F(DirAddr):            {  (dir) is @  }
F(AddrDir):               {  @dir       }
F(AddrDirMod):            {  @dir+M     }
F(RegModAddr):             {  (reg)+M    }
F(TempModAddr):            {  (temp)+M   }
F(DirModAddr):             {  (dir)+M    }
!*
%end;! Address
!*
%integerfn Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg)
!***********************************************************************
!* Stk describes an integer value (1,2 or 4 bytes)                     *
!* if Reg is >= 0 then this register must be loaded                    *
!* result is the general register to which the value has been loaded   *
!***********************************************************************
%integer Bytes
%constbyteintegerarray Lop(0:4)=0,IC,LH,0,L
      Bytes=Stk_Size
      %unless 0<Bytes<=4 %then Abort
      %if Stk_Form&31=RegVal %thenstart
         %if Stk_Reg#Reg %thenstart
            %if Reg<0 %thenstart
               %if Stk_Reg=Lockedreg %thenstart
                  Reg=Claimr(Lockedreg)
                  PIX RR(LR,Reg,Lockedreg)
               %finishelse Reg=Stk_Reg
            %finishelse PIX RR(LR,Reg,Stk_Reg)
         %finish
         Ruse(Stk_Reg)=0
         %result=Reg
      %finish
      %if Reg<0 %then Reg=Claimr(Lockedreg)
      %if Lockedreg>0 %then Ruse(Lockedreg)=-255
      %if Stk_Size=1 %then PIX RR(SR,Reg,Reg)
      OpRX(Lop(Bytes),Reg,Stk)
      %if stk_size=2 %and language=Pascal %then %c
         pix rs(sll,reg,0,0,16) %and pix rs(srl,reg,0,0,16)
      %if Lockedreg>0 %then Ruse(Lockedreg)=0
      %result=Reg
%end;! Load Int
!*
%integerfn Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg,
                                              %integername Bytes)
!***********************************************************************
!* Stk describes a real value                                          *
!* if Reg >= 0 this is the register to be loaded                       *
!* result is the floating register to which the value has been loaded  *
!***********************************************************************
%integer XAop
      Bytes=Stk_Size
      %unless 4<=Bytes<=16 %then Abort
      %if Stk_Form&31=FregVal %thenstart
         Fruse(Stk_Reg)=0
         %if Reg>=0 %and Reg#Stk_Reg %thenstart
            %if Bytes=4 %then XAop=LER %else XAop=LDR
            PIX RR(XAop,Reg,Stk_Reg)
            %result=Reg
         %finishelse %result=Stk_Reg
      %finish
      %if Reg<0 %then Reg=Claimfr(Lockedreg)
      %if Bytes=4 %then XAop=LE %else XAop=LD
      OpRX(XAop,Reg,Stk)
      %result=Reg
%end;! Load Real
!*
%integerfn Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* Stk describes a real value to be loaded at extended precision       *
!* result is the floating register to which the value has been loaded  *
!***********************************************************************
%integer Oldreg,Newreg,XAop,Bytes
      Bytes=Stk_Size
      %unless 4<=Bytes<=16 %then Abort
      %if Stk_Form&31=FregVal %thenstart
         Oldreg=Stk_Reg
         %if Newsize=8 %thenstart
            Newreg=Claimfr(Oldreg)
            PIX RR(SDR,Newreg,Newreg)
            XAop=LER
         %finishelsestart;! 16 byte
            Newreg=Claimfrpair(Oldreg)
            PIX RR(SDR,Newreg+2,Newreg+2)
            %if Bytes=4 %thenstart
               PIX RR(SDR,Newreg,Newreg)
               XAop=LER
            %finishelse XAop=LDR
         %finish
            PIX RR(XAop,Newreg,Oldreg)
         Fruse(Oldreg)=0
      %finishelsestart
         %if Newsize=8 %thenstart
            Newreg=Claimfr(-1)
            PIX RR(SDR,Newreg,Newreg)
            XAop=LE
         %finishelsestart;! 16 byte
            Newreg=Claimfrpair(-1)
            PIX RR(SDR,Newreg+2,Newreg+2)
            %if Bytes=4 %thenstart
               PIX RR(SDR,Newreg,Newreg)
               XAop=LE
            %finishelse XAop=LD
         %finish
         OpRX(XAop,Newreg,Stk)
      %finish
      %result=Newreg
%end;! Load Real Extended
!*
%routine Push Operand(%record(Stkfmt)%name Operand)
!***********************************************************************
!* create an Estack entry for a prepared operand                       *
!***********************************************************************
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Stk(Elevel)=Operand
%end;! Push Operand
!*
%routine Stackr(%integer R)
!***********************************************************************
!* create an Estack entry for a value held in a general register       *
!***********************************************************************
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=RegVal!Regflag
      Stk(Elevel)_Reg=R
      Stk(Elevel)_Size=4
      Ruse(R)=-Elevel
%end;! Stackr
!*
%routine Stackfr(%integer FR,Bytes)
!***********************************************************************
!* create an Estack entry for a value held in a floating register      *
!***********************************************************************
      Elevel=Elevel+1
      Stk(Elevel)=0
      Stk(Elevel)_Form=FregVal!Regflag
      Stk(Elevel)_Reg=FR
      Stk(Elevel)_Size=Bytes
      Fruse(FR)=-Elevel
%end;! Stackfr
!*
%routine Establish Logical
!***********************************************************************
!* called when a condition code has been set and required result is a  *
!* logical value (0 or 1)                                              *
!***********************************************************************
%integer Reg1
      CCset=0
      Reg1=Claimr(0)
      PIX RR(BASR, R14, 0)
      Pusing(R14)
      UsingR14=1
      PIX RX(LA, Reg1, 0, 0, 1)
      PIX RX(BC, CC, 0, R14, 12)
      PIX RX(LA, Reg1, 0, 0, 0)
      Stackr(Reg1);! stack integer result in Reg1
%end;! Establish Logical
!*
%routine 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:IXOR) = 0,
   AR,SR,MR,DR,0,0,0,NR,OR,0,XR
%constbyteintegerarray RXop(0:IXOR) = 0,
   A,S,M,D,0,0,0,N,O,0,X
%constintegerarray Shiftval(0:8)=-1,0,1,-1,2,-1,-1,-1,3
%integer Lform,Rform,Lreg,Rreg,Shift
%switch Opcode(0:ILE)
      %if RHS_Size<4 %thenstart
         Elevel=Elevel+2
         Estklit(4)
         Eop(Cvtii)
         Elevel=Elevel-2
      %finish
      %if LHS_Size<4 %thenstart
         Elevel=Elevel+2
         Epromote(2)
         Estklit(4)
         Eop(Cvtii)
         Epromote(2)
         Elevel=Elevel-2
      %finish
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      ->Opcode(Op)
!*
Opcode(IADD):
Opcode(IAND):
Opcode(IOR):
Opcode(IXOR):
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(RRop(Op),Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(RXop(op),Lreg,RHS)
         Stackr(Lreg)
      %finishelsestart
         %if Rform#RegVal %thenstart
            Rreg=Claimr(0)
            %if Lform=Litval %thenstart
               OpRX(L,Rreg,LHS)
               OpRX(RXop(Op),Rreg,RHS)
               Stackr(Rreg)
               %return
            %finish
            OpRX(L,Rreg,RHS)
         %finish
         OpRX(RXop(Op),Rreg,LHS)
         Stackr(Rreg)
      %finish
      %return
!*
Opcode(ISUB):
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(SR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(S,Lreg,RHS)
      %finishelsestart
         %if Rform=RegVal %thenstart
            Lreg=Claimr(Rreg)
            OpRX(L,Lreg,LHS)
            PIX RR(SR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelsestart
            Lreg=Claimr(0)
            Op RX(L,Lreg,LHS)
            Op RX(S,Lreg,RHS)
         %finish
      %finish
      Stackr(Lreg)
      %return
!*
Opcode(IGT):
Opcode(ILT):
Opcode(IEQ):
Opcode(INE):
Opcode(IGE):
Opcode(ILE):
      CC=Setcc(Op-IGT)
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(CR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(C,Lreg,RHS)
         Ruse(Lreg)=0
      %finishelsestart
         %if Rform=RegVal %thenstart
            CC=Invcc(CC)
            OpRX(C,Rreg,LHS)
         %finishelsestart
            Rreg=Claimr(0)
            OpRX(L,Rreg,LHS)
            OpRX(C,Rreg,RHS)
         %finish
         Ruse(Rreg)=0
      %finish
      CCset=1
      %return
!*
Opcode(IMULT):
      %if Lform=LitVal %thenstart
         %if 0<=LHS_Intval<=8 %thenstart
            Shift=Shiftval(LHS_Intval)
            %if Shift=0 %thenstart
               Elevel=Elevel+1
               Stk(Elevel)=RHS
               %return
            %finish
            %if Shift>0 %thenstart
               Rreg=Load Int(RHS,-1,-1)
               PIX RS(SLA,Rreg,0,0,Shift)
               Stackr(Rreg)
               %return
            %finish
         %finish
      %finish
      %if Rform=LitVal %thenstart
         %if 0<=RHS_Intval<=8 %thenstart
            Shift=Shiftval(RHS_Intval)
            %if Shift=0 %thenstart
               Elevel=Elevel+1
               Stk(Elevel)=LHS
               %return
            %finish
            %if Shift>0 %thenstart
               Rreg=Load Int(LHS,-1,-1)
               PIX RS(SLA,Rreg,0,0,Shift)
               Stackr(Rreg)
               %return
            %finish
         %finish
      %finish
!*
      %if Lform=RegVal %thenstart
         %if Lreg#R1 %thenstart
            %unless Lreg=R3 %and Ruse(R2)=0 %thenstart
               %if Ruse(R1)#0 %thenstart
                  %if Rform=RegVal %and Rreg=R1 %thenstart
                     PIX RR(MR,R0,Lreg)
                     Ruse(Lreg)=0
                     Stackr(R1)
                     %return
                  %finish
                  Freeup Reg(R1)
               %finish
               PIX RR(LR,R1,Lreg)
               Ruse(Lreg)=0
               Lreg=R1
            %finish
         %finish
         %if Rform=RegVal %thenstart
            PIX RR(MR,Lreg-1,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(M,Lreg-1,RHS)
      %finishelsestart
         %if Rform=RegVal %thenstart
            Lreg=R1
            %if Rreg#R1 %thenstart
               %if Rreg=R3 %thenstart
                  %if Ruse(R2)#0 %then Freeup Reg(R2)
                  Lreg=R3
               %finishelsestart
                  %if Ruse(R1)#0 %then Freeup Reg(R1)
                  PIX RR(LR,R1,Rreg)
                  Ruse(Rreg)=0
               %finish
            %finish
         %finishelsestart
            %if Ruse(R1)=0 %thenstart
               Lreg=R1
            %finishelsestart
               %if Ruse(R2)=0 %and Ruse(R3)=0 %thenstart
                  Lreg=R3
               %finishelsestart
                  Freeup Reg(R1)
                  Lreg=R1
               %finish
            %finish
            %if Lform=LitVal %thenstart
               OpRX(L,Lreg,LHS)
               Ruse(Lreg)=-255
               OpRX(M,Lreg-1,RHS)
               Stackr(Lreg)
               %return
            %finish
            OpRX(L,Lreg,RHS)
         %finish
         Ruse(Lreg)=-255
         OpRX(M,Lreg-1,LHS)
      %finish
      Stackr(Lreg)
      %return
!*
Opcode(IDIV):
      %if Lform=RegVal %thenstart
         %if Lreg#R1 %thenstart
            %if Ruse(R1)#0 %thenstart
               %if Rform=RegVal %and Rreg=R1 %thenstart
                  %if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
                  PIX RR(LR,R14,R1)
                  PIX RR(LR,R0,Lreg)
                  PIX RX(SRDA,R0,0,0,32)
                  PIX RR(DR,R0,R14)
                  Ruse(Lreg)=0
                  Stackr(R1)
                  %return
               %finish
               Freeup Reg(R1)
            %finish
            PIX RR(LR,R0,Lreg)
            Ruse(Lreg)=0
         %finishelse PIX RR(LR,R0,R1)
         PIX RX(SRDA,0,0,0,32)
         %if Rform=RegVal %thenstart
            PIX RR(DR,R0,Rreg)
            Ruse(Rreg)=0
         %finishelsestart
            Ruse(R1)=-255
            OpRX(D,R0,RHS)
         %finish
      %finishelsestart
         %if Rform=RegVal %thenstart
            %if Rreg#R1 %thenstart
               %if Ruse(R1)#0 %then Freeup Reg(R1)
               Ruse(Rreg)=0
            %finishelsestart
               %if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
               PIX RR(LR,R14,R1)
               Rreg=14
            %finish
            OpRX(L,R0,LHS)
            PIX RX(SRDA,0,0,0,32)
            PIX RR(DR,R0,Rreg)
         %finishelsestart
            %if Ruse(R1)#0 %then Freeup Reg(R1)
            OpRX(L,R0,LHS)
            PIX RX(SRDA,0,0,0,32)
            Ruse(R1)=-255
            OpRX(D,R0,RHS)
         %finish
      %finish
      Stackr(R1)
      %return
%end;! Int Binary Op
!*
%routine U Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports UADD,USUB,UGT,ULT,UEQ,UNE,UGE,ULE                          *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Lform,Rform,Lreg,Rreg,Shift
%switch Opcode(UADD:ULE)
!      %if RHS_Size<4 %thenstart
!         Elevel=Elevel+2
!         Estklit(4)
!         Eop(Cvtii)
!         Elevel=Elevel-2
!      %finish
!      %if LHS_Size<4 %thenstart
!         Elevel=Elevel+2
!         Epromote(2)
!         Estklit(4)
!         Eop(Cvtii)
!         Epromote(2)
!         Elevel=Elevel-2
!      %finish
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      ->Opcode(Op)
!*
Opcode(UADD):
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(ALR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(AL,Lreg,RHS)
         Stackr(Lreg)
      %finishelsestart
         %if Rform#RegVal %thenstart
            Rreg=Claimr(0)
            %if Lform=Litval %thenstart
               OpRX(L,Rreg,LHS)
               OpRX(AL,Rreg,RHS)
               Stackr(Rreg)
               %return
            %finish
            OpRX(L,Rreg,RHS)
         %finish
         OpRX(AL,Rreg,LHS)
         Stackr(Rreg)
      %finish
      %return
!*
Opcode(USUB):
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(SLR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(S,Lreg,RHS)
      %finishelsestart
         %if Rform=RegVal %thenstart
            Lreg=Claimr(Rreg)
            OpRX(L,Lreg,LHS)
            PIX RR(SLR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelsestart
            Lreg=Claimr(0)
            Op RX(L,Lreg,LHS)
            Op RX(SL,Lreg,RHS)
         %finish
      %finish
      Stackr(Lreg)
      %return
!*
Opcode(UGT):
Opcode(ULT):
Opcode(UEQ):
Opcode(UNE):
Opcode(UGE):
Opcode(ULE):
      CC=Setcc(Op-UGT)
      %if Lform=RegVal %thenstart
         %if Rform=RegVal %thenstart
            PIX RR(CLR,Lreg,Rreg)
            Ruse(Rreg)=0
         %finishelse OpRX(CL,Lreg,RHS)
         Ruse(Lreg)=0
      %finishelsestart
         %if Rform=RegVal %thenstart
            CC=Invcc(CC)
            OpRX(CL,Rreg,LHS)
         %finishelsestart
            Rreg=Claimr(0)
            OpRX(L,Rreg,LHS)
            OpRX(CL,Rreg,RHS)
         %finish
         Ruse(Rreg)=0
      %finish
      CCset=1
      %return
!*
%end;! U Int Binary Op
!*
%routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports INEG,IABS                                                  *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg1,XAop
      Reg1=Load Int(RHS,-1,0)
      %if Op=INEG %then XAop=LCR %elsestart
         %if Op=INOT %or Op=BNOT %thenstart  {++++ temp while fortran change introduced +++}
            PIX RX(LA,0,0,0,1)
            PIX RR(NR,Reg1,0)
            PIX RR(XR,Reg1,0)
            Stackr(Reg1)
            %return
         %finish
         %if Op=IABS %then XAop=LPR %else Abort
      %finish
      PIX RR(XAop,Reg1,Reg1)
      Stackr(Reg1)
%end;! Int Unary Op
!*
%routine Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports RADD,RSUB,RMULT,RDIV,RGT,RLT,REQ,RNE,RGE,RLE               *
!* descriptor to result on Estack                                      *
!***********************************************************************
%constbyteintegerarray RReop(RADD:RDIV) = AER,SER,MER,DER
%constbyteintegerarray RXeop(RADD:RDIV) = AE,SE,ME,DE
%constbyteintegerarray RRdop(RADD:RDIV) = ADR,SDR,MDR,DDR
%constbyteintegerarray RXdop(RADD:RDIV) = AD,SD,MD,DD
%constbyteintegerarray RRxop(RADD:RDIV) = AXR,SXR,MXR,0
%integer Lform,Rform,Lreg,Rreg,Bytes,XARop,XAXop,Loadop
%switch Opcode(RADD:RLE)
      Lform=LHS_Form&31
      Rform=RHS_Form&31
      Lreg=LHS_Reg
      Rreg=RHS_Reg
      Bytes=LHS_Size
      %if RADD<=Op<=RDIV %thenstart
         %if Bytes=4 %thenstart
            XARop=RReop(Op)
            XAXop=RXeop(Op)
            Loadop=LE
         %finishelsestart
            %if Bytes=8 %thenstart
               XARop=RRdop(Op)
               XAXop=RXdop(Op)
            %finishelsestart
               XARop=RRxop(Op)
            %finish
            Loadop=LD
         %finish
      %finishelsestart;! comparison
         %if Bytes=4 %thenstart
            XARop=CER
            XAXop=CE
            Loadop=LE
         %finishelsestart
            XARop=CDR
            XAXop=CD
            Loadop=LD
         %finish
      %finish
      ->Opcode(Op)
!*
Opcode(RADD):
!*
Opcode(RMULT):
      %if Lform=FregVal %thenstart
         %if Rform=FregVal %thenstart
            PIX RR(XARop,Lreg,Rreg)
            Fruse(Rreg)=0
         %finishelse OpRX(XAXop,Lreg,RHS)
         Stackfr(Lreg,Bytes)
      %finishelsestart
         %if Rform#FregVal %thenstart
            Rreg=Claimfr(-1)
            OpRX(Loadop,Rreg,RHS)
         %finish
         OpRX(XAXop,Rreg,LHS)
         Stackfr(Rreg,Bytes)
      %finish
      %return
!*
Opcode(RSUB):
!*
Opcode(RDIV):
      %if Lform=FregVal %thenstart
         %if Rform=FregVal %thenstart
            PIX RR(XARop,Lreg,Rreg)
            Fruse(Rreg)=0
         %finishelse OpRX(XAXop,Lreg,RHS)
      %finishelsestart
         %if Rform=FregVal %thenstart
            Lreg=Claimfr(Rreg)
            Op RX(Loadop,Lreg,LHS)
            PIX RR(XARop,Lreg,Rreg)
            Fruse(Rreg)=0
         %finishelsestart
            Lreg=Claimfr(-1)
            Op RX(Loadop,Lreg,LHS)
            Op RX(XAXop,Lreg,RHS)
         %finish
      %finish
      Stackfr(Lreg,Bytes)
      %return
!*
Opcode(RGT):
Opcode(RLT):
Opcode(REQ):
Opcode(RNE):
Opcode(RGE):
Opcode(RLE):
      CC=Setcc(Op-RGT)
      %if Lform=FregVal %thenstart
         %if Rform=FregVal %thenstart
            PIX RR(XARop,Lreg,Rreg)
            Fruse(Rreg)=0
         %finishelse OpRX(XAXop,Lreg,RHS)
         Fruse(Lreg)=0
      %finishelsestart
         %if Rform=FregVal %thenstart
            CC=Invcc(CC)
            OpRX(XAXop,Rreg,LHS)
         %finishelsestart
            Rreg=Claimfr(-1)
            OpRX(Loadop,Rreg,LHS)
            OpRX(XAXop,Rreg,RHS)
         %finish
         Fruse(Rreg)=0
      %finish
      CCset=1
      %return
%end;! Real Binary Op
!*
%routine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports RNEG,RABS                                                  *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg1,XAop,Bytes
      Reg1=Load Real(RHS,-1,-1,Bytes)
      %if Op=RNEG %thenstart
         %if Bytes=4 %then XAop=LCER %else XAop=LCDR 
      %finishelsestart
         %if Op=RABS %thenstart
            %if Bytes=4 %then XAop=LPER %else XAop=LPDR
         %finishelse Abort
      %finish
      PIX RR(XAop,Reg1,Reg1)
      Stackfr(Reg1,Bytes)
%end;! Real Binary Op
!*
%routine Convert II(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts between integer sizes                                      *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg
      Reg=Load Int(Stk,-1,-1)
      Stackr(Reg)
%end;! Convert II
!*
%routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts between real sizes                                         *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Freg1,Bytes,Oldsize
%switch Sw(0:10)
      Oldsize=Stk_Size
      ->Sw(((Oldsize&24)>>1)!(Newsize>>3))
!*
Sw(1):! CVTRD
      Freg1=Load Real Extended(Stk,8)
      Bytes=8
Note: Stackfr(Freg1,Bytes)
      %return
!*
Sw(4):! CVTDR
      Freg1=Load Real(Stk,-1,-1,Bytes)
      PIX RR(LRER,Freg1,Freg1)
      Bytes=4
      ->Note
!*
Sw(2):! CVTRQ
!*
Sw(6):! CVTDQ
      Freg1=Load Real Extended(Stk,16)
      Bytes=16
      ->Note
!*
Sw(8):! CVTQR
      Freg1=Load Real(Stk,-1,-1,Bytes)
      PIX RR(LRDR,Freg1,Freg1)
      PIX RR(LRER,Freg1,Freg1)
      Bytes=4
      ->Note
!*
Sw(9):! CVTQD
      Freg1=Load Real(Stk,-1,-1,Bytes)
      PIX RR(LRDR,Freg1,Freg1)
      Bytes=8
      ->Note
!*
Sw(*):
      Freg1=Load Real(Stk,-1,-1,Bytes)
      ->Note
%end;! Convert RR
!*
%routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode)
!***********************************************************************
!* converts between real and integer                                   *
!* Mode = 0   TNC                                                      *
!*        1   RND                                                      *
!*        2   FLOOR                                                    *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg1,Freg1,Bytes
      Freg1=Load Real(Stk,-1,-1,Bytes)
      Reg1=Claimr(-1)
      %if Mode=1 %thenstart
         PIX RR(BASR,14,0)
         Pusing(R14)
         Using R14=1
         %if Bytes=4 %thenstart
            PIX RR(LTER,Freg1,Freg1)
            PIX RX(BC,10,0,R14,14)
            PIX RX(SE,Freg1,0,R9,RHALF)
            PIX RX(BC,15,0,R14,18)
            PIX RX(AE,Freg1,0,R9,RHALF)
         %finishelsestart
            PIX RR(LTDR,Freg1,Freg1)
            PIX RX(BC,10,0,R14,14)
            PIX RX(SD,Freg1,0,R9,RHALF)
            PIX RX(BC,15,0,R14,18)
            PIX RX(AD,Freg1,0,R9,RHALF)
         %finish
      %finish
      %if mode=2 %Start;           ! floor only
         pix rx(ad,freg1,0,r9,maxiasr)
         pix rx(aw,freg1,0,r9,zerononstd)
      %else;                         ! tnc and rnd
         PIX RX(SD,Freg1,0,R9,TWO31R);! X'4F00 0000 0800 0000'
         PIX RX(AW,Freg1,0,R9,TWO32) ;! X'4E00 0001 0000 0000'
      %finish
      PIX RX(STD,Freg1,0,R13,Glawork)
      PIX SI(XI,X'80',R13,Glawork+4)
      PIX RX(L,Reg1,0,R13,Glawork+4)
      Stackr(Reg1)
%end;! Convert RI
!*
%routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts real to integer                                            *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg1,Freg1,Bytes
%switch Sw(0:2)
      Reg1=Load Int(Stk,-1,0)
      ->Sw(Newsize>>3)
!*
Sw(0):! FLTR
      Bytes=4
      ->Flt
!*
Sw(1):! FLTD
      Bytes=8
Flt:  Freg1=Claimfr(-1)
      PIX RX(X,Reg1,0,R9,TWO31+4);! X'8000 0000'
      PIX RX(ST,Reg1,0,R13,Glawork+4)
      PIX SS(MVC,0,4,R13,Glawork,R9,TWO31) ;! X'4E00 0000 8000 0000'
      PIX RX(LD,Freg1,0,R13,Glawork)
      PIX RX(SD,Freg1,0,R9,TWO31)
      Stackfr(Freg1,Bytes)
      %return    
!*
Sw(2):! FLTQ  
      Freg1=Claimfrpair(-1)
      PIX RR(SDR,Freg1+1,Freg1+1)
      Bytes=16
      ->Flt
%end;! Convert IR
!*
%integerfn 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 retainedin a reg                                      *
!* result is the reg used for retaining the value                      *
!***********************************************************************
%constbyteintegerarray Ad(0:21)=0(9),1(9),0(4)
%integer Bytes,Op,Reg,Form,B1,D1,B2,D2
      %If language=Pascal %and Rhs_base=Cnst %then %c
         Rhs_Size=(Rhs_size+3)&(-4);! ! Pascal literal strings have exact size
                                       ! but are stored in integral words.
      Bytes=RHS_Size
      Form=RHS_Form&31
      LHS_Form=LHS_Form&31;! remove Regflag bit if set
      %if Ad(LHS_Form)#0 %then %Start
         %if report#0 %then printstring("Warning:- Store into an address
")
         Refer(LHS,0)
         LHS_Size=Bytes
      %finish
      %if LHS_Size<Bytes %then Bytes=LHS_Size
      %if Bytes=4 %thenstart
         %if Form=RegVal %thenstart
            Op=ST
Streg:      Reg=RHS_Reg
            Ruse(Reg)=0
Pushit:     Op RX(Op,Reg,LHS)
            %result=Reg
         %finish
         %if Form=FregVal %thenstart
            Op=STE
            Reg=RHS_Reg
            Fruse(Reg)=0
            ->Pushit
         %finish
         %if Dup#0 %then Reg=Claimr(-1) %else Reg=0
         Op RX(L,Reg,RHS)
         Op=ST
         ->Pushit
      %finishelsestart
         %unless Bytes=8 %thenstart
            %if Bytes=2 %and Form=RegVal %thenstart
               Op=STH
               ->Streg
            %finish
            %if Bytes=1 %and Form=Regval %thenstart
               Op=STC
               ->Streg
            %finish
            Set Bd(LHS,B1,D1)
            Ruse(B1)=-255
            Set Bd(RHS,B2,D2)
            %if form=litval %then d2=d2+4-bytes
            PIX SS(MVC,0,Bytes,B1,D1,B2,D2)
            Ruse(B1)=0
            %result=0
         %finish
         Op=STD
         %if Form=FregVal %thenstart
            Reg=RHS_Reg
            Fruse(Reg)=0
            ->Pushit
         %finish
         Reg=Claimfr(-1)
         Op RX(LD,Reg,RHS)
         ->Pushit
      %finish
%end;! Storeop
!*
%routine Push Param(%integer Mode,%record(Stkfmt)%name Stk)
!***********************************************************************
!* the value or address of Stk is added to the parameter list          *
!* result is the reg used for retaining the value                      *
!* Mode = 0  push value
!*        1  push address
!***********************************************************************
%integer Bytes,Op,Reg,Form,B1,D1
      %if Mode=1 %thenstart
         Address(Stk)
         Stk_Size=4
      %finish
      %If language=Pascal %and Stk_base=Cnst %then %c
         Stk_Size=(Stk_size+3)&(-4);! ! Pascal literal strings have exact size
                                       ! but are stored in integral words.
      Form=Stk_Form&31
      %if Stk_Size=1 %thenstart
         Elevel = Elevel + 1
         EstkLit(4)
         Eop(CVTII)
         Elevel = Elevel - 1
      %finish
      %if Form=RegVal %then Bytes = 4 %else Bytes=Stk_Size
!      %if Mode=0 %and Form&ADDRESSED=0 %thenstart
         %if Bytes=4 %thenstart
            %if Form=RegVal %thenstart
               Op=ST
               Reg=Stk_Reg
               Ruse(Reg)=0
Pushit:        PIX RX(Op,Reg,0,R11,Next Param Offset)
               Next Param Offset=Next Param Offset+Bytes
               %return
            %finish
            %if Form=FregVal %thenstart
               Op=STE
               Reg=Stk_Reg
               Fruse(Reg)=0
               ->Pushit
            %finish
            Op RX(L,0,Stk)
            Op=ST
            Reg=0
            ->Pushit
         %finishelsestart
            %unless Bytes=8 %thenstart
               Set BD(Stk,B1,D1)
               PIX SS(MVC,0,Bytes,R11,NextParamOffset,B1,D1)
!               PIX SS(MVC,0,Bytes,B1,D1,R11,Next Param Offset)
               Next Param Offset=Next Param Offset + (Bytes+3)&X'FFC'
               %return
            %finish
            Op=STD
            %if Form=FregVal %thenstart
               Reg=Stk_Reg
               Fruse(Reg)=0
               ->Pushit
            %finish
            Reg=Claimfr(-1)
            Op RX(LD,Reg,Stk)
            ->Pushit
         %finish
!      %finishelsestart;! address required
!         Reg=Load Address(Stk)
!         Bytes=4
!         Op=ST
!         ->Pushit
!      %finish
%end;! Push Param
!*
%integerfn Load address(%record(Stkfmt)%name Stk)
!***********************************************************************
!* result is the reg holding the address of the item desribed by Stk   *
!***********************************************************************
%integer Reg,Form
      Form=Stk_Form&31
      %if Form<TempVal %then %monitor %and %stop
      Op RX(LA,0,Stk)
      %result=0
%end;! Load address
!*
%routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
!***********************************************************************
!* incorporate Index info into Base record                             *
!***********************************************************************
%integer Reg,Form
%record(Stkfmt) Mod
%switch F(0:21)
      %if Index_Form=LitVal %thenstart
         Index_Intval=Index_Intval<<Scale
         Scale=0
         %if Base_Form=AddrDir %thenstart
            Base_Offset=Base_Offset+Index_Intval
            %return
         %finish
      %finishelsestart
         %if IndRegModVal<=Index_Form&31<=AddrDirModVal %thenstart
            Reg=Claimr(0)
            OpRX(L,Reg,Index)
            Ruse(Reg)=-Elevel
            Index_Form=RegVal
            Index_Reg=Reg
            Index_Base=0
            Index_Offset=0
         %finish
      %finish
      %if Addrdirmod<=(Base_Form&31)<=dirmodaddr %or base_form&31=addrdirmodval  %thenstart
         %if Base_Modform=Litval %and Index_Form=Litval %thenstart
            Base_Modoffset=Base_Modoffset+Index_Intval<<Scale
            %return
         %finish
         Reg = LoadModifier(Base,0)
         Mod=0
         Mod_Form = RegVal
         Mod_Reg = Reg
         %if Mod_Form&Regflag#0 %then Ruse(Mod_Reg)=-255
         Mod_Size=4
         %if Base_Scale#0 %then PIX RS(SLL,Reg,0,0,Base_Scale)
         Reg = LoadInt(Index,-1,-1)
         Index = 0
         Index_Form = RegVal
         Index_Size = 4
         Index_Reg = Reg
         %if Scale#0 %then PIX RS(SLL,Reg,0,0,Scale)
         Int Binary Op(IADD,Index,Mod)
         Index = Stk(Elevel)
         Elevel=Elevel-1
         Scale = 0
         -> Set
      %finish
      %if index_size<4 %start;     !index by byte or short
         reg=loadint(index,-1,0)
         index=0; index_form=regval!regflag
          index_size=4; index_reg=reg
      %finish
      ->F(Base_Form&31)
!*
F(IndRegVal):             { ((reg))     }
F(IndTempVal):            { ((temp))    }
F(IndDirVal):             { ((dir))     }
      Base_Form=Base_Form+12
Set:  Base_Modreg=Index_Reg
      Base_Modbase=Index_Base
      Base_Modform=Index_Form
      Base_Modoffset=Index_Offset
      Base_Scale=Scale
      Form=Base_Modform&31
      %if Form=RegVal %or Form=IndRegVal %thenstart
         Ruse(Base_Modreg)=-Elevel
      %finish
      %return
!*
F(AddrDir):               {  @dir       }
F(RegAddr):               {  (reg) is @ }
F(TempAddr):              {  (temp) is @}
F(DirAddr):               {  (dir) is @ }
      Base_Form=Base_Form+4
      ->Set
!*
F(AddrDirMod):            {  @dir+M     }
F(TempModAddr):           {  (temp)+M   }
F(DirModAddr):            {  (dir)+M    }
F(RegModAddr):            { (reg)+M   }
F(IndRegModVal):          { ((reg)+M)   }
F(IndTempModVal):         { ((temp)+M)  }
F(IndDirModVal):          { ((dir)+M)   }
F(AddrDirModVal):         { (@dir+M)    }
      Reg=Claimr(0)
      OpRX(L,Reg,Base)
      Ruse(Reg)=-Elevel
      Base_Reg=Reg
      Base_Form=RegModAddr!Regflag
      ->Set
!*
F(LitVal):                {  lit        }
F(ConstVal):              {  const      }
F(FregVal):               {  (freg)     }
F(AddrConst):             {  @const     }
      Abort
F(RegVal):                {  (reg)      }
      Abort
F(TempVal):               {  (temp)     }
F(DirVal):                {  (dir)      }

      %if language=Imp %then Base_form=base_form+12 %and ->Set
      Abort
!*
%end;! Note Index
!*
!*
!***********************************************************************
!***********************************************************************
!**            Pascal-specific support procedures                     **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue)
!***********************************************************************
!* compute the bit address of an indexed bit-field.                    *
!* Factor is the number of array elements per word and must be 2, 4,   *
!* 8, 16, or 32.                                                       *
!***********************************************************************
%integer Epm,Reg
      %if Base_Form#RegAddr %then Abortm("Bit Index: base")
      %if Factor_Form#LitVal %then Abortm("Bit Index: factor")
      Epm=Factor_IntVal
      %if Epm<2 %or Epm>32 %then Abortm("Bit Index: epm")
    {  %unless Power(Epm)=1 %then Abortm("Bit Index: power")  }
!!      Load(IndexValue)
      Base_Form=RegBitModAddr
      Base_ModReg=Reg
%end;! Bit Index
!*
%routine Load Mask(%integer Width)
!***********************************************************************
!* Load a bit-mask of the specified width from the global const area   *
!***********************************************************************
      %if Width<1 %or Width>31 %then Abortm("Load Mask")
%end;! Load Mask
!*
!*
!*
!***********************************************************************
!***********************************************************************
!**                Amdahl-specific procedures                         **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Clear Regs
!***********************************************************************
!* forget all previous use of registers                                *
!***********************************************************************
%integer I
      %cycle I=0,1,15
         Ruse(I)=0
      %repeat
      %cycle I=0,2,6
         Fruse(I)=0
      %repeat
      Lastreg=0
      Lastbreg=0
      Lastfreg=-1
%end;! Clear Regs
!*
%routine Dropall
!***********************************************************************
!* no dynamic addressing registers can have assumed values             *
!***********************************************************************
%integer I
      %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
      %if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
      %cycle I=0,1,7
         Ruse(I)=0
      %repeat
      %cycle I=0,2,6
         Fruse(I)=0
      %repeat
      Lastreg=-1
      Lastfreg=-1
%end;! Dropall
!*
!*
%routine Freeup Freg(%integer R)
!***********************************************************************
!* store the content of floating register R in temp space, modifying   *
!* Estack entries as necessary                                         *
!***********************************************************************
%integer I,J,XAop,Size
      I=-Fruse(R);! was held as -Elevel
      %if report#0 %Start
         printstring("free up REg"); write(r,2); write(ruse(r),5)
         newline
      %finish
      %if I<=0 %thenstart
         Fruse(R)=0
         %return
      %finish
      %if Stk(I)_Form&31=FregVal %and Stk(I)_Reg=R %thenstart
         Size=Stk(I)_Size
         %if Size=4 %then XAop=STE %else XAop=STD
         J=New Temp(Size)
         Stk(I)_Form=TempVal
         Stk(I)_Offset=J
         Do RX(XAop,R,R10,J)
         Stk(I)_Base=0
         Fruse(R)=0
         %return
      %finish
printstring("Request to free register");write(R,2);newline
Abort
%end;! Freeup Freg
!*
%integerfn New Temp(%integer Bytes)
%integer I
      I=integer(Addrstackca)
      integer(Addrstackca)=I+(Bytes+3)&X'FFFFFFFC'
      %result=I+64
%end;! New Temp
!*
%routine Freeup Reg(%integer R)
!***********************************************************************
!* store the content of general register R in temp space, modifying    *
!* Estack entries as necessary                                         *
!* no dynamic addressing registers can have assumed values             *
!***********************************************************************
%integer I,J,K
      I=-Ruse(R);! was held as -Elevel
      %if I<=0 %thenstart
         Ruse(R)=0
         %return
      %finish
      J=New Temp(4)
      %if Stk(I)_Reg=R %thenstart
         K=Stk(I)_Form&31
         %if K=RegVal %thenstart
            Stk(I)_Form=TempVal
            Stk(I)_Offset=J
            %if Stk(i)_size<4 %Then stk(i)_offset=j+4-Stk(i)_size
                                        ! Register converted down prior to a store
            Stk(I)_Base=0
Store:      Do RX(ST,R,R10,J)
            Ruse(R)=0
            %return
         %finishelsestart
            %if K=IndRegVal %or K=RegAddr %or K=RegModAddr  %c
                            %or K=IndRegModVal %thenstart
               Stk(I)_Form=K+1
               Stk(I)_Offset=J
               Stk(I)_Base=0
              ->Store
           %finish
         %finish
      %finishelsestart
         %if Stk(I)_Modform&31=RegVal %and Stk(I)_Modreg=R %thenstart
            Stk(I)_Modform=TempVal
            Stk(I)_Modoffset=J
            Stk(I)_Modbase=0
            ->Store
         %finish
         %if Stk(I)_Modform&31=IndRegVal %and Stk(I)_Modreg=R %thenstart
            Stk(I)_Modform=IndTempVal
            Stk(I)_Modoffset=J
            Stk(I)_Modbase=0
            ->Store
         %finish
      %finish
printstring("Request to free register");write(R,2);newline
Abort
%end;! Freeup Reg
!*
%routine Reset Reguse(%integer Old,New)
%integer I
      %cycle I=1,1,3
         %if Ruse(I)=-Old %thenstart
            Ruse(I)=-New
            %return
         %finish
      %repeat
      %cycle I=0,2,6
         %if Fruse(I)=-Old %thenstart
            Fruse(I)=-New
            %return
         %finish
      %repeat
%end;! Reset Reguse
!*
%routine Freeregs
!***********************************************************************
!* save any general or floating registers                              *
!***********************************************************************
%integer I
      %cycle I=1,1,3
         %if Ruse(I)<0 %then Freeup Reg(I)
         Ruse(I)=0
      %repeat
      %if Language#Fortran %thenstart
         %for I = 4,1,7 %cycle
            %if Ruse(I)#0 %then Freeup Reg(I)
            RUse(I) = 0
         %repeat
      %finish
      %cycle I=0,2,6
         %if Fruse(I)<0 %then Freeup Freg(I)
      %repeat
      Lastreg=-1
      Lastfreg=-1
%end;! Freeregs
!*
%integerfn Claimfr(%integer Curreg)
!***********************************************************************
!* result is a free floating register, other than Curreg               *
!***********************************************************************
%integer I
      %cycle I=0,2,6
         %if Fruse(I)=0 %and I#Curreg %and I#Lastfreg %thenstart
            Lastfreg=I
            %result=I
         %finish
      %repeat
      %cycle I=0,2,6
         %unless I=Curreg %or I=Lastfreg %thenstart
            Freeup Freg(I)
            Lastfreg=I
            %result=I
         %finish
      %repeat
%end;! Claimfr
!*
%integerfn Claimfrpair(%integer Curreg)
!***********************************************************************
!* result is the smaller of a free floating register pair, not         *
!*including Curreg                                                     *
!***********************************************************************
%integer I
      %if Fruse(0)=0 %and Fruse(2)=0 %then %result=0
      %if Fruse(4)=0 %and Fruse(6)=0 %then %result=4
      %unless 0<=Curreg<=2 %thenstart
         %if Fruse(0)#0 %then Freeup Freg(0)
         %if Fruse(2)#0 %then Freeup Freg(2)
         %result=0
      %finishelsestart
         %if Fruse(4)#0 %then Freeup Freg(4)
         %if Fruse(6)#0 %then Freeup Freg(6)
         %result=4
      %finish
%end;! Claimfrpair
!*
%integerfn Claimr(%integer Curreg)
!***********************************************************************
!* result is a free general register, other than Curreg                *
!***********************************************************************
%integer I
      %cycle I=1,1,3
         %if Ruse(I)=0 %and I#Curreg %and I#Lastreg %thenstart
            Lastreg=I
            %result=I
         %finish
      %repeat
      %if report#0 %Start
         printstring("Claimr");
          write(ruse(i),5) %for i=1,1,3
         newline
      %Finish
      %cycle I=1,1,3
         %unless I=Curreg %or I=Lastreg %or Ruse(I)=-255 %thenstart
            Freeup Reg(I)
            Lastreg=I
            %result=I
         %finish
      %repeat
      %if Lastreg>0 %and Lastreg#Curreg %thenstart
         Freeup Reg(Lastreg)
         %result=Lastreg
      %finishelsestart
         %if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
         %result=R14
      %finish
 Abort
%end;! Claimr
!*
%integerfn Claimbr
!***********************************************************************
!* obtain a register, other than Lastbreg                              *
!***********************************************************************
%integer I
      %cycle I=4,1,7
       %if Ruse(I)=0 %and I#Lockedb1 %then %result=I
      %repeat
      %cycle I=4,1,7
         %unless I=Lastbreg %or I=Lockedb1 %then Ruse(I)=0 %and %result=I
      %repeat
%end;! Claimbr
!*
%routine Setint(%integer Val,Size,%integername B2,D2)
!***********************************************************************
!* set B2, D2 to address a location containing Val                     *
!***********************************************************************
      %if Size<4 %thenstart
         %if Size=1 %then Val=Val<<24 %else Val=Val<<16
     %finish
      Ed4(Cnst,CurCnst,Val)
      CurCnst=CurCnst+4
      B2=R9
      D2=CurCnst-4
%end;! Setint
!*
%integerfn Basereg(%integer Area)
!***********************************************************************
!* result is the register addressing the nominated area                *
!***********************************************************************
%integer I
      %if Area=0 %then %result=R10;! stack
      %if Area=Static %then %result=R8
      %if Area=Cnst %then %result=R9
      %if Area=Gla %then %result=R13
      %cycle I=7,-1,4
         %if Ruse(I)=Area %then Lastbreg=I %and %result=I
      %repeat
      %cycle I=7,-1,4
         %unless I=Lastbreg %thenstart
            DO RX(L,I,R13,Areabase(Area))
            Ruse(I)=Area
            Lastbreg=I
            %result=I
         %finish
      %repeat
%end;! Basereg
!*
%integerfn SetX2(%integername D2)
!***********************************************************************
!* result is a register containing an appropriate 4K multiple          *
!* D2 is adjusted accordingly                                          *
!***********************************************************************
%integer I,J
      %if D2>=4096 %thenstart
         J=D2&X'FFFFF000'
         D2=D2&X'FFF'
         %cycle I=4,1,7
            %if Ruse(I)=J %then Lastbreg=I %and %result=I
         %repeat
         %if J>>12>Max4k %then Max4k=j>>12
         I=Claimbr
         PIX RX(L,I,0,R12,J>>10)

         Ruse(I)=J
         %result=I
      %finishelse %result=0
%end;! SetX2
!*
%routine Range(%integername B,D)
!***********************************************************************
!* if necessary modify B to ensure that D is less than 4096            *
!* D is adjusted accordingly                                           *
!***********************************************************************
%integer X2
      %if D>=4096 %thenstart
         X2=SetX2(D)
         PIX RR(AR,X2,B)
         B=X2
         Ruse(X2)=0
      %finish
%end;! Range
!*
%integerfn Indbase(%integer Area,Disp)
!***********************************************************************
!* result is a register containing the address held in the nominated   *
!* location                                                            *
!***********************************************************************
%integer I,J,K
      J=(Area<<16)!Disp
      %cycle I=4,1,7
         %if Ruse(I)=J %then Lastbreg=I %and %result=I
      %repeat
      I=Basereg(Area)
      K=Claimbr
      Do RX(L,K,I,Disp)
      Ruse(K)=(Area<<16)!Disp
      Lastbreg=K
      %result=K
%end;! Indbase
!*
%routine Do RX(%integer Op,Reg,Base,Offset)
%integer X2
      %if Offset>=4096 %then X2=SetX2(Offset) %else X2=0
      PIX RX(Op,Reg,X2,Base,Offset)
%end;! Do RX
!*
%integerfn Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg)
!***********************************************************************
!* result is a register loaded with the modifier (scaled if necessary) *
!***********************************************************************
%integer Form,Reg,B2,D2
%switch F(0:21)
      Form=Stk_Modform&31
      %if Form =RegVal %thenstart
         Reg=Stk_Modreg
         Stk_Modreg=0
         Ruse(Reg)=0
Scale:   %if Stk_Scale#0 %thenstart
            PIX RS(SLL,Reg,0,0,Stk_Scale)
         %finish
         Stk_Modform=RegVal
         Stk_Scale=0
         %result=Reg
      %finish
      %if Form=IndRegVal %thenstart
         Reg=Stk_Modreg
         Stk_Modreg=0
         PIX RX(L,Reg,0,Reg,0)
         Ruse(Reg)=0
         ->Scale
      %finish
      Reg=Claimr(Lockedreg)
      D2=Stk_Modoffset
      ->F(Form);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      %if 0<=D2<4096 %thenstart
         %if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart
            PIX RX(LA,Reg,0,0,D2)
         %finish
      %finishelsestart
         Setint(D2,Stk_Size,B2,D2)
         Do RX(L,Reg,B2,D2)
      %finish
      ->Scale
!*
F(ConstVal):              {  const      }
F(TempVal):               {  (temp)     }
F(DirVal):                {  (dir)      }
      Do RX(L,Reg,Basereg(Stk_Modbase),D2)
      ->Scale
!*
F(IndTempVal):            { ((temp))    }
      Do RX(L,Reg,Basereg(Stk_Modbase),D2)
      PIX RX(L,Reg,0,Reg,0)
      ->Scale
!*
F(IndDirVal):             { ((dir))     }
      B2=Indbase(Stk_Modbase,D2)
      PIX RX(L,Reg,0,B2,0)
      ->Scale
!*
F(*): Abort
!*
%end;! Load Modifier
!*
%integerfn Negoffset(%integer Area,D)
%integer B,D2
      %if area=stack %Start
         d2=imod(d)>>12+1
         d2=d2<<12
         b=set x2(d2)
         pix rr(lcr,b,b)
         pix rx(la,b,b,r10,(4096+d)&x'fff')
         ruse(b)=0
         %result=b
      %finish
      D2=Glaspace(4)
      Efix(GLA,D2-Gla offset,Area,D)
      B=Claimbr
      Do RX(L,B,R13,D2)
      %result=B
%end;! Negoffset
!*
%routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk)
!***********************************************************************
!* generate an RX instruction appropriate to the operand               *
!***********************************************************************
%integer B2,D2,Modform,Modreg,Exitl,Xreg
%switch F(0:21)
      D2=Stk_Offset
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      %if 0<=D2<4096 %and Op=L %thenstart
         %if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart
            PIX RX(LA,Reg,0,0,D2)
         %finish
      %finishelsestart
         Setint(Stk_Intval,Stk_Size,B2,D2)
         Do RX(Op,Reg,B2,D2)
      %finish
      %return
!*
F(ConstVal):              {  const      }
F(TempAddr):              {  (temp) is @}
F(DirAddr):               {  (dir) is @ }
F(TempVal):               {  (temp)     }
F(DirVal):                {  (dir)      }
      Do RX(Op,Reg,Basereg(Stk_Base),D2)
      %if op=st %Start;           ! Check for store into recordbase
         %for modreg=4,1,7 %cycle
          %if ruse(modreg)=stk_base<<16!d2 %then ruse(modreg)=0
         %repeat
      %finish
      %return
!*
F(RegAddr):               {  (reg) is @ }
F(RegVal):               { (reg)     }
      PIX RR(Op-X'40',Reg,Stk_Reg)
      Ruse(Stk_Reg)=0
      %return
!*
F(FregVal):             { (freg)     }
      PIX RR(Op-X'40',Reg,Stk_Reg)
      Fruse(Stk_Reg)=0
      %return
!*
F(IndRegVal):             { ((reg))     }
      PIX RX(Op,Reg,0,Stk_Reg,0)
      Ruse(Stk_Reg)=0
      %return
!*
F(IndTempVal):            { ((temp))    }
      %if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
      Do RX(L,R14,Basereg(Stk_Base),D2)
      PIX RX(Op,Reg,0,R14,0)
      %return
!*
F(IndTempModVal):         { ((temp)+M)  }
      %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
      B2=R15
      Do RX(L,B2,Basereg(Stk_Base),D2)
      ->Modify
!*
F(IndDirVal):             { ((dir))     }
      B2=Indbase(Stk_Base,D2)
      PIX RX(Op,Reg,0,B2,0)
      %return
!*
F(IndDirModVal):          { ((dir)+M)   }
      B2=Indbase(Stk_Base,D2)
Modify:
      %if Stk_Modform=LitVal %thenstart
         Do RX(Op,Reg,B2,Stk_Modintval)
         %return
      %finish
      Lockedb1=B2
      Modreg=Load Modifier(Stk,Reg)
      PIX RX(Op,Reg,Modreg,B2,0)
      Lockedb1=0
      %return
!*
F(AddrDirModVal):             { (dir+M)     }
      Modreg=Load Modifier(Stk,Reg)
      Ruse(Modreg)=-255
      %if 0<=Stk_Offset<4096 %thenstart
         PIX RX(Op,Reg,Basereg(Stk_Base),Modreg,Stk_Offset)
      %finishelsestart
         %if Stk_Offset<0 %thenstart
            B2=Negoffset(Stk_Base,Stk_Offset)
         %finishelsestart
            B2=Claimr(Reg)
            Do RX(LA,B2,Basereg(Stk_Base),Stk_Offset)
         %finish
         PIX RX(Op,Reg,B2,Modreg,0)
      %finish
      Ruse(Modreg)=0
      %return
!*
F(IndRegModVal):          { ((reg)+M)   }
      B2=Stk_Reg
      Ruse(B2)=0
      Lastreg=B2;! to avoid possibility of a clash when modifying
      ->Modify
!*
F(AddrConst):             {  @const     }
F(AddrDir):               {  @dir       }
      exitl=DirVal; ->alladdr
!*
F(AddrDirMod):            {  @dir+M     }
      Exitl=AddrDirModVal; ->alladdr
!*
F(RegModAddr):             {  (reg)+M    }
      Exitl=IndRegModVal; ->alladdr
!*
F(TempModAddr):            {  (temp)+M   }
      Exitl=IndTempModVal; ->alladdr
!*
F(DirModAddr):             {  (dir)+M    }
      Exitl=IndDirModVal; ->alladdr
alladdr:
      %if Op=l %then Op=la %and ->f(exitl)
      %if Op=STC %or Op=IC %then %Start
         printstring("
Warning Call of Erefer missing. Erefer(0,1) supllied")
         ->F(exitl)
        %finish
      xreg=load int(stk,-1,reg)
      STk_reg=xreg
      ->f(regval)
%end;! OpRX
!*
%routine Set BD(%record(Stkfmt)%name Stk,%integername B,D)
!***********************************************************************
!* provide Base and Dispacement values for accessing the operand       *
!***********************************************************************
%integer Modform,Modreg,D2
%switch F(0:21)
      D=Stk_Offset
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      Setint(Stk_Intval,Stk_Size,B,D)
      %unless 0<=D<=4095 %then Range(B,D)
      %return
!*
F(ConstVal):              {  const      }
F(TempVal):               {  (temp)     }
F(DirVal):                {  (dir)      }
F(AddrDir):               {  @dir       }
      %if D<0 %thenstart;! use a fixed up address
         B=Negoffset(Stk_Base,D)
         D=0
         %return
      %finish
      B=Basereg(Stk_Base)
      %unless D<=4095 %then Range(B,D)
      %return
!*
F(IndRegVal):             { ((reg))     }
F(RegAddr):               {  (reg) is @ }
      B=Stk_Reg
      D=0
      Ruse(B)=0
      %return
!*
F(IndTempVal):            { ((temp))    }
F(TempAddr):              {  (temp) is @}
      B=Claimr(0)
      Do RX(L,B,Basereg(Stk_Base),D)
      D=0
      Ruse(B)=0
      %return
!*
F(IndTempModVal):         { ((temp)+M)  }
F(TempModAddr):           {  (temp)+M   }
      B=Claimr(0)
      Do RX(L,B,Basereg(Stk_Base),D)
      D=0
      ->Modify
!*
F(IndDirVal):             { ((dir))     }
F(DirAddr):               {  (dir) is @ }
      B=Indbase(Stk_Base,D)
      D=0
      %return
!*
F(IndDirModVal):          { ((dir)+M)   }
F(DirModAddr):            {  (dir)+M    }
      B=Indbase(Stk_Base,D)
Modify:
      %if Stk_Modform=LitVal %thenstart
         D=Stk_Modintval
         Range(B,D)
         %return
      %finish
      Modreg=Load Modifier(Stk,B)
      PIX RR(AR,Modreg,B)
      Ruse(Modreg)=0
      B=Modreg
      D=0
      %return
!*
F(AddrDirModVal):             { (dir+M)     }
      %if D<0 %thenstart
         B=Negoffset(Stk_Base,D)
      %finishelsestart
         B=Claimr(0)
         Do RX(LA,B,Basereg(Stk_Base),D)
      %finish
      Modreg=Load Modifier(Stk,B)
      PIX RR(AR,Modreg,B)
      Ruse(Modreg)=0
      B=Modreg
      D=0
      %return
!*
F(IndRegModVal):          { ((reg)+M)   }
F(RegModAddr):            {  (reg)+M    }
      B=Stk_Reg
      Ruse(B)=0
      ->Modify
!*
!*
F(AddrConst):             {  @const     }
!*
F(AddrDirMod):            {  @dir+M     }
      ->F(AddrDirModVal)
!*
!*
%end;! Set BD
!*
%routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2)
%integer I,Len1,Len2,B1,D1,B2,D2,XAop,Apars,Reg
      %if C1_Form=LitVal %then C1_Size=1
      %if C2_Form=LitVal %then C2_Size=1
      %if LenC1_Form=Litval %and LenC2_Form=LitVal %thenstart
         %if LenC1_Intval=LenC2_Intval %and LenC1_Intval<=256 %thenstart
            Set BD(C1,B1,D1)
            %if C2_Form=Litval %thenstart
               %if Op=EASGNCHAR %then XAop=MVI %else XAop=CLI
               PIX SI(XAop,C2_Intval,B1,D1)
               %return
            %finish
            Ruse(B1)=-255
            Lockedb1=B1
            Set BD(C2,B2,D2)
            Lockedb1=0
            Ruse(B1)=0
            %if Op=EASGNCHAR %then XAop=MVC %else XAop=CLC
            PIX SS(XAop,0,LenC1_Intval,B1,D1,B2,D2)
            %return
         %finish
      %finish
      Apars=Glaspace(16)
      %cycle I=0,4,12
         Pd4(GLA,Apars+I,0)
      %repeat
!*
      %if C1_Form=AddrDir %thenstart;! establish fixup
         Efix(GLA,Apars,C1_Base,C1_Offset)
      %finishelsestart
         %if C1_Form=LitVal %thenstart
            Setint(C1_Intval,1,B1,D1)
            Pfix(GLA,Apars,Cnst,D1)
         %finishelsestart
            Set BD(C1,B1,D1)
            %if D1#0 %thenstart
               PIX RX(LA,R0,0,B1,D1)
               B1=R0
            %finish
            Do RX(ST,B1,R13,Apars)
         %finish
      %finish
!*
      %if LenC1_Form=LitVal %thenstart
        Pd4(GLA,Apars+4,LenC1_Intval)
      %finishelsestart
         Reg=Load Int(LenC1,-1,-1)
         Do RX(ST,Reg,R13,Apars+4)
      %finish
!*
      %if C2_Form=AddrDir %thenstart;! establish fixup
         Efix(GLA,Apars+8,C2_Base,C2_Offset)
      %finishelsestart
         %if C2_Form=LitVal %thenstart
            Setint(C2_Intval,1,B1,D1)
            Pfix(GLA,Apars+8,Cnst,D1)
         %finishelsestart
            Set BD(C2,B1,D1)
            %if D1#0 %thenstart
               PIX RX(LA,R0,0,B1,D1)
               B1=R0
            %finish
            Do RX(ST,B1,R13,Apars+8)
         %finish
      %finish
!*
      %if LenC2_Form=LitVal %thenstart
         Pd4(GLA,Apars+12,X'20000000'!LenC2_Intval)
      %finishelsestart
         Reg=Load Int(LenC2,-1,-1)
         PIX RX(LA,0,0,0,X'20')
         PIX RS(SLL,R0,0,0,24)
         PIX RR(OR,R0,Reg)
         Do RX(ST,R0,R13,Apars+12)
      %finish
!*
      %cycle I=1,1,3
         %if Ruse(I)#0 %then Freeup Reg(I)
      %repeat
      Reg=R13
      Range(Reg,Apars)
      PIX RS(LM,R0,R3,Reg,Apars)
      %if Op=EASGNCHAR %then XAop=MVCL %else XAop=CLCL
      PIX RR(XAop,R0,R2)
%end;! Do Charop
!*
%routine Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!***********************************************************************
!* Op = 1   CXADD           5   CXNEG          9   CONJG               *
!*      2   CXSUB           6   CXASGN                                 *
!*      3   CXMULT          7   CXEQ                                   *
!*      4   CXDIV           8   CXNE                                   *
!* Flags = Variant<<8 ! Sizecode                                       *
!*         Variant:  0   complex  op  complex                          *
!*                   1   complex  op  real                             *
!*                   2      real  op  complex                          *
!*        Sizecode:  0    8                                            *
!*                   1   16                                            *
!*                   2   32                                            *
!***********************************************************************
%integer Adj,Variant,Size,D,Reg1,Reg2,Reg3,I,Op1,Adjl,Dl
%switch S(0:9)
      %cycle I=0,2,6
         %if Fruse(I)<0 %then Freeup Freg(I)
      %repeat
      Variant=Flags>>8
      Size=Flags&3
      %if Size=0 %thenstart
         D=4
         Adj=0
      %finishelsestart
         D=8
         Adj=X'10';! to be subtracted from LE etc to give LD etc
      %finish
      %if 3<=Op<=4 %and Variant=0 %thenstart;! use support procedure
         Elevel=Elevel+3;! to allow operands to be pushed
         Spcall(3*(Op-3)+Size)
         %return
      %finish
      Reg1=Claimr(-1)
      Ruse(Reg1)=-255
      Reg2=Claimr(Reg1)
      Ruse(Reg2)=-255
      OpRX(L,Reg1,LHS)
      OpRX(L,Reg2,RHS1)
      %if Op<=4 %thenstart
         Lastreg=Reg2;! to ensure that both Reg1 and Reg2 are safe
         Reg3=Claimr(Reg1)
         OpRX(L,Reg3,RHS2)
      %finish
      Ruse(Reg1)=0
      Ruse(Reg2)=0
      ->S(Op)
!*
S(1): ! CXADD
      PIX RX(LE-Adj,0,0,Reg2,0)
      PIX RX(LE-Adj,2,0,Reg2,D)
      PIX RX(AE-Adj,0,0,Reg3,0)
      %unless Variant=1 %then PIX RX(AE-Adj,2,0,Reg3,D)
Store:PIX RX(STE-Adj,0,0,Reg1,0)
      PIX RX(STE-Adj,2,0,Reg1,D)
      %return
!*
S(2): ! CXSUB
      PIX RX(LE-Adj,0,0,Reg2,0)
      %if Variant=2 %then PIX RR(SER-Adj,2,2)  %c
                    %else PIX RX(LE-Adj,2,0,Reg2,D)
      PIX RX(SE-Adj,0,0,Reg3,0)
      %unless Variant=1 %then PIX RX(SE-Adj,2,0,Reg3,D)
      ->Store
!*
S(3): ! CXMULT
      PIX RX(LE-Adj,0,0,Reg2,0)
      PIX RX(LE-Adj,2,0,Reg2,D)
      PIX RX(ME-Adj,0,0,Reg3,0)
      PIX RX(ME-Adj,2,0,Reg3,0)
{      %if Variant=0 %thenstart        }
{         PIX RX(LE-Adj,4,0,Reg2,0)    }
{         PIX RX(LE-Adj,6,0,Reg2,D)    }
{         PIX RX(ME-Adj,4,0,Reg3,D)    }
{         PIX RX(ME-Adj,6,0,Reg3,D)    }
{         PIX RR(SER-Adj,0,6)          }
{         PIX RR(AER-Adj,2,4)          }
{      %finish                         }
      ->Store
!*
S(4): ! CXDIV
      PIX RX(LE-Adj,0,0,Reg2,0)
      PIX RX(LE-Adj,2,0,Reg2,D)
      PIX RX(DE-Adj,0,0,Reg3,0)
      PIX RX(DE-Adj,2,0,Reg3,0)
      ->Store
!*
S(5): ! CXNEG
      PIX RR(SER-Adj,0,0)
      PIX RR(SER-Adj,2,2)
      PIX RX(SE-Adj,0,0,Reg2,0)
      PIX RX(SE-Adj,2,0,Reg2,D)
      ->Store
!*
S(6): ! CXASGN
      %if Flags&4=0 %thenstart;! assigning to single
         Adjl=0
         Dl=4
      %finishelsestart
         Adjl=X'10'
         Dl=8
      %finish
      %if Variant#0 %thenstart;! not Cx = Cx
         %if D=4 %and Dl=8 %then PIX RR(LDR,0,0)
         PIX RX(LE-Adj,0,0,Reg2,0)
         %if Variant=2 %thenstart;! Real = Cx
St6a:       PIX RX(STE-Adjl,0,0,Reg1,0)
            %return
         %finishelsestart;! Cx = Real
            PIX RR(SER-Adj,2,2)
St6b:       PIX RX(STE-Adjl,2,0,Reg1,Dl)
            ->St6a
         %finish
      %finish
      %if D#Dl %thenstart;! unequal lengths being assigned
         %if D=4 %thenstart;! must zero regs
            PIX RR(SDR,0,0)
            PIX RR(SDR,2,2)
         %finish
         PIX RX(LE-Adj,0,0,Reg2,0)
         PIX RX(LE-Adj,2,0,Reg2,D)
         ->St6b
      %finish
      PIX SS(MVC,0,D<<1,Reg1,0,Reg2,0)
      %return
!*
S(7): ! CXEQ
S(8): ! CXNE
      %if Op=7 %then CC=7 %else CC=8
      PIX RX(LE-Adj,0,0,Reg1,0)
      PIX RR(BASR,R14,0)
      Pusing(R14)
      UsingR14=1
      PIX RX(CE-Adj,0,0,Reg2,0)
      %if Variant=0 %then I=16 %else I=12
      PIX RX(BC,CC,0,R14,I)
      %if Variant=1 %thenstart
         PIX RR(SER,0,0)
         PIX RR(CER,2,0)
     %finishelsestart
         PIX RX(LE-Adj,2,0,Reg1,D)
         PIX RX(CE-Adj,2,0,Reg2,D)
      %finish
      CCset=1
      CC=CC!!15;! inverse test was used in the above
      %return
!*
S(9): ! CONJG
      PIX RX(LE-Adj,0,0,Reg2,0)
      PIX RR(SER-Adj,2,2)
      PIX RX(SE-Adj,2,0,Reg2,D)
      ->Store
%end;! Cx Operation
!*
!*
!***********************************************************************
!*
%externalroutine Eclear
   { Dummy on Amdahl }
%end   { of Eclear }
!*
!*
%externalroutine Ebrefer(%integer Offset,Bytes)
   { Dummy }
%end
!*
%externalroutine estkpf(%Integer i,j)
%end
%externalroutine eprefer(%integer i,j)
%end
%externalroutine etrap(%integer i,j)
%end
%externalroutine egenerateobject(%stringname s)
%end
%endoffile