!* modified 12/03/86
!*
{\VAX}%include "ftn_ht"
{\VAX}%include "ftn_fmts1"
{\VAX}%include "ftn_consts2"
{\VAX}%include "ftn_triadops1"
{\VAX}%include "ebits_ecodes1"
{\VAX}%include "ebits_especs1"
!*
!{VAX}%include "ht.inc"
!{VAX}%include "fmts1.inc"
!{VAX}%include "consts1.inc"
!{VAX}%include "triadops1.inc"
!{VAX}%include "ecodes1.inc"
!{VAX}%include "especs1.inc"
!*
%constinteger Maxelevel=8 
!*
!******************************** EXPORTS ***************************
!*
%routinespec Codegen(%integer Cgenep,%record(Triadf)%arrayname Triads,
                     %integer Comad)
!*
!*********************************************************************
!%systemroutinespec Dump(%integer Ad,Len)
!*
%externalintegerfnspec Alloc Char(%integer L,Ad,%integername IIN)
%externalintegerfnspec Alloc Const(%integer Resw,%integername IIN)
%externalintegerfnspec Scalar Space(%integer Len,%integername IIN)
%externalintegerfnspec Dict Space(%integer Length)
%externalroutinespec Init End(%integer Comad,Info)
%externalroutinespec Subprogend(%integer Action,Epilogue)
%externalroutinespec Finish(%integer Mode)
%externalroutinespec Ifault(%integer Er,Val)
!*
!****************************
!*   Pseudo - Operations    *
!****************************
!*
%externalroutinespec Ldstkaddr(%integer Offset)
%externalroutinespec Ldstk(%integer Offset,Bytes)
%externalroutinespec Ststk(%integer Offset,Bytes)
!*
%externalroutinespec Syscall(%integer Proc)
%externalroutinespec Intrincall(%integer Ref,Index,Mode)
%externalroutinespec Alloc Temp(%record(TMPF)%name Tmp)
%externalintegerfnspec Vtaddr(%integer Ad)
%externalintegerfnspec Dtaddr(%integer Ad)
!*
%owninteger Linest
%owninteger Listcode
%owninteger Boundchecks
%owninteger Anychecks
%owninteger Unasschecks
%owninteger Argchecks
%owninteger Charchecks
%owninteger Error Plab
%owninteger Unass Plab, Bound Plab
%owninteger Proc Parlist
%owninteger Addrcom
%owninteger Tctbase,Tctsize
%owninteger Initdone
%owninteger Thisprocid
!*
%owninteger Elevel
%ownintegerarray Edesc(0:16)
!*
%ownintegerarray Tempst(0:15)
%owninteger Etempst
!*
%ownintegerarray Jlkprocs(0:15)
!*
!*****************************************************************************
!*
!*
%CONSTINTEGER UNASSFAULT=401
%CONSTINTEGER CHARFAULT=411
%CONSTINTEGER INCRFAULT=415
%CONSTINTEGER FMTLABFAULT=405
%CONSTINTEGER NEGUNITFAULT=424
%CONSTINTEGER BOUNDFAULT=406
%CONSTINTEGER ASIZEFAULT=408
%CONSTINTEGER CSIZEFAULT=412
%CONSTINTEGER RECURSEFAULT=418
%CONSTINTEGER ASSLABELFAULT=404
%CONSTINTEGER ARGFAULT=422
!*
%CONSTINTEGER MAXCHARSIZE=X'7FFF'
!*
%constbyteintegerarray ModetoType(0:15)= %c
      1,1,1,2,2,2,3,3,3,4,4,4,4,5,5,1
!*
%constbyteintegerarray Sizecode(0:15) = 0(3),0,1,2,0,1,2,0(7)
!*
%constbyteintegerarray Arith Class(0:15) = %c
      1, 1,32, 2, 4,64, 8, 8,32, 1, 1, 1,32,16,16, 1
!*
%constinteger INTCLASS  =  1
%constinteger R4CLASS   =  2
%constinteger R8CLASS   =  4
%constinteger CXCLASS   =  8
%constinteger CHARCLASS = 16
%constinteger ILLEGAL   = 32
%constinteger R16CLASS  = 64
!*
%constinteger Powbase = 53 
!*
%constbyteintegerarray Ioid(0:6)=  %C
   F77IOA,F77IOB,F77IOC,F77IOD,F77IOE,F77IOF,F77IOG
!*
%conststring(6)%array Intrprocs(0:27) = "",
   "IABS"  ,"ABS"   ,"MOD"   ,"AMOD"  ,
   "ISIGN" ,"SIGN"  ,"NINT"  ,"AINT"  ,
   "ANINT" ,"IDIM"  ,"DIM"   ,"DINT"  ,
   "DNINT" ,"IDNINT","DABS"  ,"DMOD"  ,
   "DSIGN" ,"DDIM"  ,"DPROD" ,"AIMAG" ,
   "CONJG" ,"LEN"   ,"INDEX" ,"LGE"  ,
   "LGT"   ,"LLE"   ,"LGE"  
!*
%conststring(6)%array Gen Name(0:61) = "",
   "sqrt"  ,"exp"   ,"log"   ,"log10" ,   
   "sin"   ,"cos"   ,"tan"   ,"cot"   ,   
   "asin"  ,"acos"  ,"atan"  ,"atan2" ,   
   "sinh"  ,"cosh"  ,"tanh"  ,""      ,   
   ""      ,"cabs"  ,"cdabs" ,"abs"   ,   
   "lge"   ,"lgt"   ,"lle"   ,"llt"   ,   
   "dsqrt" ,"dexp"  ,"dlog"  ,"dlog10",   
   "dsin"  ,"dcos"  ,"dtan"  ,"dcot"  ,   
   "dasin" ,"dacos" ,"datan" ,"datan2",   
   "dsinh" ,"dcosh" ,"dtanh" ,""      ,   
   "csqrt" ,"cexp"  ,"clog"  ,""      ,   
   "csin"  ,"ccos"  ,"cdsqrt","cdexp" ,   
   "cdlog" ,""      ,"cdsin" ,"cdcos" ,   
   "powii" ,"powri" ,"powdi" ,"powci" ,   
   "powzi" ,"powrr" ,"powdd" ,"powcc" ,   
   "powzz"                                
!*
!***********************************************************************
!*
%externalroutine Codegen(%integer Cgenep,
                        %record(Triadf) %arrayname Triads,
                        %integer Comad)
%routinespec Load Address(%integer Resw)
%routinespec Rterror(%integer Jumpop,Err)
%routinespec Arithmetic If
%integerfnspec New Plab
%routinespec Computed Goto(%integer List,Mode)
%routinespec Assigned List
%routinespec Declare Plab(%integer Ptr)
%integerfnspec Get Label(%integer Resw)
%routinespec Load Val(%integer Resw)
%routinespec Store Val(%integer Resw,Eopcode)
%routinespec Coerce(%integer Oldmode,Newmode)
%integerfnspec Locate arrel(%integer Resw,%integername IIN,Disp)
!*
%owninteger Adict,Anames,Control,Options1,Options2
%owninteger Curop,Lastop
%owninteger I,J,K,L, Op, Next Triad, Save Triad
%owninteger Nextpp
%owninteger Atriads
%owninteger Lineno Word
%owninteger Epilogue,IIN,Disp
%owninteger Errlab,Endlab,Iostatvar,IolabA,IolabB,Ioproc
%owninteger Iomarkers,Ioindex,Ioform,Iotype,Ioinit
%owninteger Mode,Condmask
%owninteger Iodsnum,Vret
%owninteger Assigned Gotos,Assigned Labs,Next Ass Lab
%ownrecord(Comfmt)%name Com
%record(Triadf)%name Tr,Tr1
%record(Labrecf)%name Labrec
%record(Resf) Res1
%record(Resf) Res2
%record(Srecf)%name SS
!*
%byteintegerarray Tplate(0:257)
%integer Nexttplate
!*
%integerfn Addr Triad(%integer Index)
      %result=addr(Triads(Index))
%end;! Addr Triad
!*
%routine Abort(%integer I)
      printstring("
*** Expression stack error")
      write(i,1)
      newline
      %monitor
      %stop
%end;! Abort
!*
%routine Etrace(%integer Eproc)
printstring("
***Etrace")
write(Eproc,1)
write(Elevel,1)
write(Com_Codeca,1)
newline
%end;! Etrace
!*
!*
!***********************************************************************
!* routines to process register and TMPID records                      *
!*                           -  claim                                  *
!*                              release                                *
!*                              alloc temp stack locations             *
!***********************************************************************
!*
!*
%integerfn Get Cxtemp(%integer Mode)
!***********************************************************************
!* Return a result descriptor for a permid describing a complex temp   *
!***********************************************************************
%record(RESF) R
%record(TMPF)%name Tmp
%integer J
      J=Dictspace(TMPRECSIZE)
      Tmp==record(Adict+J)
      Tmp_Mode=Mode
      Tmp_Reg=0
      Alloc Temp(Tmp)
      R_Mode=Mode
      R_Form=PERMID
      R_H0=J>>DSCALE
      %result=R_W
%end;! Get Cxtemp
!*
%integerfn Get Etemp(%integer Mode)
!***********************************************************************
!* Return a result descriptor describing the item at the top of Estack *
!***********************************************************************
%record(Resf) R
%record(Tmpf)%name Tmp
%integer J,Erec
      Elevel=Elevel+1
!Etrace(1)
      J=Tempst(Mode)
      %if J=0 %then J=Dictspace(TMPRECSIZE)
      Tmp==record(Adict+J)
      Tempst(Mode)=Tmp_Link1
      Tmp_Mode=Mode
      Tmp_Reg=1
      R_Mode=Mode
      R_Form=TMPID
      R_H0=J>>DSCALE
      Edesc(Elevel)=R_W
      %result=R_W
%end;! Get Etemp
!*
%routine Free Etemp(%integer Resw)
%record(Tmpf)%name Tmp
%integer Arec
%record(RESF) R
      R_W=Resw
      Arec=R_H0<<DSCALE
      Tmp==record(Adict+Arec)
      Tmp_Link1=Tempst(R_Mode)
      Tempst(Tmp_Mode)=Arec
      Tmp_Reg=0
%end;! Free Etemp
!*
%routine Pop Estack
%integer I
      I=Elevel
      %unless 0<I<=Maxelevel %then Abort(1)
      Store Val(Edesc(I),ESTORE)
      Elevel=I-1
%end;! Pop Estack
!*
%routine Clear Estack
      %while Elevel>0 %cycle
         Pop Estack
      %repeat
%end;! Clear Estack
!*
%routine Promote(%integer Lev)
%integer I,J
      %unless 0<Lev<Elevel %then Abort(7)
      I=Edesc(Lev)
      %cycle J=Lev,1,Elevel-1
         Edesc(J)=Edesc(J+1)
      %repeat
      Edesc(Elevel)=I
      Epromote(Elevel-Lev+1)
%end;! Promote
!*
%routine Cvthi
      Estklit(4)
      Eop(CVTII)
%end;! Cvthi 
!*
%routine Get Operand Pair(%integer Reslw,Resrw)
%record(Resf) Resl,Resr
%record(Tmpf)%name Tmp
%integer Lhslevel,Rhslevel,Level
      %unless 0<=Elevel<=7 %then Clear Estack
!*
      Resl_W=Reslw
      Resr_W=Resrw
!*
      %if Resl_Form=TMPID %thenstart
         Tmp==record(Adict+Resl_H0<<DSCALE)
         Lhslevel=Tmp_Reg
         %if Lhslevel#0 %thenstart
            %unless Elevel>0 %then Abort(2)
            %cycle Level=1,1,Elevel
               %if Edesc(Level)=Reslw %then Lhslevel=Level %and ->Lhsdone
            %repeat
            Abort(3)
         %finish
      %finishelse Lhslevel=0
Lhsdone:
      %if Resr_Form=TMPID %thenstart
         Tmp==record(Adict+Resr_H0<<DSCALE)
         Rhslevel=Tmp_Reg
         %if Rhslevel#0 %thenstart
            %unless Elevel>0 %then Abort(2)
            %cycle Level=1,1,Elevel
               %if Edesc(Level)=Resrw %then Rhslevel=Level %and ->Rhsdone
            %repeat
            Abort(3)
         %finish
      %finishelse Rhslevel=0
Rhsdone:
      %if Lhslevel#0 %thenstart
         %if Rhslevel#0 %thenstart
            Free Etemp(Reslw)
            Free Etemp(Resrw)
            Level=Elevel
            Elevel=Elevel-2
            %if Rhslevel=Level %thenstart
               %if Lhslevel=Level-1 %then %return
               Elevel=Elevel+2
               Promote(Lhslevel)
               Elevel=Elevel-2
               Eop(EXCH)
               %return
            %finish
            %if Lhslevel=Level %thenstart
               %if Rhslevel=Level-1 %then Eop(EXCH) %and %return
               Elevel=Elevel+2
               Promote(Rhslevel)
               Elevel=Elevel-2
               %return
            %finish
         %finishelsestart
            %if Lhslevel#Elevel %then Promote(Lhslevel)
            Load Val(Resrw)
            Elevel=Elevel-1
            Free Etemp(Reslw)
         %finish
      %finishelsestart
         %if Rhslevel#0 %thenstart
            %if Rhslevel#Elevel %then Promote(Rhslevel)
            Load Val(Reslw)
            Eop(EXCH)
            Elevel=Elevel-1
            Free Etemp(Resrw)
         %finishelsestart
            Load Val(Reslw)
            Elevel=Elevel+1
            Edesc(Elevel)=0
            Load Val(Resrw)
            Elevel=Elevel-1
         %finish
      %finish
%end;! Get Operand Pair
!*
%routine Get Operand(%integer Reslw)
      %unless 0<=Elevel<=7 %then Clear Estack
!*
      Load Val(Reslw)
!*
%end;! Get Operand
!*
!***********************************************************************
!* routines to save and extract 'result descriptors' from triads       *
!***********************************************************************
!*
%routine Save Res(%integer Resw)
!***********************************************************************
!* save r.d. in the current triad                                      *
!***********************************************************************
%record(TMPF)%name Tmp
%record(RESF) R
%integer I,Reg
      R_W=Resw
      I=Savetriad
      %if Triads(I)_Use>1 %and R_Form=TMPID %thenstart
         Tmp==record(Adict+R_H0<<DSCALE)
         R_Form=PERMID
         Store Val(R_W,ESTORE)
         Elevel=Elevel-1
      %finish
      Triads(I)_Res1_W=R_W
      Triads(I)_Op=REPL;! to indicate that _Res1 is replacement for this triad
%end;! Save Res
!*
%integerfn Conout(%integer Resw)
%record(Resf) R
%record(Constrecf)%name Con
      R_W=Resw
      %if R_Form=NULL %then %result=0
      %IF R_Form=LIT %then %result=R_H0
      %IF R_Form=NEGLIT %then %result=-R_H0
      Con==record(Com_Adict+R_H0<<DSCALE)
      %result=integer(Com_Adict+Con_Daddr)
%end;! Conout
!*
%integerfn Extriad(%integer Resw)
!***********************************************************************
!* called when referenced item is a triad containing an r.d.           *
!***********************************************************************
%record(Resf) R
      R_W=Resw
      %unless R_Form=TRIAD %then %result=Resw
      %result=Triads(R_H0)_Res1_W
%end;! Extriad
!*
!***********************************************************************
!*
!*
%routine Load Address(%integer Resw)
%Record(Resf) R
%record(Tmpf)%name Tmp
%record(Precf)%name PP
!*
%integer Bytes,IIN
%integer Disp,Ad,Level,Adid
%SWITCH F(0:66)
Loop: R_W=Resw
      Bytes=ModetoBytes(R_Mode)
      PP==record(Adict+R_H0<<DSCALE)
      ->F(R_Form)
!*
F(NEGLIT):
!*
F(LIT):
!*
F(CNSTID):
      Disp=Alloc Const(Resw,IIN)
      Estkaddr(IIN,Disp,0,Bytes)
Clear:%return
!*
F(TRIAD):
      Resw=Extriad(Resw)
      ->Loop
!*
F(PERMID):
!*
F(TMPID):
      Tmp==record(Adict+R_H0<<DSCALE)
      %if Tmp_Addr=0 %then Alloc Temp(Tmp)
      Ad=Tmp_Addr
      %if Tmp_Reg#0 %thenstart
         %unless Elevel>0 %then Abort(6)
         %cycle Level=1,1,Elevel
            %if Edesc(Level)=Resw %thenstart
               %unless Level=Elevel %then Promote(Level)
               Pop Estack
               ->Locad
            %finish
         %repeat
         Abort(7)
      %finish
Locad:Ldstkaddr(Ad)
      ->Clear
!*
F(STKLIT):
      Ad=R_H0
      ->Locad
!*
F(VALTEMP):
      Ad=Vtaddr(R_H0<<DSCALE)
      ->Locad
!*
F(DESTEMP):
      Ad=Dtaddr(R_H0<<DSCALE)
      Estkdir(SCALARS,Ad,0,4)
      ->Clear
!*
F(PSCALID):
      IIN=PP_IIN
      Ad=PP_Addr4
      %if IIN=0 %thenstart
         Ldstk(Ad,4)
      %finishelse Estkdir(IIN,Ad,Com_Anames+PP_Iden,4)
      ->Clear
!*
F(PROCID):
!*
F(LSCALID):
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(OSCALID):
      IIN=PP_IIN
      AD=PP_Addr4
      %if IIN=0 %then ->Locad
      Adid=Com_Anames+PP_iden
Gref: Estkaddr(IIN,Ad,Adid,Bytes)
      ->Clear
!*
F(GLALIT):
      Ad=R_H0
      IIN=SCALARS
      ->Gref
!*
F(ARRID):
!*
F(ARREL):
      %if Locate Arrel(Resw,IIN,Ad)#0 %then Eop(EADDRESS) %and %return;! @ on Estack
      Adid=0
      ->Gref;! fixed ref
!*
F(*):
      %return
%end;! Load Address
!*
%routine Load Val(%integer Resw)
%record(Resf) R
%record(Precf)%name PP
%record(Tmpf)%name Tmp
%record(Constrecf)%name Con
%integer D,IIN,Form
%integer P,Op,Level,Bytes,Adid
%switch F(0:66)
Loop: R_W=Resw
      Form=R_Form
      D=R_H0<<Dscale
      Bytes=ModetoBytes(R_Mode)
      ->F(R_Form)
!*
F(LIT):
!*
F(NEGLIT):
!*
F(CNSTID):
      %if R_Mode<=INT4 %thenstart
         Estklit(Conout(Resw))
         %if R_Mode=INT2 %thenstart
            Estklit(2)
            Eop(Esize)
         %finish
      %finishelsestart
         %if Target=Gould %thenstart
            Estklit(Conout(Resw))
            %return
         %finish
         Disp=Alloc Const(Resw,IIN)
         Estkdir(IIN,Disp,0,Bytes)
      %finish
      %return
!*
F(TRIAD):
      Resw=Extriad(R_W)
      ->LOOP
!*
F(BREG):
!!      Op1(LLR0);! will not be used until Release 2
      %return
!*
F(PERMID):
!*
F(TMPID):
      Tmp==record(Adict+D)
      %if Tmp_Reg#0 %thenstart
         %unless 0<Elevel %then Abort(6)
         %cycle Level=1,1,Elevel
            %if Edesc(Level)=Resw %thenstart
               %unless Level=Elevel %then Promote (Level)
               Edesc(Elevel)=0
               Elevel=Elevel-1
               Free Etemp(Resw)
               %return
            %finish
         %repeat
         Abort(8)
      %finish
      %if Form=TMPID %then Free Etemp(Resw)
Ldtmp:D=Tmp_Addr
      ->Local
!*
F(STKLIT):
      D=R_H0  {no scaling}
Local:Ldstk(D,Bytes)
      %return
!*
F(VALTEMP):
      D=Vtaddr(D)
      ->Local
!*
F(DESTEMP):
      D=Dtaddr(D)
      Estkdir(SCALARS,D,0,4)
      ->Geta
!*
F(PSCALID):
      PP==record(Adict+D)
      D=PP_Addr4
      IIN=PP_IIN
      Adid=Com_Anames+PP_Iden
      Estkind(IIN,D,Adid,Bytes)
      ->Test
!*
F(PROCID):   ! fn value
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(LSCALID):
!*
F(OSCALID):
      PP==record(Adict+D)
      D=PP_Addr4
      IIN=PP_IIN
      %if IIN=0 %then ->Local
      Adid=Com_Anames+PP_Iden
Get:  Estkdir(IIN,D,Adid,Bytes)
Test: %if Bytes>=4 %and Com_F77parm&4=0 %then Eop(UCHECK)
      %return
!*
F(GLALIT):
      D=R_H0
      IIN=SCALARS
      Adid=0
      ->Get
!*
F(ARREL):
      Adid=0
      %if Locate Arrel(Resw,IIN,D)=0 %then ->Get;! known address (else @ on Estack)
Geta: ->Test
!*
F(*): %monitor
      %stop
!*
%end;! Load Val
!*
%routine Store Val(%integer Resw,Eopcode)
%record(RESF) R
%record(PrecF)%name PP
%record(TMPF)%name Tmp
%integer D,IIN,Bytes,Adid
%switch F(0:66)
      R_W=Resw
      D=R_H0<<Dscale
      Bytes=ModetoBytes(R_Mode)
      Adid=0
      ->F(R_Form)
!*
F(PERMID):
!*
F(TMPID):
      Tmp==record(Adict+D)
      %if Tmp_Addr=0 %then Alloc Temp(Tmp)
      Tmp_Reg=0
      D=Tmp_Addr
      ->Local
!*
F(BREG):
!      Op1(SLR0);! only used in Release 2
      %return
!*
F(STKLIT):
      D=R_H0   {no scaling}
Local:Ststk(D,Bytes)
      %return
!*
F(VALTEMP):
      D=Vtaddr(D)
      ->Local
!*
F(DESTEMP):
      D=Dtaddr(D)
      Estkdir(SCALARS,D,0,4)
      ->Puta
!*
F(PSCALID):
      PP==record(Adict+D)
      D=PP_Addr4
      IIN=PP_IIN
      Adid=Com_Anames+PP_Iden
      Estkind(IIN,D,Adid,Bytes)
      Eop(Eopcode)
      %return
!*
F(PROCID):    ! fn value
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(LSCALID):
!*
F(OSCALID):
      PP==record(Adict+D)
      D=PP_Addr4
      IIN=PP_IIN
      %if IIN=0 %then ->Local
      Adid=Com_Anames+PP_Iden
Put:  Estkdir(IIN,D,Adid,Bytes)
      Eop(Eopcode)
      %return
!*
F(GLALIT):
      D=R_H0
      IIN=SCALARS
      ->Put
!*
F(ARREL):
      %if Locate Arrel(Resw,IIN,D)=0 %then ->Put;! known @
Puta: Eop(Eopcode)
      %return
!*
F(*):
      %monitor
      %stop
%end;! Store Val
!*
%routine Load Short(%integer Resw)
%record(RESF) R
      Resw=Extriad(Resw)
      R_W=Resw
      %if Modetobytes(R_Mode)>2 %thenstart
         %if R_Form=Lit %thenstart
            Estklit(R_H0)
         %finishelsestart
            Load Val(Resw)
         %finish
         Coerce(R_Mode,INT2)
      %finishelse Load Val(Resw)
%end;! Load Short
!*
%routine Load Int(%integer Resw)
%record(RESF) R
      Resw=Extriad(Resw)
      R_W=Resw
      Load Val(Resw)
      %if R_Mode#INT4 %then Coerce(R_Mode,INT4)
%end;! Load Int
!*
%routine Load Cx Addr(%integer Resw)
      Load Address(Resw)
      Elevel=Elevel+1
      Edesc(Elevel)=0
%end;! Load Cx Addr
!*
!***********************************************************************
!*                                                                     *
!*          C H A R A C T E R   H A N D L I N G                        *
!*                                                                     *
!***********************************************************************
!*
%integerfnspec Get Charlen(%integer Resw,%integername Len)
%integerfnspec Get Charad(%integer Resw,Single,%integername IIN,Disp,Len)
!*
%routine Load Charlen(%integer Resw)
%integer L
      %if Get Charlen(Resw,L)=0 %then Estklit(L)
%end;! Load Charlen
!*
%routine Load Charad(%integer Resw,Single)
!* Single # 0  stack single char const as a literal
%integer IIN,Disp,L
      %if Get Charad(Resw,Single,IIN,Disp,L)=0 %thenstart
         Estkaddr(IIN,Disp,0,0)
      %finishelse Eop(EADDRESS)
%end;! Load Charad
!*
%integerfn Get Chartemp(%integer Len)
%record(Resf) R
%record(Tmpf)%name Tmp
%integer Ad,IIN,J
      %if Len=0 %then Len=X'7FFF'
      J=Dictspace(TMPRECSIZE)
      Tmp==record(Adict+J)
      Tmp_Mode=CHARMODE
      Tmp_Len=Len
      Tmp_Index=Com_Nexttemp
      Com_Nexttemp=Com_Nexttemp+1
      Tmp_Addr=Alloc Char(Len,0,IIN)
      R_H0=J>>DSCALE
      R_Mode=CHARMODE
      R_Form=PERMID
      %result=R_W
%end;! Get Chartemp
!*
%routine Concat List(%integer Head,Mode)
!* Head  => triad chain of concat items
!* Mode  =  0  concat to temp
!*       =  1  assignment
%integer I,J,K,Len,Disp,Start
%record(Triadf)%name Tr
      I=0;! no of entries
      K=Com_Glaca;! @ of table
      Start=K
      J=Head
      %while J#0 %cycle;! to reserve total space required to avoid possible error
         Tr==record(Addr(Triads(J)))
         J=Tr_Opd1
         Com_Glaca=Com_Glaca+8
      %repeat
      J=Head
      %while J#0 %cycle
         I=I+1
         Tr==record(Addr(Triads(J)))
         J=Tr_Opd1
         Load Charad(Tr_Res2_W,0)
         Estkdir(GLA,K,0,4)
         Eop(ESTORE)
         Load Charlen(Tr_Res2_W)
         Estkdir(GLA,K+4,0,4)
         Eop(ESTORE)
         K=K+8
      %repeat
      Estkaddr(GLA,Start,0,0)
      Estklit(I)
%end;! Concat List
!*
%integerfn Max Charlen(%integer Resw,%integername Len)
!***********************************************************************
!* result = 0  max character length set in Len                         *
!*          1  length unknown at compile time                          *
!***********************************************************************
%record(Precf)%name PP
%record(Tmpf)%name Tmp
%record(Constrecf)%name Con
%record(Dtrecf)%name Dt
%record(Triadf)%name Tr,Tr2
%record(Resf) R
%integer Lbound,Ubound,A,I,J,K,L
%switch F(0:66)
      Len=0
      R_W=Resw
Loop: A=R_H0
      ->F(R_Form)
!*
F(CNSTID):
      Con==record(Adict+A<<DSCALE)
      Len=integer(Adict+Con_Daddr)
      %result=0
!*
F(TRIAD):
      TR==record(Addr(Triads(A)))
!*
      %if Tr_Op=REPL %then R_W=Tr_Res1_W %and ->Loop
!*
      %if Tr_Op=CHAR %thenstart;! substring
         %if Tr_Qopd2=NULL %thenstart
Set:        %result=Max Charlen(Tr_Res1_W,Len)
         %finish
         Tr2==record(Addr(Triads(Tr_Opd2)))
         %if Tr2_Res2_W=0 %thenstart
            I=Max Charlen(Tr_Res1_W,Ubound)
         %finishelsestart
            %if Tr2_Qopd2&CONSTMASK#0 %thenstart
               Ubound=Conout(Tr2_Res2_W)
               I=0
            %finishelse I=1
         %finish
         %if Tr2_Res1_W=0 %thenstart
            Lbound=1
         %finishelsestart
            %if Tr2_Qopd1&CONSTMASK#0 %thenstart
               Lbound=Conout(Tr2_Res1_W)
            %finishelse ->Set
         %finish
         %if I=0 %thenstart
            Len=Ubound-Lbound+1
            %result=0
         %finishelse ->Set
      %finish
!*
      %monitor
      %stop
!*
F(TMPID):
!*
F(PERMID):
      Tmp==record(Adict+A<<DSCALE)
      Len=Tmp_Len
      %result=0
!*
F(DESTEMP):
      %result=1
!*
F(PROCID):
!*
F(LSCALID):
!*
F(PSCALID):
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(OSCALID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      %if Len#0 %then %result=0 %else %result=1
!*
F(ARREL):
      Tr==record(addr(Triads(A)))
      %if Tr_Qopd1=DESTEMP %then R_W=Tr_Res1_W %and ->Loop
      PP==record(Adict+Tr_Opd1<<DSCALE)
Alen: Len=PP_Len
      %if Len#0 %then %result=0 %else %result=1
!*
F(ARRID):
      PP==record(Adict+A<<DSCALE)
      ->Alen
!*
F(*):
      %monitor
      %stop
!*
%end;! Max Charlen
!*
%integerfn Get Charlen(%integer Resw,%integername Len)
!***********************************************************************
!* result = 0  character length set in Len                             *
!*          1  length unknown at compile time - set on Etos            *
!***********************************************************************
%record(Precf)%name PP
%record(Arraydvf)%name Dvrec
%record(Tmpf)%name Tmp
%record(Constrecf)%name Con
%record(Dtrecf)%name Dt
%record(Triadf)%name Tr,Tr2
%record(Resf) R
%integer Lbound,Ubound,A,I,J,K,L
%switch F(0:66)
      Len=0
      R_W=Resw
Loop: A=R_H0
      ->F(R_Form)
!*
F(CNSTID):
      Con==record(Adict+A<<DSCALE)
      Len=integer(Adict+Con_Daddr)
      %result=0
!*
F(TRIAD):
      TR==record(Addr(Triads(A)))
!*
      %if Tr_Op=REPL %then R_W=Tr_Res1_W %and ->Loop
!*
      %if Tr_Op=CHAR %thenstart;! substring
         %if Tr_Qopd2=NULL %then %result=Get Charlen(Tr_Res1_W,Len)
         Tr2==record(Addr(Triads(Tr_Opd2)))
         %if Tr2_Res2_W=0 %thenstart
            I=Get Charlen(Tr_Res1_W,Ubound)
         %finishelsestart
            %if Tr2_Qopd2&CONSTMASK#0 %thenstart
               Ubound=Conout(Tr2_Res2_W)
               I=0
            %finishelsestart
               Load Int(Tr2_Res2_W)
               I=1
            %finish
         %finish
         %if Tr2_Res1_W=0 %thenstart
            Lbound=1
         %finishelsestart
            %if Tr2_Qopd1&CONSTMASK#0 %thenstart
               Lbound=Conout(Tr2_Res1_W)
            %finishelsestart
               %if I=0 %thenstart
                  Estklit(Ubound+1)
                  Load Int(Tr2_Res1_W)
                  Eop(ISUB)
               %finishelsestart 
                  Load Int(Tr2_Res1_W)
                  Eop(ISUB)
                  Estklit(1)
                  Eop(IADD)
               %finish
               %result=1
            %finish
         %finish
         %if I=0 %thenstart
            Len=Ubound-Lbound+1
            %result=0
         %finishelsestart
            %if Lbound#1 %thenstart
               Estklit(Lbound-1)
               Eop(ISUB)
            %finish
            %result=1
         %finish
      %finish
!*
      %if Tr_Op=CHHEAD %thenstart;! concat list
         Len=0
         K=0
         J=A
         %while J#0 %cycle
            Tr2==record(Addr(Triads(J)))
            J=Tr2_Opd1
            %if Get Charlen(Tr2_Res2_W,L)=0 %thenstart;! known length
               Len=Len+L
            %finishelsestart;! on Estack
               %if K=0 %then K=1 %else Eop(IADD)
            %finish
         %repeat
         %if K=0 %then %result=0;! total length known
         %if Len#0 %thenstart
            Estklit(Len)
            Eop(IADD)
         %finish
         %result=1
      %finish
!*
      %monitor
      %stop
!*
F(TMPID):
!*
F(PERMID):
      Tmp==record(Adict+A<<DSCALE)
      Len=Tmp_Len
      %result=0
!*
F(DESTEMP):
      A=Dtaddr(A<<DSCALE)
      Estkdir(SCALARS,A+4,0,4)
      %result=1
!*
F(STFNID):
!*
F(PROCID):
!*
F(LSCALID):
!*
F(PSCALID):
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(OSCALID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      %if Len#0 %then %result=0
      Estkdir(PP_IIN,PP_Addr4+4,0,4);! *(*) param or procid
      %result=1
!*
F(ARREL):
      Tr==record(addr(Triads(A)))
      %if Tr_Qopd1=DESTEMP %then R_W=Tr_Res1_W %and ->Loop
      PP==record(Adict+Tr_Opd1<<DSCALE)
Alen: Len=PP_Len
      %if Len#0 %then %result=0
      Dvrec==record(Adict+PP_Addr4)
      Estkdir(DVAREA,Dvrec_Addrdv+4,0,4);! *(*) array param
      %result=1
!*
F(ARRID):
      PP==record(Adict+A<<DSCALE)
      ->Alen
!*
F(*):
      %monitor
      %stop
!*
%end;! Get Charlen
!*
%integerfn Get Charad(%integer Resw,Single,%integername IIN,Disp,Len)
!***********************************************************************
!* locate (and evaluate if necessary) the character item or expression *
!* Single # 0  stack single char const as literal                      *
!* result = 0  compile-time location achieved                          * 
!*                - character is at Disp bytes from start of area IIN  *
!*          1  address               not available at compile-time     *
!*                - @ is held at Etos                                  *
!*                - if Len = 0 then length not available               *
!***********************************************************************
%routinespec Check
!*
%record(Precf)%name PP
%record(Arraydvf)%name Dvrec
%record(Tmpf)%name Tmp
%record(Constrecf)%name Con
%record(Dtrecf)%name Dt
%record(Triadf)%name Tr,Tr2
%record(Resf) R
%integer Lbound,Ubound,A,I,J,K,L
%switch F(0:66)
      Len=0
      R_W=Resw
Loop: A=R_H0
      ->F(R_Form)
!*
F(CNSTID):
      Con==record(Adict+A<<DSCALE)
      Len=integer(Adict+Con_Daddr)
      %if Len=1 %and Single#0 %thenstart;! stack as a literal
         Estklit(byteinteger(Adict+Con_Daddr+W1))
         Estklit(1)
         Eop(Esize)
         %result=1
      %finish
      Disp=Alloc Char(Len,Adict+Con_Daddr+W1,IIN)
      %result=0
!*
F(TRIAD):
      TR==record(AddrTriad(A))
!*
      %if Tr_Op=REPL %then R_W=Tr_Res1_W %and ->Loop
!*
      %if Tr_Op=CHAR %thenstart;! substring
         I=Get Charad(Tr_Res1_W,0,IIN,Disp,Len)
         %if Tr_Qopd2=NULL %then %result=I
         Tr2==record(Atriads+Tr_Opd2*TRIADLENGTH)
         %if Tr2_Res2_W#0 %thenstart
            %if Tr2_Qopd2&CONSTMASK=0 %thenstart
               Ubound=0
            %finishelse Ubound=Conout(Tr2_Res2_W)
            Len=Ubound
         %finishelse Ubound=Len
         %if Tr2_Res1_W#0 %thenstart
            %if Tr2_Qopd1&CONSTMASK#0 %thenstart
               Lbound=Conout(Tr2_Res1_W)
               %if Ubound=0 %then Len=0 %else Len=Ubound-Lbound+1
               %if I=0 %thenstart;! all is known
                  Disp=Disp+Lbound-1
                  %result=0
               %finishelsestart
                  %unless Lbound=1 %thenstart
                     Estklit(Lbound-1)
Adjust:              Eop(INDEX1)
                  %finish
                  %result=1
               %finish
            %finishelsestart
               Len=0
               %if I=0 %then Estkaddr(IIN,Disp,0,0)
               Load Int(Tr2_Res1_W)
               Estklit(1)
               Eop(ISUB)
               ->Adjust
             %finish
         %finishelse %result=I
      %finish
!*
      %if Tr_Op=CHHEAD %thenstart;! concat list
         Len=0
         K=0
         J=A
         %while J#0 %cycle
            Tr2==record(Addr(Triads(J)))
            J=Tr2_Opd1
            %if Max Charlen(Tr2_Res2_W,L)=0 %thenstart;! known length
               Len=Len+L
            %finishelsestart;! report error
               Ifault(342,Linest);! report illegal concat
               {assumed length not allowed here}
               %result=1
            %finish
         %repeat
         Disp=Alloc Char(Len,0,IIN)
         Concat List(A,0)
         Estkaddr(IIN,Disp,0,0)
         Estklit(Len)
         Syscall(F77CONCAT)
         Len=0;! only max length was obtained
         %result=0
      %finish
      %monitor
      %stop
!*
F(TMPID):
!*
F(PERMID):
      Tmp==record(Adict+A<<DSCALE)
      IIN=GST
      Len=Tmp_Len
      Disp=Tmp_Addr
      %result=0
!*
F(DESTEMP):
      A=Dtaddr(A<<DSCALE)
      Estkind(SCALARS,A,0,4)
      %result=1
!*
F(STFNID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      R_W=PP_Addr4
      ->Loop
!*
F(LSCALID):
!*
F(PSCALID):
!*
F(ASCALID):
!*
F(CSCALID):
!*
F(OSCALID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      %if PP_Class&1#0 %thenstart;! parameter
         Estkind(PP_IIN,PP_Addr4,Com_Anames+PP_Iden,4)
         %result=1
      %finishelsestart
         IIN=PP_IIN
         Disp=PP_Addr4
         %result=0
      %finish
!*
F(ARREL):
      Tr==record(addr(Triads(A)))
      %if Tr_Qopd1=DESTEMP %then R_W=Tr_Res1_W %and ->Loop
      PP==record(Adict+Tr_Opd1<<DSCALE)
      Len=PP_Len
      Dvrec==record(Adict+PP_Addr4)
      %if PP_Class&1#0 %thenstart
         Estkind(DVAREA,Dvrec_Addrdv-4,0,4)
         Elevel=Elevel+1
         Load Int(Tr_Res2_W)
         Elevel=Elevel-1
         Check
         ->Adjust
      %finishelsestart
         %if Tr_Qopd2&CONSTMASK#0 %thenstart
            Disp=Conout(Tr_Res2_W)
            IIN=PP_IIN
            Disp=Disp+Dvrec_Addrzero
            %result=0
         %finishelsestart
            Estkaddr(PP_IIN,Dvrec_Addrzero,0,0)
            Elevel=Elevel+1
            Load Int(Tr_Res2_W)
            Elevel=Elevel-1
            Check
            ->Adjust
         %finish
      %finish
!*
F(ARRID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      Dvrec==record(Adict+PP_Addr4)
      Estkind(DVAREA,Dvrec_Addrdv,Com_Anames+PP_Iden,4)
      %result=1
!*
F(PROCID):
      PP==record(Adict+A<<DSCALE)
      Len=PP_Len
      Estkind(PP_IIN,PP_Addr4,Com_Anames+PP_Iden,4)
      %result=1
!*
F(*):
      %monitor
      %stop
!*
%routine Check
      %if Bound Checks=YES %and PP_Len#0 %thenstart
         %if PP_Class&X'80'=0 %thenstart;! exclude assumed size arrays
            %if PP_Class&X'40'=0 %thenstart
               Estklit(Dvrec_Zerotofirst*PP_Len)
               Estklit((Dvrec_Numels+Dvrec_Zerotofirst)*PP_Len-1)
            %finishelsestart
               Estkdir(DVAREA,Dvrec_Addrdv-8,0,4)
               Estklit(PP_Len)
               Eop(IMULT)
               Eop(DUPL)
               Estkdir(DVAREA,Dvrec_Addrdv+4,0,4)
               Eop(IADD)
               Estklit(1)
               Eop(ISUB)
            %finish
            Eop(CHK)
         %finish
      %finish
%end;! Check
!*
%end;! Get Charad 
!*
%integerfn Arrsub(%integer Resw)
!***********************************************************************
!* called when processing ARR or SUBS to ensure that subcript is       *
!* directly described in _RES2                                         *
!***********************************************************************
%record(Resf) R
      R_W=Resw
      %if Triads(R_H0)_Op=REPL %then %result=Triads(R_H0)_Res1_W
      %if R_Form=ARREL %thenstart
         Load Int(Resw)
      %finishelsestart
!         %unless Triads(R_H0)_Op=SUBS %thenstart
            %monitor
            %stop
!         %finish
      %finish
      %result=Get Etemp(INT4)
!*
%end;! Arrsub
!*
%integerfn Locate Arrel(%integer Resw,%integername IIN,Disp)
!***********************************************************************
!* result = 0  compile-time location identified at Disp in area IIN    *
!*          1  address on Estack                                       *
!*         -1  Disp is Resw for REPL value                             *
!***********************************************************************
%routinespec Zeroad
!%routinespec Check Sub(%record(Resf) R,%integer Index)
%record(Triadf)%name Tr
%record(Arraydvf)%name Dvrec
%record(Precf)%name Arrayrec
%record(Resf) R
%integer Bytes,Scale,Qopd2,Ind,Top
      R_W=Resw
!*
      %if R_Form=ARRID %thenstart
         Arrayrec==record(Adict+R_H0<<DSCALE)
         Dvrec==record(Adict+Arrayrec_Addr4)
         %if Arrayrec_Class&1#0 %thenstart;! param
            Estkind(DVAREA,Dvrec_Addrdv,0,4)
            %result=1
         %finishelsestart
            IIN=Arrayrec_IIN
            Disp=Dvrec_Adfirst
            %result=0
         %finish
      %finish
!*
      Tr==record(Atriads+R_H0*TRIADLENGTH)
      %if Tr_Qopd2=TRIAD %then Tr_Res2_W=Extriad(Tr_Res2_W)
      Bytes=ModetoBytes(R_Mode)
      Scale=Bytes
      Qopd2=Tr_Qopd2
      Top=0;! index on top normally
      %if Qopd2#NULL %thenstart
         Tr_Res2_W=Extriad(Tr_Res2_W)
         %if Tr_Qopd2=TMPID %thenstart
            Get Operand(Tr_Res2_W)
            Top=1
         %finish
      %finish
      %if Tr_Qopd1=ARRID %thenstart
         Arrayrec==record(Adict+Tr_Opd1<<DSCALE)
         Dvrec==record(Adict+Arrayrec_Addr4)
         %if Qopd2&CONSTMASK#0 %or Qopd2=NULL %thenstart
            Ind=Conout(Tr_Res2_W)
            %if Arrayrec_Class&1#0 %thenstart;! param array
               %if Ind=Dvrec_Zerotofirst %thenstart
                  Estkind(DVAREA,Dvrec_Addrdv,0,Bytes)
               %finishelsestart
                  Zeroad;! @ zero el
                  %if Ind#0 %thenstart
                     %if Scale#0 %then Ind=Ind*Scale
                     Estklit(Ind)
                     Eop(INDEX1)
                  %finish
               %finish
               %result=1;! @ evaluated
            %finishelsestart
               IIN=Arrayrec_IIN
               Disp=Dvrec_Addrzero+Ind*Bytes
               %result=0
            %finish
         %finish
         Zeroad
      %finishelsestart
         Load Address(Tr_Res1_W)
         %if Qopd2=NULL %then %result=1
         Top=0;! any index which was on Estack will have been stored
      %finish
!*
      %if Top=0 %then Load Int(Tr_Res2_W)
!*
      %if Bound Checks=YES %and Tr_Qopd1=ARRID %thenstart
         %if Top=1 %then Eop(EXCH) %and Top=0
         %if Arrayrec_Class&X'80'=0 %thenstart;! exclude assumed size arrays
            %if Arrayrec_Class&X'40'=0 %thenstart
               Estklit(Dvrec_Zerotofirst)
               Estklit(Dvrec_Numels+Dvrec_Zerotofirst-1)
            %finishelsestart
               Estkdir(DVAREA,Dvrec_Addrdv-8,0,4)
               Eop(DUPL)
               Estkdir(DVAREA,Dvrec_Addrdv+4,0,4)
               Eop(IADD)
               Estklit(1)
               Eop(ISUB)
            %finish
            Eop(CHK)
         %finish
      %finish
!*
      %if Top=1 %then Eop(EXCH)
      %if Scale<=1 %thenstart
         Eop(INDEX1)
      %finishelsestart
         %if Scale=2 %thenstart
            Eop(INDEX2)
         %finishelsestart
            %if Scale=4 %thenstart
               Eop(INDEX4)
            %finishelsestart
               %if Scale=8 %thenstart
                  Eop(INDEX8)
               %finishelsestart
                  Estklit(Scale)
                  Eop(INDEX)
               %finish
            %finish
         %finish
      %finish
      %result=1
!*
%routine Zeroad
     { %if Arrayrec_Class&1#0 %thenstart;! param array  }
         Estkind(DVAREA,Dvrec_Addrdv-4,0,Bytes)
     { %finishelsestart                                 }
     {    Efixi(LGA,Arrayrec_IIN,Dvrec_Addrzero)        }
     { %finish                                          }
%end;! Zeroad
%end ;! Locate Arrel
!*
%integerfn Set Address(%integer Resw,RefIIN,RefDisp,M)
!***********************************************************************
!* establish an address for Resw at the reference location             *
!* for character and byte scalars the address will be a byte address   *
!* for arrays the address will be to the dv if M=0                     *
!* result # 0  item length                                             *
!*        = 0  actual length is on Etos                                *
!***********************************************************************
%record(RESF) R
%integer IIN,Disp,Len,Bytefix,I
%record(PrecF)%name PP
%record(Arraydvf)%name Dvrec
%switch F(0:66)
      Clear Estack
      R_W=Resw
      Len=ModetoBytes(R_Mode)
      %if Len=1 %then Bytefix=X'80000000' %else Bytefix=0
      PP==record(Adict+R_H0<<DSCALE)
!*
      %if R_Mode=CHARMODE %and R_Form#ARRID %thenstart
         I=Get Charad(Resw,0,IIN,Disp,Len)
         %if I=0 %thenstart;! evaluated location
            Efix(RefIIN!x'80000000',RefDisp,IIN,Disp);! fixup byte address
         %finishelsestart;! address not known
            Eop(EADDRESS)
            Estkdir(RefIIN,RefDisp,0,4);! address evaluated on Estack
            Eop(ESTORE)
         %finish
         %if Len#0 %then %result=Len
Chlen:   I=Get Charlen(Resw,Len)
         %if I=0 %then %result=Len %else %result=0
      %finish
!*
      ->F(R_Form)
!*
F(NEGLIT):
!*
F(LIT):
!*
F(CNSTID):
      I=Alloc Const(Resw,IIN)
      Efix(RefIIN!Bytefix,RefDisp,IIN,I)
      %result=Len
!*
F(TMPID):
!*
F(PERMID):
!*
F(LSCALID):
      Ldstkaddr(PP_Addr4)
Set:  Estkdir(RefIIN,Refdisp,0,4)
      Eop(ESTORE)
      %result=Len
!*
F(PROCID):
!*
F(PSCALID):
      Load Address(Resw)
      ->Set
!*
F(OSCALID):
!*
F(ASCALID):
!*
F(CSCALID):
      Efix(RefIIN!Bytefix,RefDisp,PP_IIN,PP_Addr4)
      %result=Len
!*
F(VALTEMP):
      Disp=Vtaddr(R_H0<<DSCALE)
      Ldstkaddr(Disp)
      ->Set
!*
F(DESTEMP):
      Disp=Dtaddr(R_H0<<DSCALE)
      Estkdir(SCALARS,Disp,0,4)
      ->Set
!*
F(ARREL):
Arr:  %if Locate Arrel(Resw,IIN,Disp)=0 %thenstart;! fully evaluated
         Efix(RefIIN!Bytefix,RefDisp,IIN,Disp)
         %if R_Mode=CHARMODE %then ->Chlen
         %result=Len
      %finish
      Eop(EADDRESS)
      Estkdir(RefIIN,RefDisp,0,4);! address was in Etos
      Eop(ESTORE)
      %if R_Mode=CHARMODE %then ->Chlen
      %result=Len
!*
F(ARRID):
      %if M#0 %then ->Arr;! @ of array itself required
      Dvrec==record(Adict+PP_Addr4)
      Efix(RefIIN,RefDisp,DVAREA,Dvrec_Addrdv)
      %if R_Mode=CHARMODE %then ->Chlen
      %result=Len
!*
F(*):
      %monitor
      %stop
!*
%end;! Set Address
!*
%routine Coerce(%integer Oldmode,Newmode)
!***********************************************************************
!* convert value in Etos (real or int) to Newmode                      *
!***********************************************************************
%constbyteintegerarray Cindex(0:15) = 0,1,0,2,3,0(6),1,0(4)
%integer Op,Size
%switch C(0:15)
      ->C(Cindex(Oldmode)<<2!Cindex(Newmode))
!*
C(*): %return
!*
C(1): {I2 -> I4}
      Size=4
      Op=CVTII
!*
Out:  Estklit(Size)
      Eop(Op)
      %return
!*
C(2): {I2 -> R4}
      Size=4
      Op=CVTIR
      ->Out
!*
C(3): {I2 -> R8}
      Size=8
      Op=CVTIR
      ->Out
!*
C(4): {I4 -> I2}
      Size=2
      %if Newmode=Log1 %then Size=1
      Op=CVTII
      ->Out
!*
C(6): {I4 -> R4}
      Size=4
      Op=CVTIR
      ->Out
!*
C(7): {I4 -> R8}
      Size=8
      Op=CVTIR
      ->Out
!*
C(8): {R4 -> I2}
      Size=2
      Op=TNCRI
      ->Out
!*
C(9): {R4 -> I4}
      Size=4
      Op=TNCRI
      ->Out
!*
C(11):{R4 -> R8}
      Size=8
      Op=CVTRR
      ->Out
!*
C(12):{R8 -> I2}
      Size=2
      Op=TNCRI
      ->Out
!*
C(13):{R8 -> I4}
      Size=4
      Op=TNCRI
      ->Out
!*
C(14):{R8 -> R4}
      Size=4
      Op=CVTRR
      ->Out
!*
%end;! Coerce
!*
%integerfnspec Complexop(%integer Reslw,Op,Resrw)
%routinespec Charop(%integer Reslw,Op,Resrw)
!*
%routine Assign(%integer Reslw,Resrw)
!***********************************************************************
!* LHS = RHS  (not complex)                                            *
!***********************************************************************
%record(Tmpf)%name Tmp
%record(Tmpf)%name Tmp1
%record(Resf) Resl,Resr
%record(Triadf)%name Tr1
%integer Reg,Lmode,Rmode,Lclass,Rclass,Cclass,I,Lbytes,Rbytes
%switch S(0:15)
      Reg=0
Loop: Resl_W=Reslw
      Resr_W=Resrw
      %unless Resl_Mode=CHARMODE %thenstart
         %if Resl_Form=TRIAD %then Resl_W=Extriad(Resl_W)
         %if Resr_Form=TRIAD %then Resr_W=Extriad(Resr_W)
      %finish
      Lmode=Resl_Mode
      Rmode=Resr_Mode
      Lclass=Arith Class(Lmode)
      Rclass=Arith Class(Rmode)
      Cclass=Lclass!Rclass
!*
      %if Cclass&8#0 %thenstart
         Resrw=Complexop(Resl_W,7,Resr_W)
         %if Resl_Form=NULL %then Save Res(Resrw);! coerce only
         %return
      %finish
!*
      %if Cclass&16#0 %thenstart
         Charop(Resl_W,7,Resr_W)
         %return
      %finish
!*
      %if Cclass&32#0 %thenstart
         %monitor
         %return
      %finish
!*
      %if Lclass#Rclass %or Resl_Form=NULL %thenstart
         Load Val(Resr_W)
         Coerce(Rmode,Lmode)
         %if Resl_Form=NULL %thenstart;! coerce only
            Save Res(Get Etemp(Lmode))
            %return
         %finish
      %finishelsestart
         Lbytes=Modetobytes(Lmode)
         %if Lmode#Rmode %thenstart;! must be a mixture of BYTE,I2,I4
            %if Lbytes=4 %thenstart
               Load Val(Resr_W)
               Cvthi
            %finishelsestart
%if lbytes=1 %thenstart;! temp
   Load Val(Resr_W)
   Estklit(1)
   Eop(CVTII)
%finishelse               Load Short(Resr_W)
            %finish
         %finishelsestart
            %if Lbytes<4 %thenstart
               Load Short(Resr_W)
            %finishelsestart
               Load Val(Resr_W)
            %finish
         %finish
      %finish
!*
      Elevel=Elevel+1;! in case array subscript is on Estack
      Edesc(Elevel)=0
      Store Val(Resl_W,ESTORE)
      Elevel=Elevel-1
      %return
!*
%end;! Assign
!*
%integerfn Arithop(%integer Reslw,Op,Resrw)
!***********************************************************************
!* OP  1  COMPARE                                                      *
!*     2  +                                                            *
!*     3  -                                                            *
!*     4  *                                                            *
!*     5  /                                                            *
!*     6  UNARY -                                                      *
!***********************************************************************
%constintegerarray Realop(0:13)= %c
   0,0,RADD,RSUB,RMULT,RDIV,RNEG,0,RGT,RLT,RNE,REQ,RGE,RLE
%constintegerarray Intop(0:13)= %c
   0,0,IADD,ISUB,IMULT,IDIV,INEG,0,IGT,ILT,INE,IEQ,IGE,ILE
!*
%record(Resf) Resl
%record(Resf) Resr
!*
%integer Lclass,Rclass,Cclass,Instr
!*
      Resl_W=Reslw
      Resr_W=Resrw
      %if Resl_Form=TRIAD %then Resl_W=Extriad(Resl_W)
      %if Resr_Form=TRIAD %then Resr_W=Extriad(Resr_W)
      Lclass=Arith Class(Resl_Mode)
      Rclass=Arith Class(Resr_Mode)
      %if Op=NEG %then Cclass=Lclass %else Cclass=Lclass!Rclass
      %if Cclass&8#0 %thenstart
         %result=Complexop(Resl_W,Op,Resr_W)
      %finish
!*
      %if Op=1 %then Op=Condmask+8;! comparison
!*
      %if Cclass#1 %thenstart;! real operation
         Instr=Realop(Op)
      %finishelse Instr=Intop(Op)
      %if Op=NEG %thenstart;! negate
         Get Operand(Resl_W)
         Eop(Instr)
      %finishelsestart
         Get Operand Pair(Resl_W,Resr_W)
         Eop(Instr)
         %if Op>=8 %then %result=Get Etemp(LOG4);! comparison
      %finish
      %result=Get Etemp(Resl_Mode)
!*
%end;! Arithop
!*
%integerfn Expfn(%integer Reslw,Resrw)
!***********************************************************************
!* LHS ** RHS                                                          *
!***********************************************************************
%constbyteintegerarray Rsize(0:8)=2,2,4,0,0,2,4,0,0
%constbyteintegerarray ModetoIndex(0:15)=0,0,0,1,2,3,4,5,6,0,0,0,0,0,0,0
%record(Resf) Resl,Resr
%integer Lmode,Lclass,Rclass,J,N,Multop,Resw
%integer Procindex,P,Bytes
Loop: Resl_W=Reslw
      Resr_W=Resrw
      %if Resl_Form=TRIAD %then Reslw=Extriad(Reslw) %and ->Loop
      %if Resr_Form=TRIAD %then Resrw=Extriad(Resrw) %and ->Loop
      Lmode=Resl_Mode
      Lclass=Arith Class(Lmode)
      Rclass=Arith Class(Resr_Mode)
      Procindex=ModetoIndex(Lmode)
      Bytes=ModetoTempBytes(Resl_Mode)
!*
      %if Rclass=INTCLASS %thenstart
         %if Lclass<=R8CLASS %and Resr_Form&CONSTMASK#0 %thenstart
            N=Conout(Resrw)
            %if N<0 %then ->Usefn
!*
            %if N=0 %thenstart
               Get Operand(Resl_W)
               Eop(DISCARD);! to clear Estack
               Estklit(1)
               %if Lclass=INTCLASS %then %result=Get Etemp(INT4)
               Coerce(INT4,Resl_Mode)
               %result=Get Etemp(Resl_Mode)
            %finish
!*
            Get Operand(Resl_W)
            Estklit(N)
            Estklit(Procindex)
            Eop(EPOWERI)
            %result=Get Etemp(Resl_Mode)
         %finishelsestart
Usefn:      %if Lclass=INTCLASS %thenstart
               Get Operand Pair(Resl_W,Resr_W)
               Resl_Mode=INT4
Get Etemp:     Resw=Get Etemp(Resl_Mode)
Call Proc:     Estklit(Procindex)
               Eop(EPOWER)
               %result=Resw
            %finishelsestart
               %if Lclass<=R8CLASS %thenstart
                  Get Operand Pair(Resl_W,Resr_W)
                  ->Get Etemp
               %finishelsestart;! complex
                  Clear Estack
                  Resw=Get Cxtemp(Resl_Mode)
                  Load Address(Resw)
                  Load Address(Resl_W)
                  Get Operand(Resr_W)
                  ->Call Proc
               %finish
            %finish
         %finish
      %finishelsestart
         Procindex=Procindex+8
         %if Resr_Mode<=REAL16 %thenstart
            Get Operand Pair(Resl_W,Resr_W)
            ->Get Etemp
         %finishelsestart;! complex
            Clear Estack
            Resw=Get Cxtemp(Resl_Mode)
            Load Address(Resw)
            Load Address(Resl_W)
            Load Address(Resr_W)
            ->Call Proc
         %finish
      %finish
%end;! Expfn
!*
%routine Charop(%integer Reslw,Op,Resrw)
%integer IINl,IINr,Displ,Dispr,Lenl,Lenr,I,J,Proc
%constbyteintegerarray Cvtmask(0:5)=0,1,3,2,4,5
%record(Resf) R
%record(Precf)%name Stfn
%record(Triadf)%name Tr
      %if Op=7 %thenstart;! assign
         R_W=Reslw
         %if R_Form=STFNID %thenstart;! create temp for result
            Stfn==record(Adict+R_H0<<DSCALE)
            %if Stfn_X1&1=0 %thenstart
               Stfn_X1=Stfn_X1!1
               Reslw=Get Chartemp(Stfn_Len)
               Stfn_Addr4=Reslw
            %finish
         %finish
         R_W=Resrw
         %if R_Form=TRIAD %thenstart
            Tr==record(addr(Triads(R_H0)))
            %if Tr_Op=CHHEAD %thenstart;! concat list
               Concat List(R_H0,1)
               Load Charad(Reslw,1)
               Elevel=Elevel+1
               Edesc(Elevel)=0
               Load Charlen(Reslw)
               Elevel=Elevel-1
               Ef77op(ECONCAT)
               %return
            %finish
         %finish
         Load Charad(Reslw,1)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charlen(Reslw)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charad(Resrw,1)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charlen(Resrw)
         Elevel=Elevel-3
         Ef77op(EASGNCHAR)
         %return
      %finish
!*
      %if Op=1 %thenstart;! compare
         Load Charad(Reslw,1)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charlen(Reslw)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charad(Resrw,1)
         Elevel=Elevel+1
         Edesc(Elevel)=0
         Load Charlen(Resrw)
         Elevel=Elevel-3
         Estklit(Cvtmask(Condmask))
         Ef77op(ECOMPCHAR)
         Save Res(Get Etemp(LOG4))
         %return
      %finish
!*
      %monitor
      %stop
%end;! Charop
!*
%integerfn Complexop(%integer Reslw,Operation,Resrw)
%routinespec Swop
%record(Resf) Resl
%record(Resf) Resr
%record(Resf) Res
%record(Tmpf)%name Tmp
%integer Op,Lmode,Rmode,Opmode,Lclass,Rclass,Variant,Szcode
%constbyteintegerarray E(0:7) = 0,2,3(4),2,2
%constintegerarray Cxop(0:7)=0,0,CXADD,CXSUB,CXMULT,CXDIV,CXNEG,CXASGN
Loop: Resl_W=Reslw
      Resr_W=Resrw
      %if Resl_Form=TRIAD %then Reslw=Extriad(Reslw) %and ->Loop
      %if Resr_Form=TRIAD %then Resrw=Extriad(Resrw) %and ->Loop
      Lmode=Resl_Mode
      Rmode=Resr_Mode
      %unless INT4<Lmode<=CMPLX32 %then Lmode=INT4;! to handle INT2 and BYTE
      %unless INT4<Rmode<=CMPLX32 %then Rmode=INT4
!*
      %if Lmode<Rmode %then Opmode=Rmode %else Opmode=Lmode
!*
      Szcode=Sizecode(Resl_Mode)
      Variant=0
      %if Operation=5 %and Lmode<CMPLX8 %thenstart;! real / Cx
         Res_W=Get Cxtemp(Opmode)
         Reslw=Complexop(Res_W,7,Reslw)
         Reslw=Res_W;! now has a zero complex part
         ->Loop
      %finish
      %if Operation<=6 %thenstart;! except assign
         %if Operation>1 %thenstart;! except compare
            Res_W=Get Cxtemp(Opmode)
            Load Cx Addr(Res_W)
         %finish
         %if Lmode<CMPLX8 %and (Operation<=2 %or Operation=4) %then Swop
         Load Cx Addr(Resl_W)
         %unless Operation=6 %thenstart;! except neg
            Load Cx Addr(Resr_W)
         %finish
      %finishelsestart;! assignment
         %if Resl_Form=NULL %thenstart;! convert only - find a temp
            Res_W=Get Cxtemp(Resl_Mode)
            Resl_W=Res_W
         %finishelse Res_W=0
         Load Cx Addr(Resl_W)
         Load Cx Addr(Resr_W)
         Szcode=Szcode<<2!Sizecode(Resr_Mode)
      %finish
!*
      %if Lmode<CMPLX8 %then Variant=2
      %if Operation #6 %and Rmode<CMPLX8 %then Variant=1
      Estklit(Variant<<8!Szcode)
      Elevel=Elevel-E(Operation);! delete the temp entries created
!*
      %if Operation=1 %thenstart;! compare
         %if Condmask=2 %then Op=CXNE %else Op=CXEQ
         Ef77op(Op)
         %result=Get Etemp(LOG4)
      %finishelsestart
         Ef77op(Cxop(Operation))
         %result=Res_W
      %finish
!*
%routine Swop
      Resrw=Reslw
      Reslw=Resr_W
      Resr_W=Resrw
      Resl_W=Reslw
      Lmode=Resl_Mode
      Rmode=Resr_Mode
%end;! Swop
 %end
!*
%routinespec Inline(%integer Op,Reslw,Resrw)
!*
!*
%integerfn Set Param(%integer Fnptr,Resw,Intrin)
!***********************************************************************
!* FOLLOWING EVALUATION OF A PARAMETER  PLANT AN APPROPRIATE DESCRIPTOR*
!* ON THE STACK, STORING ACC OR MOVING CONSTS IF NECESSARY             *
!***********************************************************************
%routinespec Add Par(%integer Pdesc,Prec)
%integer I,J,K,Proc,Numels,Paramdesc,IIN,Disp,Len,Psize
%record(Resf) Rd
%record(Precf)%name PP
%record(Constrecf)%name Con
%string(255) S
%SWITCH F(0 : 66)
!*
Reset:Rd_W=Resw
     PP==record(Adict+Fnptr);! fn record 
      Paramdesc=Modetost(Rd_Mode)
      %if Rd_Mode=CHARMODE %thenstart
         Load Charad(Resw,1)
         Load Charlen(Resw)
         Ef77op(CHARARG)
         Psize=8
         ->Adpar
      %finish
      Numels=1
      Psize=4
      -> F(Rd_Form)
!*
!******  CONST record
F(CNSTID): Con == record(Adict+Rd_H0<<Dscale)
      %if Con_Mode=HOLMODE %then Paramdesc=6
!*
!****** SHORT LITERAL
F(LIT):
!*
!****** negative literal
F(NEGLIT):
!*
!****** local
F(LSCALID):
!*
!****** scalar in global area
F(OSCALID):
!*
!****** DICT record FOR SCALAR IN COMMON
F(CSCALID):
!*
!****** param
F(PSCALID):
!*
!****** SCALAR IN array AREA
F(ASCALID):
!*
!****** explicit stack location 
F(STKLIT):
!*
!****** explicit gla location
F(GLALIT):
!*
!****** array identifier
F(ARRID):
!*
!****** array element
F(ARREL):
!*
!****** value temporary
F(VALTEMP):
!*
!****** descriptor temporary
F(DESTEMP):
!*
Scalad:Load Address(Resw)
      Eop(PUSHVAL)
Adpar:%if Intrin=NO %then Add Par(Paramdesc,Fnptr);! for user subprogs only
      %result=Psize
!*
!****** in temporary
F(TMPID):
!*
F(PERMID):
      ->Scalad
!*
!****** triad
F(TRIAD):Resw=Extriad(Resw)
      ->Reset
!*
!******  Subprogram identifier
F(PROCID):
      PP==record(Adict+Rd_H0<<DSCALE)
      I=PP_Class&X'1F'
      %if I = 8 %thenstart;             ! external subprog
         Paramdesc=X'80';! must be a subprog
         %if PP_X0&7=6 %thenstart;! intrinsic fn
            I=PP_Link2;! fn details
            J=(I>>20)&X'F';! parameter mode
            K=I>>24
            %if K<=24 %thenstart
               S=Gen Name(K)
            %finishelsestart
         {      S="f_".Lowstring(string(Anames+PP_Iden))  }
               S=string(Com_Anames+PP_Iden)
            %finish
            S="f_".S

            Proc=Exname(0,S)
            Estklit(Proc)
            Ef77op(PROCARG)
            ->Adpar
         %finishelsestart;! load variable routine descriptor
         {   S=Lcstring(string(Anames+PP_Iden))            }
            Proc=Exname(0,string(Com_Anames+PP_Iden))
            Estklit(Proc)
            Ef77op(PROCARG)
         %finish
      %finishelsestart
         %if I=9 %thenstart;! subprog arg
            Estkdir(PP_IIN,PP_Addr4,Com_Anames+PP_Iden,4)
            Eop(PUSHVAL)
         %finishelse ->Scalad;! local function name
      %finish
      ->Adpar
!*
F(*):
      %monitor
      %stop
!*
%routine Add Par(%integer Pdesc,Prec)
%integer I
      %if Argchecks=NO %then %return
      %if Nexttplate<256 %thenstart
         Tplate(Nexttplate)=Pdesc
      %finish
      Nexttplate=Nexttplate-1
%end;! Add Par
%end;                                   ! Set Param
!*
!*
%routine Start Par(%integer Pct)
      Nexttplate=Pct+2
      %if Nexttplate<256 %thenstart
         Tplate(Nexttplate+1)=0
         Tplate(0)=Nexttplate
      %finishelse Tplate(0)=255
%end;! Start Par
!*
%routine Call Subprog(%integer Sub,Fptr,Fnmode,Pct,Plink)

%routinespec Set Call Template(%integer Sub,Proctype)
%record(Precf)%name Fn
%record(Precf)%name Param
%record(Arraydvf)%name Dvrec
%record(TRIADF)%name Tr
%record(CHARF)%name CH
%record(SRECF)%name SS
%integer I,J,K,Ptr,Resw,Iin,Fntype,Intrin,Len,Pcount,Psize
%integer II
%integer AD
%string(63) S
%switch R(1:5)
!*
      Clear Estack;! to ensure all temps stored
      Pcount=0
      Psize=0
      Fn == record(Adict+Fptr)
      %if Sub=YES %or Fn_Class=9 %or Fn_X0&3=0  %c
                       %then Intrin=NO %else Intrin=YES
      %if Sub=NO %then Fntype=Fn_Type&15
!*
      %if Intrin=NO %then Start Par(Pct)
!*
      %if Fn_Addr4=0 %thenstart;! establish a reference
         %if Sub=NO %thenstart
            I=(Modetobytes(Fnmode)<<8)!Fntype
         %finishelse I=0
         %if Intrin=NO %then Fn_Addr4=Exname(I,string(Com_Anames+Fn_Iden))
      %finish
      Eprecall(Fn_Addr4)
!*
      %if Sub=NO %thenstart;! fn which may need result descriptor
         ->R(Fntype)
!*
R(INTTYPE):
R(LOGTYPE):
!*
R(REALTYPE):
         I=Fn_Type>>4
         %if I=6 %thenstart
            J=4
         %finishelsestart
            %if I=5 %then J=2 %else J=1
         %finish
         ->Call
!*
R(CMPLXTYPE):
         Resw=Get Cxtemp(Fnmode)
         Load Address(Resw)
         Eop(PUSHVAL);! @ complex result on stack
         Pcount=Pcount+1
         Psize=Psize+4
         -> Call
!*
R(CHARTYPE):
         Resw=Get Chartemp(Fn_Len)
         Load Charad(Resw,1)
         Estklit(Fn_Len)
         Ef77op(CHARARG)
         Pcount=Pcount+1
         Psize=Psize+8
         ->Call
      %finish
!*
Call: %while Plink#NULL %cycle
         Tr==record(Addr Triad(Plink))
         Psize=Psize+Set Param(Fptr,Tr_Res1_W,Intrin)
         Pcount=Pcount+1
         Plink=Tr_Opd2
      %repeat
!*
      Clear Estack
!*
      %if Intrin=NO %thenstart;! user call
         Set Call Template(Sub,Fn_Type)
         %if FN_CLASS = 8 %thenstart;! STANDARD CALL
       {     S=Lcstring(string(Com_Anames+Fn_Iden))    }
       {     PI1(PnxCALL,Get Extid(S))                 }
            Ecall(Fn_Addr4,Pcount,Psize)
         %finishelsestart;           ! SUBPROG IS A PARAM
            Estkdir(SCALARS,Fn_Addr4,Com_Anames+Fn_Iden,4);! arg copied to scalar space
            Ef77op(ARGPROCCALL)
         %finish
      %finishelsestart;! intrinsic fn call
         II=FN_LINK2;! FN DETAILS
         K=FN_TYPE&15
         J=II>>20&X'F';! PARAMETER MODE
         Intrincall(0,II>>24,J)
      %finish
!*
      %if Sub=NO %thenstart
         %unless Fntype=CMPLXTYPE %or Fntype=CHARTYPE %thenstart
            Resw=Get Etemp(Fnmode)
            %if Intrin=NO %then Estkresult(0,Fntype,Modetobytes(Fnmode))
         %finish
         Save Res(Resw)
      %finish
      %return
!*
%routine Set Call Template(%integer Sub,Proctype)
%integer I,J
      %if Argchecks=NO %then %return
      %if Sub=NO %then I=Proctype %else I=1
      Tplate(1)=1;! mk no. to allow for future variations
      Tplate(2)=I
      I=((Tplate(0)+4)>>2)<<2
      J=Com_Ioareaca
      Edbytes(IOAREA,J,I,Addr(Tplate(0)))
      Com_Ioareaca=Com_Ioareaca+I
      Estkaddr(IOAREA,J,0,0)
      Ef77op(CALLTPLATE)
%end;! Set Call Template
!*
%end;! Call Subprog
!*
%routine Inline(%integer Op,Reslw,Resrw)
%constbyteintegerarray Pload(NINT:DCMPLX)=1(2),0(4),2(2),1(2),2(4),0(8)
{  1  NINT, ANINT, AINT, ABS     2  DIM, DMULT, MOD, SIGN  }
%record(Resf) Resl,Resr,Res
%integer I,J,L,Lclass,Rclass,Bytes
%integer Inst1,Inst2,IIN,Disp
%switch T(NINT:DCMPLX)
      Resl_W=Reslw
      Resr_W=Resrw
      Lclass=Arith Class(Resl_Mode)
      Rclass=Arith Class(Resr_Mode)
      %if Resl_Form=TRIAD %and Lclass#CHARCLASS %then Resl_W=Extriad(Resl_W)
      %if Resr_Form=TRIAD %and Rclass#CHARCLASS %then Resr_W=Extriad(Resr_W)
!*
      I=Pload(Op);! no. of params to be loaded
      %if I#0 %thenstart
         %if I=1 %thenstart
            Get Operand(Resr_W)
         %finishelsestart
            Get Operand Pair(Resl_W,Resr_W)
         %finish
      %finish
!*
      ->T(Op)
!*
T(NINT):
!*
T(ANINT):
      Estklit(4)
      Eop(RNDRI)
      %if Op=NINT %thenstart
Save:    Save Res(Get Etemp(Resl_Mode))
         %return
      %finish
Flt:  Coerce(INT4,Resl_Mode)
      ->Save
!*
T(AINT):
      Coerce(Resr_Mode,INT4)
      ->Flt
!*
T(ABS):
      %if Rclass=INTCLASS %then Inst1=IABS %else Inst1=RABS
      Eop(Inst1)
      ->Save
!*
T(SIGN):
      %if Rclass=INTCLASS %then Inst1=EISIGN %else INST1=ESIGN
      Ef77op(Inst1)
      ->Save
!*
T(MOD):
      %if Rclass=INTCLASS %then Inst1=EIMOD %else Inst1=ERMOD
      Ef77op(Inst1)
      ->Save
!*
T(DIM):
      %if Rclass=INTCLASS %then Inst1=EIDIM %else Inst1=ERDIM
      Ef77op(Inst1)
      ->Save
!*
T(MIN):
      %if Rclass=INTCLASS %then Inst1=EIMIN %else Inst1=ERMIN
      Ef77op(Inst1)
      ->Save
!*
T(MAX):
      %if Rclass=INTCLASS %then Inst1=EIMAX %else Inst1=ERMAX
      Ef77op(Inst1)
      ->Save
!*
T(DMULT):
      Ef77op(EDMULT)
      Resl_Mode=REAL8
      ->Save
!*
T(REALL):
      %if Rclass=CXCLASS %thenstart
         Load Cx Addr(Resr_W)
         Elevel=Elevel-1
         Resr_Mode=Resr_Mode-3;! corresponding real mode
         Erefer(0,Modetobytes(Resr_Mode))
      %finishelse Get Operand(Resr_W)
      Coerce(Resr_Mode,Resl_Mode)
      ->Save
!*
T(IMAG):
      Load Cx Addr(Resr_W)
      Elevel=Elevel-1
      Bytes=Modetobytes(Resr_Mode-3)
      Erefer(Bytes,Bytes)
      ->Save
!*
T(CONJG):
      Res_W=Get Cxtemp(Resl_Mode)
      Load Cx Addr(Res_W)
      Load Cx Addr(Resr_W)
      Elevel=Elevel-2
      Estklit(Sizecode(Resl_Mode))
      Ef77op(ECONJG)
Csave:Save Res(Res_W)
      %return
!*
T(CMPLX):
      I=CMPLX8
      J=REAL4
CX:   Res_W=Get Cxtemp(I)
      Load Cx Addr(Res_W)
      %if Rclass=CXCLASS %thenstart
         Load Cx Addr(Resr_W)
         Elevel=Elevel-1
         %if J=REAL4 %then I=0 %else I=5
         Estklit(I)
         Inst1=CXASGN;! Cx=Cx
      %finishelsestart
         %if Resl_form=NULL %thenstart
            Get Operand(Resr_W)
            I=Resr_Mode
         %finishelsestart
            Get Operand(Resl_W)
            I=Resl_Mode
         %finish
         Coerce(I,J)
         Elevel=Elevel+1
         %if Resl_form=NULL %thenstart
            Estklit(J-REAL4)
            Inst1=ECMPLX1;! Cx=R
         %finishelsestart
            Get Operand(Resr_W)
            Coerce(Resr_Mode,J)
            Estklit(J-REAL4);! 0  Real4   1  Real8   2  Real16
            Inst1=ECMPLX2;! Cx=(R,R)
         %finish
         Elevel=Elevel-1
      %finish
      Elevel=Elevel-1
      Ef77op(Inst1)
      ->Csave
!*
T(DCMPLX):
      I=CMPLX16
      J=REAL8
      ->CX
!*
T(LEN):
      I=Get Charlen(Resr_W,L)
      %if I=0 %thenstart
         Resl_H0=L
         Resl_Form=LIT
         Save Res(Resl_W)
         %return
      %finishelse ->Save
!*
T(ICHAR):
      Load Charad(Resrw,1)
      Ef77op(EICHAR)
      ->Save
!*
T(TOCHAR):
      Resl_W=Get Chartemp(1)
      Load Charad(Resl_W,1)
      Elevel=Elevel+1
      Edesc(Elevel)=0
      Get Operand(Resr_W)
      Elevel=Elevel-1
      Ef77op(ECHAR)
      Save Res(Resl_W)
      %return
!*
T(CHIND):
      Load Charad(Resl_W,1)
      Elevel=Elevel+1
      Edesc(Elevel)=0
      Load Charlen(Resl_W)
      Elevel=Elevel+1
      Edesc(Elevel)=0
      Load Charad(Resr_W,1)
      Elevel=Elevel+1
      Edesc(Elevel)=0
      Load Charlen(Resr_W)
      Elevel=Elevel-3
      Ef77op(EINDEXCHAR)
      Resl_Mode=INT4
      ->Save
!*
T(*):
      %monitor
      %stop
%end;! Inline
!*
%routine Bitsfns(%integer Index,Fmode,Plink)
%constbyteintegerarray Bitspars(0:13)=0,
   2,2,2,1,2,3,2,2,2,2,2,2,2
%record(Resf) Res1,Res2,Res3
%integer Plab1,Plab2,Order
%switch F(0:15)
      Res1_W=Triads(Plink)_Res1_W
      Plink=Triads(Plink)_Opd2
      %if Plink#0 %thenstart
         Res2_W=Triads(Plink)_Res1_W
         Plink=Triads(Plink)_Opd2
         %if Plink#0 %then Res3_W=Triads(Plink)_Res1_W %else Res3_W=0
      %finish
      %if Bitspars(Index)>=2 %thenstart
         Get Operand Pair(Res1_W,Res2_W)
      %finishelse Get Operand(Res1_W)
      ->F(Index)
!*
F(1): {AND}
F(11):{IAND}
      Eop(IAND)
Isave:Save Res(Get Etemp(Fmode))
      %return
!*
F2:
F(2): {OR}
F(12):{IOR}
      Eop(IOR)
      ->ISAVE
!*
F(3): {XOR}
F(13):{IEOR}
      Eop(IXOR)
      ->Isave
!*
F(4): {NOT}
      Eop(INOT)
      ->Isave
!*
F(5): {ISHFT}
      Ef77op(EISHFT)
      ->Isave
!*
F(6): {IBITS}
      Ef77op(EIBITS)
      ->Isave
!*
F(7): {IBSET}
      Ef77op(EIBSET)
      ->Isave
!*
F(8): {IBTEST}
      Ef77op(EIBTEST)
      ->Isave
!*
F(9): {IBCLR}
      Ef77op(EIBCLR)
      ->Isave
!*
F(10):{ISHFTC}
      Ef77op(EISHFTC)
      ->Isave
!*
F(*): %monitor
      %stop
%end;! Bitsfns
!*
%routine Call Ioproc
%integer I,J,Lab
      I=Ioproc
      %if Ioinit=0 %thenstart
         %if F77IOA<=I<=F77IOB %thenstart
            %if Ioform=2 %then I=I+F77IOAR-F77IOA
         %finish
         Ioinit=1
      %finish
      %if Iomarkers#0 %or Ioproc=F77IOC %thenstart;! possible non-zero response
         Syscall(I)
         Ef77op(NOTEIORES);! result of I/O function must be checked for error condition
         Ejump(JINTNZ,IolabA);! jump if non-zero
      %finishelsestart
         Syscall(I)
         Eop(DISCARD)
      %finish
%end;! Call Ioproc
!*
%routine Startio(%integer Form,Type)
%constbyteintegerarray FormtoIndex(0:9)=4,0,0,2,0,0,0,6,5,0
%integer Procindex,I
%record(Precf)%name Ep
%string(63) S
      %if Type>2 %then Ioform=Type+1 %else Ioform=Form
      Iotype=Type
      IolabA=New Plab
      IolabB=New Plab
      Procindex=FormtoIndex(Form)
      %if Procindex<4 %and Iotype=2 %then Procindex=Procindex+1
      Ioproc=Ioid(Procindex)
      Iomarkers=0;! for end,err,iostat
      Iodsnum=-1
     {Iodsnum=-Iotype;! set default channel indicators: -1  input, -2  output}
     {Iodsnum=Iotype+4;! default mapped to 5 and 6 on Unix}
      %if Iotype=8 %then Iodsnum=-1;! default for INQUIRE
      Errlab=0
      Endlab=0
      Iostatvar=0
      Ioindex=0;! count of I/O items
      %if Thisprocid<0 %thenstart
         EP==record(Adict+Com_Subprogptr)
         S=string(Anames+EP_Iden)                           
         %if S="F_MAIN" %or Com_Subprogtype=1 %then S="MAIN PROGRAM" 
         I=((length(S)+4)>>2)<<2
         Thisprocid=Com_Ioareaca
         Edbytes(IOAREA,Com_Ioareaca,I,addr(S))
         Com_Ioareaca=Com_Ioareaca+I
      %finish
      Ed4(IOAREA,Com_Ioareaca,(Linest<<16)!(Com_Ioareaca+4-Thisprocid))
      Com_Ioareaca=Com_Ioareaca+4
      Tctbase=Com_Ioareaca;! start of current I/O control table
      Tctsize=12;! reserve minimum space
      Nextpp=Tctbase+12;! next parameter pair location for OPEN,CLOSE,INQUIRE
      %if Type<=2 %then I=0 %else I=Type-2
      Estklit(I)
      Estkaddr(IOAREA,Tctbase,0,0)
      Ioinit=0
%end;! Startio
!*
!*
%routine Completeio(%integer Iomode,Ioflags)
      %if Ioinit=0 %thenstart
         Call Ioproc
      %finish
      Ed4(IOAREA,Tctbase,Iodsnum)
      Ed4(IOAREA,Tctbase+4,((Ioform<<8!Iomarkers)<<8!Iomode)<<8!Ioflags)
      %if Iotype>5 %thenstart
         Ed4(IOAREA,Nextpp,-1)
         Com_Ioareaca=Nextpp+4
      %finishelse Com_Ioareaca=Com_Ioareaca+Tctsize
      %if Iotype<=2 %thenstart
         Estklit(-1)
         Estklit(0)
         Call Ioproc   { -1, 0 }
      %finish
!*
      %if Iomarkers#0 %or Ioproc=F77IOC %thenstart
         %if Iostatvar#0 %thenstart
            Estkdir(IOAREA,Tctbase+8,0,4)
            Store Val(Iostatvar,ESTORE)
         %finish
         Ejump(JUMP,IolabB)
         Elabel(IolabA)
         %if Iostatvar#0 %thenstart
            Estkdir(IOAREA,Tctbase+8,0,4)
            Store Val(Iostatvar,ESTORE)
         %finish
         %if Iomarkers&3#0 %thenstart
            %if Endlab#0 %thenstart
               Ef77op(STKIORES)
               Estklit(1)
               Ejump(JIEQ,Get Label(Endlab))
            %finish
            %if Errlab#0 %thenstart
               Ef77op(STKIORES)
               Estklit(2)
               Ejump(JIEQ,Get Label(Errlab))
            %finish
         %finish
         Elabel(IolabB)
      %finish
%end;! Completeio
!*
%routine Io List Item(%integer Resw)
%integer Len,Disp,Ep,IIN
%record(RESF) R
      Clear Estack
!*
      %if Ioinit=0 %then Call Ioproc
!*
      R_W=Resw
      %if R_Form=TRIAD %and R_Mode#CHARMODE %thenstart
         Resw=Extriad(Resw)
         R_W=Resw
      %finish
!*
      Disp=Scalar Space(12,IIN)
      Len=Set Address(Resw,IIN,Disp+4,0)
      %if R_Form=ARRID %then Ep=2 %elsestart
         %if ModetoBytes(R_Mode)=1 %then Ep=3 %else Ep=1
      %finish
      Ed4(IIN,Disp,ModetoType(R_Mode)<<16!Len)
      %if Len=0 %thenstart;! actual lenth is on Etos
         Estklit(2)
         Eop(CVTII)
         Estkdir(IIN,Disp+2,0,2)
         Eop(ESTORE)
      %finish
!*
      Estklit(Ep)
      Estkaddr(IIN,Disp,0,0)
      Call Ioproc
!*
%end;! Io List Item
!*
%routine Io Spec Clause(%integer Index,Ppkey,Resw)
%integer Form,Mode
%record(Resf) R
%integer I,Ptr,Len
%record(PrecF)%name PP
%record(arraydvf)%name Dvrec
%record(Labrecf)%name Labrec
%record(Srecf)%name SS
%switch Sw(0:6)
      R_W=Resw
      Form=R_Form
      Mode=R_Mode
      %if Index>6 %thenstart;! OPEN,CLOSE,INQUIRE
         %if PPKEY&X'100'#0 %then K=PPKEY&X'1F' %else K=PPKEY&X'5F'
         %if PPKEY&X'80'#0 %then I=4 %elseSTART;! logical
            %if PPKEY&X'40'#0 %then I=5 %else I=1;! character or integer
         %finish
         %if PPKEY&X'20'#0 %thenstart;! descriptor to var required
            Len=Set Address(Resw,IOAREA,Nextpp+4,1)
         %finishelsestart
            %if I=1 %thenstart;! integer
               Load Int(Resw)
               Estkdir(IOAREA,Nextpp+4,0,4)
               Eop(ESTORE)
               Len=4
            %finishelsestart
               Len=Set Address(Resw,IOAREA,Nextpp+4,1)
            %finish
         %finish
         Ed4(IOAREA,Nextpp,K)
         Ed4(IOAREA,Nextpp+8,Len)
         %if Len=0 %then Estkdir(IOAREA,Nextpp+8,0,4) %and Eop(ESTORE)
         Nextpp=Nextpp+12
         %return
      %finish
      ->SW(Index)
!*
SW(1):! UNIT=
!*
      %if Form=LIT %thenstart ;! int >=0
         Iodsnum=R_H0
      %finishelsestart
         %if FORM#ARRID %AND MODE<=INT8 %thenstart ;! integer expression - external file
            IODSNUM=0;! will over-ride default settings
            Load Int(Resw)
            Estkdir(IOAREA,Tctbase,0,4)
            Eop(ESTORE)
!            PI(CI0)
!            Rterror(IJGE,NEGUNITFAULT);! report error if unit<0
         %finishelsestart ;! must be internal file iden
            %if Tctsize<32 %then Tctsize=32
            Len=Set Address(Resw,IOAREA,Tctbase+20,1);! actual array @ for arrid
            Ed4(IOAREA,Tctbase+24,Len)
            %if Len=0 %then Estkdir(IOAREA,Tctbase+24,0,4) %and Eop(ESTORE)
            %if Form=ARRID %thenstart
               PP==record(Adict+R_H0<<DSCALE)
               Dvrec==record(Adict+PP_Addr4)
               Estkdir(SCALARS,Dvrec_Addrdv+4,0,4)
               Estkdir(IOAREA,Tctbase+28,0,4)
               Eop(ESTORE)
            %finishelsestart
               Ed4(IOAREA,Tctbase+28,Len)
               %if Len=0 %thenstart
                  Estkdir(IOAREA,Tctbase+24,0,4)
                  Estkdir(IOAREA,Tctbase+28,0,4)
                  Eop(ESTORE)
               %finish
            %finish
         %finish
      %finish
      %return
!*
!*
SW(2): ! FMT=
!*
      %if Tctsize<16 %then Tctsize=16
      Ed4(IOAREA,Tctbase+12,0);! initialise prior to fixup
!*
      %if Form=LABID %thenstart;! format label
         Labrec==record(Adict+R_H0<<DSCALE)
         Efix(IOAREA,Tctbase+12,IOAREA,Labrec_Addr4)
         %return
      %finish
!*
      Tctsize=40
!*
      %if Form=ARRID %thenstart
         Len=Set Address(Resw,IOAREA,Tctbase+32,1)
         %if Len=0 %then Eop(DISCARD)
         PP==record(Adict+R_H0<<DSCALE)
         Dvrec==record(Adict+PP_Addr4)
         Estkdir(SCALARS,Dvrec_Addrdv+4,0,4)
         %if R_Mode#CHARMODE %thenstart
            Estklit(ModetoBytes(R_Mode))
            Eop(IMULT)
         %finish
         Estkdir(IOAREA,Tctbase+36,0,4) %and Eop(ESTORE)
         %return
      %finish
!*
      %if Mode=CHARMODE %thenstart
         Len=Set Address(Resw,IOAREA,Tctbase+32,1)
         Ed4(IOAREA,Tctbase+36,Len)
         %if Len=0 %then Estkdir(IOAREA,Tctbase+36,0,4) %and Eop(ESTORE)
         %return
      %finish
!*
      %if LSCALID<=Form<=CSCALID %thenstart ;! Scalar, must be assigned
         Load Int(Resw) 
!!         Eop(DUPL)
!!         Estklit(M'FMT ')
!!         Eop(IEQ)
!!         Rterror(JFALSE,FMTLABFAULT);! in case some arith on the var
         Estklit(4)
         Eop(IADD)
         Erefer(0,4)
         Estkdir(IOAREA,Tctbase+12,0,4)
         Eop(ESTORE)
         %return
      %finish
!*
SW(3):   ! REC=
!*
      %if Tctsize<20 %then Tctsize=20
      Load Int(Resw)
      Estkdir(IOAREA,Tctbase+16,0,4)
      Eop(ESTORE)
      %return
!*
SW(4):   ! END =
      Iomarkers=Iomarkers!1
      Endlab=Resw
      %return
!*
SW(5): ! ERR=
!*
      Iomarkers=Iomarkers!2
      Errlab=Resw
      %return
!*
SW(6): ! IOSTAT=
!*
      Iomarkers=Iomarkers!4
      Iostatvar=Resw
      %return
!*
%end;! Io Spec Clause
!*
%routine Init Descs
!%RECORD(DTRECF)%NAME DT
!%RECORD(PRECF)%NAME PP,CMN
!%RECORD(ARRAYDVF)%NAME DVREC
!%INTEGER I,N,D1,VAL,LEN
!      I=COM_DESTEMPS
!      %WHILE I#0 %CYCLE
!         DT==RECORD(ADICT+I<<DSCALE)
!         I=DT_CHAIN
!         %IF DT_FLAGS&4#0 %THENSTART
!            PP==RECORD(ADICT+DT_IDENT<<DSCALE)
!!            PRINTSTRING("
!!INIT DESC FOR ".STRING(COM_ANAMES+PP_IDEN)."
!!")
!            DVREC==RECORD(ADICT+PP_ADDR4)
!            DT_DISP2=Com_Glaca
!            Com_Glaca=Com_Glaca+4
!            VAL=CONOUT(DT_CONST_W)
!            LEN=DVREC_ELLENGTH
!            %if PP_Type=5 %or Len=1 %thenstart
!               D1=Dvrec_Addrzero+Val
!               Efix(GLA!X'80000000',Dt_Disp2,PP_IIN,D1)
!               %if PP_Type=5 %thenstart
!                  Ed4(GLA,Com_Glaca,PP_Len)
!                  Com_Glaca=Com_Glaca+4
!               %finish
!            %finishelsestart
!               D1=Dvrec_Addrzero+Val*Len
!            Efix(GLA,Dt_Disp2,PP_IIN,D1)
!            %finish
!         %finish
!      %REPEAT
%end;! Init Descs
!*
%routine Cgeninit
!***********************************************************************
!* Re-initialise at start of each subprogram                           *
!***********************************************************************
%record(Precf)%name EP
%record(Precf)%name Param
%record(Srecf)%name SS
%string(32) S
%integer I,K,Stptr,Maxstptr,Fntype,Ptype,Curptr,Props,Id,Stpcount,Pcount
      Assigned Gotos=0;! list of jumps to be filled to go to common switch
      Assigned Labs=0;! list of assigned labels to add to switch
      Next Ass Lab=1
      Proc Parlist=0
!*
      %cycle I=0,1,15
         Tempst(I)=0
         Jlkprocs(I)=0
      %repeat
      Etempst=0
      EP==record(Adict+Com_Subprogptr)
      Thisprocid=-1
      Linenoword=12
      %unless Com_Subprogtype=5 %thenstart
         %if Com_Subprogtype=1 %then Props=6 %else Props=5
         Id=-1
         Stptr=0
         Stpcount=0
         %if Com_Subprogtype=2 %thenstart;! fn
            %if EP_Type=CHARTYPE %thenstart
               Stpcount=1
               Stptr=8
            %finishelsestart
               %if EP_Type&15=3 %thenstart
                  Stpcount=1
                  Stptr=4
               %finish
            %finish
         %finishelsestart
            {%if Com_Vreturn#0 %then Stptr=4}
         %finish
         Maxstptr=Stptr
         Curptr = Com_Subprogptr
         %while Curptr#0 %cycle
            EP==record(Adict+Curptr)
            I=Stptr
            Pcount=Stpcount
            K=EP_Link2;! link to param pointers
            %while K#0 %cycle
               SS==record(Adict+K);! 2-word param ptr chain
               K=SS_Link1
               Param==record(Adict+SS_Inf0)
               Ptype=Param_Type
   %if target=gould %thenstart
      %unless Param_Class&4#0 %or Ptype=CHARTYPE %or Param_Class=9 %thenstart
         Param_Addr4=I
         Param_IIN=7
      %finish
   %finish
               %if Ptype=CHARTYPE %then I=I+4
               I=I+4
               Pcount=Pcount+1
            %repeat;! for all params
            %if I>Maxstptr %then Maxstptr=I
            %if Curptr=Com_Subprogptr %thenstart
               Eproc(string(Com_Anames+Ep_Iden),Props,Pcount,I,-1,Id)
            %finish
            Curptr=EP_Link3<<DSCALE;! to next entry point
         %repeat
         %if Maxstptr<12 %then Maxstptr=12
         Linenoword=Maxstptr
         Com_Stackca=Linenoword+4
         Init End(1,Linenoword);! to locate start of code of subprog
         Ejump(JUMP,100000);! to prologue
         %if Anychecks=YES %thenstart
            EP==record(Adict+Com_Subprogptr)
            S=string(Anames+Ep_Iden)
            %if S="F_MAIN" %or Com_Subprogtype=1 %then S="MAIN PROGRAM"
            I=((length(S)+4)>>2)<<2
            Thisprocid=Com_Ioareaca
            Edbytes(IOAREA,Com_Ioareaca,I,addr(S))
            Com_Ioareaca=Com_Ioareaca+I
         %finish
         %if Unasschecks=Yes %thenstart
            Unass Plab=New Plab
            Elabel(Unass Plab)
            Euchecklab(Unass Plab)
            Estklit(UNASSFAULT)
            Estklit(0)
            Estkaddr(IOAREA,Thisprocid,0,4)
            Syscall(F77RTERR)
         %finish
         %if Boundchecks=Yes %thenstart
            Bound Plab=New Plab
            Elabel(Bound Plab)
            Eboundlab(Bound Plab)
            Estklit(BOUNDFAULT)
            Estklit(0)
            Estkaddr(IOAREA,Thisprocid,0,4)
            Syscall(F77RTERR)
         %finish
!         %if Charchecks=Yes %thenstart
!            Char Plab=New Plab
!            Elabel(Char Plab)
!            Pshortconst(CHARFAULT)
!            Ejump(JMPB,Error Plab)
!         %finish
!         %if Argchecks=Yes %thenstart
!            Arg Plab=New Plab
!            Elabel(Arg Plab)
!            Pshortconst(ARGFAULT)
!            Ejump(JMPB,Error Plab)
!         %finish
      %finish
      Init Descs
      Initdone=1
%end;! Cgeninit
!*
!*
%routine Cgenstart
%integer I
!*
      I=Com_F77parm
      %if I&1=0 %then Charchecks=YES  %else Charchecks=NO
      %if I&2=0 %then Argchecks=YES   %else Argchecks=NO
      %if I&4=0 %then Unasschecks=YES %else Unasschecks=NO
      %if I&16=0 %then Boundchecks=YES %else Boundchecks=NO
      Anychecks=Unasschecks!Charchecks!Boundchecks
      Listcode=Control&X'4000';! LISTINGS=OBJECT
!*
      Linest=0
!*
!*
%end;! Cgenstart
!*
!***********************************************************************
!***********************************************************************
!*
!*
%switch T(0:127)
!*
      Addrcom=Comad
      Com==record(Comad)
      Adict=Com_Adict
      Anames=Com_Anames
      Control=Com_Control
      Options1=Com_Options1
      Options2=Com_Options2
!*
      Cgenstart
!*
      %if 1<=Cgenep<=2 %thenstart;! physical end of file
         Finish(Cgenep)
         %return
      %finish
      %if Cgenep=4 %thenstart;! errors or scan
         Cgeninit;! to zero counts
         Subprogend(0,0)
         %return
      %finish
!*
      %if Com_Subprogtype=5 %then ->Endoftext
!*
      Initdone=0;! to ensure that Cgeninit is called
      Next Triad = 1
      Atriads=Com_Atriads
      Epilogue=New Plab;! label to be jumped to at RETURN
      Curop=0
      Elevel=0
!*
T(NULL):
!*
Triad Loop:
!*
      %if Curop#STMT %then Lastop=Curop
      %if nexttriad=0 %then ->Endoftext
      TR==record(Atriads+Next Triad*TRIADLENGTH)
      Save Triad =Next Triad
      Next Triad=TR_Chain
      Curop=TR_Op
{printstring("+++++++++ triad"); write(Save Triad,4)}
{printstring("   Elevel ="); write(Elevel,1);newline}
      ->T(Curop)
!*
T(REPL):
      ->Triad Loop
!*
T(NOOP):
      -> Triad Loop
!*
T(STMT):
!%if Elevel>0 %then %monitor %and %stop
      I=Tr_Val2&X'7F'
      %if I=0 %thenstart;! compiler defined label
         Declare Plab(Tr_Opd2)
      %finishelsestart
         %if I=3 %or I=4 %then -> Triad Loop;! intermediate (for opt)
         Linest=Tr_Sln
         %if Initdone=0 %then Cgeninit
         %if I = 1 %thenstart;! user defined label
            %if Tr_Qopd2=PLABID %thenstart
               Declare Plab(Tr_Opd2)
            %finishelsestart
               Labrec==record(Adict+Tr_Opd2<<DSCALE)
               Labrec_Addr4 = Labrec_Lab
               Elabel(Labrec_Lab)
            %finish
         %finish
         Elinestart(Linest)
      %finish
      %if I<2 %then Clear Estack
{ consider release of any scalars or char temps on stack}
!*
      ->Triad Loop
!*
T(ADD):
!*
T(SUB):
!*
T(NEG):
!*
T(MULT):
!*
T(DIV):
      Save Res(Arithop(Tr_Res1_W,Tr_Op,Tr_Res2_W))
      ->Triad Loop
!*
T(BRK):
      %unless Tr_Mode=CHARMODE %thenstart
         Triads(Savetriad)_Res1_W = Triads(TR_Opd1)_Res1_W
      %finish
      Triads(Savetriad)_Op = REPL
      ->Triad Loop
!*
T(EXP):
      Save Res(Expfn(Tr_Res1_W,Tr_Res2_W))
      -> Triad Loop
!*
T(EXP3):
      { -1 ** Tr_Res2 }
      Ef77op(EM1EXP)
      Save Res(Get Etemp(INT4))
      ->Triad Loop
!*
T(LOADB):
      { add code for optimiser}
      ->Triad Loop
!*
T(STOREB):
      { add code for optimiser}
      ->Triad Loop
!*
T(DINIT):
      { add code for optimiser}
      ->Triad Loop
!*
T(INIT):
      { add code for optimiser}
      ->Triad Loop
!*
T(PINCR):
!*
T(INCR):
      { add code for optimiser}
      ->Triad Loop
!*
T(DECR):
      { add code for optimiser}
      ->Triad Loop
!*
T(ASGN):
      Labrec==record(Adict+Tr_Opd2<<Dscale)
      %if Labrec_X0=8 %thenstart;! format label
         I=Com_Ioareaca
         Ed4(IOAREA,I,M'FMT ')
         Efix(IOAREA,I+4,IOAREA,Labrec_Addr4);! @ format table
         Estkaddr(IOAREA,I,0,0)
         Com_Ioareaca=I+8
      %finishelsestart;! executable label
         Estklit(Next Ass Lab)
         Next Ass Lab=Next Ass Lab+1
         I=Dictspace(8)
         SS==record(Adict+I)
         SS_Inf0=Tr_Opd2<<DSCALE
         SS_Link1=Assigned Labs
         Assigned Labs=I
      %finish
      Store Val(Tr_Res1_W,ESTORE)
      ->Triad Loop
!*
T(ASMT):
!*
T(CVT):
      ASSIGN(TR_RES1_W,TR_RES2_W)
      ->Triad Loop
!*
T(DEFARR):
!*
T(ARGARR):
!*
T(ARR):
!*
T(ARR1):
      %IF TR_QOPD2&TEXTMASK#0 %THEN TR_RES2_W=ARRSUB(TR_RES2_W)
{      %IF TR_QOPD2=TMPID %THENSTART}
{         %IF CMPLX8<=TR_MODE<=CMPLX32 %THEN TR_QOPD2=PERMID}
{      %FINISH}
      %UNLESS TR_USE<2 %OR TR_MODE=CHARMODE  %C
                       %OR CMPLX8<=TR_MODE<=CMPLX32 %THENSTART
         Res1_H0=Savetriad
         Res1_Mode=Tr_Mode
         Res1_Form=ARREL
         Get Operand(Res1_W)
         Save Res(Get Etemp(Tr_Mode))
      %finish
      ->Triad Loop
!*
T(BOP):
     ->Triad Loop
!*
T(JINN):
!*
T(JINP):
!*
T(JINZ):
!*
T(JIN):
!*
T(JIP):
!*
T(JIZ):
      Arithmetic If
      ->Triad Loop
!*
T(GOTO):
      %unless Tr_Qopd1=LABID %or Tr_Qopd1=PLABID %thenstart;! assigned GOTO
         Load Int(Tr_Res1_W)
         Eop(EINTRES)
         %if Assigned Gotos=0 %then Assigned Gotos=New Plab
         Ejump(JUMP,Assigned Gotos)
      %finishelse Ejump(JUMP,Get Label(Tr_Res1_W))
      ->Triad Loop
!*
T(CGT):
      Computed Goto(Tr_Opd2<<DSCALE,0)
      ->Triad Loop
!*
T(NOT):
      Load Int(Tr_Res1_W);! will be 32 bit logical
      Eop(INOT)
      Save Res(Get Etemp(Tr_Mode))
      -> Triad Loop
!*
T(EQUIV):
!*
T(NEQ):
      {Checkstack}
      Load Int(Tr_Res1_W)
      Load Int(Tr_Res2_W)
      Eop(IXOR)
      %if Curop=Equiv %thenstart
         Estklit(1)
         Eop(IXOR)
      %finish
      Save Res(Get Etemp(LOG4))
      ->Triad Loop
!*
T(GT):
!*
T(LT):
!*
T(NE):
!*
T(EQ):
!*
T(GE):
!*
T(LE):
      Condmask=Tr_Op-GT;! may get modified for reverse ops
      %if Tr_Mode=CHARMODE %thenstart
         Charop(Tr_Res1_W,1,Tr_Res2_W)
      %finishelsestart
         Save Res(Arithop(Tr_Res1_W,1,Tr_Res2_W))
      %finish
      -> Triad Loop
!*
T(JIT):
!*
T(JIF):
      Load Int(Tr_Res1_W)
      %if Curop=JIT %then Op=JTRUE %else Op=JFALSE
      Ejump(Op,Get Label(Tr_Res2_W))
      -> Triad Loop
!*
T(STOD1):
      Tr1==record(Atriads+Next Triad*TRIADSIZE)
      Load Int(Tr_Res2_W);! initial
      %if Tr1_Op=STOD2 %then Curop=EDUPSTORE %else Curop=ESTORE
      Store Val(Tr_Res1_W,Curop);! index
      ->Triad Loop
!*
T(STOD2):
      Load Int(Tr_Res1_W);! final
      Ejump(JIGT,Get Label(Tr_Res2_W))
      ->Triad Loop
!*
T(EOD1):
      Res1_W = Tr_Res1_W;! control var
      Res2_W = Tr_Res2_W;! increment
      -> Triad Loop
!*
T(EOD2):
      Load Int(Tr_Res1_W);! final
      Load Int(Res1_W);! index
      Load Int(Res2_W);! increment
      Eop(IADD)
      Store Val(Res1_W,EDUPSTORE);! index
      Ejump(JIGE,Get Label(Tr_Res2_W))
      -> Triad Loop
!*
T(NINT):
!*
T(ANINT):
!*
T(DIM):
!*
T(LEN):
!*
T(AINT):
!*
T(ABS):
!*
T(MOD):
!*
T(SIGN):
!*
T(MIN):
!*
T(MAX):
!*
T(DMULT):
!*
T(REALL):
!*
T(IMAG):
!*
T(CMPLX):
!*
T(CONJG):
!*
T(ICHAR):
!*
T(TOCHAR):
!*
T(CHIND):
!*
T(DCMPLX):
      INLINE(TR_OP,TR_RES1_W,TR_RES2_W)
      ->Triad Loop
!*
T(INTRIN):
      Bitsfns(Tr_Opd1,Tr_Mode,Tr_Opd2)
      ->Triad Loop
!*
T(IFUN):
!*
T(FUN):
      I=NO
CPROC:Vret=0
      %if Curop=SUBR %thenstart;! check for variable return
         Tr1==record(Atriads+Next Triad*TRIADSIZE)
         %if Tr1_Op=CGT %and Tr1_Qopd1=NULL %thenstart
            Vret=1
         %finish
      %finish
      Call Subprog(I,TR_OPD1<<DSCALE,TR_MODE,TR_MODE2,TR_OPD2);! subroutine?, Fptr, fnmode, pct,  plink
      %if Vret#0 %then Estkresult(0,1,4)
      ->Triad Loop
!*
T(SUBR):
      I=YES
      ->CPROC
!*
T(ARG):
      %if Tr_Use>1 %thenstart
         %if Tr_Qopd1=TRIAD %thenstart
            Tr_Res1=Triads(Tr_Opd1)_Res1
            %if Tr_Qopd1=TMPID %thenstart
               Tr_Qopd1=PERMID
            %finish
         %finish
      %finish
     ->Triad Loop
!*
T(DARG):
      ->Triad Loop
!*
T(STOP):
!*
T(PAUSE):
      %if TR_MODE=NULL %thenstart;! no specified param
         Estklit(-1)
         Estklit(0)
      %finishelsestart
         %if Tr_Mode=CHARMODE %thenstart
            I=Adict+Tr_Opd1<<DSCALE
            L=integer(I)
            Disp=Alloc Char(L,I+W1,IIN)
            Estklit(L)
            Estkaddr(IIN,Disp,0,0)
         %finishelsestart
            Estklit(0)
            Estklit(Conout(Tr_Res1_W))
         %finish
      %finish
      %if TR_OP=STOP %then I=F77STOP %else I=F77PAUSE
      Syscall(I)
      ->Triad Loop
!*
T(RET):
      %if TR_QOPD1=NULL %thenstart
         %if Com_Vreturn#0 %thenstart
            Estklit(0)
            Ef77op(EFNOTEVR)
         %finish
      %finishelsestart
         Load Int(Tr_Res1_W)
         Ef77op(EFNOTEVR)
      %finish
      %unless Com_Subprogtype=5 %then Ejump(JUMP,Epilogue)
      ->Triad Loop
!*
T(STRTIO):
      Startio(Tr_Opd1,Tr_Opd2)
      ->Triad Loop
!*
T(DIOITEM):
!*
T(IOITEM):
      Io List Item(Tr_Res1_W)
      ->Triad Loop
!*
T(IODO):
      %if Ioinit=0 %thenstart
         Call Ioproc
         Ioinit=1
      %finish
      ->Triad Loop
!*
T(IOSPEC):
      Io Spec Clause(Tr_Qopd2,Tr_Opd2,Tr_Res1_W)
      ->Triad Loop
!*
T(ENDIO):
      Completeio(Tr_Opd1,TR_Opd2)
      ->Triad Loop
!*
T(SUBSTR):
      {force evaluation of array els in lhs or rhs}
      %if Tr_Qopd1=ARREL %then Tr_Res1_W=Arrsub(Tr_Res1_W)
      %if Tr_Qopd2=ARREL %then Tr_Res2_W=Arrsub(Tr_Res2_W)
      Tr_Res1_W=Extriad(Tr_Res1_W)
      Tr_Res2_W=Extriad(Tr_Res2_W)
      %if Tr_Qopd1=TMPID %thenstart
         TR_Qopd1=PERMID
         Clear Estack
      %finish
      %if Tr_Qopd2=TMPID %thenstart
         TR_Qopd2=PERMID
         Clear Estack
      %finish
      ->Triad Loop
!*
T(CONCAT):
!*
T(CHAR):
!*
T(CHHEAD):
      ->Triad Loop
!*
T(EOT):
Endoftext:
      %if Assigned Gotos#0 %then Assigned List
      Subprogend(1,Epilogue)
      %return
!*
T(*): %monitor
      %stop
!*
%integerfn New Plab
!***********************************************************************
!* Provide a new private label                                         *
!***********************************************************************
%integer I
      I=Com_Next Plab+100000
      Com_Next Plab=Com_Next Plab+1
      %Result=I
%end;! New Plab
!*
%routine Declare Plab(%integer Ptr)
!***********************************************************************
!* used only for private labels declared in triads                     *
!***********************************************************************
%record(Plabf)%name Plab
      Plab==record(Adict+Ptr<<DSCALE)
      Elabel(Plab_Index+100000)
%end
!*
%integerfn Get Label(%integer Resw)
!***********************************************************************
!* user label or private label inserted by Generate                    *
!***********************************************************************
%record(Labrecf)%name Labrec
%record(Plabf)%name Plab
%record(Resf) R
      R_W=Resw
      %if R_Form=LABID %thenstart
         Labrec==record(Adict+R_H0<<DSCALE)
         %RESULT=Labrec_Lab
      %finishelsestart
         PLAB==record(Adict+R_H0<<DSCALE)
         %RESULT=Plab_Index+100000
      %finish
%end;! Get Label
!*
%routine Computed Goto(%integer List,Mode)
!***********************************************************************
!* Mode = 0  normal computed goto                                      *
!*        1  label list after subprog call                             *
!***********************************************************************
%integer I,J,K,Sptr,Plab1,Plab2
%record(Labrecf)%name Labrec
%record(Srecf)%name SS
      %if Mode=0 %thenstart
         %if Tr_Qopd1#NULL %then Load Int(Tr_Res1_W)
      %finish
      I=0;! for count of items
      Sptr=List
      %while Sptr#0 %cycle
         I=I+1
         SS==record(Adict+Sptr)
         Sptr=SS_Link1
      %repeat
!******  PLANT GOTO SWITCH LIST
      Plab1=New Plab;! dummy label on switch
     {Plab2=New Plab;! for fall through effect on switch 0 - needed on POS}
      Sptr=List
      Eswitch(0,I,Plab1,-1,Com_Sstca)
     {Eswitchlabel(Plab1,0,Plab2)}
      I=1
      %while Sptr#0 %cycle
         SS==record(Adict+Sptr)
         Sptr=SS_Link1
         Labrec==record(Adict+SS_Inf0)
         Eswitchlabel(Plab1,I,Labrec_Lab)
         I=I+1
      %repeat
      Efswitchjump(Plab1)
     {Elabel(Plab2)}
%end;! Computed Goto
!*
%routine Assigned List
%integer Head,Link,Save
%record(Srecf)%name SS
      Head=0
      Link=Assigned Labs
      %while Link#0 %cycle;! invert list
         SS==record(Adict+Link)
         Save=Link
         Link=SS_Link1
         SS_Link1=Head
         Head=Save
      %repeat
      %if Assigned Gotos#0 %then Elabel(Assigned Gotos)
      %if Head#0 %thenstart;! allow case where no labels are assigned
         Estkresult(0,1,4)
         Computed Goto(Head,1)
      %finish
      Rterror(JUMP,ASSLABELFAULT)
%end;! Assigned List
!*
%routine Arithmetic If
%constintegerarray Icond(0:5)=JINTGEZ,JINTLEZ,JINTNZ,JINTLZ,JINTGZ,JINTZ
%constintegerarray Rcond(0:5)=JRGEZ,JRLEZ,JRNZ,JRLZ,JRGZ,JRZ
%constbyteintegerarray Map(0:5)=0,0,0,1,3,2
%integerarray Lab(1:3)
%Record(Triadf)%name Nexttr,Nexttr2
%integer I,J,Inst1,Inst2
      Nexttr==record(Atriads+Next Triad*Triad Size)
      %if JINN<=Nexttr_Op<=JIZ %thenstart
         Nexttr2==record(Atriads+Nexttr_Chain*Triad Size)
         %if Nexttr2_Op=GOTO %thenstart
            Next Triad=Nexttr2_Chain
            I=Get Label(Nexttr2_Res1_W)
         %finishelsestart
            Next Triad=Nexttr_Chain
            I=-1
         %finish
         %cycle J=1,1,3
            Lab(J)=I
         %repeat
         Lab(Map(Curop-JINN))=Get Label(Tr_Res2_W)
         Lab(Map(Nexttr_Op-JINN))=Get Label(Nexttr_Res2_W)
         I=1
      %finishelse I=0
      Get Operand(Tr_Res1_W)
      J=Arithclass(Tr_Res1_Mode)
      %if J=INTCLASS %thenstart;! integer
         Inst1=Icond(Curop-JINN)
         Inst2=ITWB
      %finishelsestart
         Inst1=Rcond(Curop-JINN)
         Inst2=RTWB
      %finish
      %if I=0 %thenstart
         Ejump(Inst1,Get Label(Tr_Res2_W))
      %finishelsestart
         Etwjump(Inst2,Lab(1),Lab(2),Lab(3))
      %finish
%end;! Arithmetic If
!*
%routine Rterror(%integer Jumpop,Er)
!* if Jumpop fails then report run-time error
%record(Precf)%name EP
%string(32) S
%integer Plab,I
      Plab=New Plab
      Ejump(Jumpop,Plab)
!!      %if Anychecks=YES %thenstart
!!         Estklit(er)
!!         Ejump(JUMP,Error Plab)
!!      %finishelsestart
         %if Thisprocid<0 %thenstart
            EP==record(Adict+Com_Subprogptr)
            S=string(Anames+EP_Iden)                    
            %if S="F_MAIN" %or Com_Subprogtype=1 %then S="MAIN PROGRAM"
            I=((length(S)+4)>>2)<<2
            Thisprocid=Com_Ioareaca
            Edbytes(IOAREA,Com_Ioareaca,I,addr(S))
            Com_Ioareaca=Com_Ioareaca+I
         %finish
         Estklit(Er)
         %if Com_Control&X'10000'=0 %thenstart
            Ldstk(Lineno Word,4)
         %finishelse Estklit(0)
         Estkaddr(IOAREA,Thisprocid,0,0)
         Syscall(F77RTERR)
!!      %finish
      Elabel(Plab)
%end;! Rterror
!*
!*
%end;! Codegen
%endoffile