!* modified 16/07/86 !* %constinteger increports=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 Ecall2(%integer Id,Extlevel,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 "ercs20:ib8.specs" %include "putspecs" !%include "ercs01:cfort_xaspecs" %include "ercc10:opouts" %include "ercs01:ebits_ecodes28" %include "ercs01:ebits_enames21" !%include "ercs01:cfort_xamnem" !include "ercc10:opouts" !* !* !*********************************************************************** !* Common declarations * !*********************************************************************** !* !* !* !*********************************************************************** !* %constinteger Stack = 0 !* %constinteger LitVal = 0 { lit } %constinteger ConstVal = 1 { const } %constinteger RegVal = 2 { (reg) } %constinteger FregVal = 3 { (freg) } %constinteger TempVal = 4 { (temp) } %constinteger DirVal = 5 { (dir) } %constinteger IndRegVal = 6 { ((reg)) } %constinteger IndTempVal = 7 { ((temp)) } %constinteger IndDirVal = 8 { ((dir)) } %constinteger AddrConst = 9 { @const } %constinteger AddrDir = 10 { @dir } %constinteger RegAddr = 11 { (reg) is @ } %constinteger TempAddr = 12 { (temp) is @} %constinteger DirAddr = 13 { (dir) is @ } %constinteger AddrDirMod = 14 { @dir+M } %constinteger RegModAddr = 15 { (reg)+M } %constinteger TempModAddr = 16 { (temp)+M } %constinteger DirModAddr = 17 { (dir)+M } %constinteger IndRegModVal = 18 { ((reg)+M) } %constinteger IndTempModVal = 19 { ((temp)+M) } %constinteger IndDirModVal = 20 { ((dir)+M) } %constinteger AddrDirModVal = 21 { (@dir+M) } %constinteger RegBitAddr = 22 { (reg) is @ } %constinteger RegBitModAddr = 23 { (reg)+M } %constinteger RegVar = 29 { Var in Reg} %constinteger RegPtr = 30 { Ptr in Reg } !* %constinteger Regflag = 32 {used to speedup search for reguse} !* %constbyteintegerarray Eaddrform(0:31) = %c 128, { Litval => Special } Addrconst, { Const => Addrconst } 130, { Regval => Special } 131, { Fregval => Special } AddrDir, { Tempval => AddrDir } AddrDir, { Dirval => AddrDir } RegAddr, { IndRegVal => RegAddr } TempAddr, { IndTempVal => TempAddr } Diraddr, { IndDirVal => Diraddr } 255, { Addrconst has no address } 255, { AddrDir has no address } 255{130}, { Regaddr should be as Regval } 255{addrdir}, { TempAddr should be as TempVal } 255{addrdir}, { Diraddr should be as DirVal } 255, { AddrDirMod has no address } 255, { RegModAddr has no address } 255, { TempModAddr has no address } 255, { DirModAddr has no address } RegModAddr, { IndRegModVal => RegModAddr } TempModAddr, { IndTempModVal => TempModAddr } DirModAddr, { IndDirModVal => DirModAddr } AddrDirMod, { AddrDirModVal => AddrDirMod } 255(*); { All others have no Address} ! %constbyteintegerarray Erefform(0:31) = %c 255, { Litval => Nocando } 255, { Const => Nocando } Regflag!IndRegVal, { Regval => IndRegVal } 255, { Fregval => Nocando } IndTempVal, { Tempval => IndTempVal } IndDirVal, { Dirval => IndDirVal } 128, { IndRegVal => Must Load } 128, { IndTempVal => Must Load } 128, { IndDirVal => Must Load } ConstVal, { Addrconst => ConstVal } DirVal, { AddrDir => DirVal } Regflag!IndRegVal, { Regaddr should be as Regval } IndTempVal, { TempAddr should be as TempVal } IndDirVal, { Diraddr should be as DirVal } AddrDirModVal,{ AddrDirMod => AddrDirModVal } IndRegModVal, { RegModAddr => IndRegModVal } IndTempModVal,{ TempModAddr => IndTempModVal } IndDirModVal, { DirModAddr => IndDirModVal } 128, { IndRegModVal => Must Load } 128, { IndTempModVal => Must Load } 128, { IndDirModVal => Must Load } 128, { AddrDirModVal => Must Load } 255(*); { All others => Nocando} ! ! E MACHINE OPERAND FORMS ! ----------------------- ! ! Simple Forms ! ------------ ! ! Litval ! corresponding address none (but see note A) ! ! The operand is a literal ! ! Regval& Fregval (also Regaddr & Regvar) ! corresponding address forms:- none (but see note A) ! ! The operand is in a Register - the form Regaddr ! is used when the operand is known to be an ! address but for code generation there is no ! difference. Care must be taken with Regvar ! not to overwrite it except at assignment ! ! Dirval (also Constval,TempVal,Diraddr & Tempaddr) ! corresponding address forms:- AddrDir, AddrConst and AddrDir. ! ! The operand is at a known offset in an E-machine ! area. Constval implies Constant (read only) - ! TempVal implies local stack frame and single use ! so libraries can be taken like increment in situ. ! The forms Diraddr & Tempaddr are used when the ! location is known to contain an address but for ! code generation there are no differences. ! ! ! Indirect Forms ! -------------- ! ! IndDirVal, IndTempVal and IndRegVal ! corresponding address forms:- DirVal, TempVal & Regaddr ! ! There is a pointer to the item in an E-machine and ! (or register). Pointers are 32 bit items. ! ! Modified Forms ! -------------- ! ! IndRegModVal ! Corresponding address form:- RegModAddr ! ! The operand is somewhere in store; its address is ! computed by incrementing the register by a modifier ! - not always a literal. Used for array elements and ! items in mapped records. ! ! Ind DirModVal and IndTempModVal ! corresponding address forms:- DirModAddr and TempModAddr ! ! The operand is anywhere in store; its address is ! computed by loading a base pointer from an E-machine ! area (or temparray) and adding a modifier. Items in ! IMP and Pascal global stack frames are accessed thus; ! in these cases the modifier is a literal. Also dynamic ! arrays are via this mechanism. ! ! AddrDirModVal ! corresponding address form:- AddrDirMod ! ! The operand is part of an array with fixed bounds in ! an E-machine area. The first item (A(O)) is specified ! together with a modifier. The address of the item is ! the address of the base incremented by a modifier - ! optimisations are possible for constant modifiers. ! ! ! NOTES ! ----- ! ! A) Certain forms which do not logically have an address are given one ! by storing the value in a temporary; this is for Fortran but should ! not be part of the E-machine. Fortran should do this at a higher ! level. ! ! B) Where there is hardware assistance for a display it is desirable ! for display items to be distinguished from array access. Here ! IndDispModVal and DispModAddr are used. Logically the same ! as IndDirModVal (etc). ! %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,Msize,Cmval) !* %constinteger Stkmax=48 %ownrecord(Stkfmt)%array Stk(0:stkmax) %ownrecord(Stkfmt) LitZero %ownrecord(Stkfmt) LitOne !* %owninteger Bitarea,Bitdisp,Bitval; ! For C bit initialisations %owninteger Elevel %owninteger ProgFaulty %owninteger ProcProps %owninteger NestedProcs !* %recordformat LabsFmt(%integer LabId, GlaAd) %constinteger MaxLabs = 100 %ownrecord(LabsFmt)%array Labs(1:MaxLabs) ! %recordformat exnamefmt (%integer nameaddr, refaddr, chain) %constinteger MAXEXNAMES = 300 %constinteger HASHPRIME = 211 %constinteger MAXEXNAMESTORE = MAXEXNAMES * 20 %ownrecord(exnamefmt) %array ExNames(1:MAXEXNAMES) %ownintegerarray ExHash(1:HASHPRIME) %ownbyteintegerarray ExNameStore(1:MAXEXNAMESTORE) %owninteger NextName, NextNameStore ! ! %recordformat swfmt(%integer id,sstad,upper,lower,%short sparse,proclevel) %constinteger swmax=40 %ownrecord(swfmt)%array switches(1:swmax) %ownrecord(swfmt)%name Curswitch ! %OWN %INTEGER const ptr,const hole,half hole %CONST %INTEGER const limit=1023 %OWN %INTEGER %ARRAY ctable(0:const limit) !* %conststring(11) stktop="EMAS3TOPSTK" %constinteger Nexpprocs=14 %conststring(9)%array Expprocs(0:Nexpprocs)= %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:Nexpprocs)= {Nparams<<16! Bytes of Params} {Nparams<<16! Bytes of Params} %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:Nexpprocs)={ Resulttype ! (for reals) Resultbytes<<8} %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:Nexpprocs) !* %constinteger Nspprocs=19 %conststring(9)%array Spprocs(0:Nspprocs)= %c "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv" , "f_cddiv" ,"f_cqdiv" ,"f_index" ,"f_concat", "p_stop" ,"P_trap" ,"f_econcat","p_eoft", "p_eof" ,"p_eol" ,"p_lazy" ,"c_Umult", "c_urem" ,"C_udiv", "F_ibits", "F_ishftc"; !* %constintegerarray Spprocpdesc(0:Nspprocs)= %c X'3000C',X'3000C',X'3000C',X'3000C', X'3000C',X'3000C',X'40010',X'40010', 0 ,X'10004',X'40010',X'10004', X'10004',X'10004',X'10004',X'20008', X'20008',X'20008',X'3000C',X'3000C'; !* %constintegerarray Spproctype(0:Nspprocs)={ Resulttype ! (for reals) Resultbytes<<8} %c X'10000',X'10000',X'10000',X'10000', X'10000',X'10000',X'10000',X'10000', 0 ,0 ,X'10000',X'10001', X'10001',X'10001',X'10001',X'10001', X'10001',X'10001',X'10001',X'10001'; !* %ownintegerarray Spprocref(0:Nspprocs) !* %constbyteintegerarray minelevel(0:511)=0,2(4),1(2),2(3),1,2(11),1,0,2(6),1(7){itwb}, 0(6),1,1,0,2,1,1,0(2){to 50}, 2(4),3,3,3,2,0(3),3(6){to 67}, 0(12){unused}, 2(14),1(6),2{to 100}, 2(5),0(2),2(4),0{to 112}, 2(4),1(2),0(12),2(11),1(2){to 143}, 2(6),2(6),1(7),0(2){to 164}, 0(12),1,0(6),2(2),{ to 185} 1(2),0(2),1(4),3,3,2,1,0,1,1,0,3,1,0,2{to 205}, 0(50) {to 255}, 0,4(4),3(4),0 {t05 265}, 1,1,2(6),2(4),2,3 {to279}, 2,1,4(3),5,3,4,2,3,2(4) {to 293}, 1,2,2,0,2,0(3) {to 301}, 2,2,1,3,1,0,0(15) {to 322}, 0(189); %owninteger Unasslab,Bounderr,Pastraplab,parmbits1 !* !* !*********************************************************************** !* 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,7,10,12 {GT LT EQ NE GE LE} %constbyteintegerarray Invcc(0:15)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15 !* %constinteger Stack Offset=64 %constinteger Param Offset=64 %ownintegerarray Display Offset(0:31) %owninteger Gla Offset !* %constinteger bytesofic=72 %constintegerarray Cnstinit(0:(bytesofic-1)>>2)= 0,0, X'4E000000', X'80000000', X'4E000001', X'00000000', X'4F000000', X'08000000', X'80808080', X'80808080', X'40800000', X'00000000', X'00000001', X'0000001F', x'48800000', X'00000000', X'4E000000', X'00000000' %constinteger TWO31 = 8 %constinteger TWO32 = 16 %constinteger TWO31R= 24 %constinteger RHALF = 40 %constinteger ONE=48,THIRTYONE=52 %constinteger maxiasr=56,zerononstd=64 !*********************************************************************** !* Register tracking variables * !*********************************************************************** !* %constinteger permlocked=-2 %constinteger locked=-1 %constinteger free=0 %constinteger claimed=1 ! %constinteger fourkmult=1 %constinteger Mainareabase=2 %constinteger subareabase=3 %constinteger codebase=4 ! %recordformat RuseFmt(%shortinteger Cl,Elevel,use,cnt,%integer inf) %constinteger maxreg=19 %owninteger SSTOffset %ownintegerarray Areabase(0:255) %ownintegerarray Areaprops(0:255) %ownrecord(ruseFmt) %array Ruse(0:Maxreg) !* %owninteger Addrstackca, Addrglaca %owninteger Upperlineno,Currlineno %owninteger Lastreg, Lastbreg, Lastfreg, Max4k %owninteger CC, CCset, Store pending, Oflowmask=8 %owninteger Glaf77regs,Glawork,Curdiagca, OuterLNBDisp %owninteger CurCnst %owninteger Numregvars %owninteger Ecdupflag %owninteger Numcsave=0 %ownintegerarray Regvaroffset(0:4) %ownintegerarray Regvarsize(0:4) %ownintegerarray Regvarclass(0:4) %ownintegerarray Regvarval(0:4) %ownintegerarray Regvarload(0:4) %owninteger Next Param Offset %ownintegerarray Save Param Offset(0:16) %owninteger Active Calls %constinteger elabbase=199999 %owninteger Einternallab %ownintegerarray Procmark(1:31) %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 int pair(%record(StkFmt)%name Stk,%integer oddeven,notthis) %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) %integerfnspec multiplybyLIt(%record(stkFmt)%name s,%integer l) %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 UR(%record(StkFmt)%name Stk,%integer Bytes) %routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode) %routinespec convert RU(%record(StkFmt)%name Stk,%integer bytes) %routinespec convert RIR(%record(Stkfmt)%name Stk,%integer mode) %routinespec convert UI(%record(StkFmt)%name Stk,%integer bytes) %integerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) %routinespec Push Param(%record(Stkfmt)%name Stk) %routinespec fixedmove(%integer bytes,b1,d1,b2,d2) %routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index) %routinespec Expcall(%integer Proc,%stringarrayname procs,%integerarrayname proctype,procref,procpdesc) !* %routinespec Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue) !* %routinespec Lockreg(%integer Reg) %routinespec LockFreg(%integer Freg) %routinespec UnLockreg(%integer Reg) %routinespec UnLockfreg(%integer freg) %routinespec forgetuse(%integer Reg) %routinespec forgetfuse(%integer Freg) %routinespec Funlockreg(%integer Reg) %routinespec Funlockfreg(%integer freg) %routinespec setuse(%integer REg,Use,Inf) %routinespec setfuse(%integer Freg,use,Inf) %routinespec Regclaimed(%integer REg,Elevel) %routinespec Fregclaimed(%integer Freg,Elevel) %routinespec Clear Regs %routinespec Dropall %routinespec Freeup Freg(%integer R) %routinespec Freeup Reg(%integer R) %routinespec Freeregs(%integer Mask) %routinespec Reset Reguse(%integer Old,New) %integerfnspec Claimfr(%integer Curreg) %integerfnspec Claimfrpair(%integer Curreg) %integerfnspec Claimr(%integer Curreg) %integerfnspec claimjumpreg(%integer locked) %integerfnspec claimgrpair(%integer notthis) %integerfnspec setlocalbase(%integer locked) %integerfnspec Claimbr %integerfnspec New Temp(%integer Bytes) %routinespec Setint(%integer Val,Size,%integername B2,D2) %integerfnspec Basereg(%integer Area) %integerfnspec SetX2(%integername D2) %integerfnspec fourkdisp(%Integer bigdisp) %routinespec add4k(%integer op,reg,bigdisp) %routinespec Scalereg(%integer reg,scale) %routinespec Range(%integername B,D) %integerfnspec Indbase(%integer Area,Disp) %routinespec Do Rx(%integer Op,Reg,Base,Offset) %routinespec BOunded jump(%record(StkFmt)%name OP,%integer min,max,sstad) %routinespec sparse jump(%record(StkFmt)%name Stk,%integer sstbase,labbase,entries) %routinespec extractmod(%record(stkfmt)%name stk,modify) %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) %ROUTINE %SPEC store const(%INTEGER %NAME d, %INTEGER l,ad) %INTEGER %FN %SPEC long const(%LONG %INTEGER value) %routinespec dumpla(%integer reg,index,base,dis) %INTEGER %FN %SPEC word const(%INTEGER value) %INTEGER %FN %SPEC short const(%INTEGER value) %routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2) %routinespec Set BD(%record(Stkfmt)%name Stk,%integername B,D) %integerfnspec FindExternalName(%string(255) %name Ename) %routinespec SaveExternalName(%string(255) %name Ename, %integer h, ref) !* !*********************************************************************** !* %ownstring(8)%array Areas(0:255)= %c "Stack ","Code ","Gla ","","Shrd ST","Gla ST ","Diags ","Statics", "Ioarea ","ZeroGst","Consts ",""(245) !* %externalstringfnspec itos %alias "S#ITOS" (%integer N) %externalintegermapspec comreg %alias "S#COMREGMAP" (%integer n) %routine Phex(%integer Val) %conststring(1)%array C(0:15)= %c "0","1","2","3","4","5","6","7", "8","9","A","B","C","D","E","F" %integer I %cycle I=28,-4,0 printstring(C((Val>>I)&15)) %repeat %end !* %integerfn Glaspace(%integer bytes) %integer I bytes=((bytes+3)>>2)<<2 I=integer(Addrglaca)+Gla offset integer(addrglaca)=integer(addrglaca)+bytes %result=I %end;! Glaspace !* !* %ROUTINE PRINTUSE !*********************************************************************** !* UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2 * !* BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2 * !* THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY * !* ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE * !*********************************************************************** %CONSTSTRING (3) %ARRAY REGNAMES(0:MAXREG)="GR0","GR1","GR2","GR3", "GR4","GR5","GR6","GR7", "GR8","GR9","GRA","GRB", "GRC","GRD","GRE","GRF", "FR0","FR2","FR4","FR6" %CONSTSTRING (15) %ARRAY USES(0:16)=" NOT KNOWN "," 4K Mult ", " Area Base "," Sub Base ", " NAMEBASE "," LIT CONST ", " TAB CONST "," ADDR OF ", " BASE OF "," LOCAL VAR ", " LOCALTEMP "," 4K MULT ", " 4K FORLAB "," BASE REG ", " 4K FOR EPI"," DV BASE ", " STRWKAREA " %CONSTSTRING (11) %ARRAY STATE(-2:3)= %C "Permlocked "," LOCKED ", " FREE "," E item ", " TEMPORARY "," RT-PARAM " %ROUTINESPEC OUT(%INTEGER USE,INF) %INTEGER I,USE,JJ %RECORD (RuseFmt) %NAME REG newline %CYCLE I=0,1,MAXREG REG==ruse(I) %IF REG_CL<0 %AND 8<=I<=13 %THENCONTINUE %IF REG_CL!REG_USE#0 %OR REG_CNT>0 %START USE=REG_USE PRINTSTRING(REGNAMES(I).STATE(REG_CL)) WRITE(REG_Elevel,2) WRITE(REG_CNT,1) OUT(USE,REG_INF) NEWLINE %FINISH %REPEAT %RETURN %ROUTINE OUT(%INTEGER USE,INF) PRINTSTRING("USE = ".USES(USE)) Phex(INF) %END %END %routine Dump Estack %record(Stkfmt)%name E %integer I,J,K %routine Pform(%integer Form,Reg,Base,Offset) printstring(Eform(Form&31)) %if Form&Regflag#0 %then write(Reg,1) %and %return %if reg#0 %then printstring("(Regref)") %and write(reg,1) %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 Print Use %if Elevel<=0 %then %return 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 %if E_Cmval#0 %then printstring(" Const Mod:") %and write(E_Cmval,2) printstring(" size:") write(E_Size,1) newline I=I-1 %repeat %end;! Dump Estack !* !********************************************************************** !********************************************************************** !** Error reporting ** !********************************************************************** !********************************************************************** !* !* %routine Low Estack(%integer Opcode,Reqlevel) %string(11) opname %if opcode>=768 %then opname=ecopname(opcode) %else %c %if opcode>=512 %then opname =Epasopname(opcode) %else %c %if opcode>=256 %then opname =Ef77opname(opcode) %else %c opname=Eopname(opcode) printstring("******* Estack error ****** Op = ".opname." 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 %alias"E#INITIALISE"(%integer Lang,Aver,Astackca,Aglaca,options) !*********************************************************************** !* called once at the start of compilation to initialise Eput * !*********************************************************************** %integer I,Flags %String(63) Verss ProgFaulty=0 ! Report=options&1; ! options go into gla+19 and can not be used as this frig uses them! Language=Lang %if increports#0 %and Report#0 %thenstart printstring("Einitialise ") %finish Addrstackca=Astackca Addrglaca=Aglaca Upperlineno=-1; Currlineno=-1 Clear Regs Ruse(i)_Cl=Permlocked %for i=8,1,13 CCset=0; Store pending=0 Elevel=0 Bitarea=-1; Bitval=0 OuterLNBDisp = -1 %cycle I=0,1,255 Areabase(I)=0 Areaprops(I)=0 %repeat switches(i)=0 %for i=1,1,swmax curswitch==switches(1) Einternallab=elabbase-2 %for I = 1,1,MaxLabs %cycle Labs(I)_LabId = -1 %repeat %if Language=Fortran %Start Areabase(I)=I<<2+64 %for i=4,1,10 %finish %cycle I=0,1,Nexpprocs Expprocref(I)=0 %repeat %cycle I=0,1,Nspprocs Spprocref(I)=0 %repeat !* parmbits1=comreg(27) Oflowmask=8; ! allow integer oflow, mask rest %if Language=Fortran %start %if comreg(28)&X'80'{Strict}=0 %and Parmbits1&X'200'{Inhibiof}#0 %then Oflowmask=0 ! Fortran does not use Noline so set it Parmbits from options %if Options&16=0 %then Parmbits1=Parmbits1!1<<23 %finish Gla offset=0 %if Language#Imp %then Decode=Parmbits1&X'4000' %if Language=PASCAL %then %STart Gla Offset=48 SSTOffset = 0 Verss="Pascal version ".itos(aver) aver=addr(Verss) report=parmbits1>>14&1; ! the code bit %finish %if Language=CCOMP %start Gla Offset=32 Oflowmask=0 report=parmbits1>>14&1 %finish !* %if Language=FORTRAN %then Flags=3 %else Flags=1 Pinitialise(-1,Flags,Aver) !* Pfix(Gla,4,Code,0);! initialise first six words of gla Pfix(Gla,8,Ust,0) Areabase(ust)=8 Pfix(Gla,12,SST,0) areabase(sst)=12 %if Lang=PASCAL %then Lang=15 {a communication problem} Pd4(Gla,16,(Lang<<24)!Options) Pfix(Gla,20,Diags,0) %if Language=PASCAL %thenstart PFIx(Gla,24,Zgst,0) areabase(Zgst)=24 Pdxref(4,Gla,28,stktop); ! Top of stk word to Gla+28 I=32 %finishelsestart I=Glaspace(16) %finish Glaf77regs=I Pfix(Gla,I,Static,0) Pfix(Gla,I+4,Cnst,0) Glawork=I+8 PD4(Gla,Glawork,X'4E000000'); ! For fast floating transformations !* const ptr=bytesofic>>2 ctable(i)=cnstinit(i) %for i=0,1,const ptr-1 Curcnst=4*(const limit+1) const hole=0; half hole=0 Max4k=0 Active Calls=0 !* LitZero=0; LitZero_Size=4; LitZero_Form=LitVal LitOne=0; LitOne_Size=4; LitOne_Form=LitVal; LitOne_IntVal=1 Proclevel=0 Numregvars=0 Ecdupflag=0 Numcsave=0 pix rx(la,0,0,0,0); ! till bot fixed for labels at offset 0 %if language=Pascal %Start; ! set up pascal traps Einternallab=einternallab-2 Pastraplab=Einternallab unasslab=Pastraplab+1 Plabel(Unasslab) PIX RX(LA,0,0,0,343) PLabel(Pastraplab) I=Exname(0,spprocs(9)) spprocref(9)=i Eprecall(i) pix rx(St,R0,0,R11,64) Ecall2(i,1,1,4) %finish; ! must not return NextName = 1 NextNameStore = addr(ExNameStore(1)) %cycle i = 1,1,HASHPRIME ExHash(i) = 0 %repeat %end;! Einitialise !* %externalroutine Eterminate %alias"E#TERMINATE"(%integer adareasizes) !*********************************************************************** !* called once at the end of compilation by the code generator * !*********************************************************************** %ownintegerarray S(1:10) %integer I,J %if increports#0 %and Report#0 %thenstart printstring("Eterminate ") %finish %if ProgFaulty#0 %then %return J=0 !newline %cycle I=1,1,9 S(I)=integer(Adareasizes+J) !write(s(i),4) J=J+4 %repeat !newline S(2)=S(2)+Gla Offset %if Language=PASCAL %thenstart S(4) = SSTOffset %finish pdbytes(Cnst,0,4*const ptr,addr(ctable(0))) %if curcnst=4*(const limit+1) %then curcnst=4*const ptr; ! no table overflow S(10)=CurCnst %if language#Fortran %Then pminmultiples(max4k) I=Pterminate(addr(S(1)), 0) integer(adareasizes)=S(1) %end;! Eterminate !* %externalroutine Ecommon %alias"E#COMMON"(%integer area,%stringname Name) !*********************************************************************** !* define a common area (in range 11-255) * !*********************************************************************** %integer Prop %if increports#0 %and 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 %alias"E#ENDCOMMON"(%integer area,Length) !*********************************************************************** !* define length of previously defined common * !*********************************************************************** %if increports#0 %and 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 %alias"E#LINESTART"(%integer lineno) !*********************************************************************** !* register start of a line * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4) newline %finish %if ProgFaulty#0 %then %return %if Decode#0 %then Plinedecode %if lineno=Currlineno %then %return Currlineno=lineno Plinestart(Lineno) %if parmbits1&(1<<23)#0 %then %return PIX SI(MVI, lineno&X'FF', R10, 3) %if lineno & X'FF00' # Upperlineno %thenstart PIX SI(MVI, lineno>>8, R10, 2) Upperlineno = lineno & X'FF00' %finish %end;! Elinestart !* %externalroutine Elinedecode %alias"E#LINEDECODE" !*********************************************************************** !* decompile code generated from last Elinedecode or Elinestart * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Elinedecode "); %finish %if ProgFaulty#0 %then %return Plinedecode %end;! Elinedecode !* %externalintegerfn Estkmarker %alias"E#STKMARKER" !*********************************************************************** !* Stacks a literal(<=16bits) whose exact value will be given later * !* via a call of esetmarker. The result is an identifier which is * !* returned when the value is specified. Pmarker supplies the * !* facility * !*********************************************************************** %integer reg,markval %if increports#0 %and Report#0 %thenstart printstring("Estkmarker ") %finish markval=pmarker(4); ! reserve 4 halfwords reg=claimr(0); ! zero wont work psetopd(markval,0,x'580C'!reg<<4) psetopd(markval,2,x'4100'!reg<<4!reg) stackr(reg) %result=markval %end;! Estkmarker !* %externalroutine Esetmarker %alias"E#SETMARKER"(%integer Markerid,New Value) !*********************************************************************** !* Nominate the value of the literal stacked by estkmarker(above) * !*********************************************************************** %integer j %if increports#0 %and Report#0 %thenstart printstring("Esetmarker ");write(Markerid,4) write(New Value,4) newline %finish psetopd(markerid,1,Fourkdisp(Newvalue)); ! Fill the 4k multiple psetopd(markerid,3,newvalue&4095);! file the load address offset %end;! Esetmarker !* %externalintegerfn Eswapmode %alias"E#SWAPMODE" !*********************************************************************** !* turn on internal tracing * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eswapmode ") %finish %result=0 %end;! Eswapmode !* %externalroutine Emonon %alias"E#MOMON" !*********************************************************************** !* turn on internal tracing * !*********************************************************************** Report=1 %end;! Emonon !* %externalroutine Emonoff %alias"E#MONOFF" !*********************************************************************** !* turn off internal tracing * !*********************************************************************** %if increports#0 %and report#0 %then printstring("Emonoff") %and newline Report=0 %end;! Emonoff !* %externalroutine Efaulty %alias"E#FAULTY" !*********************************************************************** !* compilation has a fault - no object file to be generated * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Efaulty "); %finish ProgFaulty=1 Pfaulty %end;! Efaulty !* !* !* !* ********************* !* * Stack operations * !* ********************* !* !* %externalroutine Estklit %alias"E#STKLIT"(%integer Val) !*********************************************************************** !* stacks Val as a 32-bit integer literal * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and Report#0 %thenstart printstring("Estklit ");write(Val,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 Lstk_Form=LitVal Lstk_Intval=Val Lstk_Size=4 %end;! Estklit !* %externalroutine Estkconst %alias"E#STKCONST"(%integer Len,Ad) !*********************************************************************** !* stacks the constant, allocating space for it if necessary * !*********************************************************************** %integer at %if increports#0 %and Report#0 %thenstart printstring("Estkconst ") write(Len,4) space; phex(integer(ad)) %if len>4 %then space %and phex(integer(ad+4)) newline %finish %if ProgFaulty#0 %then %return store const(at,len,ad) estkdir(cnst,at,0 ,len) %end;! Estkconst !* %externalroutine Estkrconst %alias"E#STKRCONST"(%integer Len,Ad) !*********************************************************************** !* stacks the constant, allocating space for it if necessary * !*********************************************************************** %integer at %if increports#0 %and Report#0 %thenstart printstring("EstkRconst ") write(Len,4) %if Len=4 %then Print(real(Ad),8,12) %else Print(longreal(Ad),8,12) newline %finish %if ProgFaulty#0 %then %return store const(at,len,ad) estkdir(cnst,at,0 ,len) %end;! Estkrconst !* %externalroutine Estkdir %alias"E#STKDIR"(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand * !*********************************************************************** %integer i %record(StkFmt)%name Lstk %if increports#0 %and 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 Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical %if Area=0 %then Offset=Offset+Stack Offset %if Area=Gla %then Offset=Offset+Gla Offset %if Elevel=stkmax %then %monitor %and %stop Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 Lstk_Form=DirVal Lstk_Size=Bytes Lstk_Base=Area %if Area=Stack %thenstart %if Numregvars>0 %thenstart %cycle I=1,1,Numregvars %if Regvaroffset(I)=Offset %thenstart Lstk_Form=Regvarclass(I) Offset=0 Lstk_Reg=Regvarval(I) %exit %finish %repeat %finish %finish Lstk_Offset=Offset Lstk_Adid=Adid %end;! Estkdir !* %externalroutine Estkind %alias"E#STKIND"(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and 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=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 LStk==Stk(Elevel) Lstk=0 Lstk_Form=IndDirVal Lstk_Size=Bytes Lstk_Base=Area Lstk_Offset=Offset Lstk_Adid=Adid %end;! Estkind !* %externalroutine Estkglobal %alias"E#STKGLOBAL"(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand local to an enclosing level * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and Report#0 %thenstart printstring("Estk[global/par] ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset = Offset + StackOffset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 %if Level=Proclevel %or Level=0 %thenstart Lstk_Form = DirVal Lstk_Offset = Offset %finishelsestart { Global } Lstk_Form=IndDirModVal Lstk_Modform=LitVal Lstk_Offset=DisplayOffset(proclevel)+(Level*4) Lstk_ModIntVal=Offset %finish Lstk_Size = Bytes Lstk_Base = 0 Lstk_Adid=Adid %end;! Estkglobal !* %externalroutine Estkglobalind %alias"E#STKGLOBALIND"(%integer Level,Offset,Adid,Bytes) %end !* %externalroutine Estkgind %alias"E#STKGIND"(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand local to an enclosing level * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and Report#0 %thenstart printstring("Estk[g/par]ind ");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=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 %if Level=0 %or Level=Proclevel %thenstart Lstk_Form=IndDirVal Lstk_Base = 0 Lstk_Offset=Offset %finishelsestart Lstk_Form = IndRegModVal Lstk_Reg = ClaimBR PIX RX(L,Lstk_Reg,0,R10,DisplayOffset(proclevel)+Level<<2) Lstk_Modform = LitVal Lstk_Modintval = Offset %finish Lstk_Size=Bytes Lstk_Adid=Adid %end;! Estkgind !* %externalroutine Estkpar %alias"E#STKPAR"(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct parameter operand * !*********************************************************************** Estkglobal(level,Offset,Adid,Bytes) %end;! Estkpar !* %externalroutine Estkparind %alias"E#STKPARIND"(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect parameter operand * !*********************************************************************** Estkgind(Level,offset,Adid,bytes) %end;! Estkparind !* %externalroutine Estkresult %alias"E#STKRESULT"(%integer Class,Type,Bytes) !*********************************************************************** !* defines the result stacked by a function call * !* Type = 1 int * !* = 2 real * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and Report#0 %thenstart printstring("Estkresult ") write(Class,4);write(Type,4);write(Bytes,4) newline %finish %if ProgFaulty#0 %then %return %if Type=2 %thenstart;! real Stackfr(0,Bytes) %finishelse %if Type=3 %thenstart Elevel = Elevel + 1 %if Elevel>stkmax %then %monitor %and %stop Stk(Elevel) = 0 Stk(Elevel)_Form = IndRegVal Stk(Elevel)_Reg = R1 regclaimed(R1,Elevel) Stk(Elevel)_Size = Bytes %finishelsestart Stackr(R1) %finish %end;! Estkresult !* %externalroutine Erefer %alias"E#REFER"(%integer Offset,Bytes) !*********************************************************************** !* stacks the address of a direct operand * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Erefer ");write(Offset,1);write(Bytes,6) dump estack 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 %alias"E#PROMOTE"(%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 increports#0 %and Report#0 %thenstart printstring("Epromote ");write(Level,4) newline %finish %if ProgFaulty#0 %then %return %if CCset#0 %then Establish Logical %unless 00 %thenstart %cycle I=1,1,Numregvars %if Regvaroffset(I)=Offset %then %return %repeat %finish %if Numregvars<4 %thenstart I=Numregvars+1 Numregvars=I Regvaroffset(I)=Offset Regvarsize(I)=Size Regvarclass(I)=RegVar Regvarval(I)=8-I Regvarload(I)=Loadit %if Loadit#0 %thenstart Numregvars=0 {to avoid mapping to reg} Estkdir(Stack,Offset,0,Size) Elevel=Elevel-1 Reg=Load Int(Stk(Elevel+1),Regvarval(I),-1) %finish %finish %end %externalroutine Eloseregs %alias"E#CLOSEREGS"(%integer Level) %integer I,Count %if Report#0 %thenstart printstring("Eloseregs");write(Level,4);newline %finish Count=Numregvars Numregvars=0 %if Count>0 %thenstart %cycle I=1,1,Count %if Regvarload(I)#0 %thenstart Estkdir(Stack,Regvaroffset(I),0,Regvarsize(I)) Elevel=Elevel-1 Op RX(ST,Regvarval(I),Stk(Elevel+1)) %finishelse Numregvars=I %repeat %finish %end;! Eloseregs %externalroutine Ecjump %alias"E#CJUMP"(%integer Opcode,Labelid) !*********************************************************************** !* special for C - condition code set * !* pds Believes that no special is needed. Generator can * !* remember if CC is set. Needed pro tem tho * !*********************************************************************** CCset=1 Ejump(Opcode,Labelid) %end;! Ecjump %externalroutine Epsave %alias"E#PSAVE"(%integername Base) !*********************************************************************** !* Saves the base address held in (Etos) * !*********************************************************************** %integer I %record(Stkfmt) S %if increports#0 %and Report#0 %thenstart printstring("Epsave ") %finish %if ProgFaulty#0 %then Base=0 %and %return %if Elevel<1 %then Abortm("Epsave") S=0 I=base; %if i<=0 %then abort S_Form=DirVal S_Base=stack S_Offset=I+paramoffset S_Size=4 ! Push Operand(Stk(Elevel)) Push Operand(S) Eop(Estore) Base=I %end;! Epsave !* %externalroutine Eprestore %alias"E#PRESTORE"(%integer Base) !*********************************************************************** !* Restores the saved base address into (Etos) * !*********************************************************************** %record(Stkfmt) S %if increports#0 %and Report#0 %thenstart printstring("Eprestore "); write(Base,1); newline dump estack %finish %if ProgFaulty#0 %then %return %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then EstablishLogical S=0 S_Form=DirAddr S_Base=stack S_Offset=Base+paramoffset S_Size=4 Push Operand(S) %end;! Eprestore !* %externalroutine Epdiscard %alias"E#PDISCARD"(%integer Base) {dummy to satisfy pascal reference} %end;! Epdiscard !* %externalroutine Evsave %alias"E#VSAVE"(%integername Base) !*********************************************************************** !* Saves the value held in (Etos) * !*********************************************************************** %integer I, Reg %record(Stkfmt) S %if increports#0 %and Report#0 %thenstart Printstring("Evsave ") %finish %if ProgFaulty#0 %then Base=0 %and %return %if Elevel<1 %then Abortm("Evsave") Reg = LoadInt(Stk(Elevel),-1,0) Stk(Elevel) = 0 Stk(Elevel)_Form = RegVal Stk(Elevel)_Reg = Reg Stk(Elevel)_Size = 4 S=0 I=New Temp(4) S_Form=DirVal S_Base=Stack S_Offset=I S_Size=4 Push Operand(Stk(Elevel)) Push Operand(S) Eop(Estore) Base=I %end;! Evsave !* %externalroutine Evrestore %alias"E#VRESTORE"(%integer Base) !*********************************************************************** !* Pushes the saved value as (Etos) * !*********************************************************************** %record(Stkfmt) S %if increports#0 %and Report#0 %thenstart printstring("Evrestore "); write(Base,1); newline %finish %if ProgFaulty#0 %then %return %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical S=0 S_Form=DirVal S_Base=Stack S_Offset=Base S_Size=4 Push Operand(S) %end;! Evrestore !* %externalroutine Evdiscard %alias"E#VDISCARD"(%integer Temp) {dummy to satisfy pascal reference} %end;! Evdiscard !* !* !* !* ********************* !* * Labels, Jumps * !* ********************* !* !* %externalroutine Elabel %alias"E#LABEL"(%integer Id) !*********************************************************************** !* register a label * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Elabel ");write(Id,4) newline %finish %if ProgFaulty#0 %then %return %if Elevel>0 %and Fortran#Language#CCOMP %then Abort Upperlineno = -1; Currlineno=-1 Dropall Plabel(id) %end;! Elabel !* %externalroutine Eplabel %alias"E#PLABEL"(%integer Id) !*********************************************************************** !* register a private label * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eplabel ");write(Id,4) newline %finish %if ProgFaulty#0 %then %return !? Dropall Plabel(id) %end;! Eplabel !* %externalroutine Ediscardlabel %alias"E#DISCARDLABEL"(%integer Id) !*********************************************************************** !* advise that a label can now be discarded - i.e. no future ref * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Ediscardlabel ");write(Id,4) newline %finish %end;! Ediscardlabel !* %externalroutine Euchecklab %alias"E#UCHECKLAB"(%integer Labid) Unasslab=Labid %end !* %externalroutine Eboundlab %alias"E#BOUNDLAB"(%integer Labid) Bounderr=Labid %end;! Eboundlab !* %externalroutine Ejump %alias"E#JUMP"(%integer Opcode, Labelid) !*********************************************************************** !* generate specified conditional or unconditional jump * !*********************************************************************** %switch Op(0:164) %integer Reg1,Freg1,XAop,Bytes,Form,B,D,Rjump %if increports#0 %and Report#0 %thenstart printstring("Ejump ".Eopname(Opcode));write(Labelid,4) newline %finish %if ProgFaulty#0 %then %return %if opcode=cjfalse %then opcode=jfalse ->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 ->jump !* Op(JUGT): Op(JULT): Op(JUEQ): Op(JUNE): Op(JUGE): Op(JULE): CC = Setcc(Opcode-JUGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(UGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2)) CCset = 0 ->jump !* 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) cc=Setcc(Opcode-JINTGZ) ->jump !* Op(JUGTZ): Op(JULTZ): Op(JUEQZ): Op(JUNEZ): Op(JUGEZ): Op(JULEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) CC=Setcc(Opcode-JUGTZ) ->jump !* Op(JUMP): CC=15 jump: Rjump=claimjumpreg(-1) Pjump(BC,Labelid,CC,Rjump) %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 ->jump !* 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) CC=Setcc(Opcode-JRGZ) ->jump !* Op(JTRUE): Op(JFALSE): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Form=Stk(Elevel+1)_form&31 %if language=Pascal %and (form=dirval %or form=tempval) %c %and Stk(elevel+1)_Offset<4095 %Start SetBD(Stk(elevel+1),B,D) pix si(CLI,0,B,D+Stk(elevel+1)_size-1) %else Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) %finish CC=7 %finish %else CCset=0 %If OPcode=JFALSE %then CC=CC!!15; ->jump %end;! Ejump !* %externalroutine Etwjump %alias"E#TWJUMP"(%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,Rjump %if increports#0 %and 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 Rjump=claimjumpreg(-1) %if Lab1>0 %then Pjump(BC,Lab1,4,Rjump);! if < 0 %if Lab2>0 %then Pjump(BC,Lab2,8,Rjump);! = 0 %if Lab3>0 %then Pjump(BC,Lab3,2,Rjump);! > 0 Forgetuse(Rjump) %end;! Etwjump !* %routine locate switch(%integer switchid) !*********************************************************************** !* Locates a switch and maps the global record Curswitch * !*********************************************************************** %integer i %for i=1,1,swmax %cycle %if switches(i)_id=switchid %then curswitch==switches(i) %and %return %repeat abortm("Can not locate switch defn") %end %externalroutine Esparse switch %alias"E#SPARSESWITCH"(%integer lower,upper,entries,switchid,errlabid,%integername SSTad) !*********************************************************************** !* Set up table entry for a sparse switch (ie list of jumps) * !*********************************************************************** %integer ad Ad=SSTad SSTad=SSTad+4*entries; ! space for list of consts locate switch(0) Einternallab=Einternallab-entries Curswitch_SSTad=ad Curswitch_id=Switchid Curswitch_Sparse=Entries Curswitch_Proclevel=Proclevel Curswitch_Lower=Einternallab; ! lowest label for First item etc Curswitch_Upper=0 %end %externalroutine Eswitch %alias"E#SWITCH"(%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 increports#0 %and Report#0 %thenstart printstring("Eswitch ") write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4) newline %finish %if ProgFaulty#0 %then %return %if Language=Ccomp %and ((lengtheni(upper)-lengtheni(lower) %c )//10)>Errlabid{entries for C} %then %c Esparse switch(lower,upper,Errlabid,switchid,0,SSTad) %and %return Ad=SSTad SSTad=SSTad+(Upper-Lower+1)<<2 Pswitch(Ad,Lower,Upper,4) ! ! Fortran has only 1 switch (computed goto) active at once so delete the ! previous one here to avoid searching time and possible table overflow ! %if language=Fortran %then curswitch=0 locate switch(0); ! an empty entry curswitch_sstad=ad curswitch_id=switchid curswitch_lower=lower curswitch_upper=upper curswitch_Sparse=0 curswitch_Proclevel=proclevel %end;! Eswitch !* %externalroutine EswitchJump %alias"E#SWITCHJUMP"(%integer Switchid) !*********************************************************************** !* jump to Switchid( (Etos) ) * !* if (Etos) is outside the bounds defined for Switchid then error * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("EswitchJump ");write(switchid,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) %if CCSet#0 %then Establish Logical %if elevel<1 %then low estack(jump,1) %and %return elevel=elevel-1 %if curswitch_sparse#0 %then sparse jump(Stk(Elevel+1),curswitch_SSTad, curswitch_lower,curswitch_sparse) %else %c bounded jump(Stk(elevel+1),1,0,curswitch_SSTad-4*curswitch_lower{zero address in unbounded mode}) %end;! EswitchJump !* %externalroutine EfswitchJump %alias"E#FSWITCHJUMP"(%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 * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("EfswitchJump ");write(switchid,4) newline %finish %if ProgFaulty#0 %then %return %If curswitch_id#switchid %then locate switch(switchid) %if CCSet#0 %then Establish Logical %if Elevel<1 %then Low Estack(JUMP,1) %and %return Elevel=Elevel-1 %if curswitch_sparse#0 %then sparse jump(Stk(Elevel+1),curswitch_SSTad, curswitch_lower,curswitch_sparse) %else %c bounded jump(Stk(elevel+1),curswitch_lower,curswitch_upper,curswitch_SSTad) %if Language=CComp %then Ejump(Jump,switchid) %else %c {Orrible C Frig} eswitchdef(switchid); ! ensurre element 0 is set to here(saves a specific test) %end;! EfswitchJump !* %externalroutine Eswitchentry %alias"E#SWITCHENTRY"(%integer Switchid, Entry) !*********************************************************************** !* define the current code address as Switchid(Entry) * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eswitchentry ");write(Switchid,4);write(Entry,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) %if Curswitch_sparse#0 %start PD4(SST,curswitch_SSTad+4*Curswitch_upper,entry) Plabel(Curswitch_Lower+Curswitch_Upper) curswitch_upper=curswitch_upper+1 %finish %else Pslabel(curswitch_sstad,entry) drop all %end;!Eswitchentry !* %externalroutine Eswitchdef %alias"E#SWITCHDEF"(%integer Switchid) !*********************************************************************** !* define the current code address as Switchid(*) - the default * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eswitchdef ");write(Switchid,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) %if curswitch_sparse#0 %then %return Einternallab=Einternallab-1 plabel(Einternallab) psdefault(curswitch_sstad,Einternallab) drop all %end;!Eswitchdef !* %externalroutine EswitchLabel %alias"E#SWITCHLABEL"(%integer Switchid, Entry, Labelid) !*********************************************************************** !* define Labelid as Switchid(Entry) * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("EswitchLabel ");write(switchid,4);write(entry,4) write(labelid,4) newline %finish %if ProgFaulty#0 %then %return %If curswitch_id#switchid %then locate switch(switchid) Pswitchval(curswitch_sstad,Entry,Labelid) Upperlineno=-1; Currlineno=-1 %end;! EswitchLabel !* %externalroutine EcaseJump %alias"E#CASEJUMP"(%integer MinLab, MaxLab, ErrLab, WFlag, CaseId) !************************************************************************ !* Plant a case jump-table for the case-statement ideintified by CaseId * !************************************************************************ %integer Ad %if increports#0 %and Report#0 %thenstart printstring("EcaseJump") write(MinLab,4); write(MaxLab,4); write(ErrLab,4); write(WFlag,4); write(CaseId,4); newline %finish %if ProgFaulty#0 %then %return Ad=SSTOffset SSTOffset=SSTOffset+(MaxLab-MinLab+1)<<2 Pswitch(Ad,0,MaxLab-MinLab,4) LOcate switch(0); ! find empty slot curswitch_Id = CaseId curswitch_Sparse=0 curswitch_SSTAd = Ad curswitch_proclevel=proclevel %if Elevel<1 %then Low Estack(JUMP,1) %and %return bounded jump(Stk(Elevel),minlab,maxlab,ad) Elevel=Elevel-1 %end;! EcaseJump !* %externalroutine EcaseEntry %alias"E#CASEENTRY"(%integer Entry, LabelId, CaseId) !************************************************************************ !* Enter the code-address of the case-label defined by LabelId into the * !* case-table entry defined by Entry. Entry is measured relative to the * !* start of the case-table and is >= 0. * !************************************************************************ %if increports#0 %and Report#0 %thenstart printstring("EcaseEntry") write(Entry,4); write(LabelId,4); write(CaseId,4); newline %finish %if ProgFaulty#0 %then %return Locate switch(Caseid) PSwitchVal(curswitch_SSTAd,Entry,LabelId) Drop all %end;! EcaseEntry !* %externalroutine EcaseEnd %alias"E#CASEEND"(%integer ErrLab, CaseId) !************************************************************************ !* Fill blank entries in the case-table denoted by CaseId with the * !* address of the error-label ErrLab. * !************************************************************************ %if increports#0 %and Report#0 %thenstart printstring("EcaseEnd") write(ErrLab,4); write(CaseId,4); newline %finish %if ProgFaulty#0 %then %return PSDefault(curswitch_SSTAd,ErrLab) Drop all Curswitch=0; ! Finished with %end;! EcaseEnd !* %externalroutine EnewLab %alias"E#NEWLAB"(%integer Labid, Offset) !************************************************************************ !* Declare a new statement label Labid at Offset within the stack-frame.* !************************************************************************ %integer I %if increports#0 %and Report#0 %thenstart printstring("EnewLab"); write(Labid,4); write(Offset,4) newline %finish %if NestedProcs=0 %thenstart %if Proclevel=1 %thenstart %if OuterLNBDisp=-1 %then OuterLNBDisp=GlaSpace(4) PIX RX(ST,R10,0,R13,OuterLNBDisp) %finish PIX RX(ST,R11,0,R10,DisplayOffset(proclevel)+4) NestedProcs=1 %finish %for I = 1,1,MaxLabs %cycle %if Labs(I)_LabId=-1 %then -> Found %repeat AbortM("Too many labels") Found: Labs(I)_LabId = LabId Labs(I)_GlaAd = Offset+Gla offset %end;! EnewLab !* %externalroutine Egjump %alias"E#GJUMP"(%integer Level, Offset) !************************************************************************ !* Jump to a label in a global stack-frame. The label address is held * !* at Offset within the stack-frame for the given textual Level. * !************************************************************************ %integer Reg %if increports#0 %and Report#0 %thenstart printstring("Egjump"); write(Level,4); write(Offset,4) newline %finish %if ProgFaulty#0 %then %return %if Level=1 %thenstart { Outermost level } %if OuterLNBDisp=-1 %then OuterLNBDisp = GlaSpace(4) PIX RX(L,R10,0,R13,OuterLNBDisp) { Loads LNB from Gla } %finishelsestart { Inner level } PIX RX(L,R10,0,R10,Display Offset(proclevel)+Level<<2) { Loads LNB } %finish PIX RX(L,R15,0,R13,Offset+GLaOffset) { Loads PC from GLa} PIX RR(BCR,15,R15) %end;! Egjump !* %externalroutine EstmtLabel %alias"E#STMTLABEL"(%integer Labid,Offset) !************************************************************************ !* Define a statement-label. * !************************************************************************ %integer I %if increports#0 %and Report#0 %thenstart printstring("Estmtlabel"); write(Labid,4); write(Offset,4) newline %finish %if ProgFaulty#0 %then %return %if NestedProcs#0 %thenstart %for I = 1,1,MaxLabs %cycle %if Labs(I)_LabId=LabId %then -> Found %repeat AbortM("Label not found") Found: PFix(Gla,Labs(I)_GlaAd,Code,PMarker(0)) PIX RX(L,R11,0,R10,DisplayOffset(proclevel)+4) %finish ELabel(LabId) %end;! Estmtlabel !* !* !* !* ******************************* !* * Data initialisation, fixups * !* ******************************* !* !* %externalroutine Ed1 %alias"E#D1"(%integer area, Disp, Val) !*********************************************************************** !* intialise an 8-bit location * !*********************************************************************** %if area=0 %then area=1//area %if increports#0 %and Report#0 %thenstart printstring("Ed1 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset %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 %alias"E#D2"(%integer area, Disp, Val) !*********************************************************************** !* intialise a 16-bit location * !*********************************************************************** %if area=0 %then area=1//area %if increports#0 %and Report#0 %thenstart printstring("Ed2 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset %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 %alias"E#D4"(%integer area, Disp, Val) !*********************************************************************** !* intialise a 32-bit location * !*********************************************************************** %if area=0 %then area=1//area %if increports#0 %and Report#0 %thenstart printstring("Ed4 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset %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 Edbits %alias"E#DBITS"(%integer area, Disp, Bitoffset, Numbits, Val) !*********************************************************************** !* intialise a bit field * !*********************************************************************** %integer Mask1,Mask2,I,J %if Report#0 %thenstart printstring("Edbits ".Areas(Area)." +");write(Disp,1) write(Bitoffset,4);write(Numbits,4);write(Val,4) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset I=(32-Bitoffset-Numbits) Mask1=(-1)<<(32-Numbits)>>(32-Numbits) Val=(Val&Mask1)<=len %or i>16 %repeat 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=Gla %then Disp=Disp+Gla Offset %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 %alias"E#DPATTERN"(%integer area, Disp, ncopies, len, ad) !*********************************************************************** !* initialise using a 1,2,4 or 8 byte pattern * !*********************************************************************** %integer I %if increports#0 %and Report#0 %thenstart printstring("Edpattern ") printstring(areas(area)." ");write(disp,1);write(ncopies,8) write(len,8);write(ad,8) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish %until ncopies <=0 %cycle I=Ncopies %if I>x'7FFF' %then I=X'7FFF' Pdpattern(area, Disp, I, len, ad) Ncopies=Ncopies-I Disp=Disp+Len*I %repeat %end;!Edpattern !* %externalroutine Efix %alias"E#FIX"(%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 increports#0 %and 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 %alias"E#XNAME"(%integer type,%string(255)%name Xref) !*********************************************************************** !* generate an external reference, returning an Id for future reference* !*********************************************************************** %integer Refad,I,h %if increports#0 %and Report#0 %thenstart printstring("EXname ".Xref);write(Type&15,4);write(Type>>4,4) newline %finish Refad=FindExternalName(Xref) %if Refad<0 %start h=-Refad Refad=Glaspace(16) %if ProgFaulty#0 %then %result=Refad %if Language=Pascal %or language=Imp %or Language=Ccomp %then PD4(Gla,RefAd+12,-1) type=type!(parmbits1>>20&1); ! or in dynamic bit pro tem I=PXname(Type&1,Xref,Refad) SaveExternalName(Xref,h,Refad) %finish %result=Refad %end;! EXname !* %externalroutine Eprecall %alias"E#PRECALL"(%integer Id) !*********************************************************************** !* called prior to planting parameters to a procedure call * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eprecall "); write(id,4); write(active calls,3) newline %finish %if Progfaulty#0 %then %return %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCset#0 %then Establish Logical Active Calls = Active Calls + 1 %if Active Calls>1 %thenstart Save Param Offset(Active Calls) = Next Param Offset DO RX(LA,R11,R11,Next Param Offset&X'FFFF') %if Next Param Offset&X'FFFF'>64 %finish Next Param Offset=64 %end;! Eprecall !* %externalroutine Ecall2 %alias"E#CALL2"(%integer Id,Extlev,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %integer X2,top,btm %if increports#0 %and Report#0 %thenstart printstring("Ecall2 "); write(Id,4); write(Extlev,4) write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return Freeregs(X'FFC01E'); ! too drastic r5-r7 are preserved PIX RX(LA,R4,0,R10,DisplayOffset(proclevel)) %unless %c (id>0 %or extlev=1 %or (language=pascal %and extlev=2)) %and Next param offset>>24=0{rt param passed} Top=R14 %if store pending#0 %then Top=R0 %and storepending=0 btm=R4 %if language#Fortran %Start; ! Sub bases can be remapped %for X2=5,1,7 %cycle %if Ruse(X2)_Use=Subareabase %then Forgetuse(X2) %repeat %finish %if next param offset>>24=0 %then %start btm=R5 BTM=BTM+1 %while BTM0 %then %Start Pd4(GLA,Id+12,(Numpars<<16)!Paramsize) %if Language#Ccomp;! for loader check %if Id>=4096 %thenstart Add4k(A,13,Id) Id=Id&x'FFF' %finish PIX RS(LM, R12, R14, R13, id) PIX RR(BASR, R15, R14) %finish %else pjump(BAS,Id+elabbase,15,r15) Pusing(R15) setuse(r15,codebase,currlineno) %if Active Calls>1 %thenstart Next Param Offset = Save Param Offset(Active Calls) %if next Param Offset&X'FFFF'>64 %then %c DO RX(SH,R11,R9,short const(Next Param Offset&X'FFFF')) %finish Active Calls = Active Calls - 1 %end;! Ecall2 %externalroutine Ecall %alias"E#CALL"(%integer Id,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %integer X2 %if increports#0 %and Report#0 %thenstart printstring("Ecall "); write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return %if language=fortran %then x2=1 %else x2=99 ecall2(id,x2,numpars,paramsize) %end;! Ecall !* !* %externalroutine Eprocref %alias"E#PROCREF"(%integer Id, Level) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %integer Ad, Rbase, Rwork %if increports#0 %and Report#0 %thenstart printstring("Eprocref ");write(Id,4) newline %finish %if Id>=0 %then Estkaddr(Gla,Id-glaoffset,0,4) %and %return Ad =New temp(16) { Make a copy of the entry descriptor } Rbase=R10 Rwork=claimjumpreg(-1) pjump(LA,Id+elabbase,Rwork,r1) DoRX(st,Rwork,rbase,Ad+8) DoRX(st,R12,rbase,Ad) DoRX(st,R13,rbase,Ad+4) Do RX(ST,R11,Rbase,Ad+12) Estkaddr(Stack,Ad-StackOffset,0,4);! Ad is offset of local copy of entry block Next Param Offset=Next Param Offset!x'01000000'{Note rt param} %end;! Eprocref !* %externalroutine Eprocptr %alias"E#PROCPTR"(%integer Area,Offset,%string(255)%name S) !*********************************************************************** !* establish a pointer to a procedure at Offset in Area * !*********************************************************************** %integer i %if Report#0 %thenstart printstring("Eprocptr ");write(Area,4);write(Offset,4) printstring(" ".S) newline %finish I=Exname(0,s) Efix(Area,Offset,Gla,i-Gla Offset) %end;! Eprocptr %externalroutine Eprocenv %alias"E#PROCENV"(%integer Level) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eprocenv ");write(Level,4) newline %finish {%if Level>1 %thenstart} {Estkdir(0,Display Offset(proclevel)+Level<<2,0,4)} {%finishelse} Estklit(0) { Dummy on Amdahl } %end;! Eprocenv !* %externalroutine Esave %alias"E#SAVE"(%integer Asave, %integername Key) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Esave ");write(Asave,4) newline %finish %end;! Esave !* %externalroutine Erestore %alias"E#RESTORE"(%integer Asave, Key, Existing) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Erestore ");write(Asave,4) newline %finish %end;! Erestore !* !* !* !* ********************************** !* * Procedure definition and entry * !* ********************************** !* !* %externalintegerfn Enextproc %alias"E#NEXTPROC" !*********************************************************************** !* result is an Id to be used for a procedure first encountered as an * !* internal spec * !*********************************************************************** %integer Refad,I %if increports#0 %and Report#0 %thenstart printstring("Enextproc ") %finish Einternallab=Einternallab-1 Refad=Einternallab-elabbase %if increports#0 %and Report#0 %thenstart printstring(" key ="); write(Refad,1) newline %finish %result=Refad %end;! Enextproc !* %externalroutine Eproclevel %alias"E#PROCLEVEL"(%integer Level) !*********************************************************************** !* record static nesting level of the current procedure * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eproclevel ");write(Level,3) newline %finish ProcLevel = Level %end;! Eproclevel !* %externalroutine Eproc %alias"E#PROC"(%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 I,Baser,Dopl %if increports#0 %and Report#0 %thenstart printstring("Eproc ");printstring(Name) write(Numpars,4); write(Paramsize,4); write(Id,4); write(props,4) newline %finish %if ProgFaulty#0 %then %return Drop all %unless Language=PASCAL %then Proclevel=Proclevel+1 Dopl = (ParamOffset + ParamSize + 3) & (\3) %if Language=PASCAL %or language=IMP %thenstart DisplayOffset(proclevel) = Dopl %finish Upperlineno = -1; Currlineno=-1 ProcProps=Props %if Props&2#0 %then Props=X'80000001' %else Props=Props&1 %if Id=-1 %then Einternallab=Einternallab-1 %and Id=Einternallab-elabbase Plabel(Id+elabbase) NestedProcs = 0 %if Numpars>=0 %and Paramsize>=0 %and Procprops&2=0 %then %c i=Numpars<<16!Paramsize %else i=-1 Pproc(Name,Props,I,Id) Curdiagca=-1 %if Language#FORTRAN %thenstart %if Astacklen#-1 %then Addrstackca=Astacklen integer(addrstackca) = (integer(addrstackca)+3)&(\3) PIX RX(ST,R15,0,R11,60) PIX RR(LR,R10,R11) Procmark(proclevel)=PMarker(2) %if parmbits1>>4&1=0 %or (Language=Ccomp %and %c parmbits1&X'410'=X'410'{ZERo,nocheck}) %Start; ! unassigned checking not inhibited %if Language=Pascal %Start;! Perform top of stk check ! Pascal fault 451 if check fails Einternallab=Einternallab-1 Pix RX(L,R1,0,R13,28); ! Pointer to top of stack value Pix RX(C,R11,0,1,0) Pjump(BC,Einternallab,13,1) Pix RR(LR,11,10); ! cut back stack Pix Rx(l,R10,0,r10,40); ! old value Pix RX(LA,0,0,0,451) Pjump(BC,Pastraplab,15,1) Plabel(Einternallab) %finish DO rx(LA,R0,R10,Dopl&X'fff') %if Dopl>=4096 %then Add4k(A,R0,Dopl) ! Must protect R4 if Do rx used here pix rr(LR,R1,R11) pix rr(SR,R1,R0) pix rr(LR,R2,R0) %if parmbits1&X'410'=X'410' %then Pix RR(SLR,R3,R3) %else %Start pix rx(LA,R3,0,0,X'80') pix rs(sll,R3,0,0,24) %finish pix rr(mvcl,r0,r2) %Finish %if (Language=Pascal %or language=IMP) %and ProcProps&4=0 %thenstart { Copy display } %if proclevel=1 %or props&1#0 %or (language=pascal %and proclevel=2)%Start Do RX(ST,R10,R10,Dopl+Proclevel<<2) %unless Procprops&256#0 Do RX(ST,R13,R10,Dopl) %unless %c parmbits1&X'800004'=X'800004' %finish %else %if proclevel>7 %or Dopl>4095 %Start Baser=R10; I=Dopl LOckreg(R4) Range(Baser,I) Unlockreg(R4) pix ss(MVC,0,4*proclevel,Baser,I,R4,0) Do RX(ST,R10,R10,Dopl+Proclevel<<2) %unless Procprops&256#0 %else I=proclevel-1 Baser=R0 %if parmbits1&x'800004'=x'800004' %Then Baser=R0+2 pix rs(LM,Baser,R0+I,R4,4*Baser) pix rr(LR,R0+proclevel,R10) %and I=I+1 %unless Procprops&256#0 pix rs(STM,Baser,R0+I,R10,Dopl+4*Baser) %Finish %finish PIX RS(LM,R8,R9,R13,Glaf77regs) %if proclevel=1 %or props&1#0 { @ statics and const area } %if ProcProps&2#0 %thenstart;! main entry PIX RX(LA,R1,0,0,Oflowmask) %if Oflowmask#0 %then PIX RS(SLL,R1,0,0,24) PIX RR(SPM,R1,0) %finish %finish %else max4k=0; ! Start count again for fortran %end;! Eproc !* %externalroutine Eprocend %alias"E#PROCEND"(%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 * !*********************************************************************** %integer i %if increports#0 %and Report#0 %thenstart printstring("Eprocend ");write(Localsize,6) Write(DiagDisp,6) newline %finish %if ProgFaulty#0 %then %return %if Language#Fortran %thenstart %if language=pascal %and proclevel=1 %then LocalSize = LocalSize+16 ! Pascal does not allow for display at outer level LocalSize = (LocalSize+3)&(\3) %if LocalSize>integer(AddrStackCa) %then localsize = LocalSize + ParamOffset %c %else localsize = integer(AddrStackCa) + ParamOffset localsize=(localsize+15)&(-16) %if localsize<=4095 %Start PSetOpd(ProcMark(proclevel),0,X'41B0') PSetOpd(Procmark(proclevel),1,X'B000'!localsize) %else psetopd(procmark(proclevel),0,x'5ab0') psetopd(procmark(proclevel),1,x'c000'+Fourkdisp(localsize+4096)) %finish %if Astacklen#-1 %then Addrstackca=Astacklen %finish PDrop(R14) DropAll PDrop(R15) upperlineno=-1; Currlineno=-1 FreeRegs(-1) %for I=1,1,SWmax %cycle %if Switches(i)_proclevel=proclevel %then switches(i)=0 %repeat Proclevel=Proclevel-1 PMinMultiples(Max4k) %if language=Fortran Pprocend %end;! Eprocend %externalroutine Eentry %alias"E#ENTRY"(%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 increports#0 %and Report#0 %thenstart printstring("Eentry ".Name);write(Index,4) write(Numpars,4);write(Paramsize,4); write(LocalSize,4) newline %finish %if ProgFaulty#0 %then %return %unless Index=0 %then Pentry(Index,Name);! Amdahl put handles 0 incorrectly Dropall %if Language=Fortran %thenstart PIX RX(ST,R15,0,R11,60) PIX RR(LR,R10,R11) Localsize=Localsize+64 %if Localsize>=4096 %then PIX RX(A,R11,0,R12,fourkdisp(Localsize)) PIX RX(LA,R11,0,R11,Localsize&X'FFF') PIX RS(LM,8,9,R13,Glaf77regs) %if ProcProps&2#0 %thenstart;! main entry PIX RX(LA,R1,0,0,Oflowmask) %if Oflowmask#0 %then PIX RS(SLL,R1,0,0,24) PIX RR(SPM,R1,0) %finish %finish PIX SI(MVI,Diagdisp>>8,R10,0) PIX SI(MVI,(Diagdisp&X'FF'),R10,1) %end;! Eentry !* !* !* !* ********************************* !* * Data definition and reference * !* ********************************* !* !* %externalroutine Edataentry %alias"E#DATAENTRY"(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* defines a data entry Name starting at Offset in Area * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Edataentry ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish %if Area=Gla %then Offset=Offset+Gla offset PDataEntry(Name,Area,(Length+3)&(\3),Offset) %end;! Edataentry !* %externalroutine Edataref %alias"E#DATAREF"(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* requests a data ref to Name (with at least Length)at Offset in Area * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Edataref ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish %if Area=Gla %then Offset=Offset+Gla offset PDXRef((Length+3)&(\3),Area,Offset,Name) %end;! Edataref !* !* !* !* ******************** !* * Ecode operations * !* ******************** !* !* %externalroutine Eop %alias"E#OP"(%integer Opcode) !*********************************************************************** !* opcodes with general applicability * !*********************************************************************** %record(StkFmt)%name Lstk,Estktos,estktosm1 %constintegerarray ChOp(MVB:CPBLE) = MVCL<<16!MVC, 0(2), MVCL<<16!MVC, 0(2), CLCL<<16!CLC(6) %string(11) opname %owninteger depth=0 %integer Reg1,Reg2,Freg1,Freg2,Bytes,B1,D1,B2,D2,XAop,Form,I,J,Pair1,Pair2, Flags,XAop1,Lab,Breg,Adj,Relop %switch F77op(256:320) %switch Op(0:255) %if Opcode>=768 %then ECCop(Opcode) %and %return %if increports#0 %and Report#0 %thenstart %if depth>0 %then printstring("recursive ") %if opcode>=768 %then opname=ecopname(opcode) %else %c %if opcode>=512 %then opname =Epasopname(opcode) %else %c %if opcode>=256 %then opname =Ef77opname(opcode) %else %c opname=Eopname(opcode) printstring("Eop ".opname) newline Dump Estack %finish %if ProgFaulty#0 %then %return %if Store pending#0 %then PIX RX(ST,R0,0,R11,64) %and Store pending=0 %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 j=minelevel(opcode) %if j>0 %and elevel1 %then Estktosm1==stk(Elevel-1) depth=depth+1 %if Opcode>=256 %then ->F77op(Opcode) ->Op(Opcode) !* Op(*):%monitor !* Op(HALT): Op(SFA): Op(ASF): Op(IPUSH): Op(IPOP): Op(TMASK): F77op(IPROCCALL): Unsupported Opcode(Opcode) wayout: depth=depth-1; %return !* Op(IADD): Op(ISUB): Op(IMULT): Op(IDIV): Op(IREM): !* Op(IAND): Op(IOR): Op(IXOR): Op(UADD): Op(USUB): !* Op(IGT): Op(ILT): Op(IEQ): Op(INE): Op(IGE): Op(ILE): Op(UGT): Op(ULT): Op(UEQ): Op(UNE): Op(UGE): Op(ULE): Elevel=Elevel-2 Int Binary Op(Opcode,Estktosm1,Estktos) ->wayout Op(UREM): Op(UDIV): Expcall(16+Opcode-UREM,Spprocs,Spproctype,Spprocref,Spprocpdesc) ->wayout !* Op(INEG): Op(IABS): Op(INOT): Op(BNOT): Elevel=Elevel-1 Int Unary Op(Opcode,Estktos) ->wayout !* !* Op(IADDST): Op(ISUBST): Op(IMULTST): Op(UDIVST): Op(IDIVST): Op(IREMST): Op(UREMST): Op(IANDST): Op(IORST): Op(IXORST): %begin %constbyteintegerarray Regop(IADDST:IREMST)= %c IADD,ISUB,IMULT,IDIV,0,UREM,UDIV, IAND,IOR,0,IXOR,IREM; Epromote(2) Eop(DUPL) Epromote(3) Eop(Regop(Opcode)) Epromote(2) Eop(Estore+Ecdupflag) Ecdupflag=0 %end ->wayout !* Op(INEGST): Op(INOTST): Eop(DUPL); ! NB This upsets the Estktos mappings Elevel=Elevel-1 OPcode=OPcode-(INEGST-INEG) Int Unary Op(Opcode,Stk(Elevel+1)) Epromote(2) Eop(Estore+Ecdupflag) ->wayout !* !* Op(ISHLL): !* Op(ISHRL): !* Op(ISHLA): !* Op(ISHRA): %begin %constbyteintegerarray shop(ishll:ishra)=SLL,SRl,SLA,SRA; %integer rreg,lreg %record(stkfmt) shifted,shifter shifter=Estktos shifted=Estktosm1 elevel=elevel-2 %if shifter_form&31=litval %Start rreg=load int(shifted,-1,-1) pix rs(shop(opcode),rreg,0,0,shifter_intval) %else lreg=load int(shifter,-1,0) rreg=load int(shifted,-1,lreg) pix rx(shop(opcode),rreg,0,lreg,0) %finish stackr(rreg) %end ->wayout !* Op(RETURN): PIX RS(LM,R4,R15,R10,16) PIX RR(BCR,15,R15) ->wayout !* !* Op(EXCH): Epromote(2) ->wayout !* Op(DUPL): Form=Estktos_Form&31 %if Form=IndRegModVal %and Estktos_Modform&31=Regval %Start J=Estktos_Size Address(Estktos) REg1=Load Int(Estktos,-1,-1) Elevel=Elevel-1 Stackr(Reg1) refer(Estktos,J) Form=Estktos_Form&31 %finish %if addrdirmod<=form<=DirmodAddr %Start reg1=loadint(Estktos,-1,-1) elevel=elevel-1 stackr(reg1) %if form=indregmodval %then form=regval %else form=regaddr Estktos_form=form %finish Stk(Elevel+1)=Estktos Elevel=Elevel+1; ! NB This upsets Estktos mappings %if Form=RegVal %or Form=RegAddr %or form=indregval %or Form=IndregModVal %start Reg1=Claimr(Stk(Elevel)_Reg) PIX RR(LR,Reg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Reg1 Regclaimed(Reg1,Elevel) ->dupexit %finish %if stk(elevel)_modform&31=regval %Start reg1=claimr(stk(elevel)_modreg) pix rr(lr,reg1,stk(elevel)_modreg) stk(elevel)_modreg=reg1 Regclaimed(reg1,elevel) ->dupexit %finish %if Form=FregVal %thenstart Freg1=Claimfr(Stk(Elevel)_Reg) %if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR PIX RR(XAop,Freg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Freg1 FRegclaimed(Freg1,Elevel) ->dupexit %finish %if Form=TempVal %then Stk(Elevel)_Form=DirVal %and ->dupexit dupexit: ->wayout !* Op(DISCARD): %if Estktos_Form&31=RegVal %thenstart Unlockreg(Estktos_Reg) %finishelsestart %if Estktos_Form&31=Fregval %then Unlockfreg(Estktos_Reg) %finish Elevel=Elevel-1 ->wayout !* Op(INDEX1): !* Op(INDEX2): !* Op(INDEX4): !* Op(INDEX8): Elevel=Elevel-1; ! NB This upsets the Estktos mappings I=Opcode-INDEX1 NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1)) ->wayout !* Op(INDEX): Elevel=Elevel-2 %if Estktos_Form=LitVal %thenstart I=Estktos_Intval %if I=16 %or I=32 %thenstart I=I>>5+4 ->NoteI %finish %if multiply by LIt(Estktosm1,I)=0 %then Elevel=Elevel-1 %and I=0 %and ->Notei %finish Int Binary Op(IMULT,Estktosm1,Estktos) Elevel=Elevel-1 I=0 ->NoteI !* Op(CHK): Elevel=Elevel-3 Reg1=Load Int(Stk(Elevel+1),-1,-1) Op RX(C,Reg1,Estktosm1) Reg2=claimjumpreg(REg1) Pjump(BC,Bounderr,4,Reg2) Op RX(C,Reg1,Estktos) Pjump(BC,Bounderr,2,Reg2) Stackr(Reg1) ->wayout !* Op(CPBGT): !* Op(CPBLT): !* Op(CPBEQ): !* Op(CPBNE): !* Op(CPBGE): !* Op(CPBLE): CC = SetCC(OpCode-CPBGT) !* Op(MVB): ! move etos bytes between two addresses Op(MVW): ! move etos (4byte) words between two addresses !* %begin %record(stkfmt)%name dest,srce,len %if opcode=MVB %then %Start; ! mvb op wrong way round! srce==stk(elevel-2) dest==Estktosm1 %else srce==Estktosm1 dest==stk(elevel-2) %finish refer(Dest,0) SetBD(Dest,B1,D1) LOckreg(B1) refer(Srce,0) SetBD(srce,B2,D2) Lockreg(b2) len==Estktos Bytes = len_IntVal %if Opcode=MVW %then Bytes=4*Bytes %if len_form&31=litval %and bytes <=256 %Start; ! move by literal use mvc PIX SS(ChOp(OpCode)&255,0,Bytes,B1,D1,B2,D2) %else; ! need execute of mvc or mvcl %if language=imp %Start; ! For any case where lmax<=256 i=Chop(opcode)<<24!b1<<12!D2 j=b2<<28!D2<<16 reg1=load int(len,-1,0); ! not gr0 for EX Lockreg(reg1) estkconst(6,addr(i)); ! target of EX into const table pix rr(bctr,reg1,0) op rx(ex,reg1,stk(elevel)) elevel=elevel-1 Funlockreg(reg1) %else DumpLA(R0,0,B1,D1) unlockreg(b1) %if b2#r2 %and ruse(r2)_CL!Ruse(r2)_Use#0 %then freeup reg(r2) DumpLA(R2,0,B2,D2) unlockreg(b2) %unless r2=b2 %if ruse(r1)_CL!Ruse(r1)_Use#0 %and R1#len_reg %then free up reg(r1) %if ruse(r3)_CL!Ruse(r3)_Use#0 %and R3#len_reg %then free up reg (r3) reg1=load int(len,r1,0) pix rr(lr,r3,r1) pix rr(chop(opcode)>>16,r0,r2) forgetuse(r0) forgetuse(r1) forgetuse(r2) forgetuse(r3) %Finish %finish Elevel = Elevel - 3 unlockreg(B1) unlockreg(b2) CCSet = 1 %unless opcode=MVB %or Opcode=MVW %end ->wayout !* Op(RADD): Op(RSUB): Op(RMULT): Op(RDIV): !* Op(RGT): Op(RLT): Op(REQ): Op(RNE): Op(RGE): Op(RLE): Elevel=Elevel-2 Real Binary Op(Opcode,Estktosm1,Estktos) ->wayout !* Op(RNEG): Op(RABS): Elevel=Elevel-1 Real Unary Op(Opcode,Estktos) ->wayout !* Op(CVTSBI): ! Signed byte to integer Elevel=Elevel-2 Bytes=Estktos_Intval %if Estktosm1_Size=1 %Start %if Estktosm1_Form&31=regval %start Reg1=Estktosm1_Reg Pix rs(SLL,Reg1,0,0,24) %else Set BD(Estktosm1,B1,D1) Reg1=claimr(-1) Pix RS(ICM,Reg1,8,B1,D1) %finish Pix RS(SRA,Reg1,0,0,24) Stackr(Reg1) %Finish %else Elevel=Elevel+1 ->wayout Op(CVTUI): Elevel=Elevel-2 Convert UI(Estktosm1,Estktos_Intval) ->wayout Op(CVTIU): Bytes=Estktos_Intval Elevel=Elevel-1 %if BytesWayout %finish %if Bytes#Estktosm1_Size %Start Reg1=LOadint(Estktosm1,0,0) Elevel=Elevel-1 Stackr(Reg1) Stk(Elevel)_Size=Bytes %finish ->wayout Op(UCVTII): Elevel=Elevel-2 Convert II(Estktosm1,Estktos_Intval) ->wayout !* Op(CVTII): Elevel=Elevel-2 Bytes=Estktos_Intval %if Bytes#Estktosm1_size %Start Convert II(Estktosm1,Bytes) Stk(Elevel)_Size=Bytes %finish %else Elevel=Elevel+1 ->wayout !* Op(CVTRR): Elevel=Elevel-2 Convert RR(Estktosm1,Estktos_Intval) ->wayout !* Op(TNCRI): Op(RNDRI): Op(EFLOOR): Elevel=Elevel-2 Convert RI(Estktosm1,Estktos_Intval,Opcode-TNCRI) ->wayout !* Op(CVTIR): Elevel=Elevel-2 Convert IR(Estktosm1,Estktos_Intval) ->wayout Op(CVTUR): Elevel=Elevel-2 Convert UR(Estktosm1,Estktos_Intval) ->wayout !* Op(TNCRR): Op(RNDRR): Elevel=Elevel-1 Convert RIR(Estktos,Opcode-TNCRR) ->wayout Op(CVTRU): Elevel=Elevel-2 Convert RU(Estktosm1,Estktos_Intval) ->wayout Op(UCHECK): %if Estktos_Form=DirVal %thenstart Set BD(Estktos,B1,D1) %finishelsestart Reg1=Claimr(-1) Bytes=Estktos_Size Address(Estktos) Op RX(L,Reg1,Estktos) Estktos_Form=IndRegVal!Regflag Estktos_Reg=Reg1 Estktos_Size=Bytes Estktos_Cmval=0 Regclaimed(Reg1,Elevel) B1=Reg1 D1=0 %finish PIX SS(CLC,0,Estktos_Size,B1,D1,R9,32) Pjump(BC,Unasslab,8,Claimjumpreg(B1)) ->wayout !* Op(ESTORE): Elevel=Elevel-2 Reg1=Storeop(Estktos,Estktosm1,0) ->wayout !* Op(EDUPSTORE): Elevel=Elevel-2 Reg1=Storeop(Estktos,Estktosm1,1) Stackr(Reg1) ->wayout !* Op(PUSHADDR): Address(stk(Elevel)) Op(PUSHVAL): Elevel=Elevel-1 Push Param(Stk(Elevel+1)) ->wayout !* Op(EVAL): Op(EVALADDR): Lstk==Stk(Elevel) Elevel=Elevel-1 %if Opcode=Eval %and (Lstk_size>4 %or Lstk_Form&31=Fregval) %Start Reg1=Load Real(Lstk,-1,-1,Bytes) Stackfr(Reg1,Bytes) %else REg1=LOad Int(Lstk,-1,-1) Stackr(Reg1) %finish ->wayout !* Op(EADDRESS): Address(Stk(Elevel)) Stk(Elevel)_Size=4 ->wayout !* Op(EPOWER): !* Op(EPOWERI): %if Stk(Elevel)_Form#Litval %then Abort Elevel=Elevel-1 Expcall(Stk(Elevel+1)_Intval,Expprocs,Expproctype,Expprocref,Expprocpdesc) ->wayout !* Op(EINTRES): Elevel=Elevel-1 %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Reg1=Load Int(Stk(Elevel+1),R1,-1) ->wayout !* Op(EREALRES): Elevel=Elevel-1 Reg1=Load Real(Stk(Elevel+1),R0,-1,Bytes) ->wayout !* Op(ESIZE): Elevel=Elevel-1 Stk(Elevel)_Size=Stk(Elevel+1)_Intval ->wayout !* Op(Argproc): Elevel=Elevel-1 %if language=pascal %then elevel=elevel-1;! Pascal apparently has xtra parm Free regs({X'FFC01E'}-1) Op RX(L,R1,Stk(Elevel)) ELevel = ELevel - 1 pix rx(la,R4,0,R10,Displayoffset(proclevel));! argproc may pass a proc PIX RS(STM,R4,R14,R11,16) PIX RS(LM,R12,R15,R1,0) PIX RR(LR,R2,R14) PIX RS(LM,R4,R10,R15,16); ! reset (possible IMP) environment PIX RX(L,R14,0,R15,56); ! reset (possible IMP) const PIX RR(BASR,R15,R2); ! and enter parametric proc %if active calls>1 %Start next param offset=save param offset(active calls) %if Next Param Offset&X'FFFF'>64 %Start pix rx(la,0,0,0,Next param offset&X'FFFF') pix rr(sr,r11,r0) %finish %finish active calls=active calls-1 setuse(r15,codebase,currlineno) ->wayout !* op(pushbytes): bytes=stk(elevel)_intval abort %unless stk(elevel)_form=litval reg1=loadint(stk(elevel-1),-1,0) fixedmove(bytes,r11,next param offset&X'FFFF',reg1,0) next param offset=next param offset+(bytes+3)&(-4) elevel=elevel-2 ->wayout Op(EAUXSF): reg1=claimr(-1) pix rr(lr,reg1,r11) stackr(reg1) ->wayout ! Op(EAUXADD): elevel=elevel-1 %if stk(elevel+1)_form&31=litval %and stk(elevel+1)_intval<4095 %c %then pix rx(la,r11,0,r11,stk(elevel+1)_intval) %and ->wayout reg1=loadint(stk(elevel+1),-1,-1) pix rr(ar,r11,reg1) ->wayout ! Op(EAUXRES): elevel=elevel-1 reg1=loadint(stk(elevel+1),r11,-1) ->wayout Op(EZERO): ! As Efill but zero implied Estklit(0); ! and drop through Op(EFILL): b1=stk(elevel)_intval bytes=stk(elevel-1)_intval abort %unless stk(elevel)_form=litval %and stk(elevel-1)_form=litval %c %and b1<=255 elevel=elevel-3 %if bytes <=512 %Start reg1=load int(stk(elevel+1),-1,0) pix si(MVI,b1,reg1,0) j=0 %if bytes>256 %then %start pix ss(mvc,0,256,reg1,1,reg1,0) j=256; bytes=bytes-256 %finish pix ss(mvc,0,bytes-1,reg1,j+1,reg1,j) %else ;! MVCL neede Pair1=Load Int Pair(Stk(Elevel+1),0,-1);! Even member pair2=Claim GR Pair(Pair1); ! A different Pair Dumpla(pair1+1,0,0,Bytes) Dumpla(pair2+1,0,0,B1) Pix RS(SLL,Pair2+1,0,0,24) %unless B1=0 Pix RR(LR,Pair2,Pair1) Pix RR(MVCL,Pair1,Pair2) Forgetuse(Pair1) Forgetuse(Pair1+1) Forgetuse(Pair2) Forgetuse(Pair2+1) %finish ->wayout Op(Eoldlnb): ! Stack previous LNB Reg1=claimr(-1) Forgetuse(Reg1) Do RX(L,Reg1,R10,40) Stackr(reg1) ->wayout Op(Ecdup): ! 'Orrible Frig till C improves Ecdupflag=1 ->wayout ! ! the Following section of code is for Fortran only. All the OPs are here unless ! They are not supported in this implementation ! F77op(*):Abort !* F77op(CXADD): F77op(CXSUB): F77op(CXMULT): F77op(CXDIV): 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)) ->wayout !* F77op(CXNEG): F77op(CXASGN): F77op(CXEQ): F77op(CXNE): Elevel=Elevel-3 Opcode=Opcode&X'FF' Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(EM1EXP): Elevel=Elevel-1 Reg2=Load Int(Stk(Elevel+1),-1,-1) OpRX(N,Reg2,Litone) Pix RR(ALR,Reg2,Reg2) Pix RR(BCTR,Reg2,0) Pix RR(LCR,Reg2,Reg2) Stackr(Reg2) ->wayout F77op(EINCR): Eop(IADDST) ->wayout !* F77op(EDECR): Eop(ISUBST) ->wayout !* F77op(EISIGN): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Breg=setlocalbase(reg1) PIX RR(LPR,Reg1,Reg1) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) Lab=Einternallab-1 Einternallab=Lab PIX RR(LTR,Reg2,Reg2) Pjump(bc,Lab,10,claimjumpreg(reg1)) PIX RR(LNR,Reg1,Reg1) PLabel(lab) Stackr(Reg1) ->wayout !* F77op(ESIGN): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) Breg=setlocalbase(reg1) %if Bytes=4 %then Adj=LER-LDR %else adj=0 PIX RR(LPDR+Adj,Reg1,Reg1) Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) Lab=Einternallab-1 Einternallab=Lab PIX RR(LTDR+Adj,Reg2,Reg2) Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(LNDR+Adj,Reg1,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMOD): Elevel=Elevel-2 %if Ruse(R15)_cl#0 %or Ruse(r15)_Use#0 %then Freeup Reg(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) ->wayout !* F77op(ERMOD): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) D1=Newtemp(bytes) DO RX(STD+Adj,Reg2,R10,d1);! STE PIX RR(LDR+Adj,Reg2,Reg1);! LER DO RX(DD+Adj,Reg2,R10,d1);! 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) DO RX(MD+Adj,Reg2,R10,d1);! ME PIX RR(SDr+Adj,Reg1,Reg2);! SER Stackfr(Reg1,Bytes) ->wayout !* F77op(EIDIM): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) OpRX(S,Reg1,Stk(Elevel+2)) Breg=setlocalbase(reg1) PIX RR(LTR,Reg1,Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(SR,Reg1,Reg1) PLabel(lab) Stackr(Reg1) ->wayout !* F77op(ERDIM): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 OpRX(SD+Adj,Reg1,Stk(Elevel+2)) Breg=setlocalbase(reg1) PIX RR(LTDR+Adj,Reg1,Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(SDR+Adj,Reg1,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMIN): Relop=12 Iminmax: Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Breg=setlocalbase(reg1) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) PIX RR(CR,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,relop,claimjumpreg(reg1)) PIX RR(LR,Reg1,Reg2) Plabel(lab) Stackr(Reg1) ->wayout !* F77op(ERMIN): Relop=12 Rminmax: Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 Breg=setlocalbase(reg1) Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) PIX RR(CDR+Adj,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,relop,claimjumpreg(reg1)) PIX RR(LDR+Adj,Reg1,Reg2) Plabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMAX): Relop=10 ->Iminmax !* F77op(ERMAX): Relop=10 ->Rminmax !* F77op(EDMULT): Elevel=Elevel-2 Real Binary Op(RMULT,Stk(Elevel+1),Stk(Elevel+2)) Stk(Elevel)_Size=8 ->wayout !* F77op(ECONJG): Elevel=Elevel-3 Opcode=9 Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(ECHAR): Elevel=Elevel-2 %if Stk(Elevel+2)_Form=LitVal %thenstart Set BD(Stk(Elevel+1),B1,D1) PIX SI(MVI,Stk(Elevel+2)_Intval&X'FF',B1,D1) %finishelsestart Reg1=Load Int(Stk(Elevel+2),-1,-1) Set BD(Stk(Elevel+1),B1,D1) Do RX(STC,Reg1,B1,D1) {Op RX(STC,Reg1,Stk(Elevel+1))} %finish ->wayout !* F77op(EICHAR): %if Stk(Elevel)_Form =LitVal %thenstart Stk(Elevel)_Size=4 ->wayout %finish Elevel=Elevel-1 Reg1=Claimr(-1) PIX RR(SR,Reg1,Reg1) Lockreg(reg1) Set BD(Stk(Elevel+1),B1,D1) Do RX(IC,Reg1,B1,D1) {Op RX(IC,Reg1,Stk(Elevel+1))} Stackr(Reg1) ->wayout !* 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) Expcall(6,Spprocs,Spproctype,Spprocref,Spprocpdesc) Stackr(R1) ->wayout !* F77op(ECONCAT): %if parmbits1&2****22#0{EBCDIC} %then i=10 %else i=7 Expcall(i,Spprocs,Spproctype,Spprocref,Spprocpdesc) ->wayout !* F77op(EASGNCHAR): Elevel=Elevel-4 Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4)) ->wayout !* F77op(ECOMPCHAR): 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 ->wayout !* F77op(ECMPLX1): Elevel=Elevel-3 Flags=Stk(Elevel+3)_Intval ->Cx1 !* F77op(ECMPLX2): 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) ->wayout !* F77op(EISHFT): %if Estktos_Form=Litval %Start %if Estktos_Intval>0 %then i=ISHLL %else I=ISHRL Eop(I) %else Reg1=load Int(Estktos,-1,-1) Reg2=Load Int (Estktosm1,-1,REg1) Elevel=Elevel-2 I=SetLOcalBase(Reg2) Einternallab=Einternallab-2 Pix RR(LTR,Reg1,Reg1) Pjump(BC,Einternallab+1,12,0) Pix RS(SLL,Reg2,0,REg1,0) Pjump(BC,Einternallab,15,0) Plabel(Einternallab+1) Pix RS(SRL,reg2,0,Reg1,0) Plabel(Einternallab) Stackr(Reg2) %finish ->Wayout !* F77op(EIBTEST): Eop(ISHRL) Estklit(1) Eop(IAND) ->Wayout !* F77op(EIBSET): %if Stk(Elevel)_Form=Litval %thenstart Stk(Elevel)_Intval=1<Wayout !* F77op(EIBCLR): %if Stk(Elevel)_Form=Litval %thenstart Stk(Elevel)_Intval=(1<Wayout !* F77op(EIBITS): !* F77op(EISHFTC): Expcall(18+Opcode-EIBITS,Spprocs,Spproctype,Spprocref,Spprocpdesc) ->Wayout !* F77op(PROCARG): 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&X'FFFF') Next Param Offset=Next Param Offset+4 ->wayout !* F77op(IPROCARG): F77op(CHARARG): Estklit(X'20000'!((parmbits1>>22&1)<<16));! Amdahl string typefor iso or ebcdic Eop(IADD) Eop(PUSHVAL) Eop(PUSHVAL) ->wayout !* F77op(ARGPROCCALL): ! bytes of params over pointer Elevel=Elevel-2 Op RX(L,R1,Stk(Elevel+1)) PIX RS(STM,R4,R14,R11,16) PIX RS(LM,R12,R15,R1,0) PIX RR(LR,R2,R14); ! save entry point PIX RS(LM,R4,R10,R15,16); ! reset (possible IMP) display PIX RX(L,R14,0,R15,56); ! reset (possible IMP) const pointr PIX RR(BASR,R15,R2) Setuse(R15,Codebase,Currlineno) Active calls=Active calls-1 ->wayout !* F77op(NOTEIORES): {no special action required here on Amdahl - result will stay in R1} ->wayout !* F77op(STKIORES): Stackr(R1) ->wayout !* F77op(CALLTPLATE): ->wayout !* F77op(EFDVACC): 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 Freeupreg(R14) Freeupreg(R15) PIX RR(LR,R15,Reg1) Regclaimed(Reg1,Elevel) Regclaimed(Reg2,Elevel-1) OpRX(M,R14,Stk(Elevel+1)) PIX RR(AR,Reg2,R15) ->wayout !* 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) ->wayout !* F77op(EFNOTEVR): Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),R1,-1) ->wayout !* F77op(EFSETVR): Stackr(R1) ->wayout %end;! Eop !* %externalroutine Ef77op %alias"E#F77OP"(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Fortran * !*********************************************************************** Eop(Opcode) %end;! Ef77op !* !* %externalroutine EPasop %alias"E#PASOP"(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Pascal * !*********************************************************************** %switch Pasop(511:645) %integer Bytes,Reg,reg1,reg2,b,d,b1,d1,dx,op,upper,lower,trapno,i %constbyteintegerarray chop(CHKLT:CHKNE)=ILT,IGT,0(3),ULT,UGT,UNE,0,INE; %record(stkfmt) low,up %if increports#0 %and Report#0 %thenstart printstring("Epasop ".Epasopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* %if Store pending#0 %then PIX RX(ST,R0,0,R11,64) %and Store pending=0 %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 Stk(Elevel)_Form#LitVal %then Abortm("Epasop: string length") Eop(CPBGT+Opcode-STRGT) %return !* Pasop(PTREQ): Pasop(PTRNE): Eop(IEQ+Opcode-PTREQ) %return !* Pasop(SETI): Pasop(SETU): Pasop(SETD): bytes=Stk(elevel)_size %if bytes=4 %Start %if opcode=setd %then eop(inot) %if opcode=setu %then eop(ior) %else eop(iand) %return %finish d1=new Temp(bytes) b1=r10; dx=d1 setbd(stk(elevel),b,d) %if d1>4095 %then range(b1,d1); ! make work area addressable %if opcode=SETD %Start PIX SI(mvi,255,b1,d1) pix ss(mvc,0,bytes-1,b1,d1+1,b1,d1) op=XC %finish %else op=MVC pix ss(op,0,bytes,b1,d1,b,d) setbd(stk(elevel-1),b,d); ! second set addressable %if opcode=SETU %then op=OC %else op=NC pix ss(op,0,bytes,b1,d1,b,d) elevel=elevel-2 Estkdir(0,dx-stackoffset,0,bytes) %return !* Pasop(SETEQ): Pasop(SETNE): bytes=stk(elevel)_size %if bytes=4 %then eop(IEQ-seteq+opcode) %else %Start address(Stk(Elevel-1)) Stk(Elevel-1)_size=4 address(Stk(Elevel)) Stk(Elevel)_size=4 estklit(bytes) eop(CPBEQ-SETEQ+opcode) %finish %return Pasop(SETIN): ! first remove the bounds up=stk(elevel) low=stk(elevel-1) elevel=elevel-2 upper=up_intval lower=low_intval ! the set is the upper operand %if Elevel<2 %then Low Estack(Opcode,2) %and %return bytes=stk(elevel)_size Einternallab=Einternallab-1 reg=R0; Op=SRL reg2=load int(stk(elevel-1),-1,1) Lockreg(reg2) %if upper>0 %then oprx(c,reg2,up) %and pjump(bc,Einternallab,2,Claimjumpreg(Reg2)) %if lower >=0 %then oprx(c,reg2,low) %and pjump(bc,Einternallab,4,Claimjumpreg(Reg2)) %if bytes=4 %start reg1=load int(stk(elevel),0,reg2) %finish %else %if bytes=8 %Start %if ruse(r1)_cl!Ruse(R1)_use#0 %then freeup reg(R1) setbd(stk(elevel),b,d) pix rx(L,R1,0,b,d) d=d+4; %if d>4095 %then range(b,d) pix rx(L,R0,0,b,d) Op=SRDL; Reg=R1 %else setbd(stk(elevel),b,d) reg1=claimr(b) pix rr(lr,reg1,reg2) pix rx(SRL,reg1,0,0,5) pix rx(SLL,reg1,0,0,2) pix rx(l,0,reg1,b,d); ! pick up right set word pix rx(N,reg2,0,R9,THIRTYONE) %finish pix rx(OP,0,0,reg2,0) pix rx(N,Reg,0,R9,ONE) Funlockreg(reg2) %if lower>=0 %or upper>0 %Start pix rx(x,Reg,0,R9,ONE) plabel(Einternallab) cc=8 %finish %else cc=7 Elevel=Elevel-2 CCset=1 %if increports#0 %and report#0 %then %Start printstring("After SETIN") newline; dump estack %finish %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?") bytes=Stk(elevel)_intval %if bytes=4 %start Elevel=Elevel-1 estklit(1) eop(EXCH) eop(ISHLL) %return %finish d1=new temp(bytes) b1=R10; dx=d1 %if bytes=8 %Start reg1=load int(Stk(elevel-1),-1,1) %if ruse(R1)_cl!Ruse(R1)_use#0 %then freeup reg(R1) pix rx(LA,R1,0,0,1) pix rr(SLR,R0,R0) pix rs(SLDL,R0,0,reg1,0) Dorx(ST,R1,b,d) Dorx(st,r0,b,d+4) %else range(b1,d1) %if d1>4095 pix ss(xc,0,bytes,b1,d1,b1,d1); ! zero set reg1=loadint(Stk(elevel-1),-1,0) reg2=claimr(reg1) pix rr(lr,reg2,reg1) pix rx(la,R0,0,0,1) pix rx(N,Reg2,0,R9,thirtyone) pix rs(sll,R0,0,Reg2,0) pix rs(SRL,Reg1,0,0,5) pix rs(SLL,reg1,0,0,2) pix rx(ST,R0,reg1,b1,d1) %finish Elevel= Elevel-2 estkdir(0,dx-Stackoffset,0,bytes) %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 ! Epromote(2); ! Params now as for move bytes Eop(MVB) %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): Expcall(Opcode-EOFOPT+10,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return !* Pasop(LAZYOP): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Expcall(14,Spprocs,Spproctype,Spprocref,Spprocpdesc) %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) ! ! The above simple code does not work on Amdahl since Dup can not know ! whether it should use FR or GR on 4 byte quantity ! reg=loadreal(Stk(Elevel),-1,-1,BYtes) Elevel=Elevel-1 STackfr(reg,bytes) %if bytes=4 %then Op=MER %else Op=MDR Pix rr(op,reg,reg) %return !* Pasop(CHKLT): Pasop(CHKGT): Pasop(UCHKLT): Pasop(UCHKGT): Pasop(UCHKNE): Pasop(CHKNE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return trapno=Stk(Elevel)_intval; ! err no always literal up=Stk(Elevel-1) Elevel=Elevel-3 reg=loadint(Stk(Elevel+1),-1,0) stackr(reg) PUshoperand(up) Eop(Chop(Opcode)) PIX RX(LA,R0,0,0,trapno) Ejump(JTRUE,Pastraplab) stackr(reg) %return !* Pasop(CHKRNG): Pasop(UCHKRNG): trapno=Stk(Elevel)_Intval Elevel=Elevel-4 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RX(LA,R0,0,0,trapno) Op RX(C,Reg1,Stk(Elevel+2)) Reg2=claimjumpreg(Reg1) Pjump(BC,pastraplab,4,Reg2) Op RX(C,Reg1,Stk(Elevel+3)) Pjump(BC,pastraplab,2,Reg2) Stackr(Reg1) %Return Pasop(CHKSETRNG): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Pasop(CHKSETGT): %if Elevel<3 %then Low estack(OPcode,4) %and %return trapno=Stk(Elevel)_intval Elevel=Elevel-1 lower=0 upper=Stk(Elevel)_Intval Elevel=Elevel-1 %if OPcode=CHKSETRNG %then lower=Stk(elevel)_intval %and Elevel=Elevel-1 Abort %unless Stk(elevel)_size=4;! only for 1 word sets Eop(Dupl) d=0 d=d!(1<Cop(Opcode) !* Cop(LOGNEG): %if CCset#0 %then CC=CC!!15 %else %start %if Elevel<1 %then Low Estack(Opcode,1) %and %return Estklit(0) Eop(IEQ) %finish Establish Logical %return !* Cop(LOGVAL): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1)%and %return Estklit(0) Eop(INE) %finish %if Ruse(R1)_cl!Ruse(R1)_Use#0 %then freeup reg(R1) {to ensure r1 is used} %if lastreg=R1 %then Lastreg=0 Establish Logical Elevel=Elevel-1 {use of r1 will be presumed by LOGSTK} unlockreg(R1) %return !* Cop(LOGSTK): Stackr(r1) %return !* Cop(ECSTORE): I=Stk(Elevel)_Size %unless Stk(Elevel-1)_Size=I %then %monitor %and %stop %if Stk(Elevel)_Form&31#Regval %then address(Stk(Elevel-1)) Address(Stk(Elevel)) Estklit(I) Eop(MVB) %return !* Cop(ECPROCCALL): ! PDS thinks this can go via argproc ! However C has dereferenced the the pointer Address(Stk(Elevel)) Estklit(0) Eop(Argproc) %return !* Cop(EPUSHSTR): ! as pushbytes but must be aligned(is on IBM) Address(Stk(Elevel-1)) EOP(Pushbytes) %return !* Cop(ELDBITS): Elevel=Elevel-3 Nbits=Stk(Elevel+3)_Intval Bstart=Stk(Elevel+2)_Intval Bmask=Bmaskval((Nbits-1)&31) Bshift=32-Bstart-Nbits Reg1=Load Int(Stk(Elevel+1),-1,-1) %if Bshift>0 %then PIX RX(SRL,Reg1,0,0,Bshift) Stackr(Reg1) Estklit(Bmask) Eop(IAND) %return !* Cop(ESTBITS): Elevel=Elevel-2 Nbits=Stk(Elevel+2)_Intval Bstart=Stk(Elevel+1)_Intval Bmask=Bmaskval((Nbits-1)&31) Bshift=32-Bstart-Nbits Eop(DUPL) Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,-1) Stackr(Reg1) Estklit((Bmask<0 %cycle Epromote(Elevel) I=I-1 %repeat Numcsave=Numcsave+1 %return !* Cop(ECRESTORE): Epromote(Elevel-Numcsave+1) Numcsave=Numcsave-1 %return !* Cop(*): %monitor %end;! Eccop !* %routine Expcall(%integer Proc,%stringarrayname procs,%integerarrayname proctype,procref,procpdesc) !*********************************************************************** !* call an exponentiation routine or other support routine * !*********************************************************************** %integer I,J,T %string(31) S T=proctype(Proc) J=procref(Proc) %if J=0 %thenstart S=procs(Proc) J=Exname(T,S) procref(Proc)=J %finish Eprecall(J) I=procpdesc(Proc)>>16 %while I>0 %cycle Epromote(I) Eop(PUSHVAL) I=I-1 %repeat I=procpdesc(Proc) Ecall(J,I>>16,I&X'FF') %if T&7#0 %thenstart;! function Estkresult(0,T&7,(T>>8)&255) %finish %end;! Expcall !* !* !* !* !*********************************************************************** !*********************************************************************** !** Code generation support procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine Refer(%record(Stkfmt)%name Stk,%integer Offset) !*********************************************************************** !* Modify an address by adding an offset and then convert the * !* the address to a reference to that which is at the address. When * !* Offset is zero this is the exact converse of address(q.v.) * !*********************************************************************** %integer Reg,Form,Rform %record(Stkfmt) Mstk %if Offset#0 %Start Mstk=0 Mstk_Form=Litval Mstk_size=4 Mstk_IntVal=Offset Note Index(0,Stk,Mstk) %finish Form=Stk_Form&31; ! removing the reg marker bit Rform=Erefform(Form) %if Rform=255 %then Abortm("Invalid attempt at refer") %if Rform=128 %Start; ! A load needed Reg=Claimr(0) OpRX(L,Reg,Stk) Stk_Reg=Reg Form=Regval; Rform=erefform(Regval) Stk_Cmval=0 %finish Stk_Form=Rform %if Rform&Regflag#0 %then Regclaimed(Stk_reg,Elevel) %end;! Refer !* %routine Address(%record(Stkfmt)%name Stk) !*********************************************************************** !* Change operand from a var to an address * !* Addresses always have size 4 * !*********************************************************************** %integer I,J,Reg,Op,Aform,Form %switch F(0:3) %record(StkFmt) Mod Form=Stk_Form&31 Aform=Eaddrform(Form) %if aform=255 %Start %if increports#0 %and report#0 %then %c Printstring("Warning:- Addr of addr? ") %return; ! treat as no-op for Atholl %Finish %if Aform>=128 %then ->f(Aform&3) Stk_size=4 Stk_Form=Aform!(Stk_Form&Regflag) ! The following sequence occurs when an array eleament ! has been dumped and the address is called on the Indtempval I=Stk_CmVal %if I#0 %and AformStore %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,sruse %constbyteintegerarray Lop(0:4)=0,IC,LH,0,L Bytes=Stk_Size %unless 00 %then sruse=ruse(lockedreg)_cl %and Lockreg(Lockedreg) %if Stk_Size=1 %then PIX RR(SR,Reg,Reg) OpRX(Lop(Bytes),Reg,Stk) %if Lockedreg>0 %and ruse(lockedreg)_CL=LOcked{Not freed by OpRX} %then Ruse(Lockedreg)_Cl=sruse %result=Reg %end;! Load Int !* %integerfn load int pair(%record(StkFmt)%name Stk,%integer oddeven,notthis) !*********************************************************************** !* Loads the operand into the odd or even member of a register * !* Pair which is left locked. The even member is the result * !*********************************************************************** %integer pair,tother,reg %if Stk_Form&31=Regval %Start Reg=Stk_reg Tother=reg!!1 pair=Reg&(-2) %if Ruse(tother)_Cl>=0 %then freeupreg(tother) %and ->set %finish Pair=Claim GR pair(notthis) set: reg=load int(Stk,pair+oddeven,-1); ! does nowt if already OK lockreg(pair); lockreg(pair+1) %result=pair %end %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 Unlockfreg(Stk_Reg) %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) Unlockfreg(Oldreg) %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=stkmax %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 Regclaimed(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 FRegclaimed(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). In c must not change the conditoin code * !* since a call of Ecjump may follow. Hence the less efficient coding * !*********************************************************************** %integer Reg1,jreg CCset=0 Reg1=Claimr(0) jreg=setlocalbase(reg1) jreg=claimjumpreg(reg1) Einternallab=Einternallab-1 PIX RX(LA, Reg1, 0, 0, 1) Pjump(BC, Einternallab, CC, Jreg) %if Language=Ccomp %then Pix RX(la,Reg1,0,0,0) %else PIX rr(slr,reg1,reg1) PLabel(Einternallab) 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,IREM,IGT,ILT,IEQ,INE,IGE,ILE,IAND,IOR,IXOR * !* descriptor to result on Estack * !*********************************************************************** %routinespec sizes %constbyteintegerarray RXop(0:ULE) = 0, A,S,M,D,0,0,0,N,O,0,X,0(4),C(6),0(UADD-ILE-1),AL,SL,CL(6); %integer Lform,Rform,Lreg,Rreg,Shift,MCop,B1,D1,B2,D2,Wreg,Pair %switch Opcode(0:ULE) MCop=RXop(op) Lform=LHS_Form&31 Rform=RHS_Form&31 Lreg=LHS_Reg Rreg=RHS_Reg ->Opcode(Op) !* Opcode(IADD): Opcode(IAND): Opcode(IOR): Opcode(IXOR): OPcode(UADD): Commbinaryop: ! Commutative binary operation ! First pick off immediate operations ! ! In these test must exclude cases where form is an address rather than an ! operand at the address. Do this with Eaddrform allowing only a literal through ! of items which dont have a valid address ! %if LHS_Size=1 %and Eaddrform(Lform)<=128 %and (MCop=C %or MCop=CL) %and %c RHS_Form=Litval %and 0<=RHS_Intval<=255 %Start SETBD(LHS,B1,D1) Pix SI(CLI,RHS_Intval,B1,D1) CCset=1 %return %finish %if LHS_Size=RHS_Size %and Eaddrform(Lform)<=128 %and Eaddrform(Rform)<=128 %and %c (MCop=CL %or (MCop=C %and (7<=CC<=8 %or LHS_Size=1))) %start SetBD(LHS,B1,D1) %if B1<8 %then Lockreg(B1) SetBD(RHS,B2,D2) Pix SS(CLC,0,LHS_Size,B1,D1,B2,D2) %if B1<8 %then Unlockreg(b1) CCset=1 %return %finish Sizes %if Lform=Litval %and Rform#REgval %Start Lreg=claimr(0) Op RX(L,Lreg,LHS) Lform=Regval %finish %if Lform=RegVal %thenstart OpRX(MCop,Lreg,RHS) Wreg=Lreg %finishelsestart %if Rform#RegVal %thenstart Rreg=Claimr(0) OpRX(L,Rreg,RHS) %finish OpRX(MCop,Rreg,LHS) Wreg=Rreg %if MCop=C %or MCop=CL %then CC=Invcc(CC) %finish %if MCop=C %or MCop=CL %then CCset=1 %and Unlockreg(wreg) %else Stackr(Wreg) %return !* Opcode(ISUB): Opcode(Usub): Sizes %if Lform=RegVal %thenstart OpRX(S,Lreg,RHS) %finishelsestart %if Rform=RegVal %thenstart Lreg=Claimr(Rreg) OpRX(L,Lreg,LHS) PIX RR(SR,Lreg,Rreg) Unlockreg(Rreg) %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) ->Commbinaryop Opcode(UGT): Opcode(ULT): Opcode(UEQ): Opcode(UNE): Opcode(UGE): Opcode(ULE): CC=Setcc(Op-UGT) ->Commbinaryop !* Opcode(IMULT): Sizes %if Lform=LitVal %and Multiply by Lit(RHS,Lhs_Intval)=0 %then %return %if Rform=LitVal %and Multiply by Lit(LHS,RHS_Intval)=0 %then %return %if Rform=Regval %and Lform#Regval %Start pair=load int pair(RHS,1,-1); ! into odd member OpRX(M,Pair,LHS) %else Pair=Load int pair(LHS,1,-1) OpRX(M,Pair,RHS) %finish Funlockreg(pair) Funlockreg(Pair+1) %if Parmbits1&16=0 %then %Start Pix RS(SLDA,Pair,0,0,32) %if Pair#0 %then Stackr(Pair) %and %return Pix rr(LR,Pair+1,Pair) %finish Stackr(Pair+1) %return !* Opcode(IDIV):Opcode(Irem): Sizes Pair=load int pair(LHS,0,-1) PIX RX(SRDA,Pair,0,0,32) OpRX(D,Pair,RHS) %if Op=IREM %Start pix rr(LTR,Pair+1,Pair) %if language=Pascal %Start; ! pascal rem is strange Einternallab=Einternallab-1 pjump(BC,Einternallab,10,15) Op RX(a,Pair+1,rhs) plabel(einternallab) %finish %finish Funlockreg(Pair) Funlockreg(Pair+1) Stackr(Pair+1) %return %routine sizes %if RHS_Size<4 %Start %if Rform#litval %then %start Rreg=load int(rhs,-1,-1) Lockreg(Rreg) Rform=regval RHS_Form=Regval!Regflag RHS_Reg=Rreg %finish RHS_Size=4 %finish %if LHS_Size<4 %Start %if Lform#litval %then %start Lreg=load int(LHS,-1,-1) Lockreg(Lreg) Lform=regval LHS_Form=Regval!Regflag LHS_Reg=Lreg %finish LHS_Size=4 %Finish %end %end;! Int Binary Op %integerfn multiply by LIt(%record(stkfmt)%name Stk,%integer lit) !*********************************************************************** !* Multiplies integers by a literal. The two multiplies M & MH * !* neither check for overflow but a software test is possible after * !* M but not after MH. Hence MH can only be used when full checking * !* is not required. Otherwise MH is best since it does not need an * !* even-odd register pair. Multilies can be reduced to A or SLA * !* quite safely. * !*********************************************************************** %integer i,j,reg %if Lit=0 %Start j=Stk_Form&31 %if j=regval %or j=indregval %then unlockreg(stk_reg) Estklit(0) %result=0 %finish %if Lit=1 %then Pushoperand(Stk) %and %result=0 ! %for i=1,1,16 %cycle j=1<shift %if j>lit %then %exit %repeat ! %if parmbits1&16=0 %then %result=1; ! o'flow checking needed %unless X'FFFF8000'<=Lit<=X'7FFF' %then %result=1; ! out of range for MH reg=load int(Stk,-1,-1) Do RX(MH,Reg,R9,short const(Lit)) forgetuse(reg) Stackr(reg) %result=0 shift: reg=load int(Stk,-1,-1) %if i=1 %then Pix RR(AR,reg,reg) %else Pix RS(SLA,Reg,0,0,I) forgetuse(reg) Stackr(reg) %result=0 %end !* %routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports INEG,IABS * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,XAop,b,d Reg1=Load Int(RHS,-1,0) %if Op=INEG %then XAop=LCR %elsestart %if {(Op=INOT %and language=Fortran) %or} Op=BNOT %thenstart {++++ temp while fortran change introduced +++} PIX RX(LA,0,0,0,1) PIX RR(NR,Reg1,0) %if op=inot PIX RR(XR,Reg1,0) Stackr(Reg1) %return %finish %if op=inot %Start; ! IMP lgical not set int(-1,4,b,d) do rx(x,reg1,b,d) 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 RXeop(RADD:RDIV) = AE,SE,ME,DE %constbyteintegerarray RXdop(RADD:RDIV) = AD,SD,MD,DD %constbyteintegerarray RRxop(RADD:RDIV) = AXR,SXR,MXR,0 %integer Lform,Rform,Lreg,Rreg,Bytes,XAXop,Loadop %switch Opcode(RADD:RLE) Lform=LHS_Form&31 Rform=RHS_Form&31 %if Lform#Fregval %then Lreg=-1 %else Lreg=LHS_Reg %if Rform#Fregval %then Rreg=-1 %else Rreg=RHS_Reg Bytes=LHS_Size %if Bytes=4 %then Loadop=LE %else Loadop=LD %if RADD<=Op<=RDIV %thenstart %if Bytes=4 %thenstart XAXop=RXeop(Op) %finishelsestart %if Bytes=8 %thenstart XAXop=RXdop(Op) %finishelsestart Abortm("No Real*16") %finish %finish %finishelsestart;! comparison %if Bytes=4 %then XAXop=CE %else XAXop=CD %finish ->Opcode(Op) !* Opcode(RADD): !* Opcode(RMULT): %if Lform=FregVal %thenstart 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 OpRX(XAXop,Lreg,RHS) %finishelsestart Lreg=Claimfr(Rreg) Op RX(Loadop,Lreg,LHS) Op RX(XAXop,Lreg,RHS) %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 OpRX(XAXop,Lreg,RHS) Unlockfreg(Lreg) %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 Funlockfreg(Rreg) %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,Val Val=stk_intval %if Stk_form=litval %and (newsize=4 %or (newsize=2 %and %c X'FFFF8000'<=val<=X'7FFF') %or (newsize=1 %and 0<=val<=255)) %Start Stk_size=newsize Push operand(Stk) %else Reg=Load Int(Stk,-1,-1) Stackr(Reg) %finish %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 raddhalf(%integer freg1,Bytes) !*********************************************************************** !* Service routine to perform rounding for convert ri etc !*********************************************************************** %integer Op,Lab,Breg,Jreg %if Bytes=4 %then op=AE-AD %else op=0 BReg=setlocalbase(-1) Jreg=claimjumpreg(-1) Lab=Einternallab-2 Einternallab=Lab pix rr(LTDR+Op,Freg1,Freg1) Pjump(BC,Lab+1,10,Jreg) Pix rx(SD+Op,freg1,0,R9,Rhalf) Pjump(bc,Lab,15,Jreg) PLabel(lab+1) PIX RX(AD+Op,Freg1,0,R9,RHALF) Plabel(lab) %end %routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode) !*********************************************************************** !* converts between real and integer * !* Mode = 0 TNC (ie truncate towards zero) * !* 1 RND (ie the nearest integer) * !* 2 FLOOR (ie Truncate towards minus infinity) * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) ! ! Theory of fixing on IBM ! Fixing is the converse of floating with 3 stages ! 1) Make unsigned by adding 2**31 ! 2) Force the integer to bottom 32 bits by unnormalized operation ! which also loses the fractional bits. ! 3) Convert the unsigned integer back to signed by SL 2**31 (via XI) ! If the fractional bits are retained thro step 1 the effect is FLOOR ! If they are discarded first the effect is TNC hence the ordering ! and different unnormalised nos. ! RND involves an adjustment by 0.5 then a TNC ! Reg1=Claimr(-1) %if Mode=1 %then raddhalf(Freg1,Bytes) %if mode=2 %Start; ! floor only pix rx(ad,freg1,0,r9,maxiasr) pix rx(aw,freg1,0,r9,zerononstd) %else; ! tnc and Rnd PIX RX(SD,Freg1,0,R9,TWO31R);! X'4F00 0000 0800 0000' PIX RX(AW,Freg1,0,R9,TWO32) ;! X'4E00 0001 0000 0000' %finish PIX RX(STD,Freg1,0,R11,0) PIX SI(XI,X'80',R11,4) PIX RX(L,Reg1,0,R11,4) Stackr(Reg1) %end;! Convert RI %routine Convert RU(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between real and unsigned integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) Reg1=Claimr(-1) PIX RR(LPDR,Freg1,Freg1) pix rx(aw,freg1,0,r9,zerononstd) PIX RX(STD,Freg1,0,R11,0) PIX RX(L,Reg1,0,R11,4) Stackr(Reg1) %end;! Convert RU %routine Convert RIR(%record(Stkfmt)%name Stk,%integer Mode) !*********************************************************************** !* converts between real and integer but leaves the result as a real * !* Mode = 0 TNCRR (ie truncate towards zero) * !* 1 RNDRR (ie the nearest integer) * !* descriptor to result on Estack * !*********************************************************************** %integer Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) %if Mode=1 %then raddhalf(Freg1,Bytes) pix rx(ad,freg1,0,r9,long const(X'4F00000000000000')) Stackfr(Freg1,Bytes) %end;! Convert RIR !* %routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1 Reg1=Load Int(Stk,-1,0) Abortm("Float target size??") %unless newsize=4 %or newsize=8 %or newsize=16 ! ! Theory of IBM floats ! An unsigned integer can be floated by prefixing with X'4E000000' and normalising ! Hence to float a signed integer we can add logically 2**31 (quickest via X) ! append the magic no already in glawork, normalise and subtracy 2**31 ! via a real operation to convert back to signed. The latter can be combined ! with the normalisation. ! %if newsize=16 %Start Freg1=Claimfrpair(-1) PIX RR(SDR,Freg1+1,Freg1+1) %finish %else 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); ! alread in glawork and undisturbed PIX RX(LD,Freg1,0,R13,Glawork) PIX RX(SD,Freg1,0,R9,TWO31); ! X'4E00 0000 8000 0000' Stackfr(Freg1,newsize) %end;! Convert IR %routine Convert UR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1 Reg1=Load Int(Stk,-1,0) Abortm("Float target size??") %unless newsize=4 %or newsize=8 %or newsize=16 ! ! Theory of IBM floats ! An unsigned integer can be floated by prefixing with X'4E000000' and normalising ! PIX RR(LPR,Reg1,Reg1) %if newsize=16 %Start Freg1=Claimfrpair(-1) PIX RR(SDR,Freg1+1,Freg1+1) %finish %else Freg1=Claimfr(-1) PIX RX(ST,Reg1,0,R13,Glawork+4) ! PIX SS(MVC,0,4,R13,Glawork,R9,TWO31); ! alread in glawork and undisturbed PIX RR(SDR,Freg1,Freg1) PIX RX(AD,Freg1,0,R13,Glawork) Stackfr(Freg1,newsize) %end;! Convert UR %routine Convert UI(%record(Stkfmt)%name Lstk,%integer Newsize) !*********************************************************************** !* converts unsigned integer to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg,Bytes,Op Bytes=Lstk_Size %if Lstk_Form=LitVal %thenstart Lstk_Size=Newsize %if Newsize=2 %then %start Lstk_Intval=Lstk_Intval&X'FFFF' %if Lstk_Intval&X'8000'#0 %then Lstk_Intval=Lstk_Intval!X'FFFF0000' %finish Elevel=Elevel+1 %return %finish Reg=Load Int(Lstk,-1,-1) Stackr(Reg) %if Bytes>2 %and Newsize=2 %thenstart Estklit(X'FFFF') Eop(IAND) %finish %if Newsize=2 %then %start Pix RX(STH,reg,0,R11,0) Pix rx(LH,reg,0,R11,0) Forgetuse(Reg) %finish Stk(Elevel)_Size=Newsize %end;! Convert UI !* %integerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) !*********************************************************************** !* value defined by RHS is assigned to LHS. If Dup is non-zero then * !* value must be retainedin a reg * !* result is the reg used for retaining the value * !*********************************************************************** %constbyteintegerarray Ad(0:21)=0(9),1(9),0(4) %integer Bytes,Op,Reg,Form,B1,D1,B2,D2 %If language=Pascal %and Rhs_base=Cnst %then %c Rhs_Size=(Rhs_size+3)&(-4);! ! Pascal literal strings have exact size ! but are stored in integral words. Bytes=RHS_Size Form=RHS_Form&31 LHS_Form=LHS_Form&31;! remove Regflag bit if set %if Ad(LHS_Form)#0 %then %Start %if increports#0 %and report#0 %then printstring("Warning:- Store into an address ") Refer(LHS,0) LHS_Size=Bytes %finish %if LHS_SizePushit %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 Dup#0 %start Reg=Load Int(RHS,-1,0) RHS_Reg=reg Form=Regval %finish %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) %if bytes=1 %and Form=litval %Start pix si(MVI,RHS_intval,b1,d1) %result=0 %Finish Lockreg(B1) Set Bd(RHS,B2,D2) {%if form=litval %then }d2=d2+RHS_size-bytes UNlockreg(B1) fixedmove(Bytes,B1,D1,B2,D2) %result=0 %finish Op=STD %if Form=FregVal %thenstart Reg=RHS_Reg unlockfreg(Reg) ->Pushit %finish Reg=Claimfr(-1) Op RX(LD,Reg,RHS) ->Pushit %finish %end;! Storeop !* %routine Push Param(%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 * !*********************************************************************** %integer Bytes,Op,Reg,Form,B1,D1,B2,D2 %If language=Pascal %and Stk_base=Cnst %then %c Stk_Size=(Stk_size+3)&(-4);! ! Pascal literal strings have exact size ! but are stored in integral words. %if Stk_Size=1 %thenstart Elevel = Elevel + 1 EstkLit(4) Eop(CVTII) Elevel = Elevel - 1 %finish Form=Stk_Form&31 %if Form=RegVal %then Bytes = 4 %else Bytes=Stk_Size %if Bytes=4 %thenstart %if Form=RegVal %thenstart Op=ST Reg=Stk_Reg Unlockreg (Reg) %finish %else %if Form=FregVal %thenstart Op=STE Reg=Stk_Reg Unlockfreg (Reg) %else Op RX(L,0,Stk) Op=ST Reg=0 %finish %finishelsestart %unless Bytes=8 %thenstart Set BD(Stk,B1,D1) fixedmove(Bytes,R11,Next Param Offset&X'FFFF',B1,D1) Next Param Offset=Next Param Offset + (Bytes+3)&(-4) %return %finish Op=STD %if Form=FregVal %thenstart Reg=Stk_Reg Unlockfreg(Reg) %else Reg=Claimfr(-1) Op RX(LD,Reg,Stk) %finish %finish %if next param offset=64 %and Op=ST %and reg=R0 %then %c Store pending=64 %else DO RX(Op,Reg,R11,Next Param Offset&X'FFFF') Next Param Offset=Next Param Offset+Bytes %end;! Push Param %routine fixedmove(%integer bytes,B1,D1,B2,D2) !*********************************************************************** !* Plant a MVC but deal with the case where bytes are >256 * !* Pascal records may involve very large moves * !*********************************************************************** %integer pair %if bytes>512 %and b1#b2{not overlapped} %and ruse(r1)_CL>Locked %then ->lmove %cycle %return %if bytes<=0 %if d1>=4096 %Start Lockreg(B2) range(B1,D1) unlockreg(B2) %finish %if D2>=4096 %Start Lockreg(B1) range(B2,D2) unlockreg(B1) %finish %exit %if bytes<256 pix ss(MVC,0,256,B1,D1,B2,D2) bytes=bytes-256 D1=D1+256 D2=D2+256 %repeat pix ss(MVC,0,Bytes,B1,D1,B2,D2) %unless bytes<=0 %return Lmove: pair=claimgrpair(0) %if Ruse(R1)_cl!Ruse(R1)_Use#0 %then freeupreg(R1) Dump LA(R0,0,B1,d1) DUMP LA(Pair,0,B2,D2) DO RX(LA,R1,0,Bytes) Pix rr(LR,Pair+1,R1) Pix RR(MVCL,R0,Pair) %end !* !* %routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index) !*********************************************************************** !* incorporate Index info into Base record * !*********************************************************************** %integer Reg,Form,Iform,Bform,X %record(Stkfmt) Mod %switch F(0:21) Bform=Base_form Iform=Index_Form&31 %if Index_Form=LitVal %thenstart Index_Intval=Index_Intval<F(BForm&31) !* F(AddrDir): { @dir } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } Base_Form=BForm+4 Set: Base_Modreg=Index_Reg Base_Modbase=Index_Base Base_Modform=Index_Form Base_Modoffset=Index_Offset Base_Scale=Scale Base_Msize=Index_Size Form=Base_Modform&31 %if Form=RegVal %or Form=IndRegVal %thenstart Regclaimed(Base_Modreg,Elevel) %finish %return !* F(AddrDirMod): { @dir+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } F(RegModAddr): { (reg)+M } %if Index_Form=Litval %then %Start X=Base_Cmval+Index_Intval Base_Cmval=X %return %finish %if Base_Modform=Litval %thenstart X=Base_Cmval+Base_Modoffset Base_Cmval=x Base_Modoffset=0 ->Set %finish %if Bform&31=RegModAddr %and scale=0 %Start Op RX(a,Base_reg,Index) Regclaimed(Base_REg,Elevel) %return %finish Reg = LoadModifier(Base,0) Lockreg(Reg) Mod=0 Mod_Form = RegVal Mod_Reg = Reg Mod_Size=4 %if scale#0 %Start Reg = LoadInt(Index,-1,Base_reg) Index = 0 Index_Form = RegVal Index_Size = 4 Index_Reg = Reg scalereg(reg,Scale) Forgetuse(Reg) %Finish Int Binary Op(IADD,Index,Mod) %if lastreg=Mod_reg %then lastreg=0 Index = Stk(Elevel) Elevel=Elevel-1 Scale = 0 -> Set F(IndRegModVal): { ((reg)+M) } F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } F(AddrDirModVal): { (@dir+M) } %if Language=Fortran %then ->F(RegModAddr); ! Till Fortram modifies consistently F(IndRegVal): { ((reg)) } F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } %if Language=Fortran {%or Language=Ccomp} %Start x=Base_Size Address(Base) nOte Index(Scale,Base,Index) refer(Base,0) Base_Size=X %return %finish Reg=Claimr(0) OpRX(L,Reg,Base) Forgetuse(Reg) Regclaimed(Reg,Elevel) Base_Reg=Reg Base_Form=RegModAddr!Regflag ->Set !* F(LitVal): { lit } F(ConstVal): { const } F(FregVal): { (freg) } F(AddrConst): { @const } Abort F(RegVal): { (reg) } Base_form=Regmodaddr!Regflag; ->Set F(TempVal): { (temp) } F(DirVal): { (dir) } Base_form=bform+12 ; ->Set !* %end;! Note Index !* !* !*********************************************************************** !*********************************************************************** !** Pascal-specific support procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue) !*********************************************************************** !* compute the bit address of an indexed bit-field. * !* Factor is the number of array elements per word and must be 2, 4, * !* 8, 16, or 32. * !*********************************************************************** %integer Epm,Reg %if Base_Form#RegAddr %then Abortm("Bit Index: base") %if Factor_Form#LitVal %then Abortm("Bit Index: factor") Epm=Factor_IntVal %if Epm<2 %or Epm>32 %then Abortm("Bit Index: epm") { %unless Power(Epm)=1 %then Abortm("Bit Index: power") } !! Load(IndexValue) Base_Form=RegBitModAddr Base_ModReg=Reg %end;! Bit Index !* !* !* !*********************************************************************** !*********************************************************************** !** Amdahl-specific procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine lockreg(%integer reg) !*********************************************************************** !* Lock a register so that it can not be dumped * !*********************************************************************** Ruse(Reg)_cl=Locked %unless Ruse(REg)_cl=permlocked %end %routine lockfreg(%integer freg) !*********************************************************************** !* Lock a register so that it can not be dumped * !*********************************************************************** Ruse(16+Freg>>1)_CL=LOcked %end %routine Unlockreg(%integer reg) !*********************************************************************** !* Unlock a Register without changing its use * !*********************************************************************** Ruse(Reg)_CL=Free %unless Ruse(Reg)_CL=Permlocked %end %routine Unlockfreg(%integer freg) !*********************************************************************** !* Unlock a Register without changing its use * !*********************************************************************** Unlockreg(16+Freg>>1) %end %routine Forgetuse(%integer reg) !*********************************************************************** !* Forget the contents of a register without changing its lockstate * !*********************************************************************** %integer Use Use=rUse(Reg)_Use %if Use=Codebase %then Pdrop(REg) Ruse(reg)_use=0 Ruse(Use)_Inf=0 %end %routine Forgetfuse(%integer freg) !*********************************************************************** !* Forget the contents of a register without changing its lockstate * !*********************************************************************** Forgetuse(16+Freg>>1) %end %routine funlockreg(%integer reg) !*********************************************************************** !* Unlock a reg and forget its use * !*********************************************************************** Ruse(reg)_cl=Free %unless Ruse(reg)_CL=Permlocked Forgetuse(Reg) %end %routine funlockfreg(%integer freg) !*********************************************************************** !* Unlock a reg and forget its use * !*********************************************************************** Funlockreg(16+Freg>>1) %end %routine Setuse(%integer reg,use,inf) !*********************************************************************** !* Set the use fields of a register record !*********************************************************************** %if Ruse(reg)_Use#0 %then Forgetuse(Reg) Ruse(Reg)_Use=Use Ruse(reg)_Inf=Inf %end %routine Setfuse(%integer freg,use,inf) !*********************************************************************** !* Set the use fields of a register record * !*********************************************************************** SetUse(16+Freg>>1,use,inf) %end %routine regclaimed(%integer reg,elevel) !*********************************************************************** !* Set a register to claimed ie dumpable by Freeupreg * !*********************************************************************** Abort %if Ruse(REg)_Cl=Permlocked Ruse(Reg)_CL=Claimed Ruse(Reg)_Elevel=Elevel %end %routine fregclaimed(%integer freg,elevel) !*********************************************************************** !* Set a register to claimed ie dumpable by Freeupfreg * !*********************************************************************** Regclaimed(freg>>1+16,Elevel) %end %routine Clear Regs !*********************************************************************** !* forget all previous use of registers * !*********************************************************************** %integer I %cycle I=0,1,Maxreg Funlockreg(i) %repeat Lastreg=0 Lastbreg=0 Lastfreg=-1 %end;! Clear Regs !* %routine Dropall !*********************************************************************** !* no dynamic addressing registers can have assumed values * !*********************************************************************** %integer I %cycle I=0,1,Maxreg Funlockreg(i) %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 J=Ruse(16+R>>1)_CL I=Ruse(16+r>>1)_Elevel %if increports#0 %and report#0 %Start printstring("free up REg"); write(r,2); write(J,5) newline %finish %if J=0 %thenstart Forgetfuse(R) %return %finish %if J=Claimed %and 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 Funlockfreg(R) %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 * !*********************************************************************** %record(stkfmt)%name lstk %integer I,J,K J=Ruse(R)_CL I=Ruse(R)_Elevel %if J=0 %thenstart Forgetuse(R) %return %finish J=New Temp(4) Lstk==stk(i) K=Lstk_Form&31 %if Lstk_Reg=R %thenstart %if K=RegVal %thenstart Lstk_Form=TempVal Lstk_Offset=J %if Lstk_size<4 %Then Lstk_offset=j+4-Lstk_size ! Register converted down prior to a store Lstk_Base=0 Store: Do RX(ST,R,R10,J) Funlockreg(R) %return %finishelsestart %if (K=regmodaddr %or k=Indregmodval) %and Lstk_modform&31=regval %Start Scalereg(Lstk_Modreg,Lstk_scale) pix rr(ar,r,Lstk_modreg) Funlockreg(Lstk_modreg) %if k=RegModAddr %then Lstk_Form=TempAddr %else Lstk_form=IndTempVal Lstk_offset=J Lstk_base=0 Lstk_reg=0 ->store %finish %if K=IndRegVal %or K=RegAddr %or K=RegModAddr %c %or K=IndRegModVal %thenstart Lstk_Form=K+1 Lstk_Offset=J Lstk_Base=0 Lstk_reg=0 ->Store %finish %finish %finishelsestart %if Lstk_Modform&31=RegVal %and Lstk_Modreg=R %thenstart %if k=Regmodaddr %or k=Indregmodval %Start Scalereg(R,Lstk_scale) pix rr(ar,r,Lstk_Reg) Funlockreg(lstk_reg) %if k=RegModAddr %then Lstk_Form=TempAddr %else Lstk_form=Indtempval Lstk_offset=j Lstk_base=0 Lstk_reg=0 Lstk_modreg=0 ->store %finish Lstk_Modform=TempVal Lstk_Modoffset=J Lstk_Modbase=0 ->Store %finish %if Lstk_Modform&31=IndRegVal %and Lstk_Modreg=R %thenstart Lstk_Modform=IndTempVal Lstk_Modoffset=J Lstk_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)_CL=Claimed %and Ruse(i)_Elevel=Old %thenstart Ruse(I)_Elevel=New %finish %repeat %cycle I=16,1,19 %if Ruse(i)_CL=Claimed %and Ruse(i)_Elevel=Old %thenstart Ruse(I)_Elevel=New %finish %repeat %end;! Reset Reguse !* %routine Freeregs(%integer mask) !*********************************************************************** !* save any general or floating registers * !*********************************************************************** %integer I,fmask fmask=mask>>16; mask=mask&x'ffff' %if fmask#0 %Start %cycle I=0,2,6 %if 1<>1+16)_cl#0 %then Freeup Freg(I) Forgetfuse(i) %finish %repeat %finish %cycle I=1,1,15 %if I=8 %then I=14; ! skip the locked regs %if 1<>1+16)_CL=0 %and I#Curreg %and I#Lastfreg %thenstart Forgetfuse(i) 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 Ruse(16)_CL=0 %and Ruse(17)_CL=0 %then %result=0 %if Ruse(17)_CL=0 %and Ruse(19)_CL=0 %then %result=4 %unless 0<=Curreg<=2 %thenstart %if Ruse(16)_CL#0 %then Freeup Freg(0) %if Ruse(17)_CL#0 %then Freeup Freg(2) %result=0 %finishelsestart %if Ruse(18)_CL#0 %then Freeup Freg(4) %if Ruse(19)_CL#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 %if increports#0 %and report#0 %Start printstring("Claimr"); printstring("cur="); write(curreg,2) printstring("lastr="); write(lastreg,2) newline Printuse %Finish %cycle I=1,1,3 %if Ruse(I)_CL=0 %and I#Curreg %and I#Lastreg %thenstart Forgetuse(i) Lastreg=I %result=I %finish %repeat %cycle I=1,1,3 %unless I=Curreg %or I=Lastreg %or Ruse(I)_cl=locked %thenstart Freeup Reg(I) Lastreg=I %result=I %finish %repeat %if Lastreg>0 %and Lastreg#Curreg %and Ruse(Lastreg)_CL#Locked %thenstart Freeup Reg(Lastreg) %result=Lastreg %finishelsestart Freeupreg(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)_CL!Ruse(I)_Use=0 %and i#Lastbreg %then %result=I %repeat %cycle I=4,1,7 %unless I=Lastbreg %or Ruse(i)_CL<0 %then Forgetuse(I) %and %result=I %repeat Abortm("No free base register") %end;! Claimbr !* %routine Setint(%integer Val,Size,%integername B2,D2) !*********************************************************************** !* set B2, D2 to address a location containing Val * !*********************************************************************** %if Size=1 %then Val=Val<<8 B2=R9 %if size<=2 %then d2=short const(val) %else d2=word const(val) %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)_Use=Mainareabase %and Ruse(I)_Inf=Area %then Lastbreg=I %and %result=I %repeat I=ClaimBR DO RX(L,I,R13,Areabase(Area)) Setuse(I,Mainareabase,Area) Lastbreg=I %result=I %end;! Basereg !* %integerfn fourkdisp(%Integer bigdisp) !*********************************************************************** !* Returns the offset of the appropiate 4k mult * !*********************************************************************** %integer n n=bigdisp>>12 %if n>Max4k %then Max4k=n %if Max4k>=1024 %then abort %result=4*n %end %routine Add4k(%integer op,reg,bigdisp) !*********************************************************************** !* Adds in a multiple of Fourk. If >1023 %then takes special action * !* Op can onl be L or A * !*********************************************************************** %integer mult,k Mult=bigdisp>>12 %if mult>1023 %then k=1023 %else k=mult ! Multiple 1023 is at max disp from R12 PIX RX(Op,reg,0,R12,Fourkdisp(k<<12)) %if mult>k %then Add4k(A,reg,Bigdisp-k<<12) %end %routine scalereg(%integer reg,scale) !*********************************************************************** !* Performs a simple shift optimising shifts by 0 & 1 * !*********************************************************************** %if scale<=0 %then %return %if scale =1 %then pix rr(ALR,reg,reg) %else %c pix rs(SLL,reg,0,0,scale) %end %integerfn SetX2(%integername D2) !*********************************************************************** !* result is a register containing an appropriate 4K multiple * !* D2 is adjusted accordingly * !*********************************************************************** %integer I,J %if D2<0 %start I=ClaimBR Do RX(l,i,R9,word const(D2)) D2=0 %result=I %finish %if D2>=4096 %thenstart J=D2&X'FFFFF000' D2=D2&X'FFF' %cycle I=4,1,7 %if Ruse(I)_Use=Fourkmult %and Ruse(I)_Inf=J %then Lastbreg=I %and %result=I %repeat I=Claimbr Add4k(L,I,J) SEtuse(I,Fourkmult,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,U %record(StkFmt) Const u=Ruse(B)_Cl %if u>=0 %Start; ! Can alter B %if D<0 %Start Const=Litone; Const_Intval=-D Op RX(S,B,Const); ! Gets BCTR and other optimisations Forgetuse(b) D=0 %finish %if D>=4096 %start Add4k(A,B,D) D=D&X'FFF' Forgetuse(b) %finish %else; ! Cant alter B make copy %if D>=4096 %or D<0 %thenstart u=ruse(b)_cl %if 4<=B<=7 %then ruse(b)_cl=LOcked X2=SetX2(D) Ruse(B)_CL=U PIX RR(AR,X2,B) B=X2 Forgetuse(X2) %finish %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)_Use=Subareabase %and Ruse(I)_Inf=J %then Lastbreg=I %and %result=I %repeat I=Basereg(Area) K=Claimbr Do RX(L,K,I,Disp) Setuse(K,Subareabase,(Area<<16)!Disp) Lastbreg=K %result=K %end;! Indbase !* %ROUTINE bounded jump(%RECORD (Stkfmt) %NAME Op, %INTEGER min,max,sstad) !*********************************************************************** !* Performs a switch jump with bounds so that the flow of control * !* passes to the next instructio if bounds exceede as reqd by * !* Fortran computed gotos and Pascal cases * !* If the bounds are inside out omit the check(Imp) * !************************************************************************ %INTEGER I,reg1,regb,lab %RECORD (Stkfmt) Bound lab=0 reg1=load int(Op,-1,0); ! To any reg bar 0 %IF max>=min %START; ! do bound check i=setlocalbase(reg1) Einternallab=Einternallab-1 Lab=Einternallab Bound=litone Bound_intval=min %IF min#0 %THEN Oprx(S,reg1,Bound) Bound=litone Bound_intval=max-min OpRX(Cl,reg1,Bound) Pjump(BC,Lab,2,claimjumpreg(reg1)) %FINISH Pix RX(SLL,reg1,0,0,2) Regb=basereg(sst) %if sstad<0 %start bound=litone; bound_intval=-SSTad OP rx(s,reg1,bound) SSTad=0 %finish %IF SSTad>4095 %START Add4k(a,reg1,SSTad) %FINISH Pix rx(L,reg1,reg1,regb,SSTad&4095) Pixrx(BC,15,reg1,R12,0) %IF lab#0 %THEN PLabel(Lab) %END %routine sparse jump(%record(StkFmt)%name Stk,%integer sstbase,labbase,entries) !*********************************************************************** !* Perform a sparse case statement via a table search of SST * !*********************************************************************** %integer reg0,jreg,breg,I reg0=load int(Stk,0,-1) breg=Basereg(SST) jreg=claimjumpreg(Breg) %for I=0,1,entries-1 %cycle DO RX(CL,0,Breg,SSTBase+4*i) Pjump(BC,Labbase+i,8,Jreg) %repeat %end %routine Do RX(%integer Op,Reg,Base,Offset) %integer X2 %if Offset<0 %or Offset>=4096 %then X2=SetX2(Offset) %else X2=0 PIX RX(Op,Reg,X2,Base,Offset) %end;! Do RX !* %routine extractmod(%record(StkFmt)%name Stk,Modstk) !*********************************************************************** !* Stk is a modified operand: Extract the modifier * !* and put into record modify * !*********************************************************************** Modstk=0; ! copy out modifier in case Modstk_form=Stk_Modform Modstk_Reg=Stk_modReg Modstk_base=Stk_Modbase Modstk_offset=Stk_Modoffset Modstk_size=Stk_Msize %end %integerfn Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg) !*********************************************************************** !* result is a register loaded with the modifier (scaled if necessary) * !*********************************************************************** %integer Form,Reg %record(Stkfmt) Temp Form=Stk_Modform&31 extractmod(Stk,Temp) reg=loadint(Temp,-1,Lockedreg) Forgetuse(Reg) %if Stk_Scale#0 %then scalereg(reg,Stk_Scale) Stk_Modform=RegVal Stk_Modreg=reg Stk_Scale=0 %result=Reg %end;! Load Modifier !* %routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) !*********************************************************************** !* generate an RX instruction appropriate to the operand * !*********************************************************************** %integer B2,D2,Modform,Modreg,Exitl,Xreg,Lockd %switch F(0:21) D2=Stk_Offset ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } %if 0<=D2<4096 %start %if Op=L %then DUMPLA(Reg,0,0,D2) %and %return %if Op=C %and D2=0 %then pix rr(LTR,Reg,REg) %and %return %if Op=S %and D2=1 %then pix rr(BCTR,reg,0) %and %return %finish %if X'FFFF8000'<=D2<=X'7FFF' %and %c (Op=L %or Op=C %or Op=A %or Op=S) %then Op=OP-16 %and Stk_size=2 Setint(Stk_Intval,Stk_Size,B2,D2) Do RX(Op,Reg,B2,D2) %return !* F(ConstVal): { const } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } F(TempVal): { (temp) } F(DirVal): { (dir) } %if Op=LA %then DumpLA(REg,0,basereg(Stk_base),d2) %else Do RX(Op,Reg,Basereg(Stk_Base),D2) %if op=st %Start; ! Check for store into recordbase %for modreg=4,1,7 %cycle %if ruse(modreg)_Use=Subareabase %and Ruse(Modreg)_Inf=stk_base<<16!d2 %then Forgetuse(modreg) %repeat %finish %return !* F(RegAddr): { (reg) is @ } F(RegVal): { (reg) } PIX RR(Op-X'40',Reg,Stk_Reg) Funlockreg(Stk_Reg) %return !* F(FregVal): { (freg) } PIX RR(Op-X'40',Reg,Stk_Reg) Funlockfreg(Stk_Reg) %return !* F(IndRegVal): { ((reg)) } DO RX(Op,Reg,Stk_Reg,Stk_Cmval); ! Const modifier may persist Funlockreg(Stk_Reg) %return !* F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } B2=Indbase(Stk_Base,D2) DO RX(Op,Reg,B2,Stk_Cmval); ! Const modifier may persist %return !* F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } B2=Indbase(Stk_Base,D2) Modify: %if Stk_Modform=LitVal %thenstart Do RX(Op,Reg,B2,Stk_Modintval+Stk_Cmval) %return %finish Lockd=B2 Lockreg(B2); ! B2 not necessarily a base register Modreg=Load Modifier(Stk,Reg) Range(B2,Stk_Cmval) PIX RX(Op,Reg,Modreg,B2,Stk_Cmval) Unlockreg(LOckd); ! B2 may be changed by range %return !* F(AddrDirModVal): { (dir+M) } %if stk_modform=Litval %then d2=d2+Stk_Modintval+Stk_Cmval %and ->f(Dirval) Stk_Offset=Stk_Offset+Stk_Cmval; Stk_Cmval=0 Modreg=Load Modifier(Stk,Reg) Lockreg(Modreg) Lockd=Modreg %if Stk_Offset<0 %thenstart Range(Modreg,Stk_Offset) %if ModReg#Lockd %start Funlockreg(Lockd) Lockreg(ModReg) Lockd=Modreg %finish %finishelsestart %if Stk_Offset>4095 %then Add4k(A,Modreg,Stk_offset) %finish PIX RX(Op,Reg,Basereg(Stk_Base),Modreg,Stk_Offset&X'FFF') Funlockreg(Lockd); ! Modreg can be changed by range %return !* F(IndRegModVal): { ((reg)+M) } B2=Stk_Reg funlockreg(B2) Lastreg=B2;! to avoid possibility of a clash when modifying ->Modify !* F(AddrConst): { @const } F(AddrDir): { @dir } exitl=DirVal; ->alladdr !* F(AddrDirMod): { @dir+M } Exitl=AddrDirModVal; ->alladdr !* F(RegModAddr): { (reg)+M } Exitl=IndRegModVal; ->alladdr !* F(TempModAddr): { (temp)+M } Exitl=IndTempModVal; ->alladdr !* F(DirModAddr): { (dir)+M } Exitl=IndDirModVal; ->alladdr alladdr: %if Op=l %then Op=la %and ->f(exitl) xreg=load int(stk,-1,reg) STk_reg=xreg ->f(regval) %end;! OpRX !* %routine Set BD(%record(Stkfmt)%name Stk,%integername B,D) !*********************************************************************** !* provide Base and Dispacement values for accessing the operand * !* Since on IBM architecture you need B&D for operations like MVC * !* and LA the routine treats address as the corresponding item. * !* This is bound to cause problems because if Addrdir can by * !* implication be rereferenced to Dirval so Dirval could be * !* rereferenced to Inddirval which causes an ambiuity. An extra * !* parameter rereference = yes is needed * !*********************************************************************** %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(Addrconst): ! If rerefencing is allowed F(TempVal): { (temp) } F(DirVal): { (dir) } f(AddrDir): B=Basereg(Stk_Base) %unless D>=0 %and D<=4095 %then Range(B,D) %return !* F(IndRegVal): { ((reg)) } B=Stk_Reg D=Stk_Cmval Funlockreg(B) Range(B,D) %return !* F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } ! above two wrongly placed but needed ! for Pascal repeated use of address F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } B=Indbase(Stk_Base,D) D=Stk_Cmval Range(B,D) %return !* F(Tempmodaddr): F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } F(DirModAddr): { (dir)+M } B=Indbase(Stk_Base,D) Modify: %if Stk_Modform=LitVal %thenstart D=Stk_Modintval+Stk_Cmval Range(B,D) %return %finish Modreg=Load Modifier(Stk,B) PIX RR(AR,Modreg,B) Funlockreg(Modreg) B=Modreg D=Stk_Cmval Range(B,D) %return !* f(AddrDirMod): F(AddrDirModVal): { (dir+M) } %if Stk_Modform=Litval %then D=D+Stk_Modintval+Stk_Cmval %and ->F(Dirval) Modreg=Load Modifier(Stk,-1) Lockreg(Modreg) D=D+Stk_Cmval; Stk_Cmval=0 B=Claimr(0) Do RX(LA,B,Basereg(Stk_Base),D) Forgetuse(B) PIX RR(AR,Modreg,B) Funlockreg(Modreg) B=Modreg D=0 %return !* F(RegMOdAddr): F(IndRegModVal): { ((reg)+M) } B=Stk_Reg Funlockreg(B) ->Modify F(*): Abortm("addr has no B&D") %end;! Set BD !* %routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2) !*********************************************************************** !* Support for Fortran Character operations wich may well * !* involve space Filling. THe Parm Ebcdic bit has an effect here * !*********************************************************************** %integer I,Pair1,Pair2,B1,D1,B2,D2,XAop,Reg,spacech spacech=X'20' %if Parmbits1&(2****22)#0 %then spacech=X'40' %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 Lockreg(B1) Set BD(C2,B2,D2) Funlockreg(B1) %if Op=EASGNCHAR %then XAop=MVC %else XAop=CLC PIX SS(XAop,0,LenC1_Intval,B1,D1,B2,D2) %return %finish %finish Address(C1) Pair1=Claimgrpair(R0); ! Not R0 (yet) B1=Load Int(C1,Pair1,-1) Lockreg(Pair1) B2=Load Int(LenC1,Pair1+1,-1) Lockreg(Pair1+1) Address(c2) Pair2=Claimgrpair(Pair1) B1=Load Int(c2,Pair2,-1) Lockreg(pair2) i=LenC2_form %if I=LItval %then LenC2_Intval=LenC2_Intval!(spacech<<24) B2=Load Int(LenC2,Pair2+1,-1) LOckreg(Pair2+1) %if i#Litval %then Do Rx(O,Pair2+1,R9,word const(Spacech<<24)) !* %if Op=EASGNCHAR %then XAop=MVCL %else XAop=CLCL PIX RR(XAop,Pair1,Pair2) Funlockreg(pair1) Funlockreg(pair1+1) Funlockreg(pair2) Funlockreg(pair2+1) %return ; ! Of setcharbase %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=16,1,19 %if Ruse(I)_CL!Ruse(i)_Use#0 %then Freeup Freg(2*(I-16)) %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 %unless Op=4 %and Variant=0 %Start; ! Unless via support proc Reg1=Claimr(-1) Lockreg(Reg1) Reg2=Claimr(Reg1) Lockreg(Reg2) OpRX(L,Reg1,LHS) OpRX(L,Reg2,RHS1) %if Op<=4 %thenstart Reg3=Claimr(Reg1) OpRX(L,Reg3,RHS2) %finish %else reg3=-1 %finish ->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) unlock: Funlockreg(Reg1) Funlockreg(Reg2) %if reg3>0 %then Funlockreg(Reg3) %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) %if Variant=0 %then Pix RR(LER-Adj,4,0) %and Pix RR(LER-Adj,6,2) PIX RX(ME-Adj,0,0,Reg3,0) PIX RX(ME-Adj,2,0,Reg3,0) %if Variant=0 %thenstart 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 %if Variant=0 %thenstart; ! use support procedure Elevel=Elevel+3; ! to allow operands to be pushed Expcall(3+Size,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return %finish 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 %and D=Dl %then PIX SS(MVC,0,D<<1,Reg1,0,Reg2,0) %and ->unlock %if Variant#0 %thenstart; ! not Cx = Cx %if D=4 %and Dl=8 %then PIX RR(SDR,0,0) PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(STE-Adjl,0,0,Reg1,0) %if Variant=2 %then ->unlock; ! Real = Cx ! Cx = Real PIX RR(SER-Adjl,2,2) PIX RX(STE-Adjl,2,0,Reg1,Dl) %else ! 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) Pix RX(STE-Adjl,0,0,Reg1,0) Pix RX(STE-Adjl,2,0,Reg1,Dl) %finish ->unlock S(7): ! CXEQ S(8): ! CXNE CC=Op!!15; ! 8 for CXEq 7 for CXNE PIX RX(LE-Adj,0,0,Reg1,0) I=setlocalbase(-1) PIX RX(CE-Adj,0,0,Reg2,0) Einternallab=Einternallab-1 Pjump(BC,Einternallab,7,0) PIX RX(LE-Adj,2,0,Reg1,D) %if Variant=1 %thenstart PIX RR(LTER-Adj,2,0) %finishelsestart PIX RX(CE-Adj,2,0,Reg2,D) %finish PLabel(Einternallab) CCset=1 ->Unlock !* 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 !* %ROUTINE DUMPLA(%INTEGER REG,X,BASE,DIS) !*********************************************************************** !* A VERSION OF DUMPRX SOLEY FOR LOAD ADDRESS. MAKES ALL THE * !* SHORT CUTS THAT PDS CAN THINK OF * !*********************************************************************** %IF DIS=0 %START; ! VARIOUS NOOPS AND LRS POSSIBLE %IF X=BASE=0 %THEN PIXRR(SLR,REG,REG) %ANDRETURN %IF REG=X>0 %START %IF BASE#0 %THEN PIX RR(AR,REG,BASE) %RETURN %FINISH %IF REG=BASE>0 %START %IF X#0 %THEN PIX RR(AR,REG,X) %RETURN %FINISH %IF BASE=0 %OR X=0 %THEN PIX RR(LR,REG,BASE+X) %ANDRETURN %FINISH %IF X=0 %OR BASE=0 %THEN DO RX (LA,REG,BASE!X,DIS) %and %return ! IMPROVES CODE IF DIS>4095 %IF DIS<0 %OR DIS>4095 %THEN range(BASE,DIS) PIX RX(LA,REG,X,BASE,DIS) %END %INTEGER %FN LONG CONST(%LONG %INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE DESCRIPTOR CONSTANT * !*********************************************************************** %INTEGER K STORE CONST(K,8,ADDR(VALUE)) %RESULT=K %END %INTEGER %FN WORD CONST(%INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS * !*********************************************************************** %INTEGER K STORE CONST(K,4,ADDR(VALUE)) %RESULT=K %END %INTEGER %FN SHORT CONST(%INTEGER VALUE) !*********************************************************************** !* STORE A 16 BIT CONSTANT VIA STORE CONST * !*********************************************************************** %INTEGER K STORE CONST(K,2,ADDR(VALUE)+2) %RESULT=K %END %ROUTINE STORE CONST(%INTEGER %NAME D, %INTEGER L,AD) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I,J,K,C1,C2,C3,C4,LP,Rl LP=(L+3)//4; C1=0; C2=0; C3=0; C4=0 rl=4; %IF l=8 %THEN rl=8 %IF l=2 %OR l=6 %THEN rl=2 ->insert %IF l>8 %and l#16; ! dont look up long strings %CYCLE I=0,1,L-1 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) %REPEAT K=0 %if L&1=1 %then l=l+1 %IF L=2 %START J=CONST PTR %FOR K=K,1,J-1 %CYCLE %IF k=consthole %THEN %CONTINUE %IF C1=CTABLE(K)&X'FFFF0000' %THEN D=4*K %AND %RETURN %IF C1=CTABLE(K)<<16 %AND k#halfhole %THEN D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %IF L=4 %THEN %START J=CONST PTR ! %IF USE IMP=YES %THEN %START %FOR K=K,1,J-1 %CYCLE %IF CTABLE(K)=C1 %AND CONSTHOLE#K#HALFHOLE %THEN D=4*K %AND %RETURN %REPEAT ! %FINISH %ELSE %START ! %FINISH %FINISH %ELSE %IF L=6 %START %FOR K=K,1,CONST PTR-2 %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)&X'FFFF0000'=C2 %AND %C (CONSTHOLEK+1) %AND (HALFHOLEK+1) %THEN D=4*K %AND %RETURN %IF CTABLE(K)<<16=C1&X'FFFF0000' %AND %C C1&X'FFFF'=CTABLE(K)>>16 %AND CTABLE(K+1)>>16=C2 %AND %C (CONSTHOLEK+1) %AND (HALFHOLEK+1) %THEN D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND (CONSTHOLE=K+LP) %AND (HALFHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %AND CTABLE(K+3)=C4) %THEN %C D=4*K %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=2 %START %IF HALFHOLE#0 %THEN %START CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) D=4*HALFHOLE+2 HALFHOLE=0 %RETURN %FINISH %IF CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 HALFHOLE=CONSTHOLE CONSTHOLE=0 D=4*HALFHOLE %RETURN %FINISH %IF const ptr>16 CTABLE(CONSTHOLE)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0; CONSTHOLE=0 %RETURN %FINISH %IF 0>16 CTABLE(CONSTPTR)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0 CONST PTR=CONST PTR+1 %RETURN %FINISH %IF const ptroverrun %IF lp+const ptr>const limit %IF rl=8 %AND CONST PTR&1#0 %THEN %C CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR %FOR i=0,1,l-1 %CYCLE byteinteger(addr(ctable(const ptr))+i)=byteinteger(ad+i) %REPEAT CONST PTR=CONST PTR+lp %RETURN overrun: ! table full hand excess to put curcnst=(curcnst+rl-1)&(-rl) pdbytes(cnst,curcnst,l,ad) d=curcnst curcnst=curcnst+l %END !* !*********************************************************************** !* %externalroutine Eclear %alias"E#CLEAR" { Dummy on Amdahl } %end { of Eclear } !* !* %externalroutine Ebrefer %alias"E#BREFER"(%integer Offset,Bytes) { Dummy } %end !* %externalroutine estkpf %alias"E#STKPF"(%Integer i,j) %end %externalroutine eprefer %alias"E#PREFER"(%integer i,j) %end %externalroutine etrap %alias"E#TRAP"(%integer Trapop,error) %if increports#0 %and report#0 %Start printstring("Etrap "); write(Trapop,5); write(error,5) newline %Finish Int binary op(trapop,Stk(elevel-1),stk(elevel)) Elevel=Elevel-2 pix rx(la,R0,0,0,error) ejump(JTRUE,Pastraplab) %end %externalroutine egenerateobject %alias"E#GENERATEOBJECT"(%stringname s) %end ! %integerfn FindExternalName(%string(255) %name Ename) !**************************************************************************** !* If Ename is an already-known external name then return offset in GLA !* of its descriptor else return negated hash value for future use. !**************************************************************************** %integer i, h, p h = 0 %cycle i = length(Ename), -1, 1 h = ((h << 1) + CHARNO(Ename, i)) & X'1FFFFFFF' %repeat h = h - ((h // HASHPRIME) * HASHPRIME) + 1 p = ExHash(h) %while p <> 0 %cycle %if STRING(ExNames(p)_nameaddr) = Ename %then %exit p = ExNames(p)_chain %repeat %if p <> 0 %then %result = ExNames(p)_refaddr %else %result = -h %end { FindExternalName } ! %routine SaveExternalName(%string(255) %name Ename, %integer h, ref) !************************************************************************** !* Record a new external name for future use. Parameter h is the name's !* hash value. !************************************************************************** %integer l, n, p, s %if NextName > MAXEXNAMES %then Abortm("Too many external names") n = NextName NextName = NextName + 1 l = length(Ename) + 1 %if ((NextNameStore + l - addr(ExNameStore(1))) > MAXEXNAMESTORE) %c %then Abortm("Not enough external name store") s = NextNameStore NextNameStore = NextNameStore + l STRING(s) = Ename ExNames(n)_nameaddr = s ExNames(n)_refaddr = ref ExNames(n)_chain = 0 p = ExHash(h) %if p = 0 %then ExHash(h) = n %and %return %while ExNames(p)_chain <> 0 %cycle p = ExNames(p)_chain %repeat ExNames(p)_chain = n %return %end { SaveExternalName } ! %endoffile