!* modified 08/03/86                                                ggen7
!*
%include "ftn_ht"
!*
%ownstring(41) Versiontext="EPC/Gould Fortran77 Compiler Version 0.1"
%owninteger Report=0
%owninteger PrimeReport=0
%owninteger Decode
%owninteger Language
!*
!***********************************************************************
!* 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 Estkrconst(%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 Estkpf(%integer FieldOffset,FieldSize)
%routinespec Eprefer(%integer FieldOffset,FieldSize)
!*
%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 Eproclevel(%integer Level)
%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)
%stringfnspec Egivename(%integer Key)
!*
%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
!*
%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) Rstk
%ownrecord(Stkfmt) Frstk
%ownrecord(Stkfmt) LitZero
%ownrecord(Stkfmt) LitOne
!*
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Init Mcode(%integer codelist,lang,options)
%externalintegerfnspec Tidy Mcode(%integer Level,%integername pltsize)
%externalroutinespec Mcode Label(%integer Label)
%externalroutinespec Op RR(%integer Op,Reg1,Reg2,Size)
%externalroutinespec Op RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Op R(%integer Op,Reg)
%externalroutinespec Op X(%integer Op,%record(Stkfmt)%name Stk)
%externalroutinespec Op RL(%integer Op,Reg,Lit)
%externalroutinespec Op Short Jump(%integer Op,Bytes)
%externalroutinespec Op Move(%record(Stkfmt)%name Source,Dest)
%externalroutinespec Op Move RR(%integer From,To)
%externalroutinespec Op Fp(%integer Op,Reg,%record(Stkfmt)%name Opd)
%externalroutinespec Op Short FBcc(%integer Condition,Bytes)
!*
%externalroutinespec Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%externalroutinespec Gop RI(%integer Op,Reg,Lit)
%externalroutinespec Gop RR(%integer Op,Dreg,Sreg)
%externalroutinespec Gop RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop X(%integer Op,%record(Stkfmt)%name Stk)
%externalroutinespec Gop R(%integer Op,Reg)
%externalroutinespec Gop(%integer Op)
%externalroutinespec Gop Shift Lit(%integer Op,Reg,Lit)
%externalroutinespec Gop Shift(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop Jump(%integer Op,Label)
%externalroutinespec Gop Call(%integer Id,Paramsize)
%externalroutinespec Gop Return
%externalroutinespec Mprecall
%externalroutinespec Mstartproc
%externalroutinespec Mtidyproc(%integer Markerid,Localsize)
%externalintegerfnspec Mmarker
%externalroutinespec Msetopd(%integer Markerid,New Value)
%externalroutinespec Mline(%integer Lineno)
%externalintegerfnspec Mgetca
%externalintegerfnspec Note Entry(%stringname Name,%integer Key,Ca)
%externalintegerfnspec Get Prockey(%stringname S)
%externalroutinespec Mswitch(%integer Form,Refad,Base,Entries,Switchid,Errlab)
%externalroutinespec Mswitchentry(%integer Switchid,Entry)
%externalroutinespec Mswitchlabel(%integer Switchid,Entry,Labelid)
!*
!*
!***********************************************************************
!*        Code generation procedure specs                              *
!***********************************************************************
!*
!!%externalintegerfnspec Load Reg(%integer Reg,%record(Stkfmt)%name Stk)
!!%externalintegerfnspec Load Dreg(%integer Reg,%record(Stkfmt)%name Stk)
%externalintegerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg)
%externalintegerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Newsize)
%externalroutinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Check Conflict(%integer Key)
%externalintegerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
%externalroutinespec Push Param(%record(Stkfmt)%name Stk)
%routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%externalintegerfnspec Claim Reg
%externalintegerfnspec Claim Freg
%externalroutinespec Unlock Reg(%integer Reg)
%externalroutinespec Reset Reguse(%integer Old,New)
%externalroutinespec Freeregs
%externalroutinespec Clear Regs
%externalroutinespec  Dump Regs
%externalroutinespec Note Reguse(%integer Reg,Use,Size)
!*
%routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Address(%record(Stkfmt)%name Stk)
%routinespec Stackr(%integer R)
%routinespec Stackfr(%integer FR,Bytes)
%routinespec Establish Logical
%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)
%routinespec Expcall(%integer Proc)
%routinespec Spcall(%integer Proc)
!*
%routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2)
%routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!*
!*
%externalroutinespec   Mlinestart   (%integer lineno,codead)
!***********************************
!* Put Interface Massing of Data   *
!***********************************
%externalroutinespec Mcbytes(%integer Disp,Len,Ad)
%externalroutinespec   MDBYTES   (%integer area, Disp, len, ad)
%externalroutinespec   MD        (%integer area, Disp, Databyte)
%externalroutinespec   MD2       (%integer area, Disp, DataDoublebyte)
%externalroutinespec   MD4       (%integer area, Disp, DataQuadbyte)
%externalroutinespec   MDPATTERN (%integer area, Disp, ncopies, len, ad)
!**********************************************
!* Put Interface RELOCATION and REFERENCES    *
!**********************************************
%externalintegerfnspec MXname (%integer type,%string(255)%name  s)
%externalroutinespec   Mfix   (%integer area,disp, tgtarea,tgtdisp)
%externalroutinespec   MDxref (%integer area,disp,id)
!**********************************
!* Put Interface - Miscellaneous  *
!**********************************
%externalroutinespec   Mreversebytes (%integer  area,disp,len)
%externalintegerfnspec Mcommon       (%string(255)%name Name)
%externalroutinespec   MendCommon    (%integer id,length)
%externalintegerfnspec MnextSymbol
%externalroutinespec   Mproc (%string(255)%name name, %integer props,codead,
                              %integername id)
%externalintegerfnspec Mentry(%integer Index,Codedisp,%string(255) %name name)
%externalroutinespec   Mprocend
!%externalroutinespec   Mdataentry(%string(255)%name name, %integer area, maxlen, disp)
%externalroutinespec   Minitialise   (%integer version,release,language)
%externalroutinespec   Mterminate    (%integer adareasizes)
%externalroutinespec   Mfaulty
%externalroutinespec   Mvar(%integer strwad,type, area, disp, bytesize,nels)
%externalroutinespec   Mmonon
%externalroutinespec   Mmonoff

!*
!*
!*************************************************************************
!*                                                                       *
!*    Mnemonics for M68000 code generator      Version 5     02/01/86    *
!*                                                                       *
!*************************************************************************
!*
%constinteger ADD    =   1 { RX }
%constinteger ADDA   =   2 { RX }
%constinteger AND    =   3 { RX }
%constinteger CHKM   =   4 { RX }
%constinteger CMP    =   5 { RX }
%constinteger CMPA   =   6 { RX }
%constinteger CMP2   =   7 { RX }
%constinteger DIVS   =   8 { RX }
!!%constinteger EOR    =   9 { RX }
%constinteger LEA    =  10 { RX }
%constinteger MULS   =  11 { RX }
%constinteger OR     =  12 { RX }
%constinteger SUB    =  13 { RX }
%constinteger SUBA   =  14 { RX }
%constinteger ABS    =  15 { RX } {pseudo-op}
%constinteger MOD    =  16 { RX } {pseudo-op}
%constinteger REM    =  17 { RX } {pseudo-op}
!*
%constinteger ADDI   =  32 { DX }
%constinteger ADDQ   =  33 { DX }
%constinteger ANDI   =  34 { DX }
%constinteger CMPI   =  35 { DX }
%constinteger EORI   =  36 { DX }
%constinteger ORI    =  37 { DX }
%constinteger SUBI   =  38 { DX }
%constinteger SUBQ   =  39 { DX }
!*
%constinteger CLR    =  64 { X  }
%constinteger JMP    =  65 { X  }
%constinteger JSR    =  66 { X  }
%constinteger NEG    =  67 { X  }
%constinteger NOT    =  68 { X  }
%constinteger PEA    =  69 { X  }
!!%constinteger ST     =  70 {  }
%constinteger SF     =  71 {  }
%constinteger SHI    =  72 {  }
%constinteger SLS    =  73 {  }
%constinteger SCC    =  74 {  }
%constinteger SCS    =  75 {  }
%constinteger SNE    =  76 {  }
%constinteger SEQ    =  77 {  }
%constinteger SVC    =  78 {  }
%constinteger SVS    =  79 {  }
%constinteger SPL    =  80 {  }
%constinteger SMI    =  81 {  }
%constinteger SGE    =  82 {  }
%constinteger SLT    =  83 {  }
%constinteger SGT    =  84 {  }
%constinteger SLE    =  85 {  }
!*
%constinteger EXTBL  =  96 { R  }
%constinteger EXTBW  =  97 { R  }
%constinteger EXTWL  =  98 { R  }
%constinteger LINK   =  99 { RD }
%constinteger RTD    = 100 { D  }
%constinteger UNLK   = 101 { R  }
!*
%constinteger ILLEGAL= 109 { n  }
!!%constinteger NOP    = 110 { n  }
%constinteger RTS    = 111 { n  }
!*
%constinteger DBT    = 112 { RD }
%constinteger DBF    = 113 { RD }
%constinteger DBHI   = 114 { RD }
%constinteger DBLS   = 115 { RD }
%constinteger DBCC   = 116 { RD }
%constinteger DBCS   = 117 { RD }
%constinteger DBNE   = 118 { RD }
%constinteger DBEQ   = 119 { RD }
%constinteger DBVC   = 120 { RD }
%constinteger DBVS   = 121 { RD }
%constinteger DBPL   = 122 { RD }
%constinteger DBMI   = 123 { RD }
%constinteger DBGE   = 124 { RD }
%constinteger DBLT   = 125 { RD }
%constinteger DBGT   = 126 { RD }
%constinteger DBLE   = 127 { RD }
!*
%constinteger LSL    = 144 { RX }
%constinteger LSR    = 145 { RX }
%constinteger ASL    = 146 { RX }
%constinteger ASR    = 147 { RX }
!*
%constinteger MOVE   = 152 { XX }
%constinteger MOVEA  = 153 { XX }
%constinteger MOVEQ  = 154 { RD }
!*
%constinteger FLOAD  = 161
%constinteger FSTORE = 162
%constinteger FABS   = 163
%constinteger FADD   = 164
%constinteger FCMP   = 165
%constinteger FDIV   = 166
%constinteger FINT   = 167
%constinteger FMOD   = 168
%constinteger FMUL   = 169
%constinteger FNEG   = 170
%constinteger FREM   = 171
%constinteger FSUB   = 172
%constinteger FTST   = 173
!*
%include "gbits_gcodes1"
%include "ebits_ecodes2"
%include "ebits_enames2"
!*
!*
!***********************************************************************
!*        Common declarations                                          *
!***********************************************************************
!*
!*
%constinteger LitVal         =  0        {  lit        }
%constinteger ConstVal       =  1        {  const      }
%constinteger RegVal         =  2        {  (reg)      }
%constinteger FregVal        =  3        {  (freg)     }
%constinteger TempVal        =  4        {  (temp)     }
%constinteger DirVal         =  5        {  (dir)      }
%constinteger IndRegVal      =  6        { ((reg))     }
%constinteger IndTempVal     =  7        { ((temp))    }
%constinteger IndDirVal      =  8        { ((dir))     }
%constinteger AddrConst      =  9        {  @const     }
%constinteger AddrDir        = 10        {  @dir       }
%constinteger RegAddr        = 11        {  (reg) is @ }
%constinteger TempAddr       = 12        {  (temp) is @}
%constinteger DirAddr        = 13        {  (dir) is @ }
%constinteger AddrDirMod     = 14        {  @dir+M     }
%constinteger RegModAddr     = 15        {  (reg)+M    }
%constinteger TempModAddr    = 16        {  (temp)+M   }
%constinteger DirModAddr     = 17        {  (dir)+M    }
%constinteger IndRegModVal   = 18        { ((reg)+M)   }
%constinteger IndTempModVal  = 19        { ((temp)+M)  }
%constinteger IndDirModVal   = 20        { ((dir)+M)   }
%constinteger AddrDirModVal  = 21        { (@dir+M)    }
%constinteger RegBitAddr     = 22        {  (reg) is @ }
%constinteger RegBitModAddr  = 23        {  (reg)+M    }
%constinteger TopOfStack     = 31        {  TOS        }
!*
%constinteger Regflag       = 32  {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:31) =  %c
  "LitVal        ","ConstVal      ","RegVal        ","FregVal       ",
  "TempVal       ","DirVal        ","IndRegVal     ","IndTempVal    ",
  "IndDirVal     ","ConstAddr     ","AddrDir       ","RegAddr       ",
  "TempAddr      ","DirAddr       ","AddrDirMod    ","RegModAddr    ",
  "TempModAddr   ","DirModAddr    ","IndRegModVal  ","IndTempModVal ",
  "IndDirModVal  ","AddrDirModVal ","RegBitAddr    ","RegBitModAddr ",
  ""              ,""              ,""              ,""              ,
  ""              ,""              ,""              ,"TOS           "
!*
%constinteger Stack  = 0
%constinteger Code   = 1
%constinteger Gla    = 2
%constinteger Sst    = 4
%constinteger Ust    = 5
%constinteger Diags  = 6
%constinteger Static = 7
%constinteger Iotab  = 8
%constinteger Zust   = 9
%constinteger Cnst   =10
!*
%owninteger Elevel
%owninteger ProgFaulty
%owninteger ProcLevel
%owninteger Savelineno
%owninteger Pltsize
!*
%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:8)= %c
      "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv"  ,
      "f_cddiv"  ,"f_cqdiv"  ,"f_index"  ,"f_concat" ,
      "p_stop"
!*
%constintegerarray Spprocpdesc(0:8)= %c
      X'3000C',X'3000C',X'3000C',X'3000C',
      X'3000C',X'3000C',X'40010',X'40010',
      0
!*
%constintegerarray Spproctype(0:8)= %c
      X'10000',X'10000',X'10000',X'10000',
      X'10000',X'10000',X'10000',X'10000',
      0
!*
%ownintegerarray Spprocref(0:7)
!*
%owninteger Unasslab,Bounderr
!*
%ownintegerarray Procstkmark(0:15)
!*
!*
!***********************************************************************
!*        Gould-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 br0=8
%constinteger br1=9
%constinteger br2=10
%constinteger br3=11
%constinteger br4=12
%constinteger br5=13
%constinteger br6=14
%constinteger br7=15
!*
!*
!***********************************************************************
!*        M68000-specific declarations                                 *
!***********************************************************************
!*
!*
%constinteger d0=0
%constinteger d1=1
%constinteger d2=2
%constinteger d3=3
%constinteger d4=4
%constinteger d5=5
%constinteger d6=6
%constinteger d7=7
%constinteger a0=8
%constinteger a1=9
%constinteger a2=10
%constinteger a3=11
%constinteger a4=12
%constinteger a5=13
%constinteger a6=14
%constinteger a7=15
%constinteger fr0=0
%constinteger fr1=1
%constinteger fr2=2
%constinteger fr3=3
%constinteger fr4=4
%constinteger fr5=5
%constinteger fr6=6
%constinteger fr7=7
!*
%constinteger Addr at  = 1
%constinteger Data at  = 1
%constinteger Addr of  = 2
%constinteger Litinreg = 4
!*
%constbyteintegerarray Invcc(0:5)  = 1,0,2,3,5,4       {LT GT EQ NE LE GE}
%constbyteintegerarray Falsecc(0:5)= 5,4,3,2,1,0       {LE GE NE EQ LT GT}
!*
%owninteger Stack Offset=0
%owninteger Param Offset=0
%owninteger Gla Offset  =0
%owninteger Display Offset=0
!*
%constintegerarray Cnstinit(0:1)= %c
 X'81818181', X'81818181'
!*
!***********************************************************************
!*
%ownintegerarray Areabase(0:255)
%ownintegerarray Areaid(0:255)
%ownintegerarray Areaprops(0:255)
%ownintegerarray Dreguse(0:7)
%ownintegerarray Freguse(0:7)
!*
%owninteger Addrstackca, Addrglaca
%owninteger CC, CCset
%owninteger Curdiagca
%owninteger CurCnst
%owninteger Next Param Offset
%owninteger Curswitchad
!*
!***********************************************************************
!*
%ownstring(8)%array Areas(0:255)=  %c
   "Locals","Code","Static","Plt","Ust","Fardata","Diags","Params",
   "Ioarea","","Consts",""(245)
!*
%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
!*
!*
%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
      printstring(Areas(Base))
      %if Offset<0 %thenstart
         printstring(" - ")
         Offset=-Offset
      %finishelse printstring(" + ")
      write(Offset,0)
%end;! Pform
      Dump Regs
      %if Elevel<=0 %then %return
!!      Dump Reg Info
      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
!*
%externalstringfn EGiveName(%integer Key)
      %result={"@".}Areas(Key)
%end;! EGiveName
!*
%externalintegerfn EGiveAreaId(%integer Area)
      %if Area<=10 %then %result=Area
      %result=AreaId(Area)
%end;! EGiveAreaId
!*
!*
%externalroutine Enote CC(%integer Cond)
      CCset=1
      CC=Cond
%end;! Enote CC
!*
!**********************************************************************
!**********************************************************************
!**                      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("
*** Mgen abort - ".S." ***
")
      Dump Estack
      %monitor
      %stop
%end;! Abort
!*
%routine Unsupported Opcode(%integer Opcode)
%string(15) S
      %if Opcode<=255 %then S=Eopname(Opcode) %else S=Ef77opname(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
      %if options&1 # 0 %then Emonon
      %if options&2 # 0 %then Mmonon
      ProgFaulty=0
      Decode=Options&X'4000'
      Language=Lang
      Stack Offset=0
      Param Offset=0
      Display Offset=0
      Gla Offset=0
      %if Language=IMP %thenstart
         Report=0
      %finishelsestart
         Report=PrimeReport
      %finish
      %if Report#0 %thenstart
         printstring("Einitialise ")
         newline
      %finish
      Init Mcode(Decode,Lang,options)
      Addrstackca=Astackca
      Addrglaca=Aglaca
      Clear Regs
      CCset=0
      Elevel=0
      ProcLevel=0
      %cycle I=0,1,255
         Areabase(I)=0
         Areaprops(I)=0
      %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,7
         Spprocref(I)=0
      %repeat
!*
      Minitialise(0,1,Language)
!*
      Mfix(Gla,8,Ust,0)
      Mfix(Gla,12,SST,0)
      Md4(Gla,16,Language<<24)
      Mfix(Gla,20,Diags,0)
!*
      
      Mdbytes(Cnst,0,8,addr(Cnstinit(0)))
      Curcnst=8
!*
      Rstk=0;  Rstk_Form=RegVal;   Rstk_Size=4
      Frstk=0; Frstk_Form=FregVal
      LitZero=0; LitZero_Form=LitVal
      LitOne=0; LitOne_Form=LitVal; LitOne_IntVal=1
!*
%end;! Einitialise
!*
%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator         *
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J,ca
      %if ProgFaulty#0 %then %return
      J=0
      %cycle I=1,1,9
         S(I)=integer(Adareasizes+J)
         %if Host=PERQPNX %thenstart
            J=J+2
         %finishelsestart
            J=J+4
         %finish
      %repeat
      ca=Tidy Mcode(1,Pltsize)
      S(1) =ca
      s(3)=Pltsize
      S(10)=CurCnst
      %if Report#0 %thenstart
         printstring("Eterminate ")
         write(S(I),1) %for I=1,1,10
         newline
      %finish
      Mterminate(addr(S(1)))
      integer(adareasizes)=S(1)
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255)                              *
!***********************************************************************
%string(31) S
%integer Prop
      %if Report#0 %thenstart
         printstring("Ecommon   ");Write(Area,1);spaces(4);printstring(Name) 
         Newline
      %finish
      %if ProgFaulty#0 %then %return
      S=Name
      %if S="F#BLCM" %then Prop=1 %and S="_BLNK__" %else Prop=2
      Areaprops(Area)=Prop
      Areas(Area)<-S
      Areaid(Area)=Mcommon(S)
%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
      Mendcommon(Areaid(Area),Length)
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line                                            *
!***********************************************************************
      Report=PrimeReport
      %if Report#0 %thenstart
         printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Savelineno=Lineno
      Mline(Lineno)
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart        *
!***********************************************************************
    { Plinedecode }
%end;! Elinedecode
!*
%externalintegerfn Estkmarker
!***********************************************************************
!* note marker for a literal value                                     *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkmarker  ")
         newline
      %finish
      Estklit(X'0101');! to guarantee 16-bit hole for later plugging
      %result=Mmarker
%end;! Estkmarker
!*
%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!* substitute value at a marker                                        *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Esetmarker  ");write(Markerid,4)
         write(New Value,4)
         newline
      %finish
      Msetopd(Markerid,New Value)
%end;! Esetmarker
!*
%externalintegerfn Eswapmode
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswapmode  ")
         newline
      %finish
      %if Host=PERQPNX %then %result=X'10000' %else %result=0
%end;! Eswapmode
!*
%externalroutine Emonon
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      PrimeReport=1
      Report=1
%end;! Emonon
!*
%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing                                           *
!***********************************************************************
      PrimeReport=0
      Report=0
%end;! Emonoff
!*
%externalroutine Efaulty
!***********************************************************************
!* compilation has a fault - no object file to be generated            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Efaulty ");
         newline
      %finish
      ProgFaulty=1
      Mfaulty
%end;! Efaulty
!*
!*
!*
!*                 *********************
!*                 * Stack operations  *
!*                 *********************
!*
!*
%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal                              *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estklit  ");write(Val,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=LitVal
      Lstk_Intval=Val
      Lstk_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)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Mdbytes(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("Estkconst     ")
         write(Len,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Mdbytes(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                                             *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %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=Stack %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=DirVal
      Lstk_Size=Bytes
      Lstk_Base=Area
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkdir
!*
%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand                                          *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %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 CCset#0 %then Establish Logical
      %if Area=Stack %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirVal
      Lstk_Size=Bytes
      Lstk_Base=Area
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkind
!*
%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand local to an enclosing level                 *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %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
      %if CCset#0 %then Establish Logical
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirModVal
      Lstk_Size=Bytes
      Lstk_Base=Stack
      Lstk_Offset=Display Offset - (Level*4)
      Lstk_Modform=Litval
      Lstk_Modoffset=Offset
      Lstk_Adid=Adid
%end;! Estkglobal
!*
%externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand local to an enclosing level              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkglobalind ");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
      %if Elevel=15 %then Abort
      Estkglobal(Level,Offset,Adid,4)
      Erefer(0,Bytes)
%end;! Estkglobalind
!*
%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct parameter operand                                   *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %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
      %if CCset#0 %then Establish Logical
      Offset=Offset+Param Offset
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=DirVal
      Lstk_Size=Bytes
      Lstk_Base=7
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkpar
!*
%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect parameter operand                                *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %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
      %if CCset#0 %then Establish Logical
      Offset=Offset+Param Offset
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirVal
      Lstk_Size=Bytes
      Lstk_Base=7
      Lstk_Offset=Offset
      Lstk_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(r0,Bytes)
      %finishelse Stackr(r0)
%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
      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
      %if CCset#0 %then Establish Logical
      %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)
%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
      %if CCset#0 %then Establish Logical
      %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                              *
!***********************************************************************
 %record(Stkfmt)%name Lstk
     %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=Stack %then Offset=Offset+Stack Offset
      %if Elevel=15 %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=AddrDir
      Lstk_Size=4;! always 4 bytes for an address
      Lstk_Base=Area
      Lstk_Offset=Offset
      Lstk_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
      Lstk_Form=IndDirVal
      Lstk_Size=4;! always 4 bytes for an address
      Lstk_Base=0
      Lstk_Offset=Display Offset - (Level*4)
      Lstk_Modform=Litval
      Lstk_Modoffset=Offset
      Lstk_Adid=Adid
      Eop(Eaddress)
%end;! Estkgaddr
!*
!*
!*
!*                 *********************
!*                 *  Labels, Jumps    *
!*                 *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label                                                    *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Elabel >>>>>>>>>>>>>>>>>>>>>>>>>>>>>  L");write(Id,0)
         newline
      %finish
      %if ProgFaulty#0 %then %return
{      %if Elevel>0 %then Abort}
      Mcode label(id)
%end;! Elabel
!*
%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
!*
%externalroutine Ejump(%integer Opcode, Labelid)
!***********************************************************************
!* generate specified conditional or unconditional jump                *
!***********************************************************************
%switch OpI(JIGT:JUMP),OpR(JRGT:JFALSE),OpU(JUGT:JULEZ)
%integer Reg1,Freg1,Bytes,Bcc,Bcond,I
      %if Report#0 %thenstart
         printstring("Ejump ".Eopname(Opcode));write(Labelid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %thenstart
         %if Opcode=JINTZ %then Opcode=JFALSE
         %if Opcode=JINTNZ %then Opcode=JTRUE
         %if Opcode<JTRUE %then Establish Logical
      %finish
      %if Opcode<JRGT %thenstart
         %if Opcode<JUGT %then ->OpI(Opcode) %else ->OpU(Opcode)
      %finishelse ->OpR(Opcode)
!*
OpI(*):
OpI(*):
      Abort
!*
OpI(JIGT):
OpI(JILT):
OpI(JIEQ):
OpI(JINE): 
OpI(JIGE): 
OpI(JILE):
      %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))
      Gop Jump(BGT+CC,Labelid)
      CCset=0
      %return
!*
OpU(JUGT):
OpU(JULT):
OpU(JUEQ):
OpU(JUNE): 
OpU(JUGE): 
OpU(JULE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
   {   Int Binary Op(IGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2))  }
   {   Gop Jump(BGT+Opcode-JUGT,Labelid)  }
      CCset=0
      %return
!*
OpI(JINTGZ):
OpI(JINTLZ):
OpI(JINTZ):
OpI(JINTNZ):
OpI(JINTGEZ):
OpI(JINTLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Gop X(TST,Stk(Elevel+1))
      Gop Jump(BGT+Opcode-JINTGZ,Labelid)
      %return
!*
OpU(JUGTZ):
OpU(JULTZ):
OpU(JUEQZ):
OpU(JUNEZ):
OpU(JUGEZ):
OpU(JULEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
    {  Gop X(TST,Stk(Elevel+1))  }
    {  Gop Jump(BGT+Opcode-JUNTGZ,Labelid)  }
      %return
!*
OpI(JUMP):
      Gop Jump(BU,Labelid)
      %return
!*
OpR(JRGT):
OpR(JRLT):
OpR(JREQ): 
OpR(JRNE): 
OpR(JRGE):
OpR(JRLE): 
      %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))
      Gop Jump(BGT+CC,Labelid)
      CCset=0
      %return
!*
OpR(JRGZ):  
OpR(JRLZ):
OpR(JRZ): 
OpR(JRNZ):
OpR(JRGEZ):
OpR(JRLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Gop X(TST,Stk(Elevel+1))
      Gop Jump(BGT+Opcode-JRGZ,Labelid)
      %return
!*
OpR(JTRUE):
      Bcc=BGT+CC
      Bcond=BNE
Jtf:  %if CCset=0 %thenstart
         %if Elevel<1 %then Low Estack(Opcode,1) %and %return
         Elevel=Elevel-1
         %if Stk(Elevel+1)_Form=LitVal %thenstart
            I=Stk(Elevel+1)_IntVal
            %if (I=0 %and Bcond=BEQ) %or (I#0 %and Bcond=BNE) %thenstart
               Gop Jump(BU,Labelid)
               %return
            %finish
         %finish
         Gop X(TST,Stk(Elevel+1))
         Gop Jump(Bcond,Labelid)
         %return
      %finish
      Gop Jump(Bcc,Labelid)
      CCset=0
      %return
!*
OpR(JFALSE):
      Bcc=BGT+Falsecc(CC)
      Bcond=BEQ
      ->Jtf
%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
      Gop X(TST,Stk(Elevel+1))
      %if Lab1>0 %then Gop Jump(BLT,Lab1);! if < 0
      %if Lab2>0 %then Gop Jump(BEQ,Lab2);!    = 0
      %if Lab3>0 %then Gop Jump(BGT,Lab3);!    > 0
%end;! Etwjump
!*
%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 for the switch table                  *
!***********************************************************************
%integer Refad,Base,Mode,Reg
      %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
      Base=SSTad
      Refad=SSTad - (Lower*4)
      SSTad=SSTad+(Upper-Lower+1)<<2
      %if Language=FORTRAN %thenstart;! computed GOTO
         Elevel=Elevel-1
         Reg=Load Int(Stk(Elevel+1),r1)  { load GOTO index }
         Gop Jump(BLT,Switchid)
         Mswitch(1,Refad,Base,Upper,Switchid,0)
         Mcode Label(Switchid)
      %finishelsestart;! IMP switch
         Mcode Label(Switchid)
         Mswitch(0,Refad,Base,Upper-Lower+1,Switchid,Errlabid)
      %finish
%end;! Eswitch
!*
%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds defined for Switchid then error     *
!***********************************************************************
%integer Reg
      %if Report#0 %thenstart
         printstring("EswitchJump ");write(switchid,4)
         newline
      %finish
      %if Elevel<1 %then Low Estack(JUMP,1) %and %return
      Elevel=Elevel-1
      Reg=Load Int(Stk(Elevel+1),r1)  { load switch index }
      Ejump(JUMP,Switchid)
%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         *
!* N.B. this procedure is only used on Amdahl                          *
!***********************************************************************
       abortm("EfswitchJump")
%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
      Mswitchentry(Switchid, Entry)
%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
      Abort
%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
      Clear Regs
      Mswitchlabel(Curswitchad,Entry,Labelid)
%end;! EswitchLabel
!*
!*
!*
!*                *******************************
!*                * 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>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md(area, Disp, Val)
%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>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md2(area, Disp, Val)
%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>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md4(area, Disp, Val)
%end;! Ed4
!*
%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data                                           *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edbytes ")
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Area=10 %then %monitor;! should not be allocated any more
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Mdbytes(area, disp, len, ad)
%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 ")
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Mdpattern(area, Disp, ncopies, len, ad)
%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 tgtarea>10 %then tgtarea=areaid(tgtarea)
      %if tgtdisp#0 %then Md4(area,disp,tgtdisp)
      Mfix(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
      %if ProgFaulty#0 %then %result=Refad
    { I=MXname(0,Xref) }
      %result=Get Prockey(Xref)
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprecall ")
         newline
      %finish
      Mprecall
%end;! Eprecall
!*
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id                                    *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ecall    "); write(Id,4)
         write(Numpars,6); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Freeregs
      %if Language=IMP %or Language=PASCAL %then Op Move RR(a6,a1);! for display
      Gop Call(Id,Paramsize)
%end;! Ecall
!*
%externalroutine Eprocref(%integer Id, Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocref ");write(Id,4)
         newline
      %finish
      Estkaddr(Gla,Id,0,4);! this is temp (and wrong!)
%end;! Eprocref
!*
%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* a (hopefully) redundant IMP requirement                             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Esave ");write(Asave,4)
         newline
      %finish
%end;! Esave
!*
%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* a (hopefully) redundant IMP requirement                             *
!***********************************************************************
      %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                                                       *
!***********************************************************************
%string(3) S
      %if Report#0 %thenstart
         printstring("Enextproc ")
         newline
      %finish
    { %result=Mnextsymbol }
      S=""
      %result=Get Prockey(S)
%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 Pprops,Ca,Disp,Putid,I,Reg
%record(Stkfmt) S1,S2
      %if Report#0 %thenstart
         printstring("Eproc ");printstring(Name);write(props&X'ffff',4)
         write(Numpars,4); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Clear Regs
      %unless Language=PASCAL %then ProcLevel=ProcLevel+1
      %if Language=PASCAL %and Proclevel=1 %then Props=2
      %if Props&2#0 %then Pprops=X'80000001' %else Pprops=Props&1
      Ca=Mgetca
      %if Props&3#0 %thenstart;! to be externally visible
         Putid=-1
         Mproc(Name,Pprops,Ca,Putid)
      %finish
      Id=Note Entry(Name,Id,Ca)
      Curdiagca=-1
      Disp=Display Offset
      Procstkmark(ProcLevel)=Mmarker
      Mstartproc
      %if Language=IMP %and Props&4#0 %then %return
    { Set the GLA @ if necessary }
!#      %if Props&4=0 %thenstart;! display required
!#         %if Proclevel>1 %thenstart       { display setting code }
!#            %cycle I=2,1,Proclevel
!#               Op Move Rdisp(a1,Disp,a6,Disp)
!#               Disp=Disp-4
!#            %repeat
!#         %finish
!#         S1_Reg=a6
!#         S2_Offset=Disp
!#         Op Move(S1,S2)
!#      %finish
%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)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=PASCAL %then Eop(RETURN)
      Mtidyproc(Procstkmark(Proclevel),Localsize)
      Mprocend
      ProcLevel=ProcLevel-1
%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) * 
!***********************************************************************
%integer Id,ca,Procid,Reg
%record(Stkfmt) S1,S2
      %if Report#0 %thenstart
         printstring("Eentry  ".Name);write(Index,4)
         write(Numpars,4);write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Index=0 %then %return;! prologue start in Eproc
      Ca=Mgetca
      Id=Mentry(Index,ca,Name)
      Procid=-1
      Id=Note Entry(Name,Procid,Ca)
!#      Op RL(LINK,a6,-Localsize)
    { set GLA @ on stack if necessary }
%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
%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
%end;! Edataref
!*
!*
!*
!*                  ********************
!*                  * Ecode operations *
!*                  ********************
!*
!*
%externalroutine Eop(%integer Opcode)
!***********************************************************************
!* opcodes with general applicability                                  *
!***********************************************************************
%integer Reg1,Freg1,Bytes,Form,I
%switch Op(0:255)
      %if Report#0 %thenstart
         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
!*
      ->Op(Opcode)
!*
Op(*):%monitor
!*
Op(HALT):
      Unsupported Opcode(Opcode)
      %return    
!*
Op(IADD):
Op(ISUB):
Op(IMULT):
Op(IDIV): 
!*
Op(IREM): 
!*
Op(IAND):
Op(IOR): 
Op(IXOR): 
!*
Op(IGT): 
Op(ILT): 
Op(IEQ): 
Op(INE):  
Op(IGE):  
Op(ILE):  
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(INEG): 
Op(IABS): 
Op(INOT):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(UADD):
Op(USUB):
!*
Op(UGT): 
Op(ULT): 
Op(UEQ): 
Op(UNE):  
Op(UGE):  
Op(ULE):  
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(IADDST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST): 
!*
Op(IANDST):
Op(IORST): 
Op(IXORST): 
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(INEGST): 
Op(INOTST):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(ISHLL):
!*
Op(ISHRL):
!*
Op(ISHLA):
!*
Op(ISHRA):
!#      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
!#      Elevel=Elevel-2
!#      Reg1=Load Int(Stk(Elevel+1),-1)
!#      Op Shift(LSL+(Opcode-ISHLL),Reg1,Stk(Elevel+2))
!#      Stackr(Reg1)
      %return    
!*
Op(RETURN): 
      Gop Return
      %return
!*
Op(SFA):
!#      Reg1=Claim Reg
!#      Op Move RR(a7,Reg1)
!#      Stackr(Reg1)
      %return
!*
Op(ASF):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
!#      Op RX(ADDA,a7,Stk(Elevel+1))
      %return
!*
Op(IPUSH):
!*
Op(IPOP):  
      Unsupported Opcode(Opcode)
      %return    
!*
Op(EXCH):
      Epromote(2)
      %return
!*
Op(DUPL):
      Stk(Elevel+1)=Stk(Elevel)
      Elevel=Elevel+1
      Form=Stk(Elevel)_Form&31
      %if Form=RegVal %or Form=RegAddr %thenstart
         Reg1=Claim Reg       { (Stk(Elevel)_Reg) }
         Op Move RR(Stk(Elevel-1)_Reg,Reg1)
         Stk(Elevel)_Reg=Reg1
         dreguse(Reg1)=-Elevel
      %finishelsestart
         %if Form=FregVal %thenstart
            Freg1=Claim Freg
!??            %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
         %finishelsestart
            %if Form=TempVal %then Stk(Elevel)_Form=DirVal
         %finish
      %finish
      %return    
!*
Op(DISCARD):
      %if Elevel<1 %then { Low Estack(Opcode,1) %and } %return
      I=Stk(Elevel)_Form&31
      %if I=RegVal %or I=FregVal %thenstart
         Note Reguse(Stk(Elevel)_Reg,0,Stk(Elevel)_Size)
      %finish
      %if I>=AddrDirMod %thenstart
         %if Stk(Elevel)_Modform=RegVal %then Note Reguse(Stk(Elevel)_Modreg,0,4)
      %finish
      Elevel=Elevel-1
      %return
!*
Op(INDEX1): 
!*
Op(INDEX2):
!*
Op(INDEX4):
!*
Op(INDEX8):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      I=Opcode-INDEX1
NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1))
      %return
!*
Op(INDEX):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      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
      %if Language=IMP %thenstart;! mixes 16 and 32 bit operands
         Elevel=Elevel+2
         %if Stk(Elevel)_Size=2 %thenstart
            Estklit(4)
            Eop(CVTII)
         %finish
         %if Stk(Elevel-1)_Size=2 %thenstart
            Epromote(2)
            Estklit(4)
            Eop(CVTII)
            Epromote(2)
         %finish
         Elevel=Elevel-2
      %finish
      Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2))
      Elevel=Elevel-1
      I=0
      ->NoteI
!*
Op(MVB):    
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
!#      Op Move Bytes(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
      %return    
!*
Op(CHK):  
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Eop(DISCARD)
      Eop(DISCARD);! ignoring checking pro tem
      %return    
!*
Op(TMASK): 
      Unsupported Opcode(Opcode)
      %return    
!*
Op(CPBGT):
!*
Op(CPBLT):
!*
Op(CPBEQ):
!*
Op(CPBNE):
!*
Op(CPBGE):
!*
Op(CPBLE):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
!#      Op Compare Bytes(Opcode-CPBGT,Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
      CCset=1
      CC=Opcode-CPBGT
      %return    
!*
Op(RADD): 
Op(RSUB): 
Op(RMULT):
Op(RDIV): 
!*
Op(RGT):  
Op(RLT):  
Op(REQ): 
Op(RNE):  
Op(RGE):   
Op(RLE): 
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Real Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(RNEG): 
Op(RABS):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Real Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(UCVTII):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTII):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTRR):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert RR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(TNCRI): 
Op(RNDRI):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI)
      %return
!*
Op(CVTIR):  
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(UCHECK):
      %if Stk(Elevel)_Form=DirVal %thenstart
!??         Set BD(Stk(Elevel),B1,D1)
      %finishelsestart
         Reg1=Claim Reg
!??         Op RX(LA,Reg1,Stk(Elevel))
         Stk(Elevel)_Form=IndRegVal!Regflag
         Stk(Elevel)_Reg=Reg1
         dreguse(Reg1)=-Elevel
      %finish
!??      PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32)
!??      Pjump(BC,Unasslab,8,R14)
      %return    
!*
Op(ESTORE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      %if AddrConst<=Stk(Elevel)_Form&31<=DirModAddr %thenstart
         Refer(Stk(Elevel+2),0)
         Stk(Elevel+2)_Size=Stk(Elevel+1)_Size
      %finish
      Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0)
      %return
!*
Op(EDUPSTORE): 
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Stk(Elevel-1)_Form&31=Fregval %thenstart
         Freg1=Stk(Elevel-1)_Reg
         Bytes=Stk(Elevel-1)_Size
         Elevel=Elevel-2
         Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0)
         Stackfr(Freg1,Bytes)
      %finishelsestart
         %if Stk(Elevel-1)_Size>4 %thenstart
            Stk(Elevel+1)=Stk(Elevel-1)
            Elevel=Elevel+1
            Epromote(2)
            Elevel=Elevel-2
            Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0)
         %finishelsestart
            Elevel=Elevel-2
            Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),1)
            Stackr(Reg1)
         %finish
      %finish
      %return
!*
Op(PUSHADDR):
      Address(Stk(Elevel))
!*
Op(PUSHVAL):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Push Param(Stk(Elevel+1))
      %return
!*
Op(EVAL):
!*
Op(EVALADDR):
      %return
!*
Op(EADDRESS):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Address(Stk(Elevel))
      Stk(Elevel)_Size=4
      %return
!*
Op(EPOWER):       
!*
Op(EPOWERI):     
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      %if Stk(Elevel)_Form#Litval %then Abort
      Elevel=Elevel-1
      Expcall(Stk(Elevel+1)_Intval)
      %return
!*
Op(EINTRES):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),d0)
      dreguse(d0)=0
      %return
!*
Op(EREALRES):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Real(Stk(Elevel+1),fr0,Stk(Elevel+1)_Size)
      freguse(fr0)=0
      %return
!*
Op(ESIZE):    
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Stk(Elevel)_Size=Stk(Elevel+1)_Intval
      %return
!*
Op(ARGPROC):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
!!!!
      %return
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran                     *
!***********************************************************************
%integer Reg1,Reg2,Freg1,Freg2,Bytes,Relop
%integer B1,D1,Flags
%record(Stkfmt) Tstk,Regstk,Fregstk
%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-1
      Eop(IABS)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Op X(TST,Stk(Elevel+2))
      Op Short Jump(BGE,2)
      Op R(NEG,Reg1)
      Stackr(Reg1)
      %return
!*
F77op(ESIGN):      
      Elevel=Elevel-1
      Eop(RABS)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Op Fp(FTST,-1,Stk(Elevel+2))
      Op Short FBcc(19,6)           {GE}
      Op Fp(FNEG,-1,Stk(Elevel+1))
      Stackfr(Reg1,Stk(Elevel+1)_Size)
      %return
!*
F77op(EIMOD):        
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1)
      Op RX(MOD,Reg1,Stk(Elevel+2))
      Stackr(Reg1)
      %return
!*
F77op(ERMOD):       
      Elevel=Elevel-2
      Bytes=Stk(Elevel+1)_Size
      Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
      Op Fp(FMOD,Reg1,Stk(Elevel+2))
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIDIM):
      Eop(ISUB)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Op Short Jump(BGE,2)
      Op R(CLR,Reg1)
      Stackr(Reg1)
      %return
!*
F77op(ERDIM):       
      Eop(RSUB)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Op Short FBcc(19,6)   { >=0 }
      Op Fp(FSUB,Reg1,Stk(Elevel+1))
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMIN):        
      Relop=15  {M68000 value only}
Iminmax:
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1)
      Reg2=Load Int(Stk(Elevel+2),-1)
      Regstk=Rstk
      Regstk_Reg=Reg2
      Op RX(CMP,Reg1,Regstk)
!#      Op Short Jump(BRA+Relop,2)
      Tstk=Rstk
      Tstk_Reg=Reg1
      Regstk=Rstk
      Regstk_Reg=Reg2
      Op Move(Regstk,Tstk)
      Stackr(Reg1)
      %return
!*
F77op(ERMIN):       
      Relop=21  {M68881 value only}
Rminmax:
      Elevel=Elevel-2
      Bytes=Stk(Elevel+1)_Size
      Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
      Reg2=Load Real(Stk(Elevel+2),-1,Bytes)
      Fregstk=Frstk
      Fregstk_Reg=Reg2
      Fregstk_Size=Bytes
      Op RX(CMP,Reg1,Fregstk)
!#      Op Short Jump(BRA+Relop,2)
      Fregstk=Frstk
      Fregstk_Reg=Reg2
      Fregstk_Size=Bytes
      Op Fp(FLOAD,Reg1,Fregstk)
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMAX):       
      Relop=12  {M68000 value only}
      ->Iminmax
!*
F77op(ERMAX):       
      Relop=19  {M68881 value only}
      ->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)
!??         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=Claim Reg
!??      PIX RR(SR,Reg1,Reg1)
!??      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)
      Spcall(6)
      Stackr(d0)
      %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=Claim Reg
!??      OpRX(L,Reg1,Stk(Elevel+1))
      Freg1=Load Real(Stk(Elevel+2),-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,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
      Md4(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))
      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)
      %return
!*
F77op(NOTEIORES):  
      {no special action required here on M68000 - result will stay in d0}
      %return
!*
F77op(STKIORES):    
      Stackr(d0)
      %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)
      Stk(Elevel-1)_Form=RegVal!Regflag
      Stk(Elevel-1)_Reg=Reg2
      Reg1=Load Int(Stk(Elevel),-1)
      Stk(Elevel)_Form=RegVal!Regflag
      Stk(Elevel)_Reg=Reg1
      Op Move RR(Reg1,d0)
      dreguse(Reg1)=-Elevel
      dreguse(Reg2)=-Elevel+1
      Op RX(MULS,d0,Stk(Elevel+1))
      Op RR(ADD,Reg2,d0,Stk(Elevel+1)_Size)
      %return
!*
F77op(EARGLEN):
      %return
!*
F77op(EFNOTEVR):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),d0)
      %return
!*
F77op(EFSETVR):
      Stackr(d0)
      %return
%end;! Ef77op
!*
%externalroutine Epasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal                      *
!***********************************************************************
      Abortm("Epasop")
!*
%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
         %if STACK DIRECTION=POSITIVE %thenstart
            Epromote(I)
         %finish
         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
         %if STACK DIRECTION=POSITIVE %thenstart
            Epromote(I)
         %finish
         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                    **
!***********************************************************************
!***********************************************************************
!*
!*
%externalroutine Epush Operand(%record(Stkfmt)%name Operand)
      %if Elevel=15 %then Abort
      Elevel=Elevel+1
      Stk(Elevel)=Operand
%end;! Push Operand
!*
%routine Refer(%record(Stkfmt)%name Stk,%integer Offset)
%integer Reg
%record(Stkfmt) S1
%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
      dreguse(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))     }
      S1=Rstk
      S1_Reg=Stk_Reg
      Op Move(Stk,S1)
      ->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=Claim Reg
      S1=Rstk
      S1_Reg=Reg
      Op Move(Stk,S1)
      Stk_Reg=Reg
      ->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
%record(Stkfmt) S1
%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
Store:S1=Stk
      Stk_Base=Stack
      Stk_Offset=I
      Stk_Form=AddrDir
      Op Move(S1,Stk)
      ->Size
!*
F(FregVal):               {  (freg)     }
!!      I=New Temp(Stk_Size)
      Stk_Base=Stack
      Stk_Offset=I
      Stk_Form=AddrDir
      Op Fp(FSTORE,Stk_Reg,Stk)
      ->Size
!*
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
!*
%externalroutine Stackr(%integer R)
!***********************************************************************
!* create an Estack entry for a value held in a general register       *
!***********************************************************************
%record(Stkfmt)%name Lstk
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=RegVal!Regflag
      Lstk_Reg=R
      Lstk_Size=4
      Note Reguse(R,-Elevel,4)
%end;! Stackr
!*
%externalroutine Stackfr(%integer FR,Bytes)
!***********************************************************************
!* create an Estack entry for a value held in a floating register      *
!***********************************************************************
%record(Stkfmt)%name Lstk
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=FregVal!Regflag
      Lstk_Reg=FR
      Lstk_Size=Bytes
      Note Reguse(FR,-Elevel,Bytes)
%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
      Reg1=Claim Reg
!#      Op R(ST+Setcc(CC),Reg1)
      Op RL(EXTBL,Reg1,0)
      Op R(NEG,Reg1)
      Stackr(Reg1);! stack integer result in Reg1
      CCset=0
%end;! Establish Logical
!*
%routine Convert II(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts between integer sizes                                      *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Bytes,Op
      Bytes=Lstk_Size
      %if Bytes=Newsize %then Elevel=Elevel+1 %and %return
      %if Lstk_Form=LitVal %thenstart
         Lstk_Size=Newsize
         Elevel=Elevel+1
         %return
      %finish
      Reg=Load Int(Lstk,-1)
      Stackr(Reg)
      Stk(Elevel)_Size=Newsize
      %if Bytes<Newsize %thenstart
         %if Bytes=1 %thenstart
     {       %if Newsize=2 %then Op=EXTBW %else Op=EXTBL  }
         %finishelsestart
            Op RL(EXTWL,Reg,0)
         %finish
      %finish
%end;! Convert II
!*
%routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts between real sizes                                         *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Freg1
      Freg1=Load Real(Stk,-1,Newsize)
      Stackfr(Freg1,Newsize)
%end;! Convert RR
!*
%routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode)
!***********************************************************************
!* converts between real and integer                                   *
!* Mode = 0   TNC                                                      *
!*        1   RND                                                      *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg
      Reg=Load Real(Stk,-1,Stk_Size)
      %if Stk_Size=4 %thenstart
         Gop RR(FIXW,Reg,Reg)
      %finishelsestart
         Gop RR(FIXD,Reg,Reg)
         unlock reg(Reg)
         Reg=Reg+1
      %finish
      Stackr(Reg)
%end;! Convert RI
!*
%routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts real to integer                                            *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg
%switch Sw(0:2)
      Reg=Load Int(Stk,-1)
      Gop RR(FLTW,Reg,Reg)
      Stackfr(Reg,Newsize)
      %return    
%end;! Convert IR
!*
!*
!***********************************************************************
!***********************************************************************
!**            Pascal-specific support procedures                     **
!***********************************************************************
!***********************************************************************
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
%routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2)
%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                                            *
!***********************************************************************
%end;! Cx Operation
!*
!*
!***********************************************************************
!*
!*
%routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
!***********************************************************************
!* incorporate Index info into Base record                             *
!***********************************************************************
%integer Reg,Form
%switch F(0:21)
      %if Index_Size#4 %thenstart
          Convert II(Index,4)
          Elevel=Elevel-1
       %finish
      %if Index_Form&31>=AddrDirMod %thenstart
!#         Reg=Load Reg(-1,Index)
!#         reguse(Reg)=-Elevel
         Index_Reg=Reg
         Index_Form=RegVal!Regflag
      %finish
      %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
      %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
      %if Base_Modform&Regflag#0 %then DRegUse(Base_Modreg)=-Elevel
      %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(RegModAddr):            {  (reg)+M    }
F(TempModAddr):           {  (temp)+M   }
F(DirModAddr):            {  (dir)+M    }
F(LitVal):                {  lit        }
F(ConstVal):              {  const      }
F(RegVal):                {  (reg)      }
F(TempVal):               {  (temp)     }
F(AddrConst):             {  @const     }
F(IndRegModVal):          { ((reg)+M)   }
F(IndTempModVal):         { ((temp)+M)  }
F(IndDirModVal):          { ((dir)+M)   }
F(AddrDirModVal):         { (@dir+M)    }
      Reg=Load Int(Base,-1)
      dreguse(Reg)=-Elevel
      Base_Reg=Reg
      Base_Form=RegModAddr!regflag
      ->Set
!*
F(DirVal):                {  (dir)      }
      ->F(IndDirVal)       { IMP failing to Refer }
!*
F(FregVal):               {  (freg)     }
      Abort
!*
%end;! Note Index
!*
%endoffile