!
! 30/12/87   -  Fix problem with refer in ECMPLX2 case of EF77OP       weop6
!
! First Release 1.0 Fix Ecmplx for movq 8 bytes.                       weop5
!               route eibits,eishiftc to spcall
! Field Trial 5 add refer to EICHAR       17/june/87                   weop4
!               add Freeregs to ARGPRPOCCALL
!               Correct Ecmplx2, eswitch
! Field Trial 3   Drop R6 from list of available regs . set to regvar
!* 25/apr/87 - Add Estkreg. And dedicate R6 to be Breg for optimiser   weop3

!%ownstring(31) Versiontext="Fortran77 Compiler Version 0.1"
%constinteger IMP = 1
%constinteger FORTRAN  =  2
%constinteger CCOMP    = 11
%constinteger PASCAL   = 14
%include "itrimp_hostcodes"
%constinteger host=emas
%constinteger target=vax
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,S1,S2,
      %INTEGER LPOPUT,SP0)

%extrinsicrecord(parmf) parm  { IMP control parameters record: for %control }
%owninteger DiagLevel   { Fortran diag level (-Dn) for setting contingencies at main program entry }

%owninteger OptR6=0
%owninteger flags
%externalintegermapspec Comreg %alias "S#COMREGMAP"(%integer n)
%externalstringfnspec itos %alias "S#ITOS"(%integer n)
%externalroutinespec Phex %alias "S#PHEX"(%integer Val)
%recordformat Stkfmt(%byteinteger Form,Size,Reg,Modreg,
                                        Base,Modbase,Scale,Modform,
      (((%integer Offset %or %integer Intval %or %real rval),
                         (%integer Modoffset %or %integer Modintval)) %c
                         %or %longreal lrval))


!***********************************************************************
!* Exports
!***********************************************************************

%routinespec Einitialise(%integer Lang,Avertext,Astackca,Aglaca,options)
%routinespec Eterminate(%integer adareasizes)
%routinespec Ecommon(%integer area, %stringname Name)
%routinespec Eendcommon(%integer area, Length)
%routinespec Elinestart(%integer lineno)
%routinespec Elinedecode
%routinespec Emonon
%routinespec Emonoff
%routinespec Efaulty
%integerfnspec Estkmarker
%routinespec Esetmarker(%integer Markerid, New Value)
%integerfnspec Eswapmode

%routinespec Estklit(%integer Val)
%routinespec Estkconst(%integer Len,Ad)
%routinespec Estkdir(%integer Area,Offset,Adid,Bytes)
%routinespec Estkind(%integer Area,Offset,Adid,Bytes)
%routinespec Estkglobal(%integer Level, Offset, Adid, Bytes)
%routinespec Estkglobalind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkpar(%integer Level, Offset, Adid, Bytes)
%routinespec Estkparind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkresult(%integer Class,Type,Bytes)
%routinespec Erefer(%integer Offset, Bytes)
%routinespec Epromote(%integer Level)
%routinespec Estkaddr(%integer Area,Offset,Adid,Bytes)

%routinespec Elabel(%integer id)
%routinespec Ediscardlabel(%integer id)
%routinespec Ejump(%integer Opcode, Labelid)
%routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3)
%routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                            %integername SSTad)
%routinespec EswitchJump(%integer Switchid)
%routinespec EfswitchJump(%integer Switchid)
%routinespec Eswitchentry(%integer Switchid, Entry)
%routinespec Eswitchdef(%integer Switchid)
%routinespec EswitchLabel(%integer Switchid, Entry, Labelid)

%routinespec Ed1(%integer area, Disp, Val)
%routinespec Ed2(%integer area, Disp, Val)
%routinespec Ed4(%integer area, Disp, Val)
%routinespec Edbytes(%integer area, Disp, len, ad)
%routinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%routinespec Efix(%integer area, disp, tgtarea, tgtdisp)

%integerfnspec EXname(%integer type, %string(255)%name Xref)
%routinespec Eprecall(%integer Id)
%routinespec Ecall(%integer Id, Numpars, Paramsize)
%routinespec Eprocref(%integer Id, Level)
%routinespec Esave(%integer Asave, %integername Key)
%routinespec Erestore(%integer Asave, Key, Existing)

%integerfnspec Enextproc
%routinespec Eproc(%stringname Name, %integer Props, npars,psize,Astacklen,
                                                                %integername Id)
%routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen)
%routinespec Eentry(%integer Index,npars,psize, Localsize, Diagdisp,
                                                                %stringname Name)

%routinespec Edataentry(%integer Area, Offset, Length,
                                                                %stringname Name)
%routinespec Edataref(%integer Area, Offset, Length,
                                                                %stringname Name)

%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
%routinespec Expcall(%integer Proc)

!***********************************************************************
!* Imports
!***********************************************************************

%include "ercs04:specs"
%include "ebits_ecodes28"
%include "ercs04:names"
%include "Ebits_enames28"

%externalinteger decode,report,language
%externalinteger Elevel
%externalrecord(Stkfmt)%array Stk(0:15)
%externalintegerarray Ruse(0:7)
%externalintegerarray Rmem(0:7)
%externalintegerarray FRmem(0:7)
%externalintegerarray Fruse(0:7)
%externalintegerarray FRCorrupt(4:7)
%externalinteger CC, CCset
%externalinteger Addrstackca, Addrglaca
%externalrecord(Stkfmt) Zero,One,TOS,Fhalf,FLhalf
%extrinsicinteger CA ,PREV
!%externalintegerfnspec seqmath(%integer id)

!***********************************************************************
!*         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 Regvar         = 27          { var in reg } { Fort opt breg only}
%constinteger FLitVal        =  28         {  Real lit   }
%constinteger StackFront     = 29
%constinteger Regflag        = 32  {used to speedup search for reguse}

%conststring(14)%array Eform(0:29) =  %c
  "LitVal        ","ConstVal      ","RegVal        ","FregVal       ",
  "TempVal       ","DirVal        ","IndRegVal     ","IndTempVal    ",
  "IndDirVal     ","ConstAddr     ","AddrDir       ","RegAddr       ",
  "TempAddr      ","DirAddr       ","AddrDirMod    ","RegModAddr    ",
  "TempModAddr   ","DirModAddr    ","IndRegModVal  ","IndTempModVal ",
  "IndDirModVal  ","AddrDirModVal ",""              ,"",
  "",              "",              "",              "Regvar",
  "FLitval",              "StackFront"

%owninteger ProgFaulty = 0
!%owninteger ProcProps
%owninteger Proclevel = 0

%owninteger unasslab
%owninteger bounderr
%owninteger DBX=0
%owninteger CurLine = 0,OldDcomp=0,PrevCA


!***********************************************************************
!*         Nat Semi specific declerations
!***********************************************************************


%constinteger TopofStack=31   {  pseudo forms }
%constinteger AbsAd = 30

%constinteger   R0  =  0,        { General registers }
                R1  =  1,
                R2  =  2,
                R3  =  3,
                R4  =  4,
                R5  =  5,
                R6  =  6,
                R7  =  7

%constinteger Resultreg     = R0,
              FirstExprReg  = R1,
              LastExprReg   = R5

%constinteger   FR0  =  0,         { Floating point registers }
                FR1  =  1,
                FR2  =  2,
                FR3  =  3,
                FR4  =  4,
                FR5  =  5,
                FR6  =  6,
                FR7  =  7

%constbyteintegerarray Setcc(0:5)= {GT}  6,
                                   {LT} 12,
                                   {EQ}  0,
                                   {NE}  1,
                                   {GE} 13,
                                   {LE}  7

%constbyteintegerarray Invcc(0:5)= {LT} 12,
                                   {GT}  6,
                                   {EQ}  0,
                                   {NE}  1,
                                   {LE}  7,
                                   {GE} 13
%constbyteintegerarray UInvCC(0:5)= {HI}  4,
                                    {LO} 10,
                                    {EQ}  0,
                                    {NE}  1,
                                    {HS} 11,
                                    {LS}  5

%constbyteintegerarray USetCC(0:5)= {LO} 10,
                                    {HI}  4,
                                    {EQ}  0,
                                    {NE}  1,
                                    {LS}  5,
                                    {HS} 11
                                    
%constbyteintegerarray INVERTCOND(0:16) =1 ,0,0,0,0,0,7,6,0,0,0,0,13,12,0,0,0

%constinteger Stack Offset=0
%owninteger Param Offset=4
%constinteger TWO31 =  8
%constinteger TWO32 = 16
%constinteger TWO31R= 24


!***** NAT SEMI ADDRESSING MODES *******
!* ( after page 4-16 of manual 

%constinteger   REGISTER        = B'00000', { 0 ->  7 registers          }
                REGREL          = B'01000', { 8 -> 15 disp(reg)          }
                FrameRel        = B'10000', { 16 =    disp2(disp1(FP))   }
                StackRel        = B'10001', { 17 =    disp2(disp1(SP))   } 
                StaticRel       = B'10010', { 18 =    disp2(disp1(SB))   }
                Immediate       = B'10100', { 20 =    value              }
                Absolute        = B'10101', { 21 =    @disp              }
                External        = B'10110', { 22 =    EXT(disp1) + disp2 }
                TOSmode         = B'10111', { 23 =    Top of stack       }
                Frame           = B'11000', { 24 =    disp(FP)           }
                StackMode       = B'11001', { 25 =    disp(SP)           }
                StaticMode      = B'11010', { 26 =    disp(SB)           }
                Program         = B'11011', { 27 =    PC + disp          }
                ByteIndexed     = B'11100', { 28 =    Basemode[Rn:B]     }
                WordIndexed     = B'11101', { 29 =    Basemode[Rn:W]     }
                DoubleIndexed   = B'11110', { 30 =    Basemode[Rn:D]     }
                QuadIndexed     = B'11111'  { 31 =    Basemode[Rn:Q]     }


!***********************************************************************

%ownbyteintegerarray Areaprops(0:255)=0(*)

%owninteger Curdiagca
%owninteger CurCnst
%ownrecord(Stkfmt) SP,Reg0,unass
%constinteger DisplayDisp = -4
%constinteger ShortRangeID=x'8FFFFFFF'{Hopefully unique - ensures 1 byte opd}
%owninteger Orgreport=0,Orgdecode=0
!***********************************************************************
!*         Code generation procedure specs
!***********************************************************************


%externalroutinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%externalroutinespec Address(%record(Stkfmt)%name Stk)
%externalintegerfnspec Load Int(%integer op,%record(Stkfmt)%name Stk, %integer Reg)
%externalintegerfnspec Load Real(%integer op,%record(Stkfmt)%name Stk, %c
                            %integer Reg,%integer newsize)
%externalroutinespec Stackr(%integer R)
%externalroutinespec Stackfr(%integer FR,Bytes)
%externalroutinespec Establish Logical
%externalroutinespec Int Binary Op(%integer Op)
%externalroutinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Real Binary Op(%integer Op)
%externalroutinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Convert RR(%integer mode ,%record(Stkfmt)%name Stk,%integer Bytes)
%externalroutinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes)
%externalroutinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes)
%externalroutinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode)
%externalroutinespec Storeop(%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Push Param(%integer Mode,%record(Stkfmt)%name Stk)
%externalroutinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%externalroutinespec Compare Bytes(%record(Stkfmt)%name len,lhs,rhs) 

%externalroutinespec new temporary(%integer bytes,%record(stkfmt)%name stk)
%externalroutinespec Forget Regs
%externalroutinespec Dropall
%externalroutinespec Freeregs
%externalroutinespec Reset Reguse(%integer Old,New)
%externalintegerfnspec Claimfr(%integer Curreg,size)
%externalintegerfnspec Claimr(%integer Curreg)
%externalroutinespec Do Charop(%integer Op,%record(Stkfmt)%name R,C1,L1,C2,L2)
%externalroutinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
%externalroutinespec COMPRESS (%record(Stkfmt)%name Stk)
%externalroutinespec OPRX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec OPXR(%integer Op,%record(Stkfmt)%name Stk,%integer Reg)
%externalroutinespec OPRR(%integer Op,Reg1,Reg2)
!%externalroutinespec OPFX(%integer Op,size,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec opXX(%integer op,%record(Stkfmt) %name lhs,rhs)
%externalroutinespec opXL(%integer op,%record(stkfmt) %name lhs, %integer rhs)

%externalroutinespec CoerceInt(%record(Stkfmt)%name Stk,%integer Bytes)
%externalroutinespec OP1lit(%integer op,opd)
%externalroutinespec OPX(%integer op,%record(Stkfmt) %name S)
%externalroutinespec CopyBytes(%record(stkfmt) %name len,from,to)
%externalroutinespec MoveMultiple(%integer l ,%record(stkfmt) %name from,to)
%externalroutinespec IndexInstr(%record(stkfmt) %name  accum,length,index)
%externalroutinespec OPDD(%integer op,base1,disp1,base2,disp2)
%externalroutinespec OPDL(%integer op,base,disp,lit,size)
%externalroutinespec OPLD(%integer op,lit,base,disp)
%externalroutinespec OPDX(%integer op,base,disp,%record(Stkfmt) %name S)
%externalroutinespec OPDR(%integer op,base,disp,reg)
%externalroutinespec OPRD(%integer op,reg,base,disp)
%externalroutinespec OPRL(%integer op,reg,lit)
%externalroutinespec OPFF(%integer op,reg,size1,reg,size2)
%externalroutinespec OPFD(%integer op,reg,size1,base,disp,size2)
%externalroutinespec OPDF(%integer op,base,disp,size,reg,size2)
%externalroutinespec OPCHECK(%record(stkfmt) %name Stk,%integer area,disp,size, %integername reg)
%routinespec Spcall(%integer Proc)
%routinespec Forget(%integer Elev)


!**********************************************************************

%ownstring(8)%array Areas(0:10)=  %c
   "Stack  ","Code   ","Gla    ","","Ust    ","Gst    ","Diags  ","Scalars",
   "Ioarea ","","Consts "

%routine Dump Estack
   %record(Stkfmt)%name E
   %integer I,J,ru,rm,disp

   %routine Pform(%integer Form,Reg,Base,Offset)
        printstring(Eform(Form&31))
        %if form=FregVal %then printstring("FR") %and write(reg,1) %and %return
        %if Form&Regflag#0 %then printstring("R") %and write(Reg,1) %and %return
        %if Form=Litval %then write(Offset,4) %and %return
        %if Form=FLitval %start
           phex(offset)
           %if E_size=8 %then phex(E_modoffset)  
           %return
        %finish
!        %if Base#0 %start
          %if base<11 %then printstring(Areas(Base)) %else write(base,1)
!        %finish
!        %if Offset#0 %start
          printstring(" + ")
          write(Offset,3)
!        %finish
   %end;! Pform

   { Dump Reg Info }

   %cycle i = 0,1,6
      ru=ruse(I); rm=rmem(i)
      %if ru#0 %or rm#0 %start
         printstring("R"); printsymbol('0'+i)
         %if ru#0 %then printstring(" - estk") %and write(-ru,1) %and spaces(2)
         %if rm#0 %start
           disp = rm&x'FFFF'
           %if disp>>15#0 %then disp=disp!x'FFFF0000'
           %if rm>>16<11 %then  printstring(" (".areas(rm>>16)." + ".itos(disp).")") %else printstring(" ".itos(rm>>16)." + ".itos(disp))
        %finish
      %finish
   %repeat
   %cycle i = 0,2,6
      ru=Fruse(I); rm=Frmem(i)
      %if ru#0 %or rm#0 %start
         printstring("FR"); printsymbol('0'+i)
         %if ru#0 %then printstring(" - estk") %and write(-ru,1) %and spaces(2)
         %if rm#0 %start
           disp = rm&x'FFFF0000'
           %if disp>>15#0 %then disp=disp!x'FFFF'
           %if rm>>16<11 %then  printstring(" (".areas(rm>>16)." + ".itos(disp).")") %else printstring(" ".itos(rm>>16)." + ".itos(disp))
        %finish
      %finish
   %repeat
   newline


   %if Elevel<=0 %then %return
        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,4);printstring(":")
          Pform(E_Form,E_Reg,E_Base,E_offset)
          %if (E_Form&31)>=AddrDirMod %and E_form<=AddrDirModVal  %start
             printstring("  mod by:")
             Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset)
             %if E_Scale>0 %start
                 printstring("  scaled by:")
                 write(E_Scale,1)
             %finish
          %finish
          printstring("  size:")
          write(E_Size,1)
          newline
          I=I-1
        %repeat
%end;! Dump Estack

%routine Rep(%string(32) s, %integer i)
         printstring(s)
         write(i,1)
         newline
%end

!**********************************************************************
!**********************************************************************
!**                         Error reporting
!**********************************************************************
!**********************************************************************


%routine Abort
        Dump Estack
        %monitor
        %stop
%end;! Abort


%externalroutine Low Estack(%integer Opcode,Reqlevel)
        printstring("******* Estack error ******
  Op = ".Eopname(Opcode)."  actual/required levels:")
        write(Elevel,4)
        write(Reqlevel,4)
        newline
        Elevel=0
        Abort
%end;! Low Estack


%routine Unsupported Opcode(%integer Opcode)
%string(15) S
        %if Opcode<=255 %then S=Eopname(Opcode) %else S=Ef77opname(Opcode)
        printstring("******* Unsupported Opcode ****** ".S)
        newline
        Abort
%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 Comreg(26)&X'4000'#0 %then decode=1 %else decode=0        
        Language=Lang
        %if Report#0 %then printstring("Einitialise  , stackca=".itos(integer(astackca))."
")
        %if comreg(26)&4#0 %then dbx=1
        Addrstackca=Astackca
        Addrglaca=Aglaca
        Forget Regs
        CCset=0
        Elevel=0
        %if Language=FORTRAN %then Flags=3 %and ParamOffset=8  %else Flags=1
        Pinitialise(Lang,3,Aver)

!******************* initialise first six words of gla **************

        Pfix(Gla,8,Ust,0)
        Pfix(Gla,12,SST,0)
        Pd4(Gla,16,x'02000000')
        Pfix(Gla,20,Diags,0)

      %if language=Imp %then OldDcomp=parm_dcomp
        Orgreport = Report
        Orgdecode = decode

        { Set up some useful pseudo E-stack records }

        Zero_form  = LitVal
        Zero_size  = 4
        One_form   = LitVal
        One_offset = 1
        One_size   = 4
        TOS_form   = TopofStack
        SP_form    = LitVal
        SP_offset  = B'1001'
        Reg0_form  = Regval
        Reg0_intval= 0
        Reg0_size  = 4
        Fhalf_form = FLitval
        Fhalf_size = 4
        Fhalf_rval  = 0.5
        FLhalf_form =  FLitval
        FLhalf_lrval = 0.5
        flhalf_size = 8
        Unass_form = Dirval
        Unass_base=  Cnst
        Unass_offset =  0

%end

%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J

        %if ProgFaulty#0 %then %return
        J=0
        %cycle I=1,1,10
          S(I)=integer(Adareasizes+J)
          j = j+4
        %repeat
        S(10)=CurCnst
        %if Report#0 %start
          printstring("Eterminate ")
          write(s(i),1) %for I=1,1,10
          newline
        %finish
        Pterminate(addr(S(1)))
        integer(adareasizes) = S(1)  { set code size }
%end
%ownintegerarray com(11:255)


%externalintegerfn EGiveAreaID(%integer area)
%result = com(area)
%end

%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255)
!***********************************************************************
%integer Prop,id
   %if Report#0 %start
      printstring("Ecommon   ");Write(Area,1);spaces(4);printstring(Name) 
      Newline
    %finish
    %if ProgFaulty#0 %then %return
    %if Name="F#BLCM" %then Prop=1 %else Prop=2
    Areaprops(Area)=Prop
    id=PCommon(Name)
    com(area)=id   { temporary - I hope }
%end;! Ecommon

%externalroutine Eendcommon(%integer area,Length)
!***********************************************************************
!* define length of previously defined common
!***********************************************************************
        %if Report#0 %start
          printstring("Eendcommon   ");write(Area,1);write(Length,6) 
          Newline
        %finish
        %if ProgFaulty#0 %then %return
        Pendcommon(com(area),Length,Areaprops(Area))
%end;! Eendcommon

%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line
!***********************************************************************
%integer dcomp

        %if language = IMP %Start
           dcomp = parm_dcomp
           %if dcomp#OldDcomp %start  { %control statement }
              %if dcomp # 0 %then Report = (Dcomp>>1)&1 %and Decode = Dcomp&1
              %if dcomp = 0 %and OldDcomp # 0 %thenc
                   Report = OrgReport %and Decode = OrgDecode
               OldDcomp = dcomp
           %finish
        %finish %else %start
           %return %if comreg(27)&x'00800000'#0  { parm NOLINE }
        %finish
        %if Report#0 %or decode#0 %start
          printstring("Line ")
          write(Lineno,4)
          printstring("------------------------------------------------------
")
        %finish
        CurLine = Lineno                { Just to be visible in diagnostics }
        %return %if ProgFaulty#0 
        %if Elevel#0 %then {printstring(" Junk on Stack after line ".itos(curline)) %and newline %and } Elevel=0
        %return %if language=IMP
        Plinestart(Lineno) %if DBX#0
        %return %if Diaglevel<0
        OPDL(MOVi,Stack,-12,Lineno,2) %unless CA=PrevCA
        Prevca=CA
%end;! Elinestart

%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart
!***********************************************************************
!        %if Report#0 %start
!          printstring("Elinedecode ");
!          newline
!        %finish
!        %if ProgFaulty#0 %then %return
!        Plinedecode
%end;! Elinedecode

%externalintegerfn Estkmarker
!***********************************************************************
!* Unknown constant to be filled in later
!***********************************************************************
        %if Report#0 %then printstring("Estkmarker  
")
        %if ProgFaulty#0 %then %result=0
        EstkLit(x'0101'); { ensure 16 bit hole left for later plugging }
        %result=Pmarker(1)  
%end;! Estkmarker

%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!*   Plug constant into instruction
!***********************************************************************
        %if Report#0 %then Rep("Esetmarker  ",Markerid)
        PsetOpd(MarkerID,0,NewVAlue)
%end;! Esetmarker

%externalintegerfn Eswapmode
!***********************************************************************

!***********************************************************************
        %if Report#0 %then printstring("Eswapmode  
")
        %if host=PNX %then %result=7;   ! Swap all
        %result=0
%end;! Eswapmode

%externalroutine Emonon
!***********************************************************************
!* turn on internal tracing
!***********************************************************************
        Report=1
        Decode=1
%end;! Emonon

%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing
!***********************************************************************
        Report=0
%end;! Emonoff

%externalroutine Efaulty
!***********************************************************************
!* compilation has a fault - no object file to be generated
!***********************************************************************
        %if Report#0 %start
          printstring("Efaulty ");
          newline
        %finish
        ProgFaulty=1
        Pfaulty
%end;! Efaulty



!*                   *********************
!*                   * Stack operations  *
!*                   *********************



!***********************************************************************

%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal
!***********************************************************************
        %if Report#0 %then Rep("Estklit  ",Val)
        %return %if ProgFaulty#0
        %if CCset#0 %then Establish Logical
        Abort %if Elevel=15
        Elevel=Elevel+1
        Stk(Elevel)=0
        Stk(Elevel)_form=LitVal
        Stk(Elevel)_size=4
        Stk(Elevel)_Intval=Val
%end;! Estklit

%externalroutine EstkRconst(%integer Len,Ad)
!***********************************************************************
!* stacks the Real constant, allocating space for it if necessary
!***********************************************************************
%real r
%longreal lr1,lr2
!
!%constreal MinSIngle = 1.17549440@-38
!%constreal MaxSingle = 3.40282356@+38

   %if report#0 %start
      printstring("EstkRconst  ")
      !%if len=4 %then print(real(addr(Ad)),8,8) %elsec
                      !print(longreal(addr(ad)),8,8)
      space; phex(integer(ad))
      %if len=8 %then space %and phex(integer(ad+4))
      printstring(" length = ")
      write(len,1)
      newline
   %finish
   %return %if ProgFaulty#0 

   %if ccset#0 %then Establish Logical
   Abort %if Elevel=15
   Elevel=Elevel+1
   Stk(elevel)=0
   Stk(Elevel)_form=Flitval
   Stk(Elevel)_size=len
   %if len=4 %then Stk(Elevel)_rval=real(ad) %c
             %else STk(Elevel)_lrval=longreal(ad)
!   %if Len=8 %start                { if 64 bit real see if it can }
                                             { go into 32 bits without loss }
!      lr1=longreal(Ad)                       { of accuracy.                 }
                                             { (because MOVFL is FASTER     }
!      %if MinSIngle<=Lr1<=MaxSingle %start   {  than MOVL on this m/c )     }

!         r = lr1
!         lr2 = r
!         %if lr1=lr2 %then Ad=addr(r) %and ->Lit

!      %finish
!   %finish

!   Pdbytes(Cnst,CurCnst,Len,Ad)      { Tuck const away in DATA }
!   Estkdir(Cnst,CurCnst,0,Len)
!   CurCnst=Curcnst+((Len+3)>>2)<<2

%end;! EstkRconst

%externalroutine Estkconst(%integer len,ad)
!************************************************
!* stack an integer constant 
!************************************************
    Rep("Estkconst     length ",len) %if report#0
    %if language=Imp %start
       pdbytes(Cnst,CurCnst,len,Ad)
       Estkdir(Cnst,CurCnst,0,len)
       CurCnst=Curcnst+((Len+3)>>2)<<2
       %return
    %finish
    Estklit(integer(ad))
%end


%externalroutine EstkReg  (%integer reg,offset)
!************************************************
!* stack a register (Fortran Optimiser only )
!************************************************
    Rep("EstkReg      ",R6) %if report#0
    %if Progfaulty#0 %then %return
    Stackr(R6)
    Stk(Elevel)_Offset = Offset
    Stk(Elevel)_Form=Regvar
 %end

%routine prestk(%string(32) rt,%integer offset,bytes,area,level,addoffset,form,adid)
%record(Stkfmt)%name Lstk
        %if area>=11 %then area = com(area)
        %if language#imp %and area=7 %then area=0 %and offset=offset+paramoffset
        %if Report#0 %start
          printstring(Rt)
          %if level#0 %then write(Level,1) %elsec
             %if area<11 %then printstring(Areas(area)." +") %elsec
                  write(area,1)
          write(Offset,1)
          write(Bytes,6)
          %if Adid#0 %then spaces(4) %and printstring(string(Adid))
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Offset=Offset+AddOffset
        %if CCset#0 %then Establish Logical
        Abort %if Elevel=15
        Elevel=Elevel+1
        Lstk==Stk(Elevel)
        LStk=0
        LStk_Form=form
        LStk_Size=Bytes
        LStk_Base=area
        LStk_Offset=Offset
%end

%externalroutine Estkdir(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a DirVal operand
!***********************************************************************
prestk("Estkdir   ", offset,bytes,area,0,Stack offset,DirVal,adid)
%end;! Estkdir

%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an IndDirVal operand
!***********************************************************************
prestk("Estkind   ", offset,bytes,area,0,Stack offset,IndDirVal,adid)
%end

%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a DirVal operand local to an enclosing level
!***********************************************************************
 prestk("Estkglobal Level = ",DisplayDisp - (level*4),bytes,stack,level,0,IndDirModVal,adid)
        %if ProgFaulty#0 %then %return
        Stk(Elevel)_ModForm = Litval
        Stk(Elevel)_ModOffset=Offset
%end;! Estkglobal

%externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an IndDirVal operand local to an enclosing level
!***********************************************************************

        %if Report#0 %start
          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
        Abort %if Elevel=15

        { First set up as Global to load address }

         Estkglobal(Level,Offset,Adid,4)
         Erefer(0,Bytes)

%end;! Estkglobalind


%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a DirVal parameter operand
!**********************************************************************
prestk("Estkpar   level = ",offset,bytes,stack,level,Paramoffset,Dirval,adid) 
%end

%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an IndDirVal parameter operand
!***********************************************************************
prestk("Estkparind Level = ",offset,bytes,stack,level,Paramoffset, %c
       IndDirVal,adid)
%end

%externalroutine Estkresult(%integer Class,Type,Bytes)
!***********************************************************************
!* defines the result stacked by a function call
!* Type = 1  int
!*        = 2  real
!***********************************************************************
        %if Report#0 %start
          printstring("Estkresult ")
          write(Class,4);write(Type,4);write(Bytes,4)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        %if Type=2 %then Stackfr(0,Bytes) %else Stackr(0)
%end;! Estkresult

%externalroutine Erefer(%integer Offset,Bytes)
!***********************************************************************
!* stacks the address of a DirVal operand
!***********************************************************************
        %if Report#0 %start
          printstring("Erefer   ");write(Offset,1);write(Bytes,6)
          newline
          DumpEstack
        %finish
        %if ProgFaulty#0 %then %return
        Refer(Stk(Elevel),Offset)
        Stk(Elevel)_Size=Bytes
%end;! Erefer

%externalroutine Epromote(%integer Level)
!***********************************************************************
!* move the entry at Level in Estack to the top of the Estack
!*  - the top entry is at level 1
!***********************************************************************
%record(Stkfmt) E 
%integer I
        Rep("Epromote ",Level)%if Report#0 
        %if ProgFaulty#0 %then %return
        %unless 0<Level<=Elevel %then abort
        %if Level=1 %then %return
        Level=Elevel-Level+1
        E=Stk(Level)
        Reset Reguse(Level,Elevel+1);! to avoid problems
        %cycle I=Level,1,Elevel-1
          Stk(I)=Stk(I+1)
          ResetReguse(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
        Rep("Edemote ",Level) %if Report#0
        %if ProgFaulty#0 %then %return
        %unless 0<Level<=Elevel %then abort
        %if Level=1 %then %return
        Level=Elevel-Level+1
        E=Stk(Elevel)
        Reset Reguse(Elevel,Elevel+1);! to avoid problems
        %cycle I=Elevel,-1,Level+1
          Stk(I)=Stk(I-1)
          Reset Reguse(I-1,I)
        %repeat
        Stk(Level)=E
        Reset Reguse(Elevel+1,Level)
%end;! Edemote

%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a Direct operand
!***********************************************************************
prestk("Estkaddr   ",offset,4,area,0,Stack offset,AddrDir,adid)
%end

%externalroutine EstkPaddr(%integer level,offset,adid,bytes)
%end
%externalroutine EstkGaddr(%integer level,offset,adid,bytes)
%end




!*                   *********************
!*                   *  Labels, Jumps    *
!*                   *********************


%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label
!***********************************************************************
        Rep("Elabel ",Id) %if Report#0
        %if ProgFaulty#0 %then %return
        Dropall
        Plabel(id)
%end;! Elabel

%externalroutine Ediscardlabel(%integer Id)
!***********************************************************************
!* advise that  a label can now be discarded - i.e. no future ref
!***********************************************************************
        Rep("Ediscardlabel ",Id) %if Report#0
%end;! Ediscardlabel

%externalroutine Euchecklab(%integer Labid)
        %constintegerarray unasspattern(0:1)=x'81818181'(2)
        
        Unasslab=Labid
        Pdbytes(Cnst,0,8,addr(unasspattern(0)))
        curcnst=8
%end

!***********************************************************************
!* Advise where to send bound check failures.
!***********************************************************************
%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 Freg1,Bytes,i
%ownrecord(Stkfmt) Zero
      Rep("Ejump ".Eopname(Opcode),Labelid) %and Dump Estack %if report#0
      %if ProgFaulty#0 %then %return
      Zero_size=stk(elevel+1)_size
      %if CCset # 0  %and Opcode<JTRUE %then Establish Logical
      %if Opcode<JRGT %thenstart
         %if Opcode<JUGT %then ->OpI(Opcode) %else ->OpU(Opcode)
      %finishelse ->OpR(Opcode)

OpI(*):OPR(*):     Abort

OpI(JIGT):
OpI(JILT):
OpI(JIEQ):
OpI(JINE): 
OpI(JIGE): 
OpI(JILE):

!        %if stk(Elevel-1)_size=1 %then CC = USetCC(opcode-JIGT) %elsec
!                                       CC =  Setcc(Opcode-JIGT)

        { IMP checks string length bytes against 256 - which ruins the }
        { one byte comparism. Watch out for now and ignore }

        %if stk(Elevel-1)_size=1 %and stk(Elevel)_form=Litval %andc
           stk(Elevel)_intval=256 %start
           forget(Elevel-1)
           elevel=elevel-2
           ->opI(JUmp)
        %finish  
        Int Binary Op(IGT+Opcode-JIGT)
BC:
        CCset=0
        Pjump(BCond,Labelid,CC)
        %return
!*
OpU(JUGT):
OpU(JULT):
OpU(JUEQ):
OpU(JUNE): 
OpU(JUGE): 
OpU(JULE):
   {   Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2))  }
   { CC = Setcc(Opcode-JIGT)
   { ->BC }

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
        opXX(CMPi,stk(Elevel+1),Zero)
        %if stk(Elevel+1)_size=1 %then CC = UInvCC(opcode-JINTGZ) %elsec
                                       CC =  Invcc(Opcode-JINTGZ)
        ->BC
!*
OpU(JUGTZ):
OpU(JULTZ):
OpU(JUEQZ):
OpU(JUNEZ):
OpU(JUGEZ):
OpU(JULEZ):
       { Fill in later }

OpI(JUMP):
        Pjump(BR,Labelid,15)
        %return

OpR(JRGT):
OpR(JRLT):
OpR(JREQ): 
OpR(JRNE): 
OpR(JRGE):
OpR(JRLE): 
        Real Binary Op(RGT+Opcode-JRGT)
        ->BC

OpR(JRGZ):  
OpR(JRLZ):
OpR(JRZ): 
OpR(JRNZ):
OpR(JRGEZ):
OpR(JRLEZ):
        %if Elevel<1 %then Low Estack(Opcode,1)
        Elevel=Elevel-1
        !Freg1=Load Real(MOVf,Stk(Elevel+1),-1,Stk(Elevel+1)_size)
        zero_size=stk(elevel+1)_size
        opXX(CMPf,Zero,stk(Elevel+1))
        CC=Setcc(Opcode-JRGZ)
        ->BC

OpR(JTRUE):
        %if CCset=0 %start
           %if Elevel<1 %then Low Estack(Opcode,1)
           Elevel=Elevel-1
           opXX(CMPi,Stk(Elevel+1),Zero)         
           CC=1 { NE }
        %finish
        ->BC

OpR(JFALSE):
        %if CCset=0 %start
           %if Elevel<1 %then Low Estack(Opcode,1)
           Elevel=Elevel-1
           opXX(CMPi,Stk(Elevel+1),Zero)         
           CC = 0 { EQ}
        %finishelse CC=invertcond(cc)
        ->BC

%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 Xop,Bytes
   %ownlongreal dpzero=0.0

        %if Report#0 %start
          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)

        %if Opcode=ITWB %then xop = CMPi %else xop = CMPf
        %if stk(elevel)_size=8 %start  { temp dp code until imm real consts}
           Estkconst(8,addr(dpzero))
           OPXX(CMPf,stk(elevel-1),stk(elevel))
           Elevel=Elevel-1
        %finishelse opXX(xop,Stk(Elevel),Zero)
        Elevel=Elevel-1
        %if Lab1>0 %then Pjump(BCond,Lab1,6);! if < 0 ( 0 > x )
        %if Lab2>0 %then Pjump(BCond,Lab2, 0);!    = 0
        %if Lab3>0 %then Pjump(BCond,Lab3, 12);!   > 0 (0 < x )
%end

%externalroutine Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                        %integername SSTad)
!***********************************************************************
!* define a switch Switchid to be indexed in the range (Lower:Upper)
!* space may be claimed from SST for the switch table
!***********************************************************************
%integer Ad,reg,reg1
%record(stkfmt) S

   %if Report#0 %start
      printstring("Eswitch ")
      write(Lower,4);write(Upper,4);write(ErrLAbID,1);write(Switchid,4)
      printstring(" SSTAD = "); phex(SSTad)
      newline
   %finish
   %if ProgFaulty#0 %then %return

   %if language = IMP %start   { %SWITCH }

      Ad = SSTad - (Lower*4)
      SSTad = SSTad+(Upper-Lower+1)<<2

      Plabel(SwitchID) 

      reg = claimr(-1)
      OPRD(Addrx,reg,SST,Ad)
      Pswitch(Ad,SwitchId)  { remember where the table is. CA taken by this! }
      S=0
      S_reg = reg
      S_Form = RegModAddr
      S_size = 4
!       S_Modreg = 0
      S_ModForm =  Regval!RegFlag
      S_scale = 2
      OPX(CASEi,S)

   %finishelsestart  { FORTRAN COMPUTED GOTO }

      %if Elevel<1 %then Low Estack(JUMP,1)
      Elevel=Elevel-1
   
       { First see if the index is within the GOTO's bounds }

       reg1 = claimr(-1)
       OPRD(Addrx,reg1,SST,SSTAD+8)
       ruse(reg1)=-255             { lock reg1 to avoid re-use as reg }
       reg = -1
       OPCHECK(Stk(Elevel+1),-reg1,-8,4,reg)   { CHECKi instr }
       ruse(reg1)=0
       PD4(SST,SSTAD,Upper)
       PD4(SST,SSTAD+4,1)                       { Lower bound }
       PJUMP(Bcond,ShortRangeId,8 { F set }){jump around CASE if bounds exceeded}

       { Then do a multi-way branch using an indexed CASE instruction }

       Pswitch(SSTAd+8,SwitchId)  { remember where the table zero point is. }
                                  { CA is also recorded for start of CASEi }
       S=0
       S_reg = reg1
       S_Form = RegModAddr
       S_size = 4
       S_Modreg = Reg
       S_ModForm =  Regval!RegFlag
       S_scale = 2           { unit size has to be 4 to allow for forward jumps }
       OPX(CASEi,S)

       Plabel(ShortRangeId)

      SSTAD = SSTAD +(Upper+2)<<2  { plus 8 bytes for bounds }
   %finish

%end;! Eswitch

%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds defined for Switchid then error     *
!***********************************************************************
%integer i

        %if Report#0 %start
          printstring("EswitchJump ");write(switchid,4)
          newline
        %finish

        %if ProgFaulty#0 %then %return
        %if Elevel <1 %then LowEstack(0,1)
        i=LoadInt(MOVi,Stk(Elevel),0)       { Switch Index to R0 }
        Elevel = Elevel -1
        EJump(JUMP,SwitchID)                { and jump back to Switch defn. }
        Ruse(0)=0                           { and free Reg 0 }
        Rmem(0)=0

%end;! EswitchJump

%externalroutine EfswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )
!* if (Etos) is outside the bounds the jump has no effect. 
!***********************************************************************
%end;! EfswitchJump

%externalroutine Eswitchentry(%integer Switchid, Entry)
!***********************************************************************
!* define the current code address as Switchid(Entry)
!***********************************************************************
        %if Report#0 %start
          printstring("Eswitchentry ");write(Switchid,4);write(Entry,4)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Dropall
        PswitchLabel(SwitchID,Entry)
%end;!Eswitchentry

%externalroutine Eswitchdef(%integer Switchid)
!***********************************************************************
!* define the current code address as Switchid(*) - the default
!***********************************************************************
!        Rep("Eswitchdef ",Switchid) %if Report#0
        Abort
%end;!Eswitchdef

%externalroutine EswitchLabel(%integer Switchid, Entry, Labelid)
!***********************************************************************
!* define Labelid as Switchid(Entry)
!***********************************************************************
        %if Report#0 %start
          printstring("EswitchLabel ");write(switchid,4);write(entry,4)
          write(LabelID,1)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Pswitchval(switchid,Entry,Labelid)
%end;! EswitchLabel



!*                  *******************************
!*                  * Data initialisation, fixups *
!*                  *******************************


%externalroutine Ed1(%integer area, Disp, Val)
!***********************************************************************
!* intialise an 8-bit location
!***********************************************************************
        %if Area>=11 %then Areaprops(Area)=Areaprops(Area)!4 %and area=com(area)
        %if Report#0 %start
          printstring("Ed1   ".Areas(Area)." +");write(Disp,1)
          spaces(4);Phex(Val)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Pdbytes(area, Disp, 1, addr(Val){+wordad})
%end;! Ed1

%externalroutine Ed2(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 16-bit location
!***********************************************************************
        %if Area>=11 %then Areaprops(Area)=Areaprops(Area)!4 %and area=com(area)
        %if Report#0 %start
          printstring("Ed2   ".Areas(Area)." +");write(Disp,1)
          spaces(4);Phex(Val)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Pdbytes(area, Disp, 2, addr(Val){+wordad})
%end;! Ed2

%externalroutine Ed4(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 32-bit location
!***********************************************************************
        %if Area>=11 %then Areaprops(Area)=Areaprops(Area)!4 %and area=com(area)
        %if Report#0 %start
          printstring("Ed4   ".Areas(Area)." +");write(Disp,1)
          spaces(4);Phex(Val)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Pd4(area, Disp, Val)
%end;! Ed4

%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data
!***********************************************************************
        %if Report#0 %start
          printstring("Edbytes ")
          write(area,1); write(disp,1); write(len,1)
          %if len<5 %then space %and phex(integer(ad))
          %monitor %if integer(ad)=0 %and len=1
          newline
        %finish
        %if ProgFaulty#0 %then %return
        %if Area=10 %then %monitor;! should not be allocated any more
        %if Area>=11 %then  Areaprops(Area)=Areaprops(Area)!4 %and area=com(area)
        Pdbytes(area, Disp, len, ad)
%end;! Edbytes

%externalroutine Edpattern(%integer area, Disp, ncopies, len, ad)
!***********************************************************************
!* initialise using a 1,2,4 or 8 byte pattern
!***********************************************************************
        %if Report#0 %then printstring("Edpattern 
")
        %if ProgFaulty#0 %then %return
        %if Area>=11 %then Areaprops(Area)=Areaprops(Area)!4 %and area=com(area)
        Pdpattern(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 ProgFaulty#0 %then %return
        %if tgtArea>=11 %then tgtarea=com(tgtarea)
        %if Report#0 %start
          printstring("Efix  ".Areas(Area)." +");write(Disp,1)
          printstring(" => ".itos(Tgtarea)." +");write(Tgtdisp,1)
          newline
        %finish
        Pfix(area,disp, tgtarea,tgtdisp)
%end



!*                   *********************
!*                   * Procedure call    *
!*                   *********************


%externalintegerfn EXname(%integer type,%string(255)%name Xref)
!***********************************************************************
!* generate an external reference, returning an Id for future reference*
!***********************************************************************
        %if Report#0 %start
          printstring("EXname  ".Xref." type = ")
          write(Type&15,4);write(Type>>4,4)
          newline
        %finish
        %if ProgFaulty#0 %then %result=1
        %result=PXname(0,Xref)
%end;! EXname

%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call
!***********************************************************************
!        %if Report#0 %start
!          printstring("Eprecall ")
!          newline
!        %finish
%end;! Eprecall

%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id
!***********************************************************************
        
%record(stkfmt) STkr6
        %if Report#0 %start
          printstring("Ecall    id = "); write(id,6)
          printstring(" Npars = "); write(numpars,1)
          printstring(" Psize = "); write(paramsize,1)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Freeregs
        !%if OptR6#0 %start
           !NewTemporary(4,StkR6)
           !Op XR(MOVi,StkR6,R6)
        !%finish

        Pcall(ID)
        
        Op1lit(ADJSPi,-Paramsize) %unless Paramsize=0 { recover Param space }{ %or seqmath(ID)=1}
        !%if OptR6#0 %then Op RX(MOVi,R6,STkR6)

%end

%externalroutine Eprocref(%integer Id, Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter
!***********************************************************************
      rep("Eprocref ",Id) %if Report#0
      Pcall(-id);  { '-' tells pcall an addri is reqd not a call }
      stackr(R1)   { environment }
      stk(elevel+1)=TOS
      Elevel=Elevel+1
%end;! Eprocref

%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter
!***********************************************************************
      rep("ESAVE ",Asave) %if Report#0
!Abort   {(hopefully) redundant}
%end;! Esave

%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter
!***********************************************************************
      rep("ERESTORE ",Asave) %if Report#0
!Abort   {(hopefully) redundant}
%end;! Erestore



!*                 **********************************
!*                 * Procedure definition and entry *
!*                 **********************************


%externalintegerfn Enextproc
!***********************************************************************
!* result is an Id to be used for a procedure first encountered as an
!* internal spec
!***********************************************************************
        %if Report#0 %start
          printstring("Enextproc ")
          newline
        %finish
        %if ProgFaulty#0 %then %result=1
        %result=PNextSymbol
%end;! Enextproc

%recordformat Procfm(%integer SFdisp,R7use)
%ownrecord(procfm) %array ProcMem(0:20)

%externalroutine Eproc(%stringname Name,%integer Props, %c
                             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
!* Props          1 if externally visible
!*                2 if main entry
!*                4 if display creation is not required
!*                8 if stack space reservation is not required
!***********************************************************************
%integer Pprops,localAd,disp,len,xid,i,j
%string(8) s
%record(stkfmt) T,F
%ownstring(5) mnem = "MOVSi"

  %if Report#0 %start
     printstring("Eproc ")
     printstring(Name)
     printstring("  Npars = ")
     write(Numpars,4)
     printstring(" Psize = ")
     write(Paramsize,4)
     printstring(" Props = ")
     phex(props)
     printstring(" Astacklen = ")
     phex(astacklen)
     newline
   %finish
   %if ProgFaulty#0 %then %return

   %cycle i = 1,1,length(name)
     j=byteinteger(addr(name)+i)
     %if j<='Z' %and j>='A' %then byteinteger(addr(name)+i)=j+('a'-'A')
   %repeat
   %unless Astacklen=-1 %then AddrstackCA = Astacklen
   Forget Regs
   Proclevel = Proclevel + 1
   %if Props&2#0 %then PProps=X'80000001' %else PProps=Props&1
   Pproc(Name,PProps,Numpars<<16!Paramsize,Id,curline+1)
   Curdiagca=-1

   %if proclevel = 1 %start     {Outer level }
      Ruse(R7) = 0              { Don't use R7 as Gla - this one time }
      OPRD(ADDRX,R7,Gla,0)      { R7 points Gla base }
      Ruse(R7) = Gla            { Now its safe to use R7 as Gla }
   %finish

   %if Props&4=0 %start     { Display }

          { Layout is:     Gla ptr            }    
          {                FP outer levels    }
          {                FP this proc       }
          {                SF ( for exit )    }

       %if proclevel = 1 %start     {Outer level }
                                   {Record Modules Gla in display for diags}
          OPDR(MOVi,Stack,DisplayDisp,R7)
          disp = DisplayDisp - 4

       %finishelsestart        { Inner level copy surrounding display } 

          Len  =  Proclevel*4
          OPRL(SUBi,R1,len)
          F=0; F_Form=Regval; F_reg=R1
          T=0; T_base = Stack; T_offset = DisplayDisp-(len-4)

          %if len < 17 %start { can use MOVMi }   

             T_form = Dirval
             MoveMultiple(Len,F,T)  { uses addr of opds }

          %finishelsestart    {  or use MOVSi }

             F_form = AddrDirmod
             opRL(MOVi,R0,Len)
             opRD(Addrx,R2,Stack, T_offset)
              PREV = CA
             PB(B'00001110')   { Plant actual MOVSi opcode }
             PB(B'00000000')
             PB(B'00000000')
             %if decode#0 %then PDumpInstr(mnem)

           %finish

           Ruse(R7) = Gla          { Now its safe to use R7 as Gla }
           disp = DisplayDisp - Len

        %finish

        OPDL(SPRi,Stack,disp,8{FP},4)          { save local stack pointer }
        OPDX(ADDRX,Stack,disp - 4,TOS)         { save SF on entry }

     %finish %else disp = 0

     %if language=IMP %Start

        ProcMem(Proclevel)_SFdisp = disp-4     { save for EXIT }
        ProcMem(Proclevel)_R7use  = Ruse(R7)   { Restore on exit from }
                                                  { nested procedures    }
     %finishelsestart
        %if Diaglevel>-1 %start
           OPDR(MOVi,Stack,-4,R7)
           OPDL(MOVi,Stack,-8,M'FDIA',4)
        %finish
        %if props&2#0  %start   { Fortran Main Program }
           %if diaglevel >-1 %start
              s="setcont"
              xid=Exname(0,s)
              Ecall(xid,0,0)   { plant call to trap contingencies }
          %finish
       %finish
       FRCorrupt(4)=0   { FR4 used marker }
       FRCorrupt(5)=0
    %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
!***********************************************************************
      Rep("Eprocend ",{Localsize}Diagdisp) %if Report#0
      %if ProgFaulty#0 %then %return
      Proclevel = Proclevel - 1
      %if localsize<0 %then localsize=-localsize  { For Fortran }
      Pprocend(localsize)
      Ruse(R7) = ProcMem(Proclevel)_R7use
%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,Procid,i,c

      %if Report#0 %thenstart
         printstring("Eentry  ".Name);write(Index,4)
         write(Numpars,4);write(Paramsize,4); write(localsize,1)
         write(diagdisp,1); newline
      %finish
      %if ProgFaulty#0 %then %return
      %if paramsize<0 %then paramsize=0  { temp }
      %if localsize<0 %then localsize=-localsize
      %if diaglevel>-1 %then OPDL(MOVi,Stack,-10,Diagdisp,2)
      %if Index=0 %start ;! prologue start in Eproc
         %if FRCorrupt(4)#0 %or FRCorrupt(6)#0 %start
            { define where registers are to be saved for ALL prologues }
            i=integer(AddrStackCA)
            %if FRCorrupt(4)#0 %then FRCorrupt(4)=i-8 %and i=i-8
            %if FRCorrupt(6)#0 %then FRCorrupt(6)=i-8 %and i=i-8
            integer(AddrStackCA)=i
         %finish
      %finish
      
      %if Index#0 %start   { size entry }
         id=-1
         { call Pproc. prop&16 tells side entry. localsize in pars }
         Pproc(Name,17,(localsize<<16)!Paramsize,id,curline+1)
         Ruse(r7)=0
         Oprd(Addrx,R7,Gla,0)
         Ruse(r7)=gla
     %finish
     %if FRCorrupt(4)#0 %then OPDF(MOVf,Stack,FRCorrupt(4),8,FR4,8)
     %if FRCorrupt(6)#0 %then OPDF(MOVf,Stack,FRCorrupt(6),8,FR6,8)
%end



!*                 *********************************
!*                 * 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 %start
          printstring("Edataentry  ".Name);write(Area,4)
          write(Offset,4);write(Length,4)
          newline
        %finish
        %if ProgFaulty#0 %then %return
        Pdataentry(Name, Area,Length,Offset)
%end;! Edataentry

%externalroutine Edataref(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* requests a data ref to Name (with at least Length)at Offset in Area *
!***********************************************************************
        %if Report#0 %start
          printstring("Edataref  ".Name);write(Area,4)
          write(Offset,4);write(Length,4)
          newline
        %finish
        %if ProgFaulty#0 %then %return
         Pdxref(Area,Offset,Length, Name)
%end;! Edataref

!*************************************
%routine Forget(%integer Elev)
%integer i

   %if report#0 %then printstring(" Forget ".itos(elev)) %and newline

   %cycle i = 0,1,LastExprReg
      %if ruse(i)=-Elev %then ruse(i)=0
   %repeat
%end


!*                    ********************
!*                    * Ecode operations *
!*                    ********************


%externalroutine Eop(%integer Opcode)
!***********************************************************************
!*                opcodes with general applicability
!***********************************************************************
%integer Reg1,Reg2,Freg1,Freg2,Bytes,form,i,size,Mform
%switch Op(0:255)
%string(16) s

        %if Report#0 %start
          s = Eopname(Opcode)
          printstring("Eop    ".s)
          %if s="" %then write(Opcode,1)
          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):
Op(EVAL):
        Unsupported Opcode(Opcode)
        %return  

  
Op(ISHLL):
Op(ISHRL):
Op(ISHLA):
Op(ISHRA):
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):  
Op(IADDST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST): 

Op(IANDST):
Op(IORST): 
Op(IXORST): 

        Int Binary Op(Opcode)
        %return

Op(INEG): 
Op(IABS): 
Op(INOT):
Op(INEGST): 
Op(INOTST):
Op(Bnot):
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        Int Unary Op(Opcode,Stk(Elevel+1))
        %return

Op(RETURN): 

        %if Language=IMP %and ProcMem(ProcLevel)_SFdisp <-4 %start

           { The EXIT instruction will reload the registers from SF.   }
           { Since IMP may have moved SF to make room for dynamic      }
           { arrays etc. It is reqd. to reset SF to the value recorded }
           { on entry to this routine.                                 }

           OPLD( LPRi, 9 { SP }, Stack, ProcMem(ProcLevel)_SFdisp)

        %finish

        %if language=Fortran %start

           { NatSemi Languages assume that called programs will not }
           { corrupt FR4-FR7. If we have used these restore them now. }
           
           %if FRCorrupt(4)#0 %then OPFD(MOVf,FR4,8,Stack,FRCorrupt(4),8)
           %if FRCorrupt(6)#0 %then OPFD(MOVf,FR6,8,Stack,FRCorrupt(6),8)
        %finish
 
        %if Language = IMP %then i = 1 %else i = B'00011111'
        op1lit(EXIT,i)   { restore only R7 for imp, R3 - R7 for others }
        op1lit(RET,0)    { If fixed length of params is assumed then }
        %return          { you could use Pparamsize instead of 0 and }
                         { drop the ADJsp in the caller routine }
      
Op(SFA):

       Elevel=Elevel+1
       Stk(Elevel)=0
       Stk(Elevel)_Form = StackFront
       Stk(Elevel)_Intval = 9
       Stk(Elevel)_size=4
       %return

Op(ASF):

        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        %if Stk(Elevel+1)_form=Litval %thenc
                      Stk(Elevel+1)_IntVal = -Stk(Elevel+1)_IntVal %c
                %else Stk(Elevel+1)_reg = LoadInt(NEGi,Stk(Elevel+1),-1)
        Compress( Stk(Elevel+1) )                                   
        opX(ADJSPi,Stk(Elevel+1))
        %return

Op(IPUSH):

        OpXX(Movi,TOS,Stk(Elevel+1))  { movf ? }
        %return    

Op(IPOP):
  
        OpXX(Movi,Stk(Elevel+1),TOS)
        %return    

Op(EXCH):
        Epromote(2)
        %return

Op(DUPL):
        Stk(Elevel+1)=Stk(Elevel)
        Elevel=Elevel+1
        Form = Stk(Elevel)_Form
        Mform = STk(Elevel)_ModForm

        %if Form&RegFlag#0 %or MForm&RegFlag#0 %start 

           %if Form&RegFlag#0 %start   {Does it involve a register ? }

              Reg2 = Stk(Elevel)_Reg
              Reg1 = Claimr(Reg2)     { Claim an unused register }           
              OPRR(MOVi,Reg1,Reg2)    { Copy register }
              Stk(Elevel)_Reg=Reg1
              Ruse(Reg1)=-Elevel      { set reguse for copy }
              Rmem(Reg2)=Rmem(reg1)
              Ruse(Reg2)=-(Elevel-1)  {restore ruse wiped by move on orig.}

           %finish

           %if MForm&RegFlag#0 %start { A Modreg ? }

              Reg2 = Stk(Elevel)_ModReg     { Yes - Then make a copy }
              Reg1 = Claimr(Reg2)     { Claim an unused register }           
              OPRR(MOVi,Reg1,Reg2)    { Copy register }
              Stk(Elevel)_ModReg=Reg1
              Ruse(Reg1)=-Elevel      { set reguse for copy }
              Rmem(Reg2)=Rmem(reg1)
              Ruse(Reg2)=-(Elevel-1)  {restore ruse wiped by move on orig.}

           %finish

        %finishelsestart

           Form=Form&31

           %if Form = FregVal %start    { Is it a Floating point register ? }
              FReg2 = Stk(Elevel)_Reg   { Yes - Then make a copy }
              size = Stk(Elevel)_Size
              Freg1 = Claimfr(FReg2,size)    { Claim an unused register }
              OPFF(MOVf,Freg1,Size,Freg2,Size)  { Copy register }
              Stk(Elevel)_Reg = Freg1
              Fruse(Freg1)=-Elevel      { set reguse for copy }
              FrMem(Freg2) = Frmem(Reg1)
              FRuse(FReg2)=-(Elevel-1)  {restore reguse wiped by move }

           %finishelsestart
             
             %if Form=TempVal %then Stk(Elevel)_Form=DirVal
          %finish

        %finish
        %return    

Op(DISCARD):
        %if Elevel<1 %then Printstring("
EOP(DISCARD) and NOTHING to Discard") %and %return
        %if Stk(Elevel)_Form=FRegVal %then Fruse(Stk(Elevel)_Reg)=0 %c
                                     %else Forget(Elevel)
        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
        Note Index(Opcode-INDEX1,Stk(Elevel),Stk(Elevel+1))
        %return

Op(Index):
        Int Binary Op(Imult)
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel = Elevel-1
        Note Index(0,Stk(Elevel),Stk(Elevel+1))
        %return


Op(MVB):    
            
        %if Elevel<3 %then Low Estack(Opcode,2) %and %return
        Elevel=Elevel-3
        CopyBytes(stk(Elevel+3),stk(Elevel+1),stk(Elevel+2))
        %return


Op(CHK):  
        %if Elevel<3 %then Low Estack(Opcode,2) %and %return
        %if language=Fortran %start
           elevel=elevel-3
           reg1=Loadint(MOVi,Stk(Elevel+1),-1)
           opxx(CMPi,STK(Elevel+2),stk(elevel+1))
           Pjump(Bcond,Bounderr,12) { BLT }
           opxx(CMPi,Stk(Elevel+3),stk(Elevel+1))
           Pjump(Bcond,Bounderr,6) { BGT }
           stackr(reg1)
        %finishelsestart { ignore bound checks }
           Elevel=Elevel-2
           Forget(Elevel+1)
           Forget(Elevel+2)
        %finish
        %return

Op(TMASK): 

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
        CC=USetcc(Opcode-CPBGT)
        Compare Bytes(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
        Establish Logical
        %return    

Op(RADD): 
Op(RSUB): 
Op(RMULT):
Op(RDIV): 

Op(RGT):  
Op(RLT):  
Op(REQ): 
Op(RNE):  
Op(RGE):   
Op(RLE): 
        Real Binary Op(Opcode)
        %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(CVTII):
        %if Elevel<2 %then Low Estack(Opcode,2) %and %return
        %if stk(elevel)_Intval = Stk(Elevel-1)_size %start { NOOP }
          Elevel = Elevel - 1
          %return
        %finish
        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(0,Stk(Elevel+1),Stk(Elevel+2)_Intval)
        %return

Op(TNCRI): 
Op(RNDRI):
Op(EFLOOR):
        %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(255):  {private imp floor - replace with EFLOOR when convenient }
        %if elevel<1 %then low estack(opcode,1) %and %return
        Elevel=Elevel-1
        Convert RI(stk(Elevel+1),4,2)
        %return

Op(TNCRR):
Op(RNDRR):
        %if elevel<1 %then low estack(opcode,1) %and %return
        elevel=elevel-1
        { 1 for Tnc; 2 for Rnd }
        Convert RR(Opcode-EFLOOR,stk(Elevel+1),Stk(Elevel+1)_size)
        %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(UFCHECK):
!        Eop(Dupl)
!        stk(Elevel)_size=4       { since using cmpi only 4 byte check }
!        OPXX(CMPi,STK(Elevel),Unass)
!        Pjump(Bcond,Unasslab,0) { beq}
!        Eop(Discard)
!        %return

Op(UCHECK):
        Elevel=Elevel-1
        reg1=loadInt(MOVi,STK(elevel+1),-1)
        OPRX(CMPi,reg1,Unass)
        Pjump(Bcond,Unasslab,0)  { beq }
        stackr(reg1)
        %return    

Op(ESTORE):
        %if Elevel<2 %then Low Estack(Opcode,2) %and %return
        Elevel=Elevel-2
        Storeop(Stk(Elevel+2),Stk(Elevel+1))
        %return

Op(EDUPSTORE):
        %if Elevel<2 %then Low Estack(Opcode,2) %and %return
        Elevel=Elevel-2
        size = Stk(Elevel+1)_size
        form = Stk(Elevel+1)_form
        %if form=Litval %then i = Stk(Elevel+1)_IntVal %elsestart
           %if size=8 %then Reg1 = Load Real(MOVf,Stk(Elevel+1),-1,8) %elsec
                            Reg1 = Load int(MOVi,Stk(Elevel+1),-1)
        %finish
        Storeop(Stk(Elevel+2),Stk(Elevel+1))
        %if form=LitVal %then Estklit(i) %and %return
        %if size=8 %then StackFR(Reg1,8) %and %return
        Stackr(Reg1)
        %return

Op(PUSHVAL):

Op(PUSHADDR):
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        Push Param(Opcode-PUSHVAL,Stk(Elevel+1))
        %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(MOVi,Stk(Elevel+1),R0)
        Ruse(0)=0    
        %return

Op(EREALRES):    
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        Reg1=Load Real(MOVf,Stk(Elevel+1),FR0,Stk(Elevel+1)_size)
        FRuse(0)=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<2 %then Low Estack(Opcode,2)
        Elevel = Elevel-2
        FreeRegs
        i=LoadInt(MOVi,Stk(Elevel+1),R1)   { environment }
        OPX(JSR,Stk(Elevel+2))             { Addr of Proc }
        OP1LIT(ADJSPi,8)  { temp until paramsize passsed }
        %return
%end

%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran
!***********************************************************************
%switch F77op(256:320)
%integer bytes,reg1,reg2,relop,d1,FR1,FR2,FR3,i,j
%constinteger ShortRangeID=x'8FFFFFFF'{Hopefully unique - ensures 1 byte opd }

        %if Report#0 %start
          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(*): Unsupported Opcode(opcode)
          %monitor
          %stop

F77op(CXADD):        
F77op(CXSUB):        
F77op(CXMULT):     
F77op(CXDIV):   
  
        i = 4     
Cxop:   
        %if Elevel<i %then Low Estack(Opcode,i) %and %return
        Elevel=Elevel-i
        Cx Operation(Opcode&255,            %c
                     Stk(Elevel+i)_Intval,  %c
                     Stk(Elevel+1),         %c
                     Stk(Elevel+2),         %c
                     Stk(Elevel+3))
        %return

F77op(ECONJG):     
        Opcode=9
F77op(CXNEG):        
F77op(CXASGN):     
F77op(CXEQ):        
F77op(CXNE): 
        i = 3       
        ->Cxop

F77op(EM1EXP):        
        Elevel=Elevel-1
        reg2=Loadint(MOVi,stk(elevel+1),-1)
        reg1=claimr(-1)
        OpRL(MOVi,reg1,-1)
        OpRx(ANDi,reg2,one)
        OPRx(CMPi,reg2,one)
        Pjump(Bcond,ShortrangeID,0)
        OPRL(MOVi,reg1,1)
        Plabel(ShortrangeID)
        stackr(reg1)
        %return

F77op(EISIGN):                {  |i| if j >= 0  ; -|i| if j < 0 }
        Elevel=Elevel-2
        Reg1=Load Int(ABSi,Stk(Elevel+1),-1)  {    Reg1 = |i|      }
        Opxx(CMPi,Stk(Elevel+2),Zero)        {    if j >= 0 then  }
        PJump(Bcond,ShortRangeID,7)           {    Skip next instr.}
        OpRR(NEGi,Reg1,Reg1)                  {    Negate |i|      }
        Plabel(ShortRangeID)
        Stackr(Reg1)
        %return

F77op(ESIGN):                {  |x| if y >= 0  ; -|x| if y < 0 }        
        Elevel=Elevel-2
        Bytes = Stk(Elevel+1)_size
        FR1=Load Real(ABSf,Stk(Elevel+1),-1,Bytes )   {    FR1 = |x|      }
        Opxx(CMPf,Stk(Elevel+2),Zero)                 {    if y >= 0 then  }
        PJump(Bcond,ShortRangeID,7)                   {    Skip next instr.}
        OPFF(NEGf,FR1,Bytes,FR1,Bytes)            {    Negate |x|      }
        Plabel(ShortRangeID)
        Stackfr(FR1,Bytes)
        %return

F77op(EIMOD): 
        Int Binary Op(EIMOD)        
        %return

F77op(ERMOD):            {  x = int( x / y ) * y }
        Elevel=Elevel-2
        Bytes = Stk(Elevel+1)_size
        FR1=Load Real(MOVf,Stk(Elevel+1),-1,Bytes)    { FR1 = x }
        FR2=Load Real(MOVf,Stk(Elevel+2),-1,Bytes)    { FR2 = y }
        FR3=ClaimFR(-1,bytes)
        OPFF(MOVf,FR3,bytes,FR1,bytes)              { FR3 also = x }
        OPFF(DIVf,FR1,bytes,FR2,bytes)              { FR1 = x / y }
        Reg1 = Claimr(-1)
        OPFF(TRUNCfi,Reg1,4,FR1,bytes)          { R1 = int(FR1) }
        OPFF(MOVif,FR1,bytes,Reg1,4)            { FR1 = float(R1) }
        OPFF(MULf,FR1,bytes,FR2,bytes)              { FR1 = FR1 * FR2 }     
        OPFF(SUBf,FR3,bytes,FR1,bytes)                          { FRs = remainder }
        Stackfr(FR3,bytes)
        %return

F77op(EIDIM):                             { i-j if i > j ;  0 if i < j }

        Int Binary Op(Isub)               {    i - j                }
        Opxx(CMPi,Stk(Elevel),Zero)      {    if  (i-j) >= 0 then  }
        PJump(Bcond,ShortRangeID,7)       {    Skip next instr      }
        Opxx(MOVi,Stk(Elevel),Zero)      {    else result = Zero   }
        Plabel(ShortRangeID)
        Ruse(Stk(Elevel)_Reg)=-Elevel
        %return

F77op(ERDIM):                            { x-y if x > y ;  0 if x < y }

        Real Binary Op(Rsub)              {    x - y                }
        Opxx(CMPf,Stk(Elevel),Zero)       {    if  (i-j) >= 0 then  }
        PJump(Bcond,ShortRangeID,7)       {    Skip next instr      }
        Opxx(MOVf,Stk(Elevel),Zero)       {    else result = Zero   }
        Plabel(ShortRangeID)
        FRuse(Stk(Elevel)_Reg)=-Elevel
        %return
        

F77op(EIMIN):                         { Leave least of i and j on stack }
        Relop=7
Iminmax:
        Elevel=Elevel-2
        Reg1=Load Int(MOVi,Stk(Elevel+1),-1)
        Reg2=Load Int(MOVi,Stk(Elevel+2),-1)
        OpRR(CMPi,Reg1,Reg2)                    {    if  i <= j then  }
        PJump(Bcond,ShortRangeID,Relop)         {    Skip next instr      }
        OpRR(MOVi,Reg2,Reg1)                    {    else result = j   }
        Plabel(ShortRangeID)
        Stackr(Reg2)
        %return
         

F77op(ERMIN):        
        Relop=7
Rminmax:
        Elevel=Elevel-2
        Bytes = Stk(Elevel+1)_size
        FR1=Load Real(MOVf,Stk(Elevel+1),-1,Bytes)
        FR2=Load Real(MOVf,Stk(Elevel+2),-1,Bytes)
        OPFF(CMPf,FR1,Bytes,FR2,Bytes)        {    if  x <= y then  }
        PJump(Bcond,ShortRangeID,Relop)         {    Skip next instr      }
        OPFF(MOVf,FR2,Bytes,FR1,Bytes)        {    else result = y   }
        Plabel(ShortRangeID)
        Stackfr(FR2,bytes)
        %return

F77op(EIMAX):        
        Relop=13
        ->Iminmax

F77op(ERMAX):        
        Relop=13
        ->Rminmax

F77op(EDMULT):        
        Elevel=elevel-2
        ConvertRR(0,stk(elevel+1),8)
        ConvertRR(0,stk(elevel+1),8)  { first convert puts res on stk, hence +1}
        Real Binary Op(RMULT)
        %return

!F77op(ECHAR):
f77op(280):        
        %if Elevel<2 %then Low Estack(Opcode,2) %and %return
        Elevel=Elevel-2
        CoerceInt(Stk(Elevel+2),1)
        %if Stk(Elevel+1)_form=AddrDir %then Stk(Elevel+1)_form=Dirval
        Stk(Elevel+1)_size=1
        OPXX(MOVi,Stk(Elevel+1),Stk(Elevel+2))
        %return

F77op(EICHAR):     
        Low Estack(Opcode,1) %and %return %if Elevel<1
        Stk(Elevel)_Size=4   %and %return %if Stk(Elevel)_Form =LitVal
        Refer(stk(elevel),0)
        CoerceInt(Stk(Elevel),1)
        %return

F77op(EINDEXCHAR):{if a char ad is a litval then thats the actual len 1 char}
        %if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3))
        %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
        { If used by a user program the char params on unix will be }
        { ad1,ad2,len1,len2 so we have to do that way as well }
        epromote(3)
        epromote(2)
        elevel=elevel-4
        Spcall(6)
        Stackr(R0)
        %return

F77op(ECONCAT):
        %if Elevel<4 %then LowEstack(Opcode,4) %and %return
        Elevel=Elevel-4    
        Spcall(7)
        %return

F77op(EASGNCHAR):  
        %if Elevel<4 %then Low Estack(Opcode,4) %and %return
        Elevel=Elevel-4
        Do Charop(Opcode,Zero,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
        j=Stk(elevel)_intval
        CC=Setcc(j)
        Elevel=Elevel-5
        Do Charop(Opcode,Stk(Elevel+5),Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
        !CCset=1
        %return


F77op(ECMPLX2):       { Stk1 is dest addr of complex var }
                      { Stk2 and stk3 are real and imag pts for loading }
                      { stk4 is precision }
        i = 4     
Cx1:    %if Elevel<i %then Low Estack(Opcode,i) %and %return
        Elevel=Elevel-i
        !refer(stk(Elevel+1),0)
        reg1=Load Int(movi,stk(elevel+1),-1)
        stk(Elevel+1)_Form=Indregval
        Stk(Elevel+1)_size=stk(Elevel+2)_size
        OPXX(MOVf,Stk(Elevel+1),Stk(Elevel+2))
        !address(stk(Elevel+1))                 { put it back for second refer}
        stk(Elevel+1)_Form = Regval
        refer(stk(Elevel+1),4<<Stk(Elevel+i)_Intval) { access imag. pt }
        Stk(Elevel+1)_size=stk(Elevel+2)_size
        ruse(reg1)=-255
        %if Opcode=ECMPLX1 %start
           { Not got a quick way to zero 8 bytes, so use MOVq twice. }
           Stk(Elevel+1)_size=4
           OPXL(MOVi,Stk(Elevel+1),0)             {  zero imag }
           %if stk(elevel+2)_size=8 %start
              Stk(Elevel+1)_ModIntVal = stk(Elevel+1)_ModIntVal+4
              OPXL(MOVi,Stk(Elevel+1),0)             {  zero imag }
           %finish
        %finishelsestart
           OPXX(MOVf,stk(elevel+1),stk(elevel+3)) { cmplx2 = move stk3 to imag}
        %finish
        ruse(reg1)=0
        %return

F77op(ECMPLX1):
        i = 3
        ->Cx1

F77op(EISHFTC):
     %if Elevel<3 %then LowEstack(Opcode,3) %and %return
     Elevel=Elevel-3    
     spcall(12)
     %return
        
F77op(EIBITS): 
     %if Elevel<3 %then LowEstack(Opcode,3) %and %return
     Elevel=Elevel-3    
     spcall(13);
     %return
       
F77op(EISHFT):        
F77op(EIBSET):        
F77op(EIBTEST):     
F77op(EIBCLR):        
        IntBinary Op(opcode)
        %return

F77op(PROCARG):    
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        Pcall(-Stk(Elevel+1)_Intval) { The '-' tells Pcall an addri is regd }
        %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<2 %then Low Estack(Opcode,2) %and %return
        Elevel=Elevel-2
        Freeregs
        reg1=LOadINT(MOVi,Stk(Elevel+1),-1) { JSR has 'addr' type operand }
        OpX(JSR,Stk(Elevel+1))
        Op1lit(ADJSPi,-stk(elevel+2)_Intval)
        %return

F77op(NOTEIORES):  
        {no special action required here on NatSemi - result will stay in R0}
        %return

F77op(STKIORES):    
        Stackr(R0)
        %return

!F77op(CALLTPLATE): 
!        %return    

F77op(EFDVACC):
        %if Elevel<3 %then Low Estack(Opcode,3) %and %return
        reg1=claimr(-1)   { get a register to preserve (etos-1) in }
        OPRX(MOVi,reg1,Stk(Elevel-1)) 
        ruse(reg1) = -1   { lock against further use until the end }
        eop(imult)
        eop(iadd)
        stackr(reg1)   { original (etos-1) => (etos) }
        %return

F77op(EFNOTEVR):
        %if Elevel<1 %then Low Estack(Opcode,1) %and %return
        Elevel=Elevel-1
        Reg1=Load Int(MOVi,Stk(Elevel+1),R1)
        Ruse(R1)=0  { ? }
        %return

F77op(EFSETVR):
        Stackr(R1)
        %return

F77op(EARGLEN): { no-op }
       %return
       %return
 
F77op(EINCR): 
         Elevel=Elevel-2
         OPXX(ADDi,stk(Elevel+1),stk(elevel+2))
         %return

F77op(EDECR):
        Int Binary Op (ISUBST)
        %return


F77op(ELOADB):
        Elevel=Elevel-1
        %if stk(Elevel+1)_Form&31=Regval %Start
           reg1 = stk(Elevel+1)_reg
           Op RR(MOVi,R6,reg1)
        %finishelsestart
           reg1 = Load Int(MOVi,stk(Elevel+1),R6)
        %finish
        ruse(R6)=0; rmem(R6)=0
        OptR6=1
        stk(Elevel+1)_Form=Regvar
        %return

F77op(ESTOREB):
        Stackr(R6)
        Epromote(2)
        Eop(Estore)
        %return

F77op(EINCRB):
        Elevel=Elevel-1
        Op RX(ADDi,R6,Stk(Elevel+1))
        %return

F77Op(EDECRB):
        Elevel=Elevel-1
        Op RX(SUBi,R6,STK(Elevel+1))
        %return

        
%end;! Ef77op

%externalroutine Epasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal
!***********************************************************************
        Abort
%end;! Epasop

%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C
!***********************************************************************
        Abort
%end;! Eccop


%routine Expcall(%integer Proc)
!***********************************************************************
!* call an exponentiation routine
!***********************************************************************
%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)=0(*)
%integer I,J,T
%string(31) S
        T=Expproctype(Proc)
        J=Expprocref(Proc)
        %if J=0 %start
          S=Expprocs(Proc)
          J=Exname(T,S)
          Expprocref(Proc)=J
        %finish
        I=Expprocpdesc(Proc)>>16
!        Elevel=Elevel+I         { access thru Epower does not drop Elevel }
        %while I>0 %cycle
          Eop(PUSHVAL)
          I=I-1
        %repeat
        I=Expprocpdesc(Proc)
        Ecall(J,I>>16,I&X'FF')
        %if T&7#0 %then Estkresult(0,T&7,(T>>8)&255) { function }
%end;! Expcall

%externalroutine Spcall(%integer Proc)
!***********************************************************************
!* call a support procedure
!***********************************************************************
%conststring(9)%array Spprocs(0:13)= %c
        "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv"  ,
        "f_cddiv"  ,"f_cqdiv"  ,"f_index"  ,"f_concat",
        "f_cpstr"  ,"f_cpystr" ,"f_nint"   ,"f_idnint",
        "f_ishftc3","f_ibits"

%constintegerarray Spprocpdesc(0:13)= %c
        X'3000C',X'3000C',X'3000C',X'3000C',
        X'3000C',X'3000C',X'40010',X'40010',
        X'50014',x'40010',X'10004',X'10004',
        x'3000C',x'3000C'

%ownintegerarray Spprocref(0:13)=0(*)
%integer I,J
%string(31) S
        J=Spprocref(Proc)
        %if J=0 %start
          S = Spprocs(Proc)
          J=EXname(0,S)
          Spprocref(Proc)=J
        %finish
        I=Spprocpdesc(Proc)>>16  { NumPars }
        Elevel=Elevel+I
        %while I>0 %cycle
          Eop(PUSHVAL)
          I=I-1
        %repeat
        I=Spprocpdesc(Proc)
        Ecall(J,I>>16,I&X'FF')
        %if proc = 12 %or proc=13 %start 
           Estkresult(0,0,4)
        %finish
%end;! Spcall

%endoffile