!* modified 24/02/86
!*
%ownstring(31) Versiontext="Fortran77 Compiler Version 0.1"
%owninteger Report=0
%owninteger Decode
%owninteger Language
!*
%constinteger IMP = 1
%constinteger FORTRAN = 2
%constinteger CCOMP = 11
%constinteger PASCAL = 14
!*
!***********************************************************************
!* Exports *
!***********************************************************************
!*
%routinespec Einitialise(%integer Lang, Avertext, Astackca,
Aglaca, Options)
%routinespec Eterminate(%integer adareasizes)
%routinespec Ecommon(%integer area, %stringname Name)
%routinespec Eendcommon(%integer area, Length)
%routinespec Elinestart(%integer lineno)
%routinespec Elinedecode
%routinespec Emonon
%routinespec Emonoff
%routinespec Efaulty
%integerfnspec Estkmarker
%routinespec Esetmarker(%integer Markerid, New Value)
%integerfnspec Eswapmode
!*
%routinespec Estklit(%integer Val)
%routinespec Estkconst(%integer Len, Ad)
%routinespec Estkdir(%integer Area, Offset, Adid, Bytes)
%routinespec Estkind(%integer Area, Offset, Adid, Bytes)
%routinespec Estkglobal(%integer Level, Offset, Adid, Bytes)
%routinespec Estkglobalind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkpar(%integer Level, Offset, Adid, Bytes)
%routinespec Estkparind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkresult(%integer Class, Type, Bytes)
%routinespec Erefer(%integer Offset, Bytes)
%routinespec Epromote(%integer Level)
%routinespec Edemote(%integer Level)
%routinespec Estkaddr(%integer Area, Offset, Adid, Bytes)
!*
%routinespec Elabel(%integer id)
%routinespec Ediscardlabel(%integer id)
%routinespec Ejump(%integer Opcode, Labelid)
%routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3)
%routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid,
%integername SSTad)
%routinespec EswitchJump(%integer Switchid)
%routinespec EfswitchJump(%integer Switchid)
%routinespec Eswitchentry(%integer Switchid, Entry)
%routinespec Eswitchdef(%integer Switchid)
%routinespec EswitchLabel(%integer Switchid, Entry, Labelid)
!*
%routinespec Ed1(%integer area, Disp, Val)
%routinespec Ed2(%integer area, Disp, Val)
%routinespec Ed4(%integer area, Disp, Val)
%routinespec Edbytes(%integer area, Disp, len, ad)
%routinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%routinespec Efix(%integer area, disp, tgtarea, tgtdisp)
!*
%integerfnspec EXname(%integer type, %string(255)%name Xref)
%routinespec Eprecall(%integer Id)
%routinespec Ecall(%integer Id, Numpars, Paramsize)
%routinespec Eprocref(%integer Id, Level)
%routinespec Esave(%integer Asave, %integername Key)
%routinespec Erestore(%integer Asave, Key, Existing)
!*
%integerfnspec Enextproc
%routinespec Eproc(%stringname Name, %integer Props, Numpars, Paramsize,
Astacklen, %integername Id)
%routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen)
%routinespec Eentry(%integer Index,Numpars,Paramsize, Localsize, Diagdisp,
%stringname Name)
!*
%routinespec Edataentry(%integer Area, Offset, Length,
%stringname Name)
%routinespec Edataref(%integer Area, Offset, Length,
%stringname Name)
!*
%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
!*
!*
!***********************************************************************
!* Imports *
!***********************************************************************
!*
%include "cfort_xaspecs1"
!%include "cfort_xaspecs"
%include "ebits_ecodes2"
%include "ebits_enames2"
%include "cfort_xamnem"
!*
!*
!***********************************************************************
!* Common declarations *
!***********************************************************************
!*
!*
!*
!***********************************************************************
!*
%constinteger LitVal = 0 { lit }
%constinteger ConstVal = 1 { const }
%constinteger RegVal = 2 { (reg) }
%constinteger FregVal = 3 { (freg) }
%constinteger TempVal = 4 { (temp) }
%constinteger DirVal = 5 { (dir) }
%constinteger IndRegVal = 6 { ((reg)) }
%constinteger IndTempVal = 7 { ((temp)) }
%constinteger IndDirVal = 8 { ((dir)) }
%constinteger AddrConst = 9 { @const }
%constinteger AddrDir = 10 { @dir }
%constinteger RegAddr = 11 { (reg) is @ }
%constinteger TempAddr = 12 { (temp) is @}
%constinteger DirAddr = 13 { (dir) is @ }
%constinteger AddrDirMod = 14 { @dir+M }
%constinteger RegModAddr = 15 { (reg)+M }
%constinteger TempModAddr = 16 { (temp)+M }
%constinteger DirModAddr = 17 { (dir)+M }
%constinteger IndRegModVal = 18 { ((reg)+M) }
%constinteger IndTempModVal = 19 { ((temp)+M) }
%constinteger IndDirModVal = 20 { ((dir)+M) }
%constinteger AddrDirModVal = 21 { (@dir+M) }
%constinteger RegBitAddr = 22 { (reg) is @ }
%constinteger RegBitModAddr = 23 { (reg)+M }
!*
%constinteger Regflag = 32 {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:21) = %c
"LitVal ","ConstVal ","RegVal ","FregVal ",
"TempVal ","DirVal ","IndRegVal ","IndTempVal ",
"IndDirVal ","ConstAddr ","AddrDir ","RegAddr ",
"TempAddr ","DirAddr ","AddrDirMod ","RegModAddr ",
"TempModAddr ","DirModAddr ","IndRegModVal ","IndTempModVal ",
"IndDirModVal ","AddrDirModVal "
!*
%recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg,
Base,Modbase,Scale,Modform,
(%integer Offset %or %integer Intval),
(%integer Modoffset %or %integer Modintval),
%integer Size,Adid)
!*
%ownrecord(Stkfmt)%array Stk(0:15)
%ownrecord(Stkfmt) LitZero
%ownrecord(Stkfmt) LitOne
!*
%owninteger Elevel
%owninteger ProgFaulty
%owninteger ProcProps
!*
%conststring(9)%array Expprocs(0:14)= %c
"f_powii" ,"f_powri" ,"f_powdi" ,"f_powqi" ,"f_powci" ,
"f_powzi" ,"f_powzzi" ,"" ,"" ,"f_powrr" ,
"f_powdd" ,"f_powqq" ,"f_powcc" ,"f_powzz" ,"f_powzzz"
!*
%constintegerarray Expprocpdesc(0:14)= %c
X'20008',X'20008',X'2000C',X'20008',X'3000C',
X'3000C',X'3000C',0 ,0 ,X'20008',
X'20010',X'20008',X'3000C',X'3000C',X'3000C'
!*
%constintegerarray Expproctype(0:14)= %c
X'10401',X'10402',X'10802',X'11002',X'10000',
X'10000',X'10000', 0, 0,X'10402',
X'10802',X'11002',X'10000',X'10000',X'10000'
!*
%ownintegerarray Expprocref(0:14)
!*
%conststring(9)%array Spprocs(0:8)= %c
"f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv" ,
"f_cddiv" ,"f_cqdiv" ,"f_index" ,"f_concat",
"p_stop"
!*
%constintegerarray Spprocpdesc(0:8)= %c
X'3000C',X'3000C',X'3000C',X'3000C',
X'3000C',X'3000C',X'40010',X'40010',
0
!*
%constintegerarray Spproctype(0:8)= %c
X'10000',X'10000',X'10000',X'10000',
X'10000',X'10000',X'10000',X'10000',
0!*
%ownintegerarray Spprocref(0:8)
!*
%owninteger Unasslab,Bounderr
!*
!*
!***********************************************************************
!* Amdahl-specific declarations *
!***********************************************************************
!*
!*
%constinteger R0 = 0
%constinteger R1 = 1
%constinteger R2 = 2
%constinteger R3 = 3
%constinteger R4 = 4
%constinteger R5 = 5
%constinteger R6 = 6
%constinteger R7 = 7
%constinteger R8 = 8
%constinteger R9 = 9
%constinteger R10 = 10
%constinteger R11 = 11
%constinteger R12 = 12
%constinteger R13 = 13
%constinteger R14 = 14
%constinteger R15 = 15
!*
%constbyteintegerarray Setcc(0:5)=2,4,8,6,10,12 {GT LT EQ NE GE LE}
%constbyteintegerarray Invcc(0:15)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15
!*
%constinteger Stack Offset=64
%constinteger Param Offset=64
%owninteger Display Offset
%owninteger Gla Offset
!*
%constintegerarray Cnstinit(0:13)= 0,0,
X'4E000000', X'80000000',
X'4E000001', X'00000000',
X'4F000000', X'08000000',
X'81818181', X'81818181',
X'40800000', X'00000000',
X'00000000', X'00000000'
%constinteger TWO31 = 8
%constinteger TWO32 = 16
%constinteger TWO31R= 24
%constinteger RHALF = 40
!*
!***********************************************************************
!*
%ownintegerarray Areabase(0:255)
%ownintegerarray Areaprops(0:255)
%ownintegerarray Ruse(0:15)
%ownintegerarray Fruse(0:6)
!*
%owninteger Addrstackca, Addrglaca
%owninteger Upperlineno
%owninteger UsingR14, UsingR15, Lastreg, Lastbreg, Lastfreg, Max4k
%owninteger Lockedb1
%owninteger CC, CCset
%owninteger Glaf77regs,Glawork,Curdiagca
%owninteger CurCnst
%owninteger Next Param Offset
%owninteger Save Param Offset
%owninteger Active Calls
%owninteger Curswitchad
%owninteger Curswitchmax
%owninteger Procmark
%owninteger Proclevel
!*
!*
!***********************************************************************
!* Code generation procedure specs *
!***********************************************************************
!*
!*
%routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Address(%record(Stkfmt)%name Stk)
%integerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg)
%integerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg,
%integername Bytes)
%integerfnspec Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize)
%routinespec Push Operand(%record(Stkfmt)%name Operand)
%routinespec Stackr(%integer R)
%routinespec Stackfr(%integer FR,Bytes)
%routinespec Establish Logical
%routinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%routinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%routinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%routinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%routinespec Convert RR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode)
%integerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
%routinespec Push Param(%integer Mode,%record(Stkfmt)%name Stk)
%integerfnspec Load address(%record(Stkfmt)%name Stk)
%routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%routinespec Expcall(%integer Proc)
%routinespec Spcall(%integer Proc)
!*
%routinespec Referp(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec String Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS,
%integer Bytes)
%routinespec Set Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS,
%integer Bytes)
%routinespec Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue)
!*
%routinespec Clear Regs
%routinespec Dropall
%routinespec Freeup Freg(%integer R)
%routinespec Freeup Reg(%integer R)
%routinespec Freeregs
%routinespec Reset Reguse(%integer Old,New)
%integerfnspec Claimfr(%integer Curreg)
%integerfnspec Claimfrpair(%integer Curreg)
%integerfnspec Claimr(%integer Curreg)
%integerfnspec Claimrpair(%integer Curreg)
%integerfnspec Claimbr
%integerfnspec New Temp(%integer Bytes)
%routinespec Setint(%integer Val,Size,%integername B2,D2)
%integerfnspec Basereg(%integer Area)
%integerfnspec SetX2(%integername D2)
%routinespec Range(%integername B,D)
%integerfnspec Indbase(%integer Area,Disp)
%routinespec Do Rx(%integer Op,Reg,Base,Offset)
%integerfnspec Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg)
%routinespec OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2)
%routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
%routinespec Set BD(%record(Stkfmt)%name Stk,%integername B,D)
!*
!***********************************************************************
!*
%ownstring(8)%array Areas(0:255)= %c
"Stack ","Code ","Gla ","","Ust ","Gst ","Diags ","Scalars",
"Ioarea ","","Consts ",""(245)
!*
%routine Phex(%integer Val)
%conststring(1)%array C(0:15)= %c
"0","1","2","3","4","5","6","7",
"8","9","A","B","C","D","E","F"
%integer I
%cycle I=28,-4,0
printstring(C((Val>>I)&15))
%repeat
%end
!*
%integerfn Glaspace(%integer bytes)
%integer I
bytes=((bytes+3)>>2)<<2
I=integer(Addrglaca)+Gla offset
integer(addrglaca)=integer(addrglaca)+bytes
%result=I
%end;! Glaspace
!*
%routine Dump Estack
%record(Stkfmt)%name E
%integer I,J,K
%routine Pform(%integer Form,Reg,Base,Offset)
printstring(Eform(Form&31))
%if Form&Regflag#0 %then write(Reg,1) %and %return
%if Form=Litval %thenstart
write(Offset,4)
%return
%finish
! %if Base#0 %thenstart
printstring(Areas(Base))
! %finish
! %if Offset#0 %thenstart
printstring(" + ")
write(Offset,3)
! %finish
%end;! Pform
%if Elevel<=0 %then %return
write(ruse(1),1);write(ruse(2),1);write(ruse(3),1);newline
printstring("Estack:
")
I=Elevel
%while I>0 %cycle
J=addr(Stk(I))
! %cycle K=0,4,16
! Phex(integer(J+K))
! space
! %repeat
E==record(J)
write(I,1);printstring(":")
Pform(E_Form,E_Reg,E_Base,E_offset)
%if (E_Form&31)>=AddrDirMod %thenstart
printstring(" mod by:")
Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset)
%if E_Scale>1 %thenstart
printstring(" scaled by:")
write(E_Scale,1)
%finish
%finish
printstring(" size:")
write(E_Size,1)
newline
I=I-1
%repeat
%end;! Dump Estack
!*
!*
!**********************************************************************
!**********************************************************************
!** Error reporting **
!**********************************************************************
!**********************************************************************
!*
!*
%routine Low Estack(%integer Opcode,Reqlevel)
printstring("******* Estack error ******
Op = ".Eopname(Opcode)." actual/required levels:")
write(Elevel,4)
write(Reqlevel,4)
newline
%monitor
%stop
Elevel=0
%end;! Low Estack
!*
%routine Abort
Dump Estack
%monitor
%stop
%end;! Abort
!*
%routine abortm(%string(31) S)
printstring("
*** Xgen abort - ".S." ***
")
Dump Estack
%monitor
%stop
%end;! abortm
!*
%routine Unsupported Opcode(%integer Opcode)
%string(15) S
%if Opcode<=255 %then S=Eopname(Opcode) %elseif %c
Opcode<511 %then S=Ef77opname(Opcode) %else S=Epasopname(Opcode)
printstring("******* Unsupported Opcode ****** ".S)
newline
%end;! Unsupported Opcode
!*
!*
!***********************************************************************
!***********************************************************************
!** Externally visible procedures **
!***********************************************************************
!***********************************************************************
!*
!*
!* *********************
!* * Administration *
!* *********************
!*
!*
%externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options)
!***********************************************************************
!* called once at the start of compilation to initialise Eput *
!***********************************************************************
%integer I,Flags
ProgFaulty=0
Report=options&1
Decode=Options&X'4000'
Language=Lang
%if Report#0 %thenstart
printstring("Einitialise ")
newline
%finish
Addrstackca=Astackca
Addrglaca=Aglaca
Upperlineno=-1
UsingR14=0
UsingR15=0
Clear Regs
CCset=0
Elevel=0
%cycle I=0,1,255
Areabase(I)=0
Areaprops(I)=0
%repeat
%cycle I=4,1,10
Areabase(I)=I<<2+64
%repeat
%cycle I=0,1,14
Expprocref(I)=0
%repeat
%cycle I=0,1,8
Spprocref(I)=0
%repeat
!*
%if Language=PASCAL %then Gla Offset=48 %else Gla Offset=0
!*
%if Language=FORTRAN %then Flags=3 %else Flags=1
Pinitialise(-1,Flags,Aver)
!*
Pfix(Gla,4,Code,0);! initialise first six words of gla
Pfix(Gla,8,Ust,0)
Areabase(5)=8
Pfix(Gla,12,SST,0)
%if Lang=PASCAL %then Lang=15 {a communication problem}
Pd4(Gla,16,Lang<<24)
Pfix(Gla,20,Diags,0)
%if Language=PASCAL %thenstart
I=32
%finishelsestart
I=Glaspace(16)
%finish
Glaf77regs=I
Pfix(Gla,I,Static,0)
Pfix(Gla,I+4,Cnst,0)
Glawork=I+8
!*
Pdbytes(Cnst,0,56,addr(Cnstinit(0)))
Curcnst=56
Max4k=0
Lockedb1=0
Active Calls=0
!*
LitZero=0; LitZero_Form=LitVal
LitOne=0; LitOne_Form=LitVal; LitOne_IntVal=1
Proclevel=0
%end;! Einitialise
!*
%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator *
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J
%if Report#0 %thenstart
printstring("Eterminate ")
newline
%finish
%if ProgFaulty#0 %then %return
J=0
!newline
%cycle I=1,1,9
S(I)=integer(Adareasizes+J)
!write(s(i),4)
J=J+4
%repeat
!newline
%if Language=PASCAL %thenstart
Spcall(8)
S(2)=S(2)+Gla Offset+16
%finish
S(10)=CurCnst
I=Pterminate(addr(S(1)), 0)
integer(adareasizes)=S(1)
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255) *
!***********************************************************************
%integer Prop
%if Report#0 %thenstart
printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name)
Newline
%finish
%if ProgFaulty#0 %then %return
Area=Area+256
%if Name="F#BLCM" %then Prop=1 %else Prop=2
Areaprops(Area-256)=Prop
Pnewarea(Name,Area,Prop)
%end;! Ecommon
!*
%externalroutine Eendcommon(%integer area,Length)
!***********************************************************************
!* define length of previously defined common *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eendcommon ");write(Area,1);write(Length,6)
Newline
%finish
%if ProgFaulty#0 %then %return
Area=Area+256
Pendarea(Area,Length,Areaprops(Area-256))
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line *
!***********************************************************************
%if Report#0 %thenstart
printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Decode#0 %then Plinedecode
Plinestart(Lineno)
%if lineno & X'FF00' # Upperlineno %thenstart
PIX SI(MVI, lineno>>8, R10, 2)
Upperlineno = lineno & X'FF00'
%finish
PIX SI(MVI, lineno&X'FF', R10, 3)
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elinedecode ");
newline
%finish
%if ProgFaulty#0 %then %return
Plinedecode
%end;! Elinedecode
!*
%externalintegerfn Estkmarker
!***********************************************************************
!* turn on internal tracing *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkmarker ")
newline
%finish
%result=0
%end;! Estkmarker
!*
%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!* turn off internal tracing *
!***********************************************************************
%if Report#0 %thenstart
printstring("Esetmarker ");write(Markerid,4)
write(New Value,4)
newline
%finish
%end;! Esetmarker
!*
%externalintegerfn Eswapmode
!***********************************************************************
!* turn on internal tracing *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eswapmode ")
newline
%finish
%result=0
%end;! Eswapmode
!*
%externalroutine Emonon
!***********************************************************************
!* turn on internal tracing *
!***********************************************************************
Report=1
%end;! Emonon
!*
%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing *
!***********************************************************************
Report=0
%end;! Emonoff
!*
%externalroutine Efaulty
!***********************************************************************
!* compilation has a fault - no object file to be generated *
!***********************************************************************
%if Report#0 %thenstart
printstring("Efaulty ");
newline
%finish
ProgFaulty=1
Pfaulty
%end;! Efaulty
!*
!*
!*
!* *********************
!* * Stack operations *
!* *********************
!*
!*
%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estklit ");write(Val,6)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=LitVal
Stk(Elevel)_Intval=Val
Stk(Elevel)_Size=4
%end;! Estklit
!*
%externalroutine Estkconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkconst ")
write(Len,4)
newline
%finish
%if ProgFaulty#0 %then %return
Pdbytes(Cnst,CurCnst,Len,Ad)
Estkdir(Cnst,CurCnst,0,Len)
CurCnst=Curcnst+((Len+3)>>2)<<2
%end;! Estkconst
!*
%externalroutine Estkrconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkconst ")
write(Len,4)
newline
%finish
%if ProgFaulty#0 %then %return
Pdbytes(Cnst,CurCnst,Len,Ad)
Estkdir(Cnst,CurCnst,0,Len)
CurCnst=Curcnst+((Len+3)>>2)<<2
%end;! Estkrconst
!*
%externalroutine Estkdir(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkdir ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
%if Area=0 %then Offset=Offset+Stack Offset
%if Area=Gla %then Offset=Offset+Gla Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=DirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=Area
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkdir
!*
%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkind ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
%if Area=0 %then Offset=Offset+Stack Offset
%if Area=Gla %then Offset=Offset+Gla Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=IndDirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=Area
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkind
!*
%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand local to an enclosing level *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkglobal ");write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=DirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=0
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkglobal
!*
%externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand local to an enclosing level *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkglobalind ");write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=IndDirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=0
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkglobalind
!*
%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct parameter operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkpar ");write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=DirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=0
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkpar
!*
%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect parameter operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkparind ");write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=IndDirVal
Stk(Elevel)_Size=Bytes
Stk(Elevel)_Base=0
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkparind
!*
%externalroutine Estkresult(%integer Class,Type,Bytes)
!***********************************************************************
!* defines the result stacked by a function call *
!* Type = 1 int *
!* = 2 real *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkresult ")
write(Class,4);write(Type,4);write(Bytes,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Type=2 %thenstart;! real
Stackfr(0,Bytes)
%finishelse Stackr(1)
%end;! Estkresult
!*
%externalroutine Erefer(%integer Offset,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Erefer ");write(Offset,1);write(Bytes,6)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel<1 %then Abort %and %return
Refer(Stk(Elevel),Offset)
Stk(Elevel)_Size=Bytes
%end;! Erefer
!*
%externalroutine Epromote(%integer Level)
!***********************************************************************
!* move the entry at Level in Estack to the top of the Estack *
!* - the top entry is at level 1 *
!***********************************************************************
%record(Stkfmt) E
%integer I
%if Report#0 %thenstart
printstring("Epromote ");write(Level,4)
newline
%finish
%if ProgFaulty#0 %then %return
%unless 0<Level<=Elevel %then abort
%if Level=1 %then %return
Level=Elevel-Level+1
E=Stk(Level)
Reset Reguse(Level,Elevel+1);! to avoid problems
%cycle I=Level,1,Elevel-1
Stk(I)=Stk(I+1)
Reset Reguse(I+1,I)
%repeat
Stk(Elevel)=E
Reset Reguse(Elevel+1,Elevel)
%end;! Epromote
!*
%externalroutine Edemote(%integer Level)
!***********************************************************************
!* move the entry at the top of the Estack to Level in Estack *
!* - the top entry is at level 1 *
!***********************************************************************
%record(Stkfmt) E
%integer I
%if Report#0 %thenstart
printstring("Edemote ");write(Level,4)
newline
%finish
%if ProgFaulty#0 %then %return
%unless 0<Level<=Elevel %then abort
%if Level=1 %then %return
Level=Elevel-Level+1
E=Stk(Elevel)
Reset Reguse(Elevel,Elevel+1);! to avoid problems
%cycle I=Elevel,-1,Level+1
Stk(I)=Stk(I-1)
Reset Reguse(I-1,I)
%repeat
Stk(Level)=E
Reset Reguse(Elevel+1,Level)
%end;! Edemote
!*
%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkaddr ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
%if Area=0 %then Offset=Offset+Stack Offset
%if Area=Gla %then Offset=Offset+Gla Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=AddrDir
Stk(Elevel)_Size=4;! always 4 bytes for an address
Stk(Elevel)_Base=Area
Stk(Elevel)_Offset=Offset
Stk(Elevel)_Adid=Adid
%end;! Estkaddr
!*
%externalroutine Estkgaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%if Report#0 %thenstart
printstring("Estkgaddr ")
write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if Level=Proclevel %then Estkaddr(0,Offset,Adid,Bytes) %and %return
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirVal
Lstk_Size=4;! always 4 bytes for an address
Lstk_Base=0
Lstk_Offset=Display Offset - (Level*4)
Lstk_Modform=Litval
Lstk_Modoffset=Offset
Lstk_Adid=Adid
Eop(Eaddress)
%end;! Estkgaddr
!*
%externalroutine Estkpaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%if Report#0 %thenstart
printstring("Estkpaddr ")
write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
Offset=Offset+Param Offset
%if Elevel=15 %then %monitor %and %stop
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirVal
Lstk_Size=4;! always 4 bytes for an address
Lstk_Base=0
Lstk_Adid=Adid
Eop(Eaddress)
%end;! Estkpaddr
!*
!*
!*
!* *********************
!* * Labels, Jumps *
!* *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elabel ");write(Id,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel>0 %then Abort
Upperlineno = -1
Dropall
%if id =100027 %then %return
Plabel(id)
%end;! Elabel
!*
%externalroutine Ediscardlabel(%integer Id)
!***********************************************************************
!* advise that a label can now be discarded - i.e. no future ref *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ediscardlabel ");write(Id,4)
newline
%finish
%end;! Ediscardlabel
!*
%externalroutine Euchecklab(%integer Labid)
Unasslab=Labid
%end
!*
%externalroutine Eboundlab(%integer Labid)
Bounderr=Labid
%end;! Eboundlab
!*
%externalroutine Ejump(%integer Opcode, Labelid)
!***********************************************************************
!* generate specified conditional or unconditional jump *
!***********************************************************************
%switch Op(0:164)
%integer Reg1,Freg1,XAop,Bytes
%if Report#0 %thenstart
printstring("Ejump ".Eopname(Opcode));write(Labelid,4)
newline
%finish
%if ProgFaulty#0 %then %return
->Op(Opcode)
!*
Op(*):%monitor
%stop
!*
Op(JIGT):
Op(JILT):
Op(JIEQ):
Op(JINE):
Op(JIGE):
Op(JILE):
CC=Setcc(Opcode-JIGT)
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2))
CCset=0
Pjump(BC,Labelid,CC,R14)
%return
!*
Op(JUGT):
Op(JULT):
Op(JUEQ):
Op(JUNE):
Op(JUGE):
Op(JULE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
{ Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2)) }
{ Op Jump(BRA+Setcc(Opcode-JIGT),Labelid) }
CCset=0
%return
!*
Op(JINTGZ):
Op(JINTLZ):
Op(JINTZ):
Op(JINTNZ):
Op(JINTGEZ):
Op(JINTLEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1,0)
PIX RR(LTR,Reg1,Reg1)
Pjump(BC,Labelid,Setcc(Opcode-JINTGZ),R14)
%return
!*
Op(JUGTZ):
Op(JULTZ):
Op(JUEQZ):
Op(JUNEZ):
Op(JUGEZ):
Op(JULEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
{ Op X(TST,Stk(Elevel+1)) }
{ Op Jump(BRA+Setcc(Opcode-JINTGZ),Labelid) }
%return
!*
Op(JUMP):
Pjump(BC,Labelid,15,R14)
%return
!*
Op(JRGT):
Op(JRLT):
Op(JREQ):
Op(JRNE):
Op(JRGE):
Op(JRLE):
CC=Setcc(Opcode-JRGT)
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Real Binary Op(RGT+Opcode-JRGT,Stk(Elevel+1),Stk(Elevel+2))
CCset=0
Pjump(BC,Labelid,CC,R14)
%return
!*
Op(JRGZ):
Op(JRLZ):
Op(JRZ):
Op(JRNZ):
Op(JRGEZ):
Op(JRLEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %then XAop=LTER %else XAop=LTDR
PIX RR(XAop,Freg1,Freg1)
Pjump(BC,Labelid,Setcc(Opcode-JRGZ),R14)
%return
!*
Op(JTRUE):
%if CCset=0 %thenstart
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1,0)
PIX RR(LTR,Reg1,Reg1)
Pjump(BC,Labelid,6,R14)
%return
%finish
CCset=0
Pjump(BC,Labelid,CC,R14)
%return
!*
Op(JFALSE):
%if CCset=0 %thenstart
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1,0)
PIX RR(LTR,Reg1,Reg1)
Pjump(BC,Labelid,8,R14)
%return
%finish
CCset=0
Pjump(BC,Labelid,14-CC,R14)
%return
%end;! Ejump
!*
%externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3)
!***********************************************************************
!* generate the code for a Fortran three-way jump *
!* opcode = ITWB or RTWB for integer or real expression on Estack *
!* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0 *
!* - if Labi <= 0 that jump is not required *
!***********************************************************************
%integer Op,Reg1,Freg1,Bytes
%if Report#0 %thenstart
printstring("Etwjump ".Eopname(Opcode))
write(Lab1,4);write(Lab2,4);write(Lab3,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
%if Opcode=ITWB %thenstart
Reg1=Load Int(Stk(Elevel+1),-1,0)
PIX RR(LTR,Reg1,Reg1)
%finishelsestart
Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %then Op=LTER %else Op=LTDR
PIX RR(Op,Freg1,Freg1)
%finish
%if Lab1>0 %then Pjump(BC,Lab1,4,R14);! if < 0
%if Lab2>0 %then Pjump(BC,Lab2,8,R14);! = 0
%if Lab3>0 %then Pjump(BC,Lab3,2,R14);! > 0
%end;! Etwjump
!*
%externalroutine Eswitch(%integer Lower, Upper, Switchid, Errlabid,
%integername SSTad)
!***********************************************************************
!* define a switch Switchid to be indexed in the range (Lower:Upper) *
!* space may be claimed from SST fotr the switch table *
!***********************************************************************
%integer Ad
%if Report#0 %thenstart
printstring("Eswitch ")
write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4)
newline
%finish
%if ProgFaulty#0 %then %return
Ad=SSTad
SSTad=SSTad+(Upper-Lower+1)<<2
Pswitch(Ad,Lower,Upper,4)
Curswitchad=Ad
Curswitchmax=Upper
%end;! Eswitch
!*
%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) ) *
!* if (Etos) is outside the bounds defined for Switchid then error *
!***********************************************************************
%if Report#0 %thenstart
printstring("EswitchJump ");write(switchid,4)
newline
%finish
%end;! EswitchJump
!*
%externalroutine EfswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) ) *
!* if (Etos) is outside the bounds the jump has no effect. Note that *
!* in this case Switchid(Lower) addresses the next instruction *
!***********************************************************************
%integer Reg1,Reg2,Adtable
%if Report#0 %thenstart
printstring("EfswitchJump ");write(switchid,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel<1 %then Low Estack(JUMP,1) %and %return
Elevel=Elevel-1
Adtable=Glaspace(4)
Pfix(GLA,Adtable,SST,Curswitchad)
Reg1=Load Int(Stk(Elevel+1),-1,0)
%if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
Reg2=Indbase(GLA,Adtable)
PIX RR(BASR,R14,0)
PIX RR(LTR,Reg1,Reg1)
PIX RX(BC,12,0,R14,28)
PIX RX(LA,0,0,0,Curswitchmax)
PIX RR(CR,Reg1,0)
PIX RX(BC,2,0,R14,28)
PIX RS(SLL,Reg1,0,0,2)
PIX RX(L,R15,Reg1,Reg2,0)
PIX RX(BC,15,R12,R15,0)
%end;! EfswitchJump
!*
%externalroutine Eswitchentry(%integer Switchid, Entry)
!***********************************************************************
!* define the current code address as Switchid(Entry) *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eswitchentry ");write(Switchid,4);write(Entry,4)
newline
%finish
%end;!Eswitchentry
!*
%externalroutine Eswitchdef(%integer Switchid)
!***********************************************************************
!* define the current code address as Switchid(*) - the default *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eswitchdef ");write(Switchid,4)
newline
%finish
%end;!Eswitchdef
!*
%externalroutine EswitchLabel(%integer Switchid, Entry, Labelid)
!***********************************************************************
!* define Labelid as Switchid(Entry) *
!***********************************************************************
%if Report#0 %thenstart
printstring("EswitchLabel ");write(switchid,4);write(entry,4)
write(labelid,4)
newline
%finish
%if ProgFaulty#0 %then %return
Pswitchval(Curswitchad,Entry,Labelid)
%end;! EswitchLabel
!*
!*
!*
!* *******************************
!* * Data initialisation, fixups *
!* *******************************
!*
!*
%externalroutine Ed1(%integer area, Disp, Val)
!***********************************************************************
!* intialise an 8-bit location *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ed1 ".Areas(Area)." +");write(Disp,1)
spaces(4);Phex(Val)
newline
%finish
%if ProgFaulty#0 %then %return
%if Area>=11 %thenstart
Areaprops(Area)=Areaprops(Area)!X'400'
Area=Area+256
%finish
Pdbytes(area, Disp, 1, addr(Val)+3)
%end;! Ed1
!*
%externalroutine Ed2(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 16-bit location *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ed2 ".Areas(Area)." +");write(Disp,1)
spaces(4);Phex(Val)
newline
%finish
%if ProgFaulty#0 %then %return
%if Area>=11 %thenstart
Areaprops(Area)=Areaprops(Area)!X'400'
Area=Area+256
%finish
Pdbytes(area, Disp, 2, addr(Val)+2)
%end;! Ed2
!*
%externalroutine Ed4(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 32-bit location *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ed4 ".Areas(Area)." +");write(Disp,1)
spaces(4);Phex(Val)
newline
%finish
%if ProgFaulty#0 %then %return
%if Area>=11 %thenstart
Areaprops(Area)=Areaprops(Area)!X'400'
Area=Area+256
Pdpattern(Area,Disp,1,4,addr(Val))
%finishelsestart
Pd4(area, Disp, Val)
%finish
%end;! Ed4
!*
%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data *
!***********************************************************************
%if Report#0 %thenstart
printstring("Edbytes ")
newline
%finish
%if ProgFaulty#0 %then %return
%if Area=10 %then %monitor;! should not be allocated any more
%if len=8 %thenstart
Ed4(area,disp,integer(ad))
Ed4(area,disp+4,integer(ad+4))
%return
%finish
%if Area>=11 %thenstart
Areaprops(Area)=Areaprops(Area)!X'400'
Area=Area+256
%finish
%if area<=10 %thenstart
Pdbytes(area, disp, len, ad)
%finishelsestart
Pdpattern(area, Disp, 1, len, ad)
%finish
%end;! Edbytes
!*
%externalroutine Edpattern(%integer area, Disp, ncopies, len, ad)
!***********************************************************************
!* initialise using a 1,2,4 or 8 byte pattern *
!***********************************************************************
%integer I
%if Report#0 %thenstart
printstring("Edpattern ")
newline
%finish
%if ProgFaulty#0 %then %return
%if Area>=11 %thenstart
Areaprops(Area)=Areaprops(Area)!X'400'
Area=Area+256
%finish
%if Area<=10 %thenstart
%cycle I=1,1,ncopies
Pdbytes(Area,Disp,Len,Ad)
Disp=Disp+Len
%repeat
%finishelsestart
Pdpattern(area, Disp, ncopies, len, ad)
%finish
%end;!Edpattern
!*
%externalroutine Efix(%integer area,disp, tgtarea,tgtdisp)
!***********************************************************************
!* relocate area+disp to tgtarea+tgtdisp (all are byte addresses) *
!***********************************************************************
Area=Area&X'FFF';! in case 'byte' marker had been set (historic)
%if Report#0 %thenstart
printstring("Efix ".Areas(Area)." +");write(Disp,1)
printstring(" => ".Areas(Tgtarea)." +");write(Tgtdisp,1)
newline
%finish
%if ProgFaulty#0 %then %return
%if Area=Gla %then Disp=Disp+Gla Offset
%if Tgtarea=Gla %then Tgtdisp=Tgtdisp+Gla Offset
%if Tgtarea>=11 %thenstart
%if Area=2 %and Tgtdisp=0 %then Areabase(Tgtarea)=Disp
Tgtarea=Tgtarea+256
%finish
PD4(Area,Disp,Tgtdisp)
Tgtdisp=0
Pfix(area,disp, tgtarea,0)
%end;! Efix
!*
!*
!*
!* *********************
!* * Procedure call *
!* *********************
!*
!*
%externalintegerfn EXname(%integer type,%string(255)%name Xref)
!***********************************************************************
!* generate an external reference, returning an Id for future reference*
!***********************************************************************
%integer Refad,I
%if Report#0 %thenstart
printstring("EXname ".Xref);write(Type&15,4);write(Type>>4,4)
newline
%finish
Refad=Glaspace(16)
%if ProgFaulty#0 %then %result=Refad
I=PXname(0,Xref,Refad)
%result=Refad
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprecall ")
newline
%finish
%if Active Calls#0 %thenstart
Save Param Offset = Next Param Offset
PIX RX(LA,R11,0,R11,Next Param Offset)
%finish
Active Calls = Active Calls + 1
Next Param Offset=64
%end;! Eprecall
!*
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id *
!***********************************************************************
%integer X2
%if Report#0 %thenstart
printstring("Ecall "); write(Numpars,6); write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
Freeregs
Pd4(GLA,Id+12,(Numpars<<16)!Paramsize);! for loader check
PIX RS(STM, R4, R14, R11, 16)
%if Id>=4096 %thenstart
X2=SetX2(Id)
PIX RX(LA,13,X2,13,0)
Ruse(X2)=0;! since X2 has not been saved
%finish
PIX RS(LM, R12, R14, R13, id)
PIX RR(BASR, R15, R14)
Pusing(R15)
UsingR15 = 1
%if Active Calls>1 %thenstart
PIX RX(LA,R0,0,0,Save Param Offset)
PIX RR(SR,R11,R0)
Next Param Offset = Save Param Offset
%finish
Active Calls = Active Calls - 1
%end;! Ecall
!*
%externalroutine Eprocref(%integer Id, Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprocref ");write(Id,4)
newline
%finish
Estkaddr(Gla,Id,0,4);! Id is gla offset of a register set for entry
%end;! Eprocref
!*
%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter *
!***********************************************************************
%if Report#0 %thenstart
printstring("Esave ");write(Asave,4)
newline
%finish
%end;! Esave
!*
%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter *
!***********************************************************************
%if Report#0 %thenstart
printstring("Erestore ");write(Asave,4)
newline
%finish
%end;! Erestore
!*
!*
!*
!* **********************************
!* * Procedure definition and entry *
!* **********************************
!*
!*
%externalintegerfn Enextproc
!***********************************************************************
!* result is an Id to be used for a procedure first encountered as an *
!* internal spec *
!***********************************************************************
%integer Refad,I
%if Report#0 %thenstart
printstring("Enextproc ")
newline
%finish
Refad=Glaspace(16)
%cycle I=0,4,12
Pd4(Gla,Refad+I,0)
%repeat
%result=Refad
%end;! Enextproc
!*
%externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize,
Astacklen, %integername Id)
!***********************************************************************
!* define the start of a procedure body *
!* if Id > 0 this is the Id returned by a previous call of Enextproc *
!* Astacklen is the address of the word noting the current local *
!* stack-frame size *
!***********************************************************************
%integer Refad
%if Report#0 %thenstart
printstring("Eproc ");printstring(Name)
write(Numpars,4); write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
ProcProps=Props
%if Props&2#0 %then Props=X'80000001' %else Props=Props&1
%if Props&1=0 %and Id=-1 %thenstart;! establish entry block
Refad=Glaspace(16)
Pfix(Gla,Refad,1,0)
Pfix(Gla,Refad+4,Gla,0)
Pfix(Gla,Refad+8,1,Pmarker(0))
Id=Refad
%finish
Pproc(Name,Props,Numpars<<16!Paramsize,Id)
Curdiagca=-1
Max4k=0
%if Language#FORTRAN %thenstart
%if Astacklen#-1 %then Addrstackca=Astacklen
PIX RX(ST,R15,0,R11,60)
PIX RR(LR,R10,R11)
Procmark=PMarker(0)
PIX RX(LA,11,0,11,64+integer(Addrstackca))
PIX RS(LM,8,9,R13,Glaf77regs)
%if ProcProps&2#0 %thenstart;! main entry
PIX RX(LA,R1,0,0,8)
PIX RS(SLL,R1,0,0,24)
PIX RR(SPM,R1,0)
%finish
%finish
Proclevel=Proclevel+1
%end;! Eproc
!*
%externalroutine Eprocend(%integer Localsize,Diagdisp,Astacklen)
!***********************************************************************
!* called at procedure end *
!* Localsize is the total stack-frame requirement (excluding red tape) *
!* Astacklen is the address of the word noting the current local *
!* stack-frame size of th enclosing procedure *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprocend ");write(Localsize,6)
newline
%finish
%if ProgFaulty#0 %then %return
%if Language#FORTRAN %thenstart
{ PSetOpd(Procmark,1,X'B000'!integer(Addrstackca)) }
%if Astacklen#-1 %then Addrstackca=Astacklen
%finish
%if Language=PASCAL %and Proclevel#1 %thenstart
Eop(RETURN)
%finish
Proclevel=Proclevel-1
PMinMultiples(Max4k>>12)
Pprocend
%end;! Eprocend
!*
%externalroutine Eentry(%integer Index,Numpars,Paramsize,
Localsize,Diagdisp,%stringname Name)
!***********************************************************************
!* defines a side entry within the current procedure (used by Fortran) *
!* Localsize is the total stack-frame requirement (excluding red tape) *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eentry ".Name);write(Index,4)
write(Numpars,4);write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
%unless Index=0 %then Pentry(Index,Name);! Amdahl put handles 0 incorrectly
PIX RX(ST,R15,0,R11,60)
PIX RR(LR,R10,R11)
Localsize=Localsize+64
%if Localsize>=4096 %thenstart
PIX RX(LA,1,0,0,Localsize>>12)
PIX RS(SLL,1,0,0,12)
PIX RX(LA,11,1,11,Localsize&X'FFF')
%finishelse PIX RX(LA,11,0,11,Localsize)
PIX RS(LM,8,9,R13,Glaf77regs)
%if ProcProps&2#0 %thenstart;! main entry
PIX RX(LA,R1,0,0,8)
PIX RS(SLL,R1,0,0,24)
PIX RR(SPM,R1,0)
%finish
PIX SI(MVI,Diagdisp>>8,R10,0)
PIX SI(MVI,(Diagdisp&X'FF'),R10,1)
%end;! Eentry
!*
!*
!*
!* *********************************
!* * Data definition and reference *
!* *********************************
!*
!*
%externalroutine Edataentry(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* defines a data entry Name starting at Offset in Area *
!***********************************************************************
%if Report#0 %thenstart
printstring("Edataentry ".Name);write(Area,4)
write(Offset,4);write(Length,4)
newline
%finish
%end;! Edataentry
!*
%externalroutine Edataref(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* requests a data ref to Name (with at least Length)at Offset in Area *
!***********************************************************************
%if Report#0 %thenstart
printstring("Edataref ".Name);write(Area,4)
write(Offset,4);write(Length,4)
newline
%finish
%end;! Edataref
!*
!*
!*
!* ********************
!* * Ecode operations *
!* ********************
!*
!*
%externalroutine Eop(%integer Opcode)
!***********************************************************************
!* opcodes with general applicability *
!***********************************************************************
%integer Reg1,Freg1,Bytes,B1,D1,XAop,Form,I
%switch Op(0:255)
%if Report#0 %thenstart
printstring("Eop ".Eopname(Opcode))
newline
Dump Estack
%finish
%if ProgFaulty#0 %then %return
!*
%if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
->Op(Opcode)
!*
Op(*):%monitor
!*
Op(HALT):
Unsupported Opcode(Opcode)
%return
!*
Op(IADD):
Op(ISUB):
Op(IMULT):
Op(IDIV):
!*
Op(IAND):
Op(IOR):
Op(IXOR):
!*
Op(IGT):
Op(ILT):
Op(IEQ):
Op(INE):
Op(IGE):
Op(ILE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(INEG):
Op(IABS):
Op(INOT):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Int Unary Op(Opcode,Stk(Elevel+1))
%return
!*
Op(UADD):
Op(USUB):
!*
Op(UGT):
Op(ULT):
Op(UEQ):
Op(UNE):
Op(UGE):
Op(ULE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(IADDST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST):
!*
Op(IANDST):
Op(IORST):
Op(IXORST):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(INEGST):
Op(INOTST):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Int Unary Op(Opcode,Stk(Elevel+1))
%return
!*
Op(IREM):
Eop(IDIV);! result will be in an odd register
Reg1=Stk(Elevel)_Reg;! remainder will be in the even one
PIX RR(LR,Reg1,Reg1-1)
%return
!*
Op(ISHLL):
!*
Op(ISHRL):
!*
Op(ISHLA):
!*
Op(ISHRA):
Unsupported Opcode(Opcode)
%return
!*
Op(RETURN):
PIX RS(LM,R4,R15,R10,16)
PIX RR(BCR,15,R15)
%return
!*
Op(SFA):
!*
Op(ASF):
!*
Op(IPUSH):
!*
Op(IPOP):
Unsupported Opcode(Opcode)
%return
!*
Op(EXCH):
Epromote(2)
%return
!*
Op(DUPL):
Stk(Elevel+1)=Stk(Elevel)
Elevel=Elevel+1
Form=Stk(Elevel)_Form&31
%if Form=RegVal %or Form=RegAddr %thenstart
Reg1=Claimr(Stk(Elevel)_Reg)
PIX RR(LR,Reg1,Stk(Elevel)_Reg)
Stk(Elevel)_Reg=Reg1
Ruse(Reg1)=-Elevel
%finishelsestart
%if Form=FregVal %thenstart
Freg1=Claimfr(Stk(Elevel)_Reg)
%if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR
PIX RR(XAop,Freg1,Stk(Elevel)_Reg)
Stk(Elevel)_Reg=Freg1
Fruse(Freg1)=-Elevel
%finishelsestart
%if Form=TempVal %then Stk(Elevel)_Form=DirVal
%finish
%finish
%return
!*
Op(DISCARD):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
%if Stk(Elevel)_Form&31=RegVal %thenstart
Ruse(Stk(Elevel)_Reg)=0
%finishelsestart
%if Stk(Elevel)_Form&31=Fregval %then Fruse(Stk(Elevel)_Reg)=0
%finish
Elevel=Elevel-1
%return
!*
Op(INDEX1):
!*
Op(INDEX2):
!*
Op(INDEX4):
!*
Op(INDEX8):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
I=Opcode-INDEX1
NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1))
%return
!*
Op(INDEX):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-2
%if Stk(Elevel+2)_Form=LitVal %thenstart
I=Stk(Elevel+2)_Intval
%if I=16 %or I=32 %thenstart
I=I>>5+4
->NoteI
%finish
%finish
Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2))
Elevel=Elevel-1
I=0
->NoteI
!*
Op(CHK):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Reg1=Load Int(Stk(Elevel+1),-1,-1)
Op RX(C,Reg1,Stk(Elevel+2))
Pjump(BC,Bounderr,4,R14)
Op RX(C,Reg1,Stk(Elevel+3))
Pjump(BC,Bounderr,2,R14)
Stackr(Reg1)
%return
!*
Op(MVB):
!*
Op(TMASK):
!*
Op(CPBGT):
!*
Op(CPBLT):
!*
Op(CPBEQ):
!*
Op(CPBNE):
!*
Op(CPBGE):
!*
Op(CPBLE):
Unsupported Opcode(Opcode)
%return
!*
Op(RADD):
Op(RSUB):
Op(RMULT):
Op(RDIV):
!*
Op(RGT):
Op(RLT):
Op(REQ):
Op(RNE):
Op(RGE):
Op(RLE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Real Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(RNEG):
Op(RABS):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Real Unary Op(Opcode,Stk(Elevel+1))
%return
!*
Op(UCVTII):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(CVTII):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Bytes=Stk(Elevel+2)_Intval
Convert II(Stk(Elevel+1),Bytes)
Stk(Elevel)_Size=Bytes
%return
!*
Op(CVTRR):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert RR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(TNCRI):
Op(RNDRI):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI)
%return
!*
Op(CVTIR):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(UCHECK):
%if Stk(Elevel)_Form=DirVal %thenstart
Set BD(Stk(Elevel),B1,D1)
%finishelsestart
Reg1=Claimr(-1)
Address(Stk(Elevel))
Op RX(L,Reg1,Stk(Elevel))
Stk(Elevel)_Form=IndRegVal!Regflag
Stk(Elevel)_Reg=Reg1
Ruse(Reg1)=-Elevel
B1=Reg1
D1=0
%finish
PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32)
Pjump(BC,Unasslab,8,R14)
%return
!*
Op(ESTORE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0)
%return
!*
Op(EDUPSTORE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),1)
Stackr(Reg1)
%return
!*
Op(PUSHVAL):
!*
Op(PUSHADDR):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Push Param(Opcode-PUSHVAL,Stk(Elevel+1))
%return
!*
Op(EVAL):
!*
Op(EVALADDR):
%return
!*
Op(EADDRESS):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Address(Stk(Elevel))
Stk(Elevel)_Size=4
%return
!*
Op(EPOWER):
!*
Op(EPOWERI):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
%if Stk(Elevel)_Form#Litval %then Abort
Elevel=Elevel-1
Expcall(Stk(Elevel+1)_Intval)
%return
!*
Op(EINTRES):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),R1,-1)
%return
!*
Op(EREALRES):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Real(Stk(Elevel+1),R0,-1,Bytes)
%return
!*
Op(ESIZE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Stk(Elevel)_Size=Stk(Elevel+1)_Intval
%return
!*
Op(Argproc):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Op RX(L,R1,Stk(Elevel+1))
PIX RS(STM,R4,R14,R11,16)
PIX RS(LM,R12,R14,R1,0)
PIX RR(BASR,R15,R14)
Pusing(R15)
UsingR15=1
%return
!*
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran *
!***********************************************************************
%integer Reg1,Reg2,Freg1,Freg2,XAop1,XAop2,XAop3,XAop4,XAop5,Bytes,Relop
%integer B1,D1,Flags
%switch F77op(256:320)
%if Report#0 %thenstart
printstring("Ef77op ".Ef77opname(Opcode))
newline
Dump Estack
%finish
%if ProgFaulty#0 %then %return
!*
%if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
->F77op(Opcode)
!*
F77op(*):Abort
!*
F77op(CXADD):
!*
F77op(CXSUB):
!*
F77op(CXMULT):
!*
F77op(CXDIV):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Opcode=Opcode&X'FF'
Flags=Stk(Elevel+4)_Intval
Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3))
%return
!*
F77op(CXNEG):
!*
F77op(CXASGN):
!*
F77op(CXEQ):
!*
F77op(CXNE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Opcode=Opcode&X'FF'
Flags=Stk(Elevel+3)_Intval
->Cxop
!*
F77op(EM1EXP):
Unsupported Opcode(Opcode)
%return
!*
F77op(EISIGN):
Elevel=Elevel-2
Reg1=Load Int(Stk(Elevel+1),-1,0)
PIX RR(LPR,Reg1,Reg1)
Reg2=Load Int(Stk(Elevel+2),-1,Reg1)
PIX RR(BASR,R14,0)
PIX RR(LTR,Reg2,Reg2)
PIX RX(BC,10,0,R14,8)
PIX RR(LNR,Reg1,Reg1)
Stackr(Reg1)
%return
!*
F77op(ESIGN):
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %thenstart
XAop1=LPER
XAop2=LNER
XAop3=LTER
%finishelsestart
XAop1=LPDR
XAop2=LNDR
XAop3=LTDR
%finish
PIX RR(XAop1,Reg1,Reg1)
Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
PIX RR(BASR,R14,0)
PIX RR(XAop3,Reg2,Reg2)
PIX RX(BC,10,0,R14,8)
PIX RR(XAop2,Reg1,Reg1)
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIMOD):
Elevel=Elevel-2
%if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
OpRX(L,R15,Stk(Elevel+2))
Reg1=Claimr(R1)
Freeup Reg(R1)
OpRX(L,R0,Stk(Elevel+1))
PIX RR(LR,Reg1,R0)
PIX RX(SRDA,0,0,0,32)
PIX RR(DR,R0,R15)
PIX RR(MR,R0,R15)
PIX RR(SR,Reg1,R1)
Stackr(Reg1)
%return
!*
F77op(ERMOD):
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %thenstart
XAop1=LER
XAop2=ME
XAop3=DE
XAop4=SER
XAop5=STE
%finishelsestart
XAop1=LDR
XAop2=MD
XAop3=DD
XAop4=SDR
XAop5=STD
%finish
Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
PIX RX(XAop5,Reg2,0,R11,0);! STE
PIX RR(XAop1,Reg2,Reg1);! LER
PIX RX(XAop3,Reg2,0,R11,0);! DE
Stackfr(Reg2,Bytes)
Elevel=Elevel-1
Convert RI(Stk(Elevel+1),4,0);! Truncate
Elevel=Elevel-1
Lastfreg=Reg1;! to ensure it is not used
Convert IR(Stk(Elevel+1),Bytes)
Elevel=Elevel-1
Reg2=Load Real(Stk(Elevel+1),-1,Reg1,Bytes)
PIX RX(XAop2,Reg2,0,R11,0);! ME
PIX RR(XAop4,Reg1,Reg2);! SER
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIDIM):
Elevel=Elevel-2
Reg1=Load Int(Stk(Elevel+1),-1,0)
OpRX(S,Reg1,Stk(Elevel+2))
PIX RR(LTR,Reg1,Reg1)
PIX RR(BASR,R14,0)
PIX RX(BC,10,0,R14,6)
PIX RR(SR,Reg1,Reg1)
Stackr(Reg1)
%return
!*
F77op(ERDIM):
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %thenstart
XAop1=SE
XAop2=LTER
XAop3=SER
%finishelsestart
XAop1=SD
XAop2=LTDR
XAop3=SDR
%finish
OpRX(XAop1,Reg1,Stk(Elevel+2))
PIX RR(XAop2,Reg1,Reg1)
PIX RR(BASR,R14,0)
PIX RX(BC,10,0,R14,6)
PIX RR(XAop3,Reg1,Reg1)
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIMIN):
Relop=12
Iminmax:
Elevel=Elevel-2
Reg1=Load Int(Stk(Elevel+1),-1,0)
Reg2=Load Int(Stk(Elevel+2),-1,Reg1)
PIX RR(CR,Reg1,Reg2)
PIX RR(BASR,R14,0)
PIX RX(BC,Relop,0,14,6)
PIX RR(LR,Reg1,Reg2)
Stackr(Reg1)
%return
!*
F77op(ERMIN):
Relop=12
Rminmax:
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes)
%if Bytes=4 %thenstart
XAop1=CER
XAop2=LER
%finishelsestart
XAop1=CDR
XAop2=LDR
%finish
Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes)
PIX RR(XAop1,Reg1,Reg2)
PIX RR(BASR,R14,0)
PIX RX(BC,Relop,0,14,6)
PIX RR(XAop2,Reg1,Reg2)
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIMAX):
Relop=10
->Iminmax
!*
F77op(ERMAX):
Relop=10
->Rminmax
!*
F77op(EDMULT):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Real Binary Op(RMULT,Stk(Elevel+1),Stk(Elevel+2))
Stk(Elevel)_Size=8
%return
!*
F77op(ECONJG):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Opcode=9
Flags=Stk(Elevel+3)_Intval
->Cxop
!*
F77op(ECHAR):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
%if Stk(Elevel+2)_Form=LitVal %thenstart
Set BD(Stk(Elevel+1),B1,D1)
PIX SI(MVI,Stk(Elevel+2)_Intval&X'FF',B1,D1)
%finishelsestart
Reg1=Load Int(Stk(Elevel+2),-1,-1)
Op RX(STC,Reg1,Stk(Elevel+1))
%finish
%return
!*
F77op(EICHAR):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
%if Stk(Elevel)_Form =LitVal %thenstart
Stk(Elevel)_Size=4
%return
%finish
Elevel=Elevel-1
Reg1=Claimr(-1)
PIX RR(SR,Reg1,Reg1)
Op RX(IC,Reg1,Stk(Elevel+1))
Stackr(Reg1)
%return
!*
F77op(EINDEXCHAR):
%if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3))
%if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
{for Unix compatibility call requires A1,A2,L1,L2}
{Epromote(3)}
{Epromote(2)}
{but for Amdahl we must have L1,A1,L2,A2}
Epromote(4)
Epromote(2)
Epromote(3)
Spcall(6)
Stackr(R1)
%return
!*
F77op(ECONCAT):
Spcall(7)
%return
!*
F77op(EASGNCHAR):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
%return
!*
F77op(ECOMPCHAR):
%if Elevel<5 %then Low Estack(Opcode,5) %and %return
CC=Setcc(Stk(Elevel)_Intval)
Elevel=Elevel-5
Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
CCset=1
%return
!*
F77op(ECMPLX1):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Flags=Stk(Elevel+3)_Intval
->Cx1
!*
F77op(ECMPLX2):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Flags=Stk(Elevel+4)_Intval
Cx1: %if Flags=0 %then XAop1=STE %else XAop1=STD
Reg1=Claimr(-1)
OpRX(L,Reg1,Stk(Elevel+1))
Freg1=Load Real(Stk(Elevel+2),-1,-1,Bytes)
PIX RX(XAop1,Freg1,0,Reg1,0)
%if Opcode=ECMPLX1 %thenstart
Freg2=Freg1
PIX RR(SDR,Freg2,Freg2)
%finishelsestart
Freg2=Load Real(Stk(Elevel+3),-1,-1,Bytes)
%finish
PIX RX(XAop1,Freg2,0,Reg1,Bytes)
%return
!*
F77op(EISHFT):
!*
F77op(EIBITS):
!*
F77op(EIBSET):
!*
F77op(EIBTEST):
!*
F77op(EIBCLR):
!*
F77op(EISHFTC):
Unsupported Opcode(Opcode)
%return
!*
F77op(PROCARG):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
D1=Stk(Elevel+1)_Intval
Pd4(GLA,D1+12,-1)
Do RX(LA,R0,R13,D1)
PIX RX(ST,R0,0,R11,Next Param Offset)
Next Param Offset=Next Param Offset+4
%return
!*
F77op(IPROCARG):
!*
F77op(CHARARG):
%if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
Estklit(X'20000');! Amdahl string type
Eop(IADD)
Eop(PUSHVAL)
Eop(PUSHVAL)
%return
!*
F77op(IPROCCALL):
Unsupported Opcode(Opcode)
%return
!*
F77op(ARGPROCCALL):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Op RX(L,R1,Stk(Elevel+1))
PIX RS(STM,R4,R14,R11,16)
PIX RS(LM,R12,R14,R1,0)
PIX RR(BASR,R15,R14)
Pusing(R15)
UsingR15=1
%return
!*
F77op(NOTEIORES):
{no special action required here on Amdahl - result will stay in R1}
%return
!*
F77op(STKIORES):
Stackr(R1)
%return
!*
F77op(CALLTPLATE):
%return
!*
F77op(EFDVACC):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-1
{ on Amdahl the two entries still on Estack will usually be in regs}
Reg2=Load Int(Stk(Elevel-1),-1,-1)
Stk(Elevel-1)_Form=RegVal!Regflag
Stk(Elevel-1)_Reg=Reg2
Reg1=Load Int(Stk(Elevel),-1,Reg2)
Stk(Elevel)_Form=RegVal!Regflag
Stk(Elevel)_Reg=Reg1
%if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
%if UsingR15#0 %then Pdrop(R15) %and UsingR15=0
PIX RR(LR,R15,Reg1)
Ruse(Reg1)=-Elevel
Ruse(Reg2)=-Elevel+1
OpRX(M,R14,Stk(Elevel+1))
PIX RR(AR,Reg2,R15)
%return
!*
F77op(EARGLEN):
{on Amdahl it may be necessary to mask out the upper half of char len }
Stk(Elevel)_Offset=Stk(Elevel)_Offset+2
Stk(Elevel)_Size=2
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1,-1)
Stackr(Reg1)
%return
!*
F77op(EFNOTEVR):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),R1,-1)
%return
!*
F77op(EFSETVR):
Stackr(R1)
%return
%end;! Ef77op
!*
!*
%externalroutine EPasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal *
!***********************************************************************
%switch Pasop(511:643)
%integer Bytes
%if Report#0 %thenstart
printstring("Epasop ".Epasopname(Opcode))
newline
Dump Estack
%finish
%if ProgFaulty#0 %then %return
!*
%if CCset # 0 %then Establish Logical; ! estsblish logical value 0 or 1
!*
->Pasop(Opcode)
!*
Pasop(*): %monitor
!*
Pasop(STRGT):
Pasop(STRLT):
Pasop(STREQ):
Pasop(STRNE):
Pasop(STRGE):
Pasop(STRLE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
%if Stk(Elevel)_Form#LitVal %then Abortm("Epasop: string length")
Bytes=Stk(Elevel)_IntVal
Elevel=Elevel-3
String Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),Bytes)
%return
!*
Pasop(PTREQ):
Pasop(PTRNE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Unsupported Opcode(Opcode)
%return
!*
Pasop(SETI):
Pasop(SETU):
Pasop(SETD):
!*
Pasop(SETEQ):
Pasop(SETNE):
Pasop(SETIN):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),0)
%return
!*
Pasop(SETLE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Eop(DUPL)
Epromote(3)
Epasop(SETU)
Epasop(SETEQ)
%return
!*
Pasop(SETSING):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
%if Stk(Elevel)_Form#LitVal %then Abortm("SETSING: size?")
Elevel= Elevel-2
Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+1),Stk(Elevel+2)_IntVal)
%return
!*
Pasop(SETRANGE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
%if Stk(Elevel)_Form#LitVal %then Abortm("SETRANGE: size?")
Elevel= Elevel-3
Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3)_IntVal)
%return
!*
Pasop(CAPMOVE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Unsupported Opcode(Opcode)
%return
!*
Pasop(INDEXP):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-2
Bit Index(Stk(Elevel+2),Stk(Elevel),Stk(Elevel+1))
%return
!*
Pasop(EOFOP):
Pasop(EOLOP):
Pasop(LAZYOP):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Unsupported Opcode(Opcode)
%return
!*
Pasop(ISQR):
Eop(DUPL)
Eop(IMULT)
%return
!*
Pasop(IODD):
Pasop(UODD):
Push Operand(LitOne)
Eop(IAND)
%return
!*
Pasop(ISUCC):
Pasop(USUCC):
Push Operand(LitOne)
Eop(IADD)
%return
!*
Pasop(IPRED):
Pasop(UPRED):
Push Operand(LitOne)
Eop(ISUB)
%return
!*
Pasop(RSQR):
Eop(DUPL)
Eop(RMULT)
%return
!*
Pasop(CHKLT):
Pasop(CHKGT):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-2
Unsupported Opcode(Opcode)
%return
!*
Pasop(CHKRNG):
Pasop(CHKSETGT):
Pasop(CHKSETRNG):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-3
Unsupported Opcode(Opcode)
%return
!*
Pasop(UCHKLT):
Pasop(UCHKGT):
Pasop(UCHKNE):
Pasop(UCHKRNG):
Pasop(CHKNE):
Unsupported Opcode(Opcode)
!*
Pasop(CHKNEW2):
Pasop(CHKUNDEF):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Unsupported Opcode(Opcode)
%return
!*
Pasop(SETUNDEF):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Unsupported Opcode(Opcode)
%return
!*
Pasop(TRAP):
Unsupported Opcode(Opcode)
!*
Pasop(ICLPSH):
Pasop(ICLPROT):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Unsupported Opcode(Opcode)
%end;! EPasop
!*
%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C *
!***********************************************************************
%monitor
%end;! Eccop
!*
%routine Expcall(%integer Proc)
!***********************************************************************
!* call an exponentiation routine *
!***********************************************************************
%integer I,J,T
%string(31) S
T=Expproctype(Proc)
J=Expprocref(Proc)
%if J=0 %thenstart
S=Expprocs(Proc)
J=Exname(T,S)
Expprocref(Proc)=J
%finish
Eprecall(J)
I=Expprocpdesc(Proc)>>16
%while I>0 %cycle
Epromote(I)
Eop(PUSHVAL)
I=I-1
%repeat
I=Expprocpdesc(Proc)
Freeregs
Ecall(J,I>>16,I&X'FF')
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%end;! Expcall
!*
%routine Spcall(%integer Proc)
!***********************************************************************
!* call a support procedure *
!***********************************************************************
%integer I,J,T
%string(31) S
T=Spproctype(Proc)
J=Spprocref(Proc)
%if J=0 %thenstart
S=Spprocs(Proc)
J=Exname(T,S)
Spprocref(Proc)=J
%finish
Eprecall(J)
I=Spprocpdesc(Proc)>>16
%while I>0 %cycle
Epromote(I)
Eop(PUSHVAL)
I=I-1
%repeat
I=Spprocpdesc(Proc)
Freeregs
Ecall(J,I>>16,I&X'FF')
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%end;! Spcall
!*
!*
!*
!*
!***********************************************************************
!***********************************************************************
!** Code generation support procedures **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Refer(%record(Stkfmt)%name Stk,%integer Offset)
%integer Reg
%switch F(0:21)
->F(Stk_Form&31);! removing the reg marker bit
!*
F(RegVal): { (reg) }
%if Offset#0 %thenstart
Stk_Form=IndRegModVal!Regflag
Setoff: Stk_Modform=Litval
Stk_Modintval=Offset
Stk_Scale=0
%return
%finish
Stk_Form=IndRegVal!Regflag
Ruse(Stk_Reg)=-Elevel
%return
!*
F(TempVal): { (temp) }
%if Offset#0 %thenstart
Stk_Form=IndTempModVal
->Setoff
%finish
Stk_Form=IndTempVal
%return
!*
F(DirVal): { (dir) }
%if Offset#0 %thenstart
Stk_Form=IndDirModVal
->Setoff
%finish
Stk_Form=IndDirVal
%return
!*
F(IndRegVal): { ((reg)) }
PIX RX(L,Stk_Reg,0,Stk_Reg,0)
->F(RegVal)
!*
F(AddrDirMod): { @dir+M }
%if Offset=0 %thenstart
Stk_Form=AddrDirModVal
%return
%finish
->Loadr
!*
F(IndTempVal): { ((temp)) }
F(IndDirVal): { ((dir)) }
F(AddrDirModVal): { (dir+M) }
F(IndRegModVal): { ((reg)+M) }
F(IndTempModVal): { ((temp)+M) }
F(IndDirModVal): { ((dir)+M) }
Loadr:Reg=Claimr(0)
OpRX(L,Reg,Stk)
Stk_Reg=Reg
Ruse(Stk_Reg)=-Elevel
->F(RegVal)
!*
F(AddrConst): { @const }
Stk_Form=ConstVal
Stk_Offset=Stk_Offset+Offset
%return
!*
F(AddrDir): { @dir }
Stk_Form=DirVal
Stk_Offset=Stk_Offset+Offset
%return
!*
F(RegAddr): { (reg) is @ }
->F(RegVal)
!*
F(TempAddr): { (temp) is @}
%if Offset#0 %thenstart
Stk_Form=IndTempModVal
->Setoff
%finish
Stk_Form=IndTempVal
%return
!*
F(DirAddr): { (dir) is @ }
%if Offset#0 %thenstart
Stk_Form=IndDirModVal
->Setoff
%finish
Stk_Form=IndDirVal
%return
!*
F(RegModAddr): { (reg)+M }
%if Offset=0 %thenstart
Stk_Form=IndRegModVal!Regflag
%return
%finish
->Loadr
!*
F(TempModAddr): { (temp)+M }
%if Offset=0 %thenstart
Stk_Form=IndTempModVal
%return
%finish
->Loadr
!*
F(DirModAddr): { (dir)+M }
%if Offset=0 %thenstart
Stk_Form=InddirModVal
%return
%finish
->Loadr
!*
F(LitVal): { lit }
F(ConstVal): { const }
F(FregVal): { (freg) }
printstring("
Invalid attempt to Refer
")
Abort
!*
%end;! Refer
!*
%routine Address(%record(Stkfmt)%name Stk)
%integer I,J,Reg,Op
%switch F(0:21)
->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal): { lit }
Setint(Stk_Intval,Stk_Size,I,J)
Stk_Base=Cnst
Stk_Offset=J
F(ConstVal): { const }
Stk_Form=AddrConst
Size: Stk_Size=4
%return
!*
F(RegVal): { (reg) }
I=New Temp(4)
Op=ST
Store:Do RX(Op,Stk_Reg,R10,I)
Stk_Base=0
Stk_Offset=I
Stk_Form=AddrDir
->Size
!*
F(FregVal): { (freg) }
I=New Temp(Stk_Size)
%if Stk_Size=4 %then Op=STE %else Op=STD
->Store
!*
F(TempVal): { (temp) }
Stk_Form=AddrDir
%return
!*
F(DirVal): { (dir) }
Stk_Form=AddrDir
%return
!*
F(IndRegVal): { ((reg)) }
Stk_Form=RegAddr!Regflag
%return
!*
F(IndTempVal): { ((temp)) }
Stk_Form=TempAddr
%return
!*
F(IndDirVal): { ((dir)) }
Stk_Form=DirAddr
%return
!*
F(AddrDirModVal): { (dir+M) }
Stk_Form=AddrDirMod!(Stk_Form&Regflag)
%return
!*
F(IndRegModVal): { ((reg)+M) }
Stk_Form=RegModAddr!Regflag
%return
!*
F(IndTempModVal): { ((temp)+M) }
Stk_Form=TempModAddr!(Stk_Form&Regflag)
%return
!*
F(IndDirModVal): { ((dir)+M) }
Stk_Form=DirModAddr!(Stk_Form&Regflag)
%return
!*
F(AddrConst): { @const }
F(RegAddr): { (reg) is @ }
F(TempAddr): { (temp) is @ }
F(DirAddr): { (dir) is @ }
F(AddrDir): { @dir }
F(AddrDirMod): { @dir+M }
F(RegModAddr): { (reg)+M }
F(TempModAddr): { (temp)+M }
F(DirModAddr): { (dir)+M }
!*
%end;! Address
!*
%integerfn Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg)
!***********************************************************************
!* Stk describes an integer value (1,2 or 4 bytes) *
!* if Reg is >= 0 then this register must be loaded *
!* result is the general register to which the value has been loaded *
!***********************************************************************
%integer Bytes
%constbyteintegerarray Lop(0:4)=0,IC,LH,0,L
Bytes=Stk_Size
%unless 0<Bytes<=4 %then Abort
%if Stk_Form&31=RegVal %thenstart
%if Stk_Reg#Reg %thenstart
%if Reg<0 %thenstart
%if Stk_Reg=Lockedreg %thenstart
Reg=Claimr(Lockedreg)
PIX RR(LR,Reg,Lockedreg)
%finishelse Reg=Stk_Reg
%finishelse PIX RR(LR,Reg,Stk_Reg)
%finish
Ruse(Stk_Reg)=0
%result=Reg
%finish
%if Reg<0 %then Reg=Claimr(Lockedreg)
%if Lockedreg>0 %then Ruse(Lockedreg)=-255
OpRX(Lop(Bytes),Reg,Stk)
%if Lockedreg>0 %then Ruse(Lockedreg)=0
%result=Reg
%end;! Load Int
!*
%integerfn Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg,
%integername Bytes)
!***********************************************************************
!* Stk describes a real value *
!* if Reg >= 0 this is the register to be loaded *
!* result is the floating register to which the value has been loaded *
!***********************************************************************
%integer XAop
Bytes=Stk_Size
%unless 4<=Bytes<=16 %then Abort
%if Stk_Form&31=FregVal %thenstart
Fruse(Stk_Reg)=0
%if Reg>=0 %and Reg#Stk_Reg %thenstart
%if Bytes=4 %then XAop=LER %else XAop=LDR
PIX RR(XAop,Reg,Stk_Reg)
%result=Reg
%finishelse %result=Stk_Reg
%finish
%if Reg<0 %then Reg=Claimfr(Lockedreg)
%if Bytes=4 %then XAop=LE %else XAop=LD
OpRX(XAop,Reg,Stk)
%result=Reg
%end;! Load Real
!*
%integerfn Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* Stk describes a real value to be loaded at extended precision *
!* result is the floating register to which the value has been loaded *
!***********************************************************************
%integer Oldreg,Newreg,XAop,Bytes
Bytes=Stk_Size
%unless 4<=Bytes<=16 %then Abort
%if Stk_Form&31=FregVal %thenstart
Oldreg=Stk_Reg
%if Newsize=8 %thenstart
Newreg=Claimfr(Oldreg)
PIX RR(SDR,Newreg,Newreg)
XAop=LER
%finishelsestart;! 16 byte
Newreg=Claimfrpair(Oldreg)
PIX RR(SDR,Newreg+2,Newreg+2)
%if Bytes=4 %thenstart
PIX RR(SDR,Newreg,Newreg)
XAop=LER
%finishelse XAop=LDR
%finish
PIX RR(XAop,Newreg,Oldreg)
Fruse(Oldreg)=0
%finishelsestart
%if Newsize=8 %thenstart
Newreg=Claimfr(-1)
PIX RR(SDR,Newreg,Newreg)
XAop=LE
%finishelsestart;! 16 byte
Newreg=Claimfrpair(-1)
PIX RR(SDR,Newreg+2,Newreg+2)
%if Bytes=4 %thenstart
PIX RR(SDR,Newreg,Newreg)
XAop=LE
%finishelse XAop=LD
%finish
OpRX(XAop,Newreg,Stk)
%finish
%result=Newreg
%end;! Load Real Extended
!*
%routine Push Operand(%record(Stkfmt)%name Operand)
!***********************************************************************
!* create an Estack entry for a prepared operand *
!***********************************************************************
%if Elevel=15 %then Abort
Elevel=Elevel+1
Stk(Elevel)=Operand
%end;! Push Operand
!*
%routine Stackr(%integer R)
!***********************************************************************
!* create an Estack entry for a value held in a general register *
!***********************************************************************
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=RegVal!Regflag
Stk(Elevel)_Reg=R
Stk(Elevel)_Size=4
Ruse(R)=-Elevel
%end;! Stackr
!*
%routine Stackfr(%integer FR,Bytes)
!***********************************************************************
!* create an Estack entry for a value held in a floating register *
!***********************************************************************
Elevel=Elevel+1
Stk(Elevel)=0
Stk(Elevel)_Form=FregVal!Regflag
Stk(Elevel)_Reg=FR
Stk(Elevel)_Size=Bytes
Fruse(FR)=-Elevel
%end;! Stackfr
!*
%routine Establish Logical
!***********************************************************************
!* called when a condition code has been set and required result is a *
!* logical value (0 or 1) *
!***********************************************************************
%integer Reg1
CCset=0
PIX RR(BASR, R14, 0)
Pusing(R14)
UsingR14=1
Reg1=Claimr(0)
PIX RX(LA, Reg1, 0, 0, 0)
PIX RX(BC, CC, 0, R14, 12)
PIX RX(LA, Reg1, 0, 0, 1)
Stackr(Reg1);! stack integer result in Reg1
%end;! Establish Logical
!*
%routine Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports IADD,ISUB,IMULT,IDIV,IGT,ILT,IEQ,INE,IGE,ILE,IAND,IOR,IXOR *
!* descriptor to result on Estack *
!***********************************************************************
%constbyteintegerarray RRop(0:IXOR) = 0,
AR,SR,MR,DR,0,0,0,NR,OR,0,XR
%constbyteintegerarray RXop(0:IXOR) = 0,
A,S,M,D,0,0,0,N,O,0,X
%constintegerarray Shiftval(0:8)=-1,0,1,-1,2,-1,-1,-1,3
%integer Lform,Rform,Lreg,Rreg,Shift
%switch Opcode(0:ILE)
Lform=LHS_Form&31
Rform=RHS_Form&31
Lreg=LHS_Reg
Rreg=RHS_Reg
->Opcode(Op)
!*
Opcode(IADD):
Opcode(IAND):
Opcode(IOR):
Opcode(IXOR):
%if Lform=RegVal %thenstart
%if Rform=RegVal %thenstart
PIX RR(RRop(Op),Lreg,Rreg)
Ruse(Rreg)=0
%finishelse OpRX(RXop(op),Lreg,RHS)
Stackr(Lreg)
%finishelsestart
%if Rform#RegVal %thenstart
Rreg=Claimr(0)
%if Lform=Litval %thenstart
OpRX(L,Rreg,LHS)
OpRX(RXop(Op),Rreg,RHS)
Stackr(Rreg)
%return
%finish
OpRX(L,Rreg,RHS)
%finish
OpRX(RXop(Op),Rreg,LHS)
Stackr(Rreg)
%finish
%return
!*
Opcode(ISUB):
%if Lform=RegVal %thenstart
%if Rform=RegVal %thenstart
PIX RR(SR,Lreg,Rreg)
Ruse(Rreg)=0
%finishelse OpRX(S,Lreg,RHS)
%finishelsestart
%if Rform=RegVal %thenstart
Lreg=Claimr(Rreg)
OpRX(L,Lreg,LHS)
PIX RR(SR,Lreg,Rreg)
Ruse(Rreg)=0
%finishelsestart
Lreg=Claimr(0)
Op RX(L,Lreg,LHS)
Op RX(S,Lreg,RHS)
%finish
%finish
Stackr(Lreg)
%return
!*
Opcode(IGT):
Opcode(ILT):
Opcode(IEQ):
Opcode(INE):
Opcode(IGE):
Opcode(ILE):
CC=Setcc(Op-IGT)
%if Lform=RegVal %thenstart
%if Rform=RegVal %thenstart
PIX RR(CR,Lreg,Rreg)
Ruse(Rreg)=0
%finishelse OpRX(C,Lreg,RHS)
Ruse(Lreg)=0
%finishelsestart
%if Rform=RegVal %thenstart
CC=Invcc(CC)
OpRX(C,Rreg,LHS)
%finishelsestart
Rreg=Claimr(0)
OpRX(L,Rreg,LHS)
OpRX(C,Rreg,RHS)
%finish
Ruse(Rreg)=0
%finish
CCset=1
%return
!*
Opcode(IMULT):
%if Lform=LitVal %thenstart
%if 0<=LHS_Intval<=8 %thenstart
Shift=Shiftval(LHS_Intval)
%if Shift=0 %thenstart
Elevel=Elevel+1
Stk(Elevel)=RHS
%return
%finish
%if Shift>0 %thenstart
Rreg=Load Int(RHS,-1,-1)
PIX RS(SLA,Rreg,0,0,Shift)
Stackr(Rreg)
%return
%finish
%finish
%finish
%if Rform=LitVal %thenstart
%if 0<=RHS_Intval<=8 %thenstart
Shift=Shiftval(RHS_Intval)
%if Shift=0 %thenstart
Elevel=Elevel+1
Stk(Elevel)=LHS
%return
%finish
%if Shift>0 %thenstart
Rreg=Load Int(LHS,-1,-1)
PIX RS(SLA,Rreg,0,0,Shift)
Stackr(Rreg)
%return
%finish
%finish
%finish
!*
%if Lform=RegVal %thenstart
%if Lreg#R1 %thenstart
%unless Lreg=R3 %and Ruse(R2)=0 %thenstart
%if Ruse(R1)#0 %thenstart
%if Rform=RegVal %and Rreg=R1 %thenstart
PIX RR(MR,R0,Lreg)
Ruse(Lreg)=0
Stackr(R1)
%return
%finish
Freeup Reg(R1)
%finish
PIX RR(LR,R1,Lreg)
Ruse(Lreg)=0
Lreg=R1
%finish
%finish
%if Rform=RegVal %thenstart
PIX RR(MR,Lreg-1,Rreg)
Ruse(Rreg)=0
%finishelse OpRX(M,Lreg-1,RHS)
%finishelsestart
%if Rform=RegVal %thenstart
Lreg=R1
%if Rreg#R1 %thenstart
%if Rreg=R3 %thenstart
%if Ruse(R2)#0 %then Freeup Reg(R2)
Lreg=R3
%finishelsestart
%if Ruse(R1)#0 %then Freeup Reg(R1)
PIX RR(LR,R1,Rreg)
Ruse(Rreg)=0
%finish
%finish
%finishelsestart
%if Ruse(R1)=0 %thenstart
Lreg=R1
%finishelsestart
%if Ruse(R2)=0 %and Ruse(R3)=0 %thenstart
Lreg=R3
%finishelsestart
Freeup Reg(R1)
Lreg=R1
%finish
%finish
%if Lform=LitVal %thenstart
OpRX(L,Lreg,LHS)
Ruse(Lreg)=-255
OpRX(M,Lreg-1,RHS)
Stackr(Lreg)
%return
%finish
OpRX(L,Lreg,RHS)
%finish
Ruse(Lreg)=-255
OpRX(M,Lreg-1,LHS)
%finish
Stackr(Lreg)
%return
!*
Opcode(IDIV):
%if Lform=RegVal %thenstart
%if Lreg#R1 %thenstart
%if Ruse(R1)#0 %thenstart
%if Rform=RegVal %and Rreg=R1 %thenstart
%if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
PIX RR(LR,R14,R1)
PIX RR(LR,R0,Lreg)
PIX RX(SRDA,R0,0,0,32)
PIX RR(DR,R0,R14)
Ruse(Lreg)=0
Stackr(R1)
%return
%finish
Freeup Reg(R1)
%finish
PIX RR(LR,R0,Lreg)
Ruse(Lreg)=0
%finishelse PIX RR(LR,R0,R1)
PIX RX(SRDA,0,0,0,32)
%if Rform=RegVal %thenstart
PIX RR(DR,R0,Rreg)
Ruse(Rreg)=0
%finishelsestart
Ruse(R1)=-255
OpRX(D,R0,RHS)
%finish
%finishelsestart
%if Rform=RegVal %thenstart
%if Rreg#R1 %thenstart
%if Ruse(R1)#0 %then Freeup Reg(R1)
Ruse(Rreg)=0
%finishelsestart
%if UsingR14#0 %then Pdrop(R14) %and UsingR14=0
PIX RR(LR,R14,R1)
Rreg=14
%finish
OpRX(L,R0,LHS)
PIX RX(SRDA,0,0,0,32)
PIX RR(DR,R0,Rreg)
%finishelsestart
%if Ruse(R1)#0 %then Freeup Reg(R1)
OpRX(L,R0,LHS)
PIX RX(SRDA,0,0,0,32)
Ruse(R1)=-255
OpRX(D,R0,RHS)
%finish
%finish
Stackr(R1)
%return
%end;! Int Binary Op
!*
%routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports INEG,IABS *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg1,XAop
Reg1=Load Int(RHS,-1,0)
%if Op=INEG %then XAop=LCR %elsestart
%if Op=INOT %thenstart
PIX RX(LA,0,0,0,1)
PIX RR(NR,Reg1,0)
PIX RR(XR,Reg1,0)
Stackr(Reg1)
%return
%finish
%if Op=IABS %then XAop=LPR %else Abort
%finish
PIX RR(XAop,Reg1,Reg1)
Stackr(Reg1)
%end;! Int Unary Op
!*
%routine Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
!***********************************************************************
!* supports RADD,RSUB,RMULT,RDIV,RGT,RLT,REQ,RNE,RGE,RLE *
!* descriptor to result on Estack *
!***********************************************************************
%constbyteintegerarray RReop(RADD:RDIV) = AER,SER,MER,DER
%constbyteintegerarray RXeop(RADD:RDIV) = AE,SE,ME,DE
%constbyteintegerarray RRdop(RADD:RDIV) = ADR,SDR,MDR,DDR
%constbyteintegerarray RXdop(RADD:RDIV) = AD,SD,MD,DD
%constbyteintegerarray RRxop(RADD:RDIV) = AXR,SXR,MXR,0
%integer Lform,Rform,Lreg,Rreg,Bytes,XARop,XAXop,Loadop
%switch Opcode(RADD:RLE)
Lform=LHS_Form&31
Rform=RHS_Form&31
Lreg=LHS_Reg
Rreg=RHS_Reg
Bytes=LHS_Size
%if RADD<=Op<=RDIV %thenstart
%if Bytes=4 %thenstart
XARop=RReop(Op)
XAXop=RXeop(Op)
Loadop=LE
%finishelsestart
%if Bytes=8 %thenstart
XARop=RRdop(Op)
XAXop=RXdop(Op)
%finishelsestart
XARop=RRxop(Op)
%finish
Loadop=LD
%finish
%finishelsestart;! comparison
%if Bytes=4 %thenstart
XARop=CER
XAXop=CE
Loadop=LE
%finishelsestart
XARop=CDR
XAXop=CD
Loadop=LD
%finish
%finish
->Opcode(Op)
!*
Opcode(RADD):
!*
Opcode(RMULT):
%if Lform=FregVal %thenstart
%if Rform=FregVal %thenstart
PIX RR(XARop,Lreg,Rreg)
Fruse(Rreg)=0
%finishelse OpRX(XAXop,Lreg,RHS)
Stackfr(Lreg,Bytes)
%finishelsestart
%if Rform#FregVal %thenstart
Rreg=Claimfr(-1)
OpRX(Loadop,Rreg,RHS)
%finish
OpRX(XAXop,Rreg,LHS)
Stackfr(Rreg,Bytes)
%finish
%return
!*
Opcode(RSUB):
!*
Opcode(RDIV):
%if Lform=FregVal %thenstart
%if Rform=FregVal %thenstart
PIX RR(XARop,Lreg,Rreg)
Fruse(Rreg)=0
%finishelse OpRX(XAXop,Lreg,RHS)
%finishelsestart
%if Rform=FregVal %thenstart
Lreg=Claimfr(Rreg)
Op RX(Loadop,Lreg,LHS)
PIX RR(XARop,Lreg,Rreg)
Fruse(Rreg)=0
%finishelsestart
Lreg=Claimfr(-1)
Op RX(Loadop,Lreg,LHS)
Op RX(XAXop,Lreg,RHS)
%finish
%finish
Stackfr(Lreg,Bytes)
%return
!*
Opcode(RGT):
Opcode(RLT):
Opcode(REQ):
Opcode(RNE):
Opcode(RGE):
Opcode(RLE):
CC=Setcc(Op-RGT)
%if Lform=FregVal %thenstart
%if Rform=FregVal %thenstart
PIX RR(XARop,Lreg,Rreg)
Fruse(Rreg)=0
%finishelse OpRX(XAXop,Lreg,RHS)
Fruse(Lreg)=0
%finishelsestart
%if Rform=FregVal %thenstart
CC=Invcc(CC)
OpRX(XAXop,Rreg,LHS)
%finishelsestart
Rreg=Claimfr(-1)
OpRX(Loadop,Rreg,LHS)
OpRX(XAXop,Rreg,RHS)
%finish
Fruse(Rreg)=0
%finish
CCset=1
%return
%end;! Real Binary Op
!*
%routine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
!***********************************************************************
!* supports RNEG,RABS *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg1,XAop,Bytes
Reg1=Load Real(RHS,-1,-1,Bytes)
%if Op=RNEG %thenstart
%if Bytes=4 %then XAop=LCER %else XAop=LCDR
%finishelsestart
%if Op=RABS %thenstart
%if Bytes=4 %then XAop=LPER %else XAop=LPDR
%finishelse Abort
%finish
PIX RR(XAop,Reg1,Reg1)
Stackfr(Reg1,Bytes)
%end;! Real Binary Op
!*
%routine Convert II(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts between integer sizes *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg
Reg=Load Int(Stk,-1,-1)
Stackr(Reg)
%end;! Convert II
!*
%routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts between real sizes *
!* descriptor to result on Estack *
!***********************************************************************
%integer Freg1,Bytes,Oldsize
%switch Sw(0:10)
Oldsize=Stk_Size
->Sw(((Oldsize&24)>>1)!(Newsize>>3))
!*
Sw(1):! CVTRD
Freg1=Load Real Extended(Stk,8)
Bytes=8
Note: Stackfr(Freg1,Bytes)
%return
!*
Sw(4):! CVTDR
Freg1=Load Real(Stk,-1,-1,Bytes)
PIX RR(LRER,Freg1,Freg1)
Bytes=4
->Note
!*
Sw(2):! CVTRQ
!*
Sw(6):! CVTDQ
Freg1=Load Real Extended(Stk,16)
Bytes=16
->Note
!*
Sw(8):! CVTQR
Freg1=Load Real(Stk,-1,-1,Bytes)
PIX RR(LRDR,Freg1,Freg1)
PIX RR(LRER,Freg1,Freg1)
Bytes=4
->Note
!*
Sw(9):! CVTQD
Freg1=Load Real(Stk,-1,-1,Bytes)
PIX RR(LRDR,Freg1,Freg1)
Bytes=8
->Note
!*
Sw(*):
Freg1=Load Real(Stk,-1,-1,Bytes)
->Note
%end;! Convert RR
!*
%routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode)
!***********************************************************************
!* converts between real and integer *
!* Mode = 0 TNC *
!* 1 RND *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg1,Freg1,Bytes
Freg1=Load Real(Stk,-1,-1,Bytes)
Reg1=Claimr(-1)
%if Mode=1 %thenstart
PIX RR(BASR,14,0)
Pusing(R14)
Using R14=1
%if Bytes=4 %thenstart
PIX RR(LTER,Freg1,Freg1)
PIX RX(BC,10,0,R14,14)
PIX RX(SE,Freg1,0,R9,RHALF)
PIX RX(BC,15,0,R14,18)
PIX RX(AE,Freg1,0,R9,RHALF)
%finishelsestart
PIX RR(LTDR,Freg1,Freg1)
PIX RX(BC,10,0,R14,14)
PIX RX(SD,Freg1,0,R9,RHALF)
PIX RX(BC,15,0,R14,18)
PIX RX(AD,Freg1,0,R9,RHALF)
%finish
%finish
PIX RX(SD,Freg1,0,R9,TWO31R);! X'4F00 0000 0800 0000'
PIX RX(AW,Freg1,0,R9,TWO32) ;! X'4E00 0001 0000 0000'
PIX RX(STD,Freg1,0,R13,Glawork)
PIX SI(XI,X'80',R13,Glawork+4)
PIX RX(L,Reg1,0,R13,Glawork+4)
Stackr(Reg1)
%end;! Convert RI
!*
%routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* converts real to integer *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg1,Freg1,Bytes
%switch Sw(0:2)
Reg1=Load Int(Stk,-1,0)
->Sw(Newsize>>3)
!*
Sw(0):! FLTR
Bytes=4
->Flt
!*
Sw(1):! FLTD
Bytes=8
Flt: Freg1=Claimfr(-1)
PIX RX(X,Reg1,0,R9,TWO31+4);! X'8000 0000'
PIX RX(ST,Reg1,0,R13,Glawork+4)
PIX SS(MVC,0,4,R13,Glawork,R9,TWO31) ;! X'4E00 0000 8000 0000'
PIX RX(LD,Freg1,0,R13,Glawork)
PIX RX(SD,Freg1,0,R9,TWO31)
Stackfr(Freg1,Bytes)
%return
!*
Sw(2):! FLTQ
Freg1=Claimfrpair(-1)
PIX RR(SDR,Freg1+1,Freg1+1)
Bytes=16
->Flt
%end;! Convert IR
!*
%integerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
!***********************************************************************
!* value defined by RHS is assigned to LHS. If Dup is non-zero then *
!* value must be retainedin a reg *
!* result is the reg used for retaining the value *
!***********************************************************************
%constbyteintegerarray Ad(0:21)=0(9),1(9),0(4)
%integer Bytes,Op,Reg,Form,B1,D1,B2,D2
Form=RHS_Form&31
Bytes=RHS_Size
LHS_Form=LHS_Form&31;! remove Regflag bit if set
%if Ad(LHS_Form)#0 %then Refer(LHS,0) %and LHS_Size=Bytes
%if Bytes=4 %thenstart
%if Form=RegVal %thenstart
Op=ST
Streg: Reg=RHS_Reg
Ruse(Reg)=0
Pushit: Op RX(Op,Reg,LHS)
%result=Reg
%finish
%if Form=FregVal %thenstart
Op=STE
Reg=RHS_Reg
Fruse(Reg)=0
->Pushit
%finish
%if Dup#0 %then Reg=Claimr(-1) %else Reg=0
Op RX(L,Reg,RHS)
Op=ST
->Pushit
%finishelsestart
%unless Bytes=8 %thenstart
%if Bytes=2 %and Form=RegVal %thenstart
Op=STH
->Streg
%finish
%if Bytes=1 %and Form=Regval %thenstart
Op=STC
->Streg
%finish
Set Bd(LHS,B1,D1)
Ruse(B1)=-255
Set Bd(RHS,B2,D2)
PIX SS(MVC,0,Bytes,B1,D1,B2,D2)
Ruse(B1)=0
%result=0
%finish
Op=STD
%if Form=FregVal %thenstart
Reg=RHS_Reg
Fruse(Reg)=0
->Pushit
%finish
Reg=Claimfr(-1)
Op RX(LD,Reg,RHS)
->Pushit
%finish
%end;! Storeop
!*
%routine Push Param(%integer Mode,%record(Stkfmt)%name Stk)
!***********************************************************************
!* the value or address of Stk is added to the parameter list *
!* result is the reg used for retaining the value *
!* Mode = 0 push value
!* 1 push address
!***********************************************************************
%integer Bytes,Op,Reg,Form
%if Mode=1 %thenstart
Address(Stk)
Stk_Size=4
%finish
Form=Stk_Form&31
Bytes=Stk_Size
! %if Mode=0 %and Form&ADDRESSED=0 %thenstart
%if Bytes=4 %thenstart
%if Form=RegVal %thenstart
Op=ST
Reg=Stk_Reg
Ruse(Reg)=0
Pushit: PIX RX(Op,Reg,0,R11,Next Param Offset)
Next Param Offset=Next Param Offset+Bytes
%return
%finish
%if Form=FregVal %thenstart
Op=STE
Reg=Stk_Reg
Fruse(Reg)=0
->Pushit
%finish
Op RX(L,0,Stk)
Op=ST
Reg=0
->Pushit
%finishelsestart
%unless Bytes=8 %then %monitor %and %stop
Op=STD
%if Form=FregVal %thenstart
Reg=Stk_Reg
Fruse(Reg)=0
->Pushit
%finish
Reg=Claimfr(-1)
Op RX(LD,Reg,Stk)
->Pushit
%finish
! %finishelsestart;! address required
! Reg=Load Address(Stk)
! Bytes=4
! Op=ST
! ->Pushit
! %finish
%end;! Push Param
!*
%integerfn Load address(%record(Stkfmt)%name Stk)
!***********************************************************************
!* result is the reg holding the address of the item desribed by Stk *
!***********************************************************************
%integer Reg,Form
Form=Stk_Form&31
%if Form<TempVal %then %monitor %and %stop
Op RX(LA,0,Stk)
%result=0
%end;! Load address
!*
%routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
!***********************************************************************
!* incorporate Index info into Base record *
!***********************************************************************
%integer Reg,Form
%switch F(0:21)
%if Index_Form=LitVal %thenstart
Index_Intval=Index_Intval<<Scale
Scale=0
%if Base_Form=AddrDir %thenstart
Base_Offset=Base_Offset+Index_Intval
%return
%finish
%finishelsestart
%if IndRegModVal<=Index_Form&31<=AddrDirModVal %thenstart
Reg=Claimr(0)
OpRX(L,Reg,Index)
Ruse(Reg)=-Elevel
Index_Form=RegVal
Index_Reg=Reg
Index_Base=0
Index_Offset=0
%finish
%finish
->F(Base_Form&31)
!*
F(IndRegVal): { ((reg)) }
F(IndTempVal): { ((temp)) }
F(IndDirVal): { ((dir)) }
Base_Form=Base_Form+12
Set: Base_Modreg=Index_Reg
Base_Modbase=Index_Base
Base_Modform=Index_Form
Base_Modoffset=Index_Offset
Base_Scale=Scale
Form=Base_Modform&31
%if Form=RegVal %or Form=IndRegVal %thenstart
Ruse(Base_Modreg)=-Elevel
%finish
%return
!*
F(AddrDir): { @dir }
F(RegAddr): { (reg) is @ }
F(TempAddr): { (temp) is @}
F(DirAddr): { (dir) is @ }
Base_Form=Base_Form+4
->Set
!*
F(AddrDirMod): { @dir+M }
F(RegModAddr): { (reg)+M }
F(TempModAddr): { (temp)+M }
F(DirModAddr): { (dir)+M }
Reg=Claimr(0)
OpRX(L,Reg,Base)
Ruse(Reg)=-Elevel
Base_Reg=Reg
Base_Form=RegModAddr!Regflag
->Set
!*
F(LitVal): { lit }
F(ConstVal): { const }
F(RegVal): { (reg) }
F(FregVal): { (freg) }
F(TempVal): { (temp) }
F(DirVal): { (dir) }
F(AddrConst): { @const }
F(IndRegModVal): { ((reg)+M) }
F(IndTempModVal): { ((temp)+M) }
F(IndDirModVal): { ((dir)+M) }
F(AddrDirModVal): { (@dir+M) }
Abort
!*
%end;! Note Index
!*
!*
!***********************************************************************
!***********************************************************************
!** Pascal-specific support procedures **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Load(%record(Stkfmt)%name Stk)
!***********************************************************************
!* load the operand to a register as a 32 bit item *
!***********************************************************************
%end;! Load
!*
%routine Eval Address(%record(Stkfmt)%name Stk)
!***********************************************************************
!* load the address of the operand to a register (set Stk to RegAddr) *
!***********************************************************************
%end;! Load
!*
%routine Referp(%record(Stkfmt)%name Stk,%integer Offset)
!***********************************************************************
!* adjust a descriptor for a packed-field reference *
!***********************************************************************
%switch F(0:35)
->F(Stk_Form)
!*
F(RegBitAddr): { (Reg) is pf }
Stk_ModOffset=Stk_ModOffset+Offset
%return
!*
F(RegBitModAddr): { (Reg)+(reg) }
{ PI1(ATR0+Stk_ModReg,Offset) }
%return
!*
F(*):
Abortm("Referp: ".Eform(Stk_Form))
%end;! Referp
!*
%routine String Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS,
%integer Bytes)
!***********************************************************************
!* implement STRGT, STRLT, SRTREQ, STRNE, STRLE STRGE *
!***********************************************************************
%integer B1,D1,B2,D2
%if Bytes<0 %then Abortm("String Binary Op")
Address(LHS)
Address(RHS)
Set BD(LHS,B1,D1)
Set BD(RHS,B2,D2)
PIX SS(CLC,0,Bytes,B1,D1,B2,D2)
CC=Op-STRGT
CCset=1
%end;! String Binary Op
!*
%routine Index Set Word
!***********************************************************************
!* index to the word containing a set member whose value is currently *
!* on top of the stack *
!***********************************************************************
{ PI1(ISHL,-5) }
{ PI(INDINT) }
%end;! Index Set Word
!*
%routine Index Set Bit
!***********************************************************************
!* index to the bit-offset for a set member whose value is currently *
!* on top of the stack *
!***********************************************************************
{ PLoadConst(31) }
{ PI(ILAND) }
%end;! Index Set Bit
!*
%routine Make Set(%integer Bytes,%record(Stkfmt)%name Set)
!***********************************************************************
!* allocate temporary space for a set-value and return a descriptor *
!* that value *
!***********************************************************************
%if Bytes&3#0 %then Abortm("Make Set: size")
Set=0
Set_Form=AddrDir
Set_Size=Bytes
Set_Base=0
Set_Offset=New Temp(Bytes)
%end;! Make Set
!*
%routine Empty Set(%integer Bytes,%record(Stkfmt)%name Set)
!***********************************************************************
!* make an empty set-value in temporary space and return a descriptor *
!* to that value *
!***********************************************************************
%integer MReg
%if Bytes&3#0 %then Abortm("Empty Set: size")
%if Bytes>4 %thenstart
Make Set(Bytes,Set)
Eval Address(Set)
{ zero set }
%finish { else PLoadConst(0) }
%end;! Empty Set
!*
%routine Load Set(%record(Stkfmt)%name Set)
!**********************************************************************
!* load a set value. If the set is larger than one word then stack *
!* its address else stack its value. If Baddr#0 then load byte addr *
!**********************************************************************
%if Set_Size>4 %thenstart
%if Set_Form#RegAddr %then Address(Set)
Eval Address(Set)
%finish { else Load(Set) }
%end;! Load Set
!*
%routine Set Word(%record(Stkfmt)%name I,J)
!***********************************************************************
!* set a word to a bit-pattern of the form {1}{0}. The number of *
!* leading 1's is given by (31-I) *
!***********************************************************************
%end;! Set Word
!*
%routine Set Part Word(%record(Stkfmt)%name I,J)
!***********************************************************************
!* set word to a bit-pattern of the form {0}{1}{0} where the least *
!* significant 1 is at bit-position I and the most significant 1 is at *
!* bit-position J *
!***********************************************************************
%end;! Set Part Word
!*
%routine Index Set(%record(Stkfmt)%name Set)
!***********************************************************************
!* construct an address descriptor for the end of a set *
!***********************************************************************
%if Set_Form#RegAddr %then Address(Set)
Refer(Set,Set_Size)
Address(Set)
Eval Address(Set)
%end;! Index Set
!*
%routine Set Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS,
%integer Bytes)
!***********************************************************************
!* implement SETI, SETU, SETD, SETEQ, SETNE, SETIN, SETSING *
!* and SETRANGE. *
!***********************************************************************
%integer MReg,CountReg,Label,Loop,Exit
%record(Stkfmt) Result
%switch Setop(SETI:SETRANGE)
->Setop(Op)
!*
Setop(SETI):
Setop(SETU):
Setop(SETD):
%if LHS_Size#RHS_Size %then Abortm("Set Binary Op: Sizes?")
Bytes=LHS_Size
%if Bytes>4 %thenstart
Index Set(LHS)
Index Set(RHS)
Make Set(Bytes,Result)
Index Set(Result)
{ PLoadConst(Bytes//4) }
Result=0
Result_Form=RegAddr
Result_Size=Bytes
Push Operand(Result)
%finishelsestart
{ Load(LHS) }
{ Load(RHS) }
{ %if Op=SETD %then PI(ILNOT) }
{ %if Op=SETU %then PI(ILOR) %else PI(ILAND) }
{ Push Int Result }
%finish
!*
Setop(SETEQ):
Setop(SETNE):
%if LHS_Size#RHS_Size %then Abortm("Set Binary Op: Sizes?")
Bytes=RHS_Size
%if Bytes>4 %thenstart
Load Set(LHS)
Load Set(RHS)
{ PLoadConst(Bytes) }
{ PI(STRCMP) }
{ Push Int Result; ! simulate }
{ Push Int Result; ! strcmp }
%finishelsestart
{ Push Operand(LHS) }
{ Push Operand(RHS) }
%finish
CC=Op-SETEQ+2; ! cc is 2 or 3
CCSet=1
%return
!*
Setop(SETIN):
Bytes=RHS_Size
Load Set(RHS)
{ %if LHS_Form=TosVal %then PI(EXCHOP) %else Load(LHS) }
%if Bytes>4 %thenstart
Index Set Word
{ PI(LI) }
{ PI(LR0+MReg) }
%finish
Index Set Bit
{ PI(ISRLT) }
{ PLoadConst(1) }
{ PI(ILAND) }
{ Push Int Result }
%return
!*
Setop(SETSING):
{ PLoadConst(1) }
{ %if LHS_Form=TosVal %then PI(EXCHOP) %else Load(LHS) }
%if Bytes>4 %thenstart
Index Set Bit
{ PI(ISLLT) }
Empty Set(Bytes,Result)
{ PI(LR0+MReg) }
Index Set Word
{ PI(ASS) }
{ PI(DISCARDOP) }
Push Operand(Result)
%finishelsestart
{ PI(ISLLT) }
{ Push Int Result }
%finish
%return
!*
Setop(SETRANGE):
Empty Set(Bytes,Result)
Load(LHS)
Load(RHS)
Push Operand(Result)
%return
!*
Setop(*):
Abortm("Set Binary Op")
%end;! Set Binary Op
!*
%routine Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue)
!***********************************************************************
!* compute the bit address of an indexed bit-field. *
!* Factor is the number of array elements per word and must be 2, 4, *
!* 8, 16, or 32. *
!***********************************************************************
%integer Epm,Reg
%if Base_Form#RegAddr %then Abortm("Bit Index: base")
%if Factor_Form#LitVal %then Abortm("Bit Index: factor")
Epm=Factor_IntVal
%if Epm<2 %or Epm>32 %then Abortm("Bit Index: epm")
{ %unless Power(Epm)=1 %then Abortm("Bit Index: power") }
Load(IndexValue)
Base_Form=RegBitModAddr
Base_ModReg=Reg
%end;! Bit Index
!*
%routine Load Mask(%integer Width)
!***********************************************************************
!* Load a bit-mask of the specified width from the global const area *
!***********************************************************************
%if Width<1 %or Width>31 %then Abortm("Load Mask")
%end;! Load Mask
!*
!*
!*
!***********************************************************************
!***********************************************************************
!** Amdahl-specific procedures **
!***********************************************************************
!***********************************************************************
!*
!*
%routine Clear Regs
!***********************************************************************
!* forget all previous use of registers *
!***********************************************************************
%integer I
%cycle I=0,1,15
Ruse(I)=0
%repeat
%cycle I=0,2,6
Fruse(I)=0
%repeat
Lastreg=0
Lastbreg=0
Lastfreg=-1
%end;! Clear Regs
!*
%routine Dropall
!***********************************************************************
!* no dynamic addressing registers can have assumed values *
!***********************************************************************
%integer I
%if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
%if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
%cycle I=0,1,7
Ruse(I)=0
%repeat
%cycle I=0,2,6
Fruse(I)=0
%repeat
Lastreg=-1
Lastfreg=-1
%end;! Dropall
!*
!*
%routine Freeup Freg(%integer R)
!***********************************************************************
!* store the content of floating register R in temp space, modifying *
!* Estack entries as necessary *
!***********************************************************************
%integer I,J,XAop,Size
I=-Fruse(R);! was held as -Elevel
%if I<=0 %thenstart
Fruse(R)=0
%return
%finish
%if Stk(I)_Form&31=FregVal %and Stk(I)_Reg=R %thenstart
Size=Stk(I)_Size
%if Size=4 %then XAop=STE %else XAop=STD
J=New Temp(Size)
Stk(I)_Form=TempVal
Stk(I)_Offset=J
Do RX(XAop,R,R10,J)
Stk(I)_Base=0
Fruse(R)=0
%return
%finish
printstring("Request to free register");write(R,2);newline
Abort
%end;! Freeup Freg
!*
%integerfn New Temp(%integer Bytes)
%integer I
I=integer(Addrstackca)
integer(Addrstackca)=I+(Bytes+3)&X'FFFFFFFC'
%result=I+64
%end;! New Temp
!*
%routine Freeup Reg(%integer R)
!***********************************************************************
!* store the content of general register R in temp space, modifying *
!* Estack entries as necessary *
!* no dynamic addressing registers can have assumed values *
!***********************************************************************
%integer I,J,K
I=-Ruse(R);! was held as -Elevel
%if I<=0 %thenstart
Ruse(R)=0
%return
%finish
J=New Temp(4)
%if Stk(I)_Reg=R %thenstart
K=Stk(I)_Form&31
%if K=RegVal %thenstart
Stk(I)_Form=TempVal
Stk(I)_Offset=J
Stk(I)_Base=0
Store: Do RX(ST,R,R10,J)
Ruse(R)=0
%return
%finishelsestart
%if K=IndRegVal %or K=RegAddr %or K=RegModAddr %c
%or K=IndRegModVal %thenstart
Stk(I)_Form=K+1
Stk(I)_Offset=J
Stk(I)_Base=0
->Store
%finish
%finish
%finishelsestart
%if Stk(I)_Modform&31=RegVal %and Stk(I)_Modreg=R %thenstart
Stk(I)_Modform=TempVal
Stk(I)_Modoffset=J
Stk(I)_Modbase=0
->Store
%finish
%if Stk(I)_Modform&31=IndRegVal %and Stk(I)_Modreg=R %thenstart
Stk(I)_Modform=IndTempVal
Stk(I)_Modoffset=J
Stk(I)_Modbase=0
->Store
%finish
%finish
printstring("Request to free register");write(R,2);newline
Abort
%end;! Freeup Reg
!*
%routine Reset Reguse(%integer Old,New)
%integer I
%cycle I=1,1,3
%if Ruse(I)=-Old %thenstart
Ruse(I)=-New
%return
%finish
%repeat
%cycle I=0,2,6
%if Fruse(I)=-Old %thenstart
Fruse(I)=-New
%return
%finish
%repeat
%end;! Reset Reguse
!*
%routine Freeregs
!***********************************************************************
!* save any general or floating registers *
!***********************************************************************
%integer I
%cycle I=1,1,3
%if Ruse(I)<0 %then Freeup Reg(I)
Ruse(I)=0
%repeat
%cycle I=0,2,6
%if Fruse(I)<0 %then Freeup Freg(I)
%repeat
Lastreg=-1
Lastfreg=-1
%end;! Freeregs
!*
%integerfn Claimfr(%integer Curreg)
!***********************************************************************
!* result is a free floating register, other than Curreg *
!***********************************************************************
%integer I
%cycle I=0,2,6
%if Fruse(I)=0 %and I#Curreg %and I#Lastfreg %thenstart
Lastfreg=I
%result=I
%finish
%repeat
%cycle I=0,2,6
%unless I=Curreg %or I=Lastfreg %thenstart
Freeup Freg(I)
Lastfreg=I
%result=I
%finish
%repeat
%end;! Claimfr
!*
%integerfn Claimfrpair(%integer Curreg)
!***********************************************************************
!* result is the smaller of a free floating register pair, not *
!*including Curreg *
!***********************************************************************
%integer I
%if Fruse(0)=0 %and Fruse(2)=0 %then %result=0
%if Fruse(4)=0 %and Fruse(6)=0 %then %result=4
%unless 0<=Curreg<=2 %thenstart
%if Fruse(0)#0 %then Freeup Freg(0)
%if Fruse(2)#0 %then Freeup Freg(2)
%result=0
%finishelsestart
%if Fruse(4)#0 %then Freeup Freg(4)
%if Fruse(6)#0 %then Freeup Freg(6)
%result=4
%finish
%end;! Claimfrpair
!*
%integerfn Claimr(%integer Curreg)
!***********************************************************************
!* result is a free general register, other than Curreg *
!***********************************************************************
%integer I
%cycle I=1,1,3
%if Ruse(I)=0 %and I#Curreg %and I#Lastreg %thenstart
Lastreg=I
%result=I
%finish
%repeat
%cycle I=1,1,3
%unless I=Curreg %or I=Lastreg %or Ruse(I)=-255 %thenstart
Freeup Reg(I)
Lastreg=I
%result=I
%finish
%repeat
%if Lastreg>0 %and Lastreg#Curreg %thenstart
Freeup Reg(Lastreg)
%result=Lastreg
%finishelsestart
%if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
%result=R14
%finish
Abort
%end;! Claimr
!*
%integerfn Claimbr
!***********************************************************************
!* obtain a register, other than Lastbreg *
!***********************************************************************
%integer I
%cycle I=4,1,7
%if Ruse(I)=0 %and I#Lockedb1 %then %result=I
%repeat
%cycle I=4,1,7
%unless I=Lastbreg %or I=Lockedb1 %then Ruse(I)=0 %and %result=I
%repeat
%end;! Claimbr
!*
%routine Setint(%integer Val,Size,%integername B2,D2)
!***********************************************************************
!* set B2, D2 to address a location containing Val *
!***********************************************************************
%if Size<4 %thenstart
%if Size=1 %then Val=Val<<24 %else Val=Val<<16
%finish
Ed4(Cnst,CurCnst,Val)
CurCnst=CurCnst+4
B2=R9
D2=CurCnst-4
%end;! Setint
!*
%integerfn Basereg(%integer Area)
!***********************************************************************
!* result is the register addressing the nominated area *
!***********************************************************************
%integer I
%if Area=0 %then %result=R10;! stack
%if Area=Static %then %result=R8
%if Area=Cnst %then %result=R9
%if Area=Gla %then %result=R13
%cycle I=7,-1,4
%if Ruse(I)=Area %then Lastbreg=I %and %result=I
%repeat
%cycle I=7,-1,4
%unless I=Lastbreg %thenstart
PIX RX(L,I,0,R13,Areabase(Area))
Ruse(I)=Area
Lastbreg=I
%result=I
%finish
%repeat
%end;! Basereg
!*
%integerfn SetX2(%integername D2)
!***********************************************************************
!* result is a register containing an appropriate 4K multiple *
!* D2 is adjusted accordingly *
!***********************************************************************
%integer I,J
%if D2>=4096 %thenstart
J=D2&X'FFFFF000'
D2=D2&X'FFF'
%cycle I=4,1,7
%if Ruse(I)=J %then Lastbreg=I %and %result=I
%repeat
{ %if J>Max4k %then Max4k=j}
I=Claimbr
{ PIX RX(L,I,0,R12,J>>10)}
PIX RX(LA,I,0,0,J>>12)
PIX RS(SLL,I,0,0,12)
Ruse(I)=J
%result=I
%finishelse %result=0
%end;! SetX2
!*
%routine Range(%integername B,D)
!***********************************************************************
!* if necessary modify B to ensure that D is less than 4096 *
!* D is adjusted accordingly *
!***********************************************************************
%integer X2
%if D>=4096 %thenstart
X2=SetX2(D)
PIX RR(AR,X2,B)
B=X2
Ruse(X2)=0
%finish
%end;! Range
!*
%integerfn Indbase(%integer Area,Disp)
!***********************************************************************
!* result is a register containing the address held in the nominated *
!* location *
!***********************************************************************
%integer I,J,K
J=(Area<<16)!Disp
%cycle I=4,1,7
%if Ruse(I)=J %then Lastbreg=I %and %result=I
%repeat
I=Basereg(Area)
K=Claimbr
Do RX(L,K,I,Disp)
Ruse(K)=(Area<<16)!Disp
Lastbreg=K
%result=K
%end;! Indbase
!*
%routine Do RX(%integer Op,Reg,Base,Offset)
%integer X2
%if Offset>=4096 %then X2=SetX2(Offset) %else X2=0
PIX RX(Op,Reg,X2,Base,Offset)
%end;! Do RX
!*
%integerfn Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg)
!***********************************************************************
!* result is a register loaded with the modifier (scaled if necessary) *
!***********************************************************************
%integer Form,Reg,B2,D2
%switch F(0:21)
Form=Stk_Modform&31
%if Form =RegVal %thenstart
Reg=Stk_Modreg
Stk_Modreg=0
Ruse(Reg)=0
Scale: %if Stk_Scale#0 %thenstart
PIX RS(SLL,Reg,0,0,Stk_Scale)
%finish
Stk_Modform=RegVal
Stk_Scale=0
%result=Reg
%finish
%if Form=IndRegVal %thenstart
Reg=Stk_Modreg
Stk_Modreg=0
PIX RX(L,Reg,0,Reg,0)
Ruse(Reg)=0
->Scale
%finish
Reg=Claimr(Lockedreg)
D2=Stk_Modoffset
->F(Form);! removing the reg marker bit
!*
F(LitVal): { lit }
%if 0<=D2<4096 %thenstart
%if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart
PIX RX(LA,Reg,0,0,D2)
%finish
%finishelsestart
Setint(D2,Stk_Size,B2,D2)
Do RX(L,Reg,B2,D2)
%finish
->Scale
!*
F(ConstVal): { const }
F(TempVal): { (temp) }
F(DirVal): { (dir) }
Do RX(L,Reg,Basereg(Stk_Modbase),D2)
->Scale
!*
F(IndTempVal): { ((temp)) }
Do RX(L,Reg,Basereg(Stk_Modbase),D2)
PIX RX(L,Reg,0,Reg,0)
->Scale
!*
F(IndDirVal): { ((dir)) }
B2=Indbase(Stk_Modbase,D2)
PIX RX(L,Reg,0,B2,0)
->Scale
!*
F(*): Abort
!*
%end;! Load Modifier
!*
%integerfn Negoffset(%integer Area,D)
%integer B,D2
D2=Glaspace(4)
Efix(GLA,D2-Gla offset,Area,D)
B=Claimbr
Do RX(L,B,R13,D2)
%result=B
%end;! Negoffset
!*
%routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk)
!***********************************************************************
!* generate an RX instruction appropriate to the operand *
!***********************************************************************
%integer B2,D2,Modform,Modreg
%switch F(0:21)
D2=Stk_Offset
->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal): { lit }
%if 0<=D2<4096 %and Op=L %thenstart
%if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart
PIX RX(LA,Reg,0,0,D2)
%finish
%finishelsestart
Setint(Stk_Intval,Stk_Size,B2,D2)
Do RX(Op,Reg,B2,D2)
%finish
%return
!*
F(ConstVal): { const }
F(TempAddr): { (temp) is @}
F(DirAddr): { (dir) is @ }
F(TempVal): { (temp) }
F(DirVal): { (dir) }
Do RX(Op,Reg,Basereg(Stk_Base),D2)
%return
!*
F(RegAddr): { (reg) is @ }
F(RegVal): { (reg) }
PIX RR(Op-X'40',Reg,Stk_Reg)
Ruse(Stk_Reg)=0
%return
!*
F(FregVal): { (freg) }
PIX RR(Op-X'40',Reg,Stk_Reg)
Fruse(Stk_Reg)=0
%return
!*
F(IndRegVal): { ((reg)) }
PIX RX(Op,Reg,0,Stk_Reg,0)
Ruse(Stk_Reg)=0
%return
!*
F(IndTempVal): { ((temp)) }
%if UsingR14#0 %then UsingR14=0 %and Pdrop(R14)
Do RX(L,R14,Basereg(Stk_Base),D2)
PIX RX(Op,Reg,0,R14,0)
%return
!*
F(IndTempModVal): { ((temp)+M) }
%if UsingR15#0 %then UsingR15=0 %and Pdrop(R15)
B2=R15
Do RX(L,B2,Basereg(Stk_Base),D2)
->Modify
!*
F(IndDirVal): { ((dir)) }
B2=Indbase(Stk_Base,D2)
PIX RX(Op,Reg,0,B2,0)
%return
!*
F(IndDirModVal): { ((dir)+M) }
B2=Indbase(Stk_Base,D2)
Modify:
%if Stk_Modform=LitVal %thenstart
Do RX(Op,Reg,B2,Stk_Modintval)
%return
%finish
Lockedb1=B2
Modreg=Load Modifier(Stk,Reg)
PIX RX(Op,Reg,Modreg,B2,0)
Lockedb1=0
%return
!*
F(AddrDirModVal): { (dir+M) }
Modreg=Load Modifier(Stk,Reg)
%if 0<=Stk_Offset<4096 %thenstart
PIX RX(Op,Reg,Basereg(Stk_Base),Modreg,Stk_Offset)
%finishelsestart
%if Stk_Offset<0 %thenstart
B2=Negoffset(Stk_Base,Stk_Offset)
%finishelsestart
B2=Claimr(Reg)
Do RX(LA,B2,Basereg(Stk_Base),Stk_Offset)
%finish
PIX RX(Op,Reg,B2,Modreg,0)
%finish
%return
!*
F(IndRegModVal): { ((reg)+M) }
B2=Stk_Reg
Ruse(B2)=0
Lastreg=B2;! to avoid possibility of a clash when modifying
->Modify
!*
F(AddrConst): { @const }
F(AddrDir): { @dir }
%if Op= L %then Op=LA %elsestart
%unless Op=STC %or Op=IC %then Abort
%finish
->F(DirVal)
!*
F(AddrDirMod): { @dir+M }
%if Op=L %then Op=LA %elsestart
%unless Op=STC %or Op=IC %then Abort
%finish
->F(AddrDirModVal)
!*
F(RegModAddr): { (reg)+M }
%if Op=L %then Op=LA %elsestart
%unless Op=STC %or Op=IC %then Abort
%finish
->F(IndRegModVal)
!*
F(TempModAddr): { (temp)+M }
%if Op=L %then Op=LA %elsestart
%unless Op=STC %or Op=IC %then Abort
%finish
->F(IndTempModVal)
!*
F(DirModAddr): { (dir)+M }
%if Op=L %then Op=LA %elsestart
%unless Op=STC %or Op=IC %then Abort
%finish
->F(IndDirModVal)
!*
%end;! OpRX
!*
%routine Set BD(%record(Stkfmt)%name Stk,%integername B,D)
!***********************************************************************
!* provide Base and Dispacement values for accessing the operand *
!***********************************************************************
%integer Modform,Modreg,D2
%switch F(0:21)
D=Stk_Offset
->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal): { lit }
Setint(Stk_Intval,Stk_Size,B,D)
%unless 0<=D<=4095 %then Range(B,D)
%return
!*
F(ConstVal): { const }
F(TempVal): { (temp) }
F(DirVal): { (dir) }
F(AddrDir): { @dir }
%if D<0 %thenstart;! use a fixed up address
B=Negoffset(Stk_Base,D)
D=0
%return
%finish
B=Basereg(Stk_Base)
%unless D<=4095 %then Range(B,D)
%return
!*
F(IndRegVal): { ((reg)) }
F(RegAddr): { (reg) is @ }
B=Stk_Reg
D=0
Ruse(B)=0
%return
!*
F(IndTempVal): { ((temp)) }
F(TempAddr): { (temp) is @}
B=Claimr(0)
Do RX(L,B,Basereg(Stk_Base),D)
D=0
Ruse(B)=0
%return
!*
F(IndTempModVal): { ((temp)+M) }
F(TempModAddr): { (temp)+M }
B=Claimr(0)
Do RX(L,B,Basereg(Stk_Base),D)
D=0
->Modify
!*
F(IndDirVal): { ((dir)) }
F(DirAddr): { (dir) is @ }
B=Indbase(Stk_Base,D)
D=0
%return
!*
F(IndDirModVal): { ((dir)+M) }
F(DirModAddr): { (dir)+M }
B=Indbase(Stk_Base,D)
Modify:
%if Stk_Modform=LitVal %thenstart
D=Stk_Modintval
Range(B,D)
%return
%finish
Modreg=Load Modifier(Stk,B)
PIX RR(AR,Modreg,B)
Ruse(Modreg)=0
B=Modreg
D=0
%return
!*
F(AddrDirModVal): { (dir+M) }
%if D<0 %thenstart
B=Negoffset(Stk_Base,D)
%finishelsestart
B=Claimr(0)
Do RX(LA,B,Basereg(Stk_Base),D)
%finish
Modreg=Load Modifier(Stk,B)
PIX RR(AR,Modreg,B)
Ruse(Modreg)=0
B=Modreg
D=0
%return
!*
F(IndRegModVal): { ((reg)+M) }
F(RegModAddr): { (reg)+M }
B=Stk_Reg
Ruse(B)=0
->Modify
!*
!*
F(AddrConst): { @const }
!*
F(AddrDirMod): { @dir+M }
->F(AddrDirModVal)
!*
!*
%end;! Set BD
!*
%routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2)
%integer I,Len1,Len2,B1,D1,B2,D2,XAop,Apars,Reg
%if C1_Form=LitVal %then C1_Size=1
%if C2_Form=LitVal %then C2_Size=1
%if LenC1_Form=Litval %and LenC2_Form=LitVal %thenstart
%if LenC1_Intval=LenC2_Intval %and LenC1_Intval<=256 %thenstart
Set BD(C1,B1,D1)
%if C2_Form=Litval %thenstart
%if Op=EASGNCHAR %then XAop=MVI %else XAop=CLI
PIX SI(XAop,C2_Intval,B1,D1)
%return
%finish
Ruse(B1)=-255
Lockedb1=B1
Set BD(C2,B2,D2)
Lockedb1=0
Ruse(B1)=0
%if Op=EASGNCHAR %then XAop=MVC %else XAop=CLC
PIX SS(XAop,0,LenC1_Intval,B1,D1,B2,D2)
%return
%finish
%finish
Apars=Glaspace(16)
%cycle I=0,4,12
Pd4(GLA,Apars+I,0)
%repeat
!*
%if C1_Form=AddrDir %thenstart;! establish fixup
Efix(GLA,Apars,C1_Base,C1_Offset)
%finishelsestart
%if C1_Form=LitVal %thenstart
Setint(C1_Intval,1,B1,D1)
Pfix(GLA,Apars,Cnst,D1)
%finishelsestart
Set BD(C1,B1,D1)
%if D1#0 %thenstart
PIX RX(LA,R0,0,B1,D1)
B1=R0
%finish
Do RX(ST,B1,R13,Apars)
%finish
%finish
!*
%if LenC1_Form=LitVal %thenstart
Pd4(GLA,Apars+4,LenC1_Intval)
%finishelsestart
Reg=Load Int(LenC1,-1,-1)
Do RX(ST,Reg,R13,Apars+4)
%finish
!*
%if C2_Form=AddrDir %thenstart;! establish fixup
Efix(GLA,Apars+8,C2_Base,C2_Offset)
%finishelsestart
%if C2_Form=LitVal %thenstart
Setint(C2_Intval,1,B1,D1)
Pfix(GLA,Apars+8,Cnst,D1)
%finishelsestart
Set BD(C2,B1,D1)
%if D1#0 %thenstart
PIX RX(LA,R0,0,B1,D1)
B1=R0
%finish
Do RX(ST,B1,R13,Apars+8)
%finish
%finish
!*
%if LenC2_Form=LitVal %thenstart
Pd4(GLA,Apars+12,X'20000000'!LenC2_Intval)
%finishelsestart
Reg=Load Int(LenC2,-1,-1)
PIX RX(LA,0,0,0,X'20')
PIX RS(SLL,R0,0,0,24)
PIX RR(OR,R0,Reg)
Do RX(ST,R0,R13,Apars+12)
%finish
!*
%cycle I=1,1,3
%if Ruse(I)#0 %then Freeup Reg(I)
%repeat
Reg=R13
Range(Reg,Apars)
PIX RS(LM,R0,R3,Reg,Apars)
%if Op=EASGNCHAR %then XAop=MVCL %else XAop=CLCL
PIX RR(XAop,R0,R2)
%end;! Do Charop
!*
%routine Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!***********************************************************************
!* Op = 1 CXADD 5 CXNEG 9 CONJG *
!* 2 CXSUB 6 CXASGN *
!* 3 CXMULT 7 CXEQ *
!* 4 CXDIV 8 CXNE *
!* Flags = Variant<<8 ! Sizecode *
!* Variant: 0 complex op complex *
!* 1 complex op real *
!* 2 real op complex *
!* Sizecode: 0 8 *
!* 1 16 *
!* 2 32 *
!***********************************************************************
%integer Adj,Variant,Size,D,Reg1,Reg2,Reg3,I,Op1,Adjl,Dl
%switch S(0:9)
%cycle I=0,2,6
%if Fruse(I)<0 %then Freeup Freg(I)
%repeat
Variant=Flags>>8
Size=Flags&3
%if Size=0 %thenstart
D=4
Adj=0
%finishelsestart
D=8
Adj=X'10';! to be subtracted from LE etc to give LD etc
%finish
%if 3<=Op<=4 %and Variant=0 %thenstart;! use support procedure
Elevel=Elevel+3;! to allow operands to be pushed
Spcall(3*(Op-3)+Size)
%return
%finish
Reg1=Claimr(-1)
Ruse(Reg1)=-255
Reg2=Claimr(Reg1)
Ruse(Reg2)=-255
OpRX(L,Reg1,LHS)
OpRX(L,Reg2,RHS1)
%if Op<=4 %thenstart
Lastreg=Reg2;! to ensure that both Reg1 and Reg2 are safe
Reg3=Claimr(Reg1)
OpRX(L,Reg3,RHS2)
%finish
Ruse(Reg1)=0
Ruse(Reg2)=0
->S(Op)
!*
S(1): ! CXADD
PIX RX(LE-Adj,0,0,Reg2,0)
PIX RX(LE-Adj,2,0,Reg2,D)
PIX RX(AE-Adj,0,0,Reg3,0)
%unless Variant=1 %then PIX RX(AE-Adj,2,0,Reg3,D)
Store:PIX RX(STE-Adj,0,0,Reg1,0)
PIX RX(STE-Adj,2,0,Reg1,D)
%return
!*
S(2): ! CXSUB
PIX RX(LE-Adj,0,0,Reg2,0)
%if Variant=2 %then PIX RR(SER-Adj,2,2) %c
%else PIX RX(LE-Adj,2,0,Reg2,D)
PIX RX(SE-Adj,0,0,Reg3,0)
%unless Variant=1 %then PIX RX(SE-Adj,2,0,Reg3,D)
->Store
!*
S(3): ! CXMULT
PIX RX(LE-Adj,0,0,Reg2,0)
PIX RX(LE-Adj,2,0,Reg2,D)
PIX RX(ME-Adj,0,0,Reg3,0)
PIX RX(ME-Adj,2,0,Reg3,0)
{ %if Variant=0 %thenstart }
{ PIX RX(LE-Adj,4,0,Reg2,0) }
{ PIX RX(LE-Adj,6,0,Reg2,D) }
{ PIX RX(ME-Adj,4,0,Reg3,D) }
{ PIX RX(ME-Adj,6,0,Reg3,D) }
{ PIX RR(SER-Adj,0,6) }
{ PIX RR(AER-Adj,2,4) }
{ %finish }
->Store
!*
S(4): ! CXDIV
PIX RX(LE-Adj,0,0,Reg2,0)
PIX RX(LE-Adj,2,0,Reg2,D)
PIX RX(DE-Adj,0,0,Reg3,0)
PIX RX(DE-Adj,2,0,Reg3,0)
->Store
!*
S(5): ! CXNEG
PIX RR(SER-Adj,0,0)
PIX RR(SER-Adj,2,2)
PIX RX(SE-Adj,0,0,Reg2,0)
PIX RX(SE-Adj,2,0,Reg2,D)
->Store
!*
S(6): ! CXASGN
%if Flags&4=0 %thenstart;! assigning to single
Adjl=0
Dl=4
%finishelsestart
Adjl=X'10'
Dl=8
%finish
%if Variant#0 %thenstart;! not Cx = Cx
%if D=4 %and Dl=8 %then PIX RR(LDR,0,0)
PIX RX(LE-Adj,0,0,Reg2,0)
%if Variant=2 %thenstart;! Real = Cx
St6a: PIX RX(STE-Adjl,0,0,Reg1,0)
%return
%finishelsestart;! Cx = Real
PIX RR(SER-Adj,2,2)
St6b: PIX RX(STE-Adjl,2,0,Reg1,Dl)
->St6a
%finish
%finish
%if D#Dl %thenstart;! unequal lengths being assigned
%if D=4 %thenstart;! must zero regs
PIX RR(SDR,0,0)
PIX RR(SDR,2,2)
%finish
PIX RX(LE-Adj,0,0,Reg2,0)
PIX RX(LE-Adj,2,0,Reg2,D)
->St6b
%finish
PIX SS(MVC,0,D<<1,Reg1,0,Reg2,0)
%return
!*
S(7): ! CXEQ
S(8): ! CXNE
%if Op=7 %then CC=7 %else CC=8
PIX RX(LE-Adj,0,0,Reg1,0)
PIX RR(BASR,R14,0)
Pusing(R14)
UsingR14=1
PIX RX(CE-Adj,0,0,Reg2,0)
%if Variant=0 %then I=16 %else I=12
PIX RX(BC,CC,0,R14,I)
%if Variant=1 %thenstart
PIX RR(SER,0,0)
PIX RR(CER,2,0)
%finishelsestart
PIX RX(LE-Adj,2,0,Reg1,D)
PIX RX(CE-Adj,2,0,Reg2,D)
%finish
CCset=1
CC=CC!!15;! inverse test was used in the above
%return
!*
S(9): ! CONJG
PIX RX(LE-Adj,0,0,Reg2,0)
PIX RR(SER-Adj,2,2)
PIX RX(SE-Adj,2,0,Reg2,D)
->Store
%end;! Cx Operation
!*
!*
!***********************************************************************
!*
!*
%endoffile