! ! Copyright P.D.Stephens 1988 ! This is a modified Ecode generator with chenges so that it is available ! for rapid implementation of a complete compiler system. The aim is to be able ! to bring up EMAS compilers fast on another system if there is a big bang ! change in the near future. Also this version is intended to be "Definitive" ! ie to define what some of the more specialised operations have to do. ! To aid this extended commentary has been added. ! ! The following changes have been made from a standard generator ! ! 1) All eops go via one routine(EOP). The Ef77op, Epasop etc are dummies ! ! 2) As many specialized operations as possible are re-implemted in terms ! of simplier Ecode operations. This makes the generator highly recursive ! ! 3) Address and refer are implemented as far as possible via state ! transitions not by planting code ! ! 4) A routine Trapjump (QV) has been introduced to tidy up error exits ! %include "ercc07:itrimp_hostcodes" %constinteger host=ibmxa %constinteger target=Vax %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 Eprocenv(%integer 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 * !*********************************************************************** !* %externalintegerfnspec Etempworkspace(%integer size{in byte}) ! %include "ercc07:vaxspecs" %include "ercc07:vaxopcodes" %include "ercs01:ebits_ecodes28" %include "ercs01:ebits_enames21" !include "ercc10:opouts" !* !* !*********************************************************************** !* Common declarations * !*********************************************************************** !* !* !* !*********************************************************************** !* %constinteger LitVal = 0 { lit } %constinteger ConstVal = 1 { const } %constinteger RegVal = 2 { (reg) } %constinteger FregVal = 3 { (freg) } %constinteger TempVal = 4 { (temp) } %constinteger DirVal = 5 { (dir) } %constinteger IndRegVal = 6 { ((reg)) } %constinteger IndTempVal = 7 { ((temp)) } %constinteger IndDirVal = 8 { ((dir)) } %constinteger AddrConst = 9 { @const } %constinteger AddrDir = 10 { @dir } %constinteger RegAddr = 11 { (reg) is @ } %constinteger TempAddr = 12 { (temp) is @} %constinteger DirAddr = 13 { (dir) is @ } %constinteger AddrDirMod = 14 { @dir+M } %constinteger RegModAddr = 15 { (reg)+M } %constinteger TempModAddr = 16 { (temp)+M } %constinteger DirModAddr = 17 { (dir)+M } %constinteger IndRegModVal = 18 { ((reg)+M) } %constinteger IndTempModVal = 19 { ((temp)+M) } %constinteger IndDirModVal = 20 { ((dir)+M) } %constinteger AddrDirModVal = 21 { (@dir+M) } %constinteger RegBitAddr = 22 { (reg) is @ } %constinteger RegBitModAddr = 23 { (reg)+M } %constinteger 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} %constbyteintegerarray Demodform(14:21)= %c AddrDir, RegAddr, TempAddr, DirAddr, IndRegVal, IndTempVal, IndDirVal, Dirval; ! ! 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 liberties 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 area ! (or register). Pointers are 32 bit items. ! ! Modified Forms ! -------------- ! ! IndRegModVal ! Corresponding address form:- RegModAddr ! ! The operand is anywhere 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 temporary) 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 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 %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 Min Elevel(0:790)=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(188), 2(6),0(3),2,2,0(3),2,0(4){ to 529}, 2(7),1,2,0(7),4,3,3,0(9),1(3){to EOLop=560}, 0(13),1,0(26),1(7),0(3),1(3),0,1{PERROR=615}, 0(4),3,3,4,3,4,3(3),4,3{CHKNE=629}, 1(9),0,1(3),0,1(2){ICLCPTR=645}, 0(122) {to Cops}, 0(3),2,1,2,3,4 {775 Estbits}, 2(3),0,2(6),1,1,1,2,0; %owninteger Unasslab,Bounderr,Pastraplab,parmbits1 !* !* !*********************************************************************** !* VAX/VMS-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 AP = 12 %constinteger FP = 13 %constinteger SP = 14 %constinteger PC = 15 %constinteger Dispptrreg=R6 %constinteger indexmode = x'40' %constinteger regmode = x'50' %constinteger regdefmode = x'60' %constinteger autodecmode = x'70' %constinteger autoincmode = x'80' %constinteger autoincdefmode = x'90' %constinteger bytedispmode = x'A0' %constinteger bytedispdefmode = x'B0' %constinteger worddispmode = x'C0' %constinteger worddispdefmode = x'D0' %constinteger longdispmode = x'E0' %constinteger longdispdefmode = x'F0' %constinteger immediate = x'8F' %constinteger absolute = x'9F' %constinteger byterelmode = x'AF' %constinteger bytereldefmode = x'BF' %constinteger wordrelmode = x'CF' %constinteger wordreldefmode = x'DF' %constinteger longrelmode = x'EF' %constinteger longreldefmode = x'FF' %externalintegerspec CA; ! Ca maintained by put !* !* %constbyteintegerarray Setcc(0:5)=2,4,8,7,10,12 {GT LT EQ NE GE LE} %constbyteintegerarray Invcc(0:31)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15, 16+0,16+1,16+4,16+5,16+2,16+3,16+6,16+7,16+8,16+9,16+12,16+13,16+10,16+11,16+14,16+15 !* %constinteger Stack Offset=0 %constinteger Param Offset=4 %constinteger display offset=-4 %ownintegerarray param space(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'81818181', X'81818181', 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=15 %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 %owninteger CC, CCset, Oflowmask=8 %owninteger Glaf77regs,Curdiagca, OuterLNBDisp %owninteger CurCnst,Ptr to Cnsts %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 %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 MaskOflow %routinespec UnmaskOflow %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) %integerfnspec Regumask(%record(StkFmt)%name Stk) %routinespec fixedmove(%integer Opcode,%record(StkFmt)%name Len,Srce,dest) %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,Size) %routinespec UnLockreg(%integer Reg) %routinespec UnLockfreg(%integer freg,Size) %routinespec forgetuse(%integer Reg) %routinespec forgetfuse(%integer Freg,Size) %routinespec Funlockreg(%integer Reg) %routinespec Funlockfreg(%integer freg,Size) %routinespec setuse(%integer REg,Use,Inf) %routinespec setfuse(%integer Freg,use,Inf,Size) %routinespec Regclaimed(%integer REg,Elevel) %routinespec Fregclaimed(%integer Freg,Elevel,Size) %routinespec Clear Regs %routinespec Dropall %routinespec Freeup Freg(%integer R,Size) %routinespec Freeup Reg(%integer R) %routinespec Freeregs(%integer Mask) %routinespec Reset Reguse(%integer Old,New) %integerfnspec Claimfr(%integer Curreg,Size) %integerfnspec Claimr(%integer Curreg) %integerfnspec ClaimBR %integerfnspec claimgrpair(%integer notthis) %integerfnspec New Temp(%integer Bytes) %routinespec Setint(%integer Val,Size,%integername B2,D2) %integerfnspec Basereg(%integer Area) %routinespec Scalereg(%integer reg,scale) %integerfnspec Indbase(%integer Area,Disp) !%routinespec Do set addr(%integer area,offset,Areg) %routinespec Do Rx(%integer Op,Reg,%record(StkFmt)%name Stk) %routinespec Do XR(%integer op,%record(StkFmt)%name Stk,%integer REg) %routinespec Do X(%integer Op,%record(StkFmt)%name Stk1) %routinespec Do XX(%integer op,%record(StkFmt)%name Stk1,Stk2) %routinespec Do XXR(%integer op,%record(StkFmt)%name Stk1,Stk2,%integer Reg) %routinespec Do R(%integer op,Reg) %routinespec Do RR(%integer opcode,reg1,Reg2) %routinespec Do RRR(%integer opcode,R1,R2,R3) %routinespec DoRLit(%integer opcode,Reg,Lit,Size) %routinespec Do LitR(%integer Opcode,Lit,Size,Reg) %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 Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2) %ROUTINE %SPEC store const(%INTEGER %NAME d, %INTEGER l,ad) %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 Simplify Opnd(%integer op,%record(Stkfmt)%name Stk) %routinespec Do Operand(%record(StkFmt)%name Stk,%integer op,dest) !* !*********************************************************************** !* %ownstring(8)%array Areas(0:255)= %c "Stack ","Code ","Gla ","","Shrd ST","Gla ST ","Diags ","Params", "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)="R0","R1","R2","R3", "R4","R5","R6","R7", "R8","R9","R10","R11", "AP","FP","SP","PC" %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 10<=I<=15 %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 E==Stk(I) 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) %if E_Adid#0 %then printstring(" ID=".string(E_Adid)) newline I=I-1 %repeat %end;! Dump Estack !* !********************************************************************** !********************************************************************** !** Error reporting ** !********************************************************************** !********************************************************************** !* !* %string(11)%fn Opname(%integer Opcode) !*********************************************************************** !* Gives the name for Opcode !*********************************************************************** %if opcode>=768 %then %result=ecopname(opcode) %if opcode>=511 %then %result =Epasopname(opcode) %if opcode>=256 %then %result =Ef77opname(opcode) %result=Eopname(opcode) %end %routine Low Estack(%integer Opcode,Reqlevel) printstring("******* Estack error ****** Op = ".opname(Opcode)." actual/required levels:") write(Elevel,4) write(Reqlevel,4) newline %monitor %stop Elevel=0 %end;! Low Estack !* %routine Abort Dump Estack %monitor %stop %end;! Abort !* %routine abortm(%string(31) S) printstring(" *** Xgen abort - ".S." *** ") Dump Estack %monitor %stop %end;! abortm !* %routine Unsupported Opcode(%integer Opcode) !*********************************************************************** !* Reports an unimplemented operation * !*********************************************************************** printstring("******* Unsupported Opcode ****** ".Opname(Opcode)) 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=10,1,15 CCset=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} %if host=target %then i=Lang<<24!Options %else %c i=options<<24!(options>>8<<16)!lang Pd4(Gla,16,I) 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(8) %finish Glaf77regs=I ! Pfix(Gla,I,Static,0) Ptr to Cnsts=I+4 Pfix(Gla,Ptr to Cnsts,Cnst,0); ! Fix word to point at const table !* const ptr=bytesofic>>2 ctable(i)=cnstinit(i) %for i=0,1,const ptr-1 Curcnst=4*(const limit+1) const hole=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 Popcode(NOP) %if language=Pascal %Start; ! set up pascal traps Einternallab=einternallab-2 Pastraplab=Einternallab unasslab=Pastraplab+1 Plabel(Unasslab) Do LitR(MOVZWL,343,2,R0) PLabel(Pastraplab) I=Exname(0,spprocs(9)) spprocref(9)=i Eprecall(i) DoR(PUSHL,R0) Ecall2(i,1,1,4) %finish; ! must not return %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 Pterminate(addr(S(1))) 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,id %if increports#0 %and Report#0 %thenstart printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name) Newline %finish %if ProgFaulty#0 %then %return %if Name="F#BLCM" %then Prop=1 %else Prop=2 Id=Pcommon(name) Areaprops(Area)=Prop!(Id<<16); ! Props dont usually need more than 8 bits %end;! Ecommon !* %externalroutine Eendcommon {%alias"E#ENDCOMMON"}(%integer area,Length) !*********************************************************************** !* define length of previously defined common * !*********************************************************************** %integer i %if increports#0 %and Report#0 %thenstart printstring("Eendcommon ");write(Area,1);write(Length,6) Newline %finish %if ProgFaulty#0 %then %return i=Areaprops(Area) Pendcommon(I>>16{Id},Length,I&X'FFFF'{Props}) %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) %end;! Elinestart !* %externalroutine Elinedecode {%alias"E#LINEDECODE"} !*********************************************************************** !* decompile code generated from last Elinedecode or Elinestart * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Elinedecode"); newline %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 reg=claimr(0); ! zero wont work Popcode(MOVZWL) PB(Immediate) markval=Pmarker(1) PB(REgmode!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,0,Newvalue); ! Fill the Value %end;! Esetmarker !* %externalintegerfn Eswapmode {%alias"E#SWAPMODE"} !*********************************************************************** !* Specify the swapping needed for compiler produced data * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eswapmode ") %finish %if host=target %then %result=0 %result=X'10007' %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 * !* ********************* !* ! ! Notes on the Vax stack ! It seems desirable that Ecode should be able to be called by both CALLS ! and CALLG opcodes event tho only CALLS will be planted. It also seems ! desirable that the mask feature can be used to speed up procedure calls ! by storing the minimum number of registers. either of these preclude ! Parameters being found from LNB (FP). Consequently the parameters are ! found by AP and global parameters via a stored value of AP in the display ! which is enlarged by 4 bytes specially. Parameters are not in the frame and ! Eprocend must deduct paramsize from Localspace accordingly ! ! Thus Fp-4 = Stored value of Ap ! FP-8 = Gla pointer (Need for Diags ) ! FP-12 = Display level 1 etc ! ! This means that all parameters must be referenced via Estackparam ! attempts to use Estackdir or Estackglobal will fail ! %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 Abortm("Estk Overflow") %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) space; Phex(integer(ad)) %if Len=8 %then Phex(Integer(ad+4)) 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 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 Abortm("Estk Overflow") 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 Abortm("Estk Overflow") %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 Abortm("Estk Overflow") %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-4-(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+Stack Offset %if Elevel=stkmax %then Abortm("Estk Overflow") %if CCSet#0 %then Establish Logical %if Level=0 %or Level=Proclevel %thenstart Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 Lstk_Form=IndDirVal Lstk_Base = 0 Lstk_Offset=Offset Lstk_Size=Bytes Lstk_Adid=Adid %finishelsestart Estkglobal(Level,Offset-Stack Offset,Adid,4) Erefer(0,Bytes) %finish %end;! Estkgind !* %externalroutine Estkpar {%alias"E#STKPAR"}(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct parameter operand * !*********************************************************************** %record(StkFmt)%name Lstk %if increports#0 %and report#0 %Start printstring("Estkpar "); write(Level,1); write(Offset,1) write(Bytes,1) %if Adid#0 %then spaces(3) %and printstring(string(adid)) newline %finish %if ProgFaulty#0 %then %return %if Elevel=stkmax %then Abortm("Estk Overflow") %if CCset#0 %then Establish Logical Offset=Offset+Param Offset %if Level=0 %then Level=Proclevel; ! 0 Shorthand for current frame %if Level=Proclevel %Start; ! Via current AP Elevel=Elevel+1 Lstk==Stk(Elevel) Lstk=0 Lstk_Form=Dirval Lstk_Base=7 Lstk_Offset=Offset Lstk_Size=bytes Lstk_Adid=Adid %return %finish Estkglobal(level,-4,0,4); ! Relevant AP from Global frame Erefer(Offset,Bytes) %end;! Estkpar !* %externalroutine Estkparind {%alias"E#STKPARIND"}(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect parameter operand * !*********************************************************************** EstkPar(Level,offset,Adid,4) Erefer(0,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(R0,Bytes) %finishelse %if Type=3 %thenstart Elevel = Elevel + 1 %if Elevel>stkmax %then Abortm("Estk Overflow") Stk(Elevel) = 0 Stk(Elevel)_Form = RegAddr Stk(Elevel)_Reg = R0 regclaimed(R0,Elevel) Stk(Elevel)_Size = Bytes %finishelsestart Stackr(R0) %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 Estkreg(Regvarval(I),0) Estkdir(Stack,Regvaroffset(I),0,Regvarsize(I)) Eop(Estore) %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 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 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(18:164) %constbyteintegerarray TSTform(1:4)=TSTB,TSTW,HALT,TSTl; %integer XAop,Bytes,J %record(StkFmt)%name Estktos,Estktosm1 %if increports#0 %and Report#0 %thenstart printstring("Ejump ".Opname(Opcode));write(Labelid,4) newline Dump Estack %finish %if ProgFaulty#0 %then %return %if opcode=cjfalse %then opcode=jfalse J=Min Elevel(Opcode) %if J>0 %and Elevel1 %then Estktosm1==Stk(Elevel-1) Bytes=Estktos_Size ->Op(Opcode) !* Op(*):%monitor %stop !* Op(JIGT): Op(JILT): Op(JIEQ): Op(JINE): Op(JIGE): Op(JILE): CC=Setcc(Opcode-JIGT) Elevel=Elevel-2 %if Estktos_Form=Litval %and Estktos_Intval=0 %then %c Elevel=Elevel+1 %and Ejump(JINTGZ-JIGT+Opcode,Labelid) %and %return Int Binary Op(IGT+Opcode-JIGT,Estktosm1,Estktos) CCset=0 ->jump !* Op(JUGT): Op(JULT): Op(JUEQ): Op(JUNE): Op(JUGE): Op(JULE): CC = Setcc(Opcode-JUGT)+16 Elevel=Elevel-2 %if Estktos_Form=Litval %and Estktos_Intval=0 %then %c Elevel=Elevel+1 %and Ejump(JUGTZ-JUGT+Opcode,Labelid) %and %return Int Binary Op(UGT+Opcode-JUGT,Estktosm1,Estktos) CCset = 0 ->jump !* Op(JINTGZ): Op(JINTLZ): Op(JINTZ): Op(JINTNZ): Op(JINTGEZ): Op(JINTLEZ): Elevel=Elevel-1 %if Bytes>4 %then Bytes=4 Do X(TSTForm(Bytes),Estktos) cc=Setcc(Opcode-JINTGZ) %if Bytes=1 %then cc=cc+16; ! Force unsigned comparison ->jump !* Op(JUGTZ): Op(JULTZ): Op(JUEQZ): Op(JUNEZ): Op(JUGEZ): Op(JULEZ): Elevel=Elevel-1 Bytes=4 %if Bytes>4 Do X(TSTform(Bytes),Estktos) CC=Setcc(Opcode-JUGTZ)+16 ->jump !* Op(JUMP): CC=15 jump: Pjump(BCond,Labelid,CC) %return !* Op(JRGT): Op(JRLT): Op(JREQ): Op(JRNE): Op(JRGE): Op(JRLE): CC=Setcc(Opcode-JRGT) Elevel=Elevel-2 Real Binary Op(RGT+Opcode-JRGT,Estktosm1,Estktos) CCset=0 ->jump !* Op(JRGZ): Op(JRLZ): Op(JRZ): Op(JRNZ): Op(JRGEZ): Op(JRLEZ): Elevel=Elevel-1 %if Bytes=4 %then XAop=TSTF %else XAop=TSTG Do X(XAop,Estktos) 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 Do X(TSTL,Estktos) CC=7 %finish %else CCset=0 %If OPcode=JFALSE %then CC=CC!!15; ->jump %end;! Ejump %routine Etrapjump(%integer Opcode,label,Trapno) !*********************************************************************** !* If some condition is true jump to label with error number * !* on display. Easier said than done as we can not jump with * !* anything in the Estack which in any event has atleast true * !* or false on top. On Vax anything chanes condition code * !* so may have to jump around a jump. Other machines may demand * !* different solutions. Trapno is small and positive * !*********************************************************************** %if Opcode=JUMP %or Trapno<=0 %start %if Trapno>0 %then Do RLit(MOVZWL,R0,Trapno,2) EJUMP(Opcode,Label) %return %finish Einternallab=Einternallab-1 Abortm("Unimplemented trap") %unless opcode=JTRUE %or Opcode=JFALSE Ejump(JTRUE+JFALSE-opcode,Einternallab) Do Rlit(MOVZWL,R0,Trapno,2) Ejump(JUMP,Label) Plabel(Einternallab) %end !* %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 ".Opname(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) Do R(TSTL,Reg1) %finishelsestart Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then Op=TSTF %else Op=TSTG DoR(Op,Freg1) %finish %if Lab1>0 %then Pjump(BCond,Lab1,4);! if < 0 %if Lab2>0 %then Pjump(BCond,Lab2,8);! = 0 %if Lab3>0 %then Pjump(BCond,Lab3,2);! > 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) ! ! 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 %start Pswitchlabel(curswitch_sstad,entry) %finish 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) 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) POPcode(MOVL); PB(Regmode!FP);PBDisp(longdispmode!R11,OuterLNBDisp) %finish POpcode(MOVL);PB(Regmode!SP);PBDisp(longdispmode!FP,DisplayOffset-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) POpcode(MOVL); PBDISP(Longdispmode!R11,OuterLNBDisp) PB(Regmode!FP); ! Loads LNB from Gla %finishelsestart { Inner level } Popcode(MOVL); PBDisp(Longdispmode!FP,Display Offset-Level<<2) { Loads LNB } PB(Regmode!FP) %finish POpcode(JMP); ! Jump to address fixed up in gla by Estmntlabel PBDISP(longdispdefmode!R11,Offset+Gla Offset) %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,CA) POpcode(MOVL); PBDisp(Longdispmode!FP,DisplayOffset-4) %finish ELabel(LabId) %end;! Estmtlabel !* !* !* !* ******************************* !* * Data initialisation, fixups * !* ******************************* !* !* %externalroutine Ed1 {%alias"E#D1"}(%integer area, Disp, Val) !*********************************************************************** !* intialise an 8-bit location * !*********************************************************************** %integer Ad ad=addr(val) %if Host#Vax %then Ad=Ad+3 %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, Ad) %end;! Ed1 !* %externalroutine Ed2 {%alias"E#D2"}(%integer area, Disp, Val) !*********************************************************************** !* intialise a 16-bit location * !*********************************************************************** %integer Ad ad=addr(val) %if Host#Vax %then Ad=Ad+2 %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, Ad) %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)<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); ! No point in vax cant addin a reloc Pfix(area,disp, tgtarea,Tgtdisp) %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* !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("EXname ".Xref);write(Type&15,4);write(Type>>4,4) newline %finish type=type!(parmbits1>>20&1); ! or in dynamic bit pro tem %result=PXname(Type&1,Xref) %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 CCset#0 %then Establish Logical Active Calls = Active Calls + 1 %if Active Calls>1 %thenstart %finish Next Param Offset=0; ! May no longer be needed %end;! Eprecall !* %externalroutine Ecall2 {%alias"E#CALL2"}(%integer Id,Extlev,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %integer X2 %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(3!1<>2); ! Let Put plant the CALLS %if Active Calls>1 %thenstart %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 * !*********************************************************************** %if increports#0 %and Report#0 %thenstart printstring("Eprocref ");write(Id,4); write(level,4) newline %finish Freeupreg(R0) Pcall(-Id,0); ! Negative address means get adr to R0 Stackr(R0) Eprocenv(Level) 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) Freeupreg(R0) Pcall(-I,0) Stackr(R0) Estkdir(area,Offset,0,4) Eop(Estore) %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>0 %thenstart Estkdir(0,Display Offset-4-Level<<2,0,4) %finishelse Estklit(0); ! 0= No env needed %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 Refad=Pnextsymbol %if increports#0 %and Report#0 %thenstart printstring(" key ="); write(Refad,1) newline %finish %result=Refad %end;! Enextproc !* !* %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 * !* * !* PDS thinks props is as follows:? * !* 2**0 Set if external * !* 2**1 Set if main entry (2**31 is used by Fortran!) * !* 2**2 Set if display not required (Implied for Fortran & C) * !* 2**3 Set if there are no local variables * !* 2**4 Set if this is a side entry (Do all these go via eentry?* !* 2**5 Set if there are no internal blocks or procedures * !* 2**14 Set if first param is a word * !* 2**15 Set if first param a Dword Used if Numpars = 1? * !* 2**16-2**23 Byte giving nesting level of procedure * !* The level bits, if zero, mean the next textual level but * !* enable Pascal to define the level without using Eproclevel which * !* is no longer needed. The absence of notes probably cause AH to * !* introduce this procedure * !*********************************************************************** %integer I,Dopl %record(StkFmt) Wk %constintegerarray dcopyop(1:4)=MOVL,MOVQ,MOVO,MOVO; %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 i=Props>>16&255; ! Level or zero %if i#0 %then proclevel=I %else Proclevel=Proclevel+1 Dopl = (ParamOffset + ParamSize + 3) & (\3) %if Language=PASCAL %or language=IMP %thenstart Param space(proclevel) = Dopl %finish Upperlineno = -1; Currlineno=-1 ProcProps=Props %if Props&2#0 %then Props=X'80000001' %else Props=Props&1 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) %if Props&1#0 %start Popcode(MOVL) PBDisp(longdispmode!R11,Ptr to Cnsts) PB(Regmode!r10); ! Const area base from gla -> R10 %finish Curdiagca=-1 %if Language#FORTRAN %thenstart %if 0#Astacklen#-1 %then Addrstackca=Astacklen integer(addrstackca) = (integer(addrstackca)+3)&(\3) Popcode(SUBL2) PB(Immediate) Procmark(proclevel)=PMarker(2);! To be filled with frame size at procend PB(Regmode!SP) ! ! If we are going to check top of stack it must be done here before any ! refenece is made to SF which might be invalid. If limit is exceed careful ! cutting back is needed for diagnostics ! %if Parmbits1>>4&1=0 %and Language=Pascal %Start;! Perform top of stk check ! Pascal fault 451 if check fails Einternallab=Einternallab-1 Wk=0; Wk_Form=Inddirval;! Pointer to top of stack value Wk_Base=Gla; Wk_Offset=28; Wk_Size=4 Do RX(CMPL,SP,Wk);! Check Sp aginst limit Pjump(BCond,Einternallab,4) Do RR(MOVL,FP,SP); ! cut back stack Popcode(MOVL); PBDisp(longdispmode!FP,12); PB(Regmode!FP);! old value of FP For diags Do Rlit(MOVL,R0,451,4) Pjump(BCond,Pastraplab,15) Plabel(Einternallab) %finish ! ! Set up all that is neede of a display ! %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 ! ! If external store Gla disp into FP-8 unless no diagnostics ! %unless parmbits1&X'800004'=X'800004' %then %Start POpcode(MOVL); PB(Regmode!R11); PBDisp(Longdispmode!FP,-8) %finish %else; ! Internal ! ! For internal procedures set a MOVC to copy Gla and all global pointers ! using the display address passed in Dispptrreg ! %if 1<=Proclevel<=4 %then POpcode(Dcopyop(Proclevel)) %else %start POpcode(MOVC3); PLit(4*Proclevel,1) %finish PBDisp(Longdispmode!Dispptrreg,-4-4*Proclevel) PBDisp(Longdispmode!FP,-4-4*Proclevel) %Finish ! ! Store AP on front of the display unless no internalsand no diags ! %if procprops&32=0 %or parmbits1&x'800004'#x'800004' %Start POpcode(MOVL); PB(Regmode!AP); PBDisp(Longdispmode!FP,-4) %finish ! ! Add the current frame pointer on to display unless no internalsand no diags ! %if Procprops&32=0 %or parmbits1&x'800004'#x'800004' %Start POpcode(MOVL); PB(Regmode !FP) PBDisp(Longdispmode!FP,-8-4*Proclevel) %finish %finish %if parmbits1&X'10010'=0 %or (Language=Ccomp %and %c parmbits1&X'410'=X'410'{ZERo,nocheck}) %Start; ! unassigned checking not inhibited ! ! Set up a five operand move to fill frame with unassigned note this ! will corrupt R0-R5 inclusive (!) ! Popcode(SUBL3); PB(Regmode!SP) PB(Regmode!FP); PB(Regmode!R0);! R0=FP-SP = Frame size %if (Language=Imp %or Language=Pascal) %and ProcProps&4=0 %thenc DoLitR(SUBL2,4*proclevel+8,4,R0);! Minus display space POpcode(MOVC5); Plit(0,1); ! Source opnd zero length PB(Regdefmode!SP); ! source opnd at SF %if parmbits1&X'410'=X'410' %then Plit(0,1) %else Plit(X'80',1) PB(regmode!R0); PB(Regdefmode!SP);! destsize=R0 Freeregs(X'3f'); ! Corrupted regs %Finish %if ProcProps&2#0 %thenstart;! main entry %finish %finish %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+15)&(-16) PSetOpd(ProcMark(proclevel),0,Localsize&X'FFFF') PSetOpd(Procmark(proclevel),1,localsize>>16) %if 0#Astacklen#-1 %then Addrstackca=Astacklen %finish DropAll 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 Pprocend(Localsize); ! Does nothing at the moment %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 PProc(Name,16!2,Numpars<<16!Paramsize,Index) Dropall %if Language=Fortran %thenstart Localsize=Localsize+Stack Offset POpcode(SUBL2) Plit(Localsize,4) PB(Regmode!FP) %if ProcProps&2#0 %thenstart;! main entry %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#EOP"} (%integer opcode) !*********************************************************************** !* opcodes with general applicability * !*********************************************************************** %record(StkFmt)%name Lstk,Estktos,estktosm1 %constbyteintegerarray ChOp(MVB:CPBLE) = MOVC3, 0(2), MOVC3, 0(2), CMPC3(6) %constbyteintegerarray Pchop(CHKLT:CHKNE)=ILT,IGT,0(3),ULT,UGT,UNE,0,INE; %constintegerarray Bmaskval(0:31) = %c x'1',x'3',x'7',x'f',x'1f',x'3f',x'7f',x'ff', x'1ff',x'3ff',x'7ff',x'fff',x'1fff',x'3fff',x'7fff',x'ffff', x'1ffff',x'3ffff',x'7ffff',x'fffff', x'1fffff',x'3fffff',x'7fffff',x'ffffff', x'1ffffff',x'3ffffff',x'7ffffff',x'fffffff', x'1fffffff',x'3fffffff',x'7fffffff',x'ffffffff' %constintegerarray Uopst(0:3) = IADDST,ISUBST,IMULTST,IDIVST %constintegerarray Ropst(0:9) = RADD,RSUB,RMULT,RDIV,ISHLL,ISHRL,0(3),ISHRA; %owninteger depth=0 %integer Reg1,Reg2,Reg3,Freg1,Freg2,Bytes,B1,D1,XAop,Form,I,J, Flags,XAop1,Lab,Adj,Relop %integer Reg,d,dx,upper,lower,trapno,Bstart,Nbits,Bmask,Bshift,Bitval %record(stkfmt) low,up,Work %switch Op(0:255),F77op(256:320),Pasop(511:645),Cop(768:790) %if increports#0 %and Report#0 %thenstart %if depth>0 %then printstring("recursive ") printstring("Eop ".opname(opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 j=Min Elevel(opcode) %if j>0 %and elevel1 %then Estktosm1==stk(Elevel-1) depth=depth+1 %if Opcode>=768 %then ->Cop(Opcode) %if opcode>=511 %then ->Pasop(opcode) %if Opcode>=256 %then ->F77op(Opcode) ->Op(Opcode) !* Op(*): F77op(*): Pasop(*): Cop(*): Unsupported Opcode(Opcode) ->wayout !* Op(HALT): %if Elevel>=2 %and Stk(Elevel)_Form=Litval=Stk(Elevel-1)_Form %Start Elevel=Elevel-2 I=Stk(Elevel+1)_Intval %if Stk(Elevel+2)_Intval=4 %then Pb(I>>24) %and Pb(I>>16&255) Pb(I>>8&255); Pb(I&255) Dropall %return %finish 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): %if Estktos_Form=Litval %and Estktos_intval=1 %start %if opcode=IADDST %then XAOp1=INCL %else XAOp1=DECL %if Estktosm1_size=2 %then XAOp1=XAOp1-32 Elevel=Elevel-2 Do X(XAOp1,Estktosm1) ->Wayout %finish Op(IMULTST): Op(IDIVST): Op(IORST): Op(IXORST): ->regway %if Ecdupflag#0 %begin %constbyteintegerarray stop(IADDST:IXORST)= ADDL2, SUBL2,MULL2,DIVL2,0(4),BISL2,0,XORL2; Elevel=Elevel-2 Do XX(Stop(Opcode),Estktos,Estktosm1) %end ->Wayout Op(UDIVST): Op(IREMST): Op(UREMST): Op(IANDST): regway: %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) Ecdupflag=0 ->wayout !* !* Op(ISHLL): Op(ISHLA): Elevel=Elevel-2 Reg1=Load int(Estktosm1,-1,-1) %if Opcode=ISHLL %then MaskOflow Do XR(ASHl,Estktos,Reg1) PB(Regmode!Reg1) %if Opcode=ISHLL %then UnmaskOflow Stackr(reg1) ->Wayout Op(ISHRL): ! ! NB The use of extract fails with modified opernads since the implied size ! of EXT is one byte. Avoid the problem meantimes ! %if Estktos_Form=Litval %and Estktosm1_Size<=4 %and0<=Estktos_Intval<=8*Estktosm1_Size %Start %if Estktosm1_FormWayout %finish %finish Eop(INEG); ! Should leave in register Reg1=Loadintpair(Estktosm1,0,Estktos_reg) DoR(CLRL,Reg1+1); ! Clear upper reg to prevent sign propogating ! MaskOflow DoRR(ASHQ,Estktos_reg,REg1) PB(Regmode!reg1); ! Final dest reg1 & reg1+1 ! UnmaskOflow Funlockreg(Reg1); Funlockreg(Reg1+1) Unlockreg(Estktos_reg) Elevel=Elevel-2 Stackr(Reg1) ->Wayout Op(ISHRA): Eop(INEG) Eop(ISHLA) ->Wayout; ! Crude but works !* Op(RETURN): Popcode(RET) ->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) Do RR(MOVL,Stk(Elevel)_Reg,Reg1) Stk(Elevel)_Reg=Reg1 Regclaimed(Reg1,Elevel) ->dupexit %finish %if stk(elevel)_modform&31=regval %Start reg1=claimr(stk(elevel)_modreg) Do rr(MOVL,stk(elevel)_modreg,Reg1) stk(elevel)_modreg=reg1 Regclaimed(reg1,elevel) ->dupexit %finish %if Form=FregVal %thenstart Freg1=Claimfr(Stk(Elevel)_Reg,Stk(Elevel)_Size) %if Stk(Elevel)_Size=4 %then XAop=MOVF %else XAop=MOVG Do RR(XAop,Stk(Elevel)_Reg,Freg1) Stk(Elevel)_Reg=Freg1 FRegclaimed(Freg1,Elevel,Stk(Elevel)_Size) ->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,Estktos_Size) %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) Do RX(CMPL,Reg1,Estktosm1) Pjump(BCond,Bounderr,4) Do RX(CMPL,Reg1,Estktos) Pjump(BCond,Bounderr,2) 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 len==Estktos Bytes = len_IntVal %if Opcode=MVW %then %start %if Len_Form=Litval %then Bytes=4*Bytes %and Len_Intval=Bytes %elsestart Estklit(2); Eop(ISHLA) %finish %finish Refer(Srce,0); Srce_Size=1 Refer(Dest,0); Dest_Size=1 Fixedmove(ChOp(OpCode),Len,Srce,Dest) Elevel = Elevel - 3 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 Do RR(CVTBL,Reg1,Reg1) %else Reg1=claimr(-1) Do Xr(CVTBL,Estktosm1,Reg1) %finish 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): Bytes=Estktos_Size %if Bytes=1 %then ->Wayout %if Estktos_Form=DirVal %thenstart Simplify Opnd(CMPL,Estktos) %finishelsestart Address(Estktos) Reg1=Load Int(Estktos,-1,-1) Estktos=0 Estktos_Form=IndRegVal!Regflag Estktos_Reg=Reg1 Estktos_Size=Bytes Estktos_Cmval=0 Regclaimed(Reg1,Elevel) B1=Reg1 D1=0 %finish %if Bytes<=2 %then Xaop=CMPW %else %if Bytes=4 %then Xaop=CMPL %c %else Xaop=CMPG POpcode(Xaop); Do operand(Estktos,Xaop,no) PBDisp(Longdispmode!R10,32) Pjump(BCond,Unasslab,8) Elevel=Elevel-1 Push Operand(Estktos); ! RE record in new simplified format ->wayout !* Op(ESTORE): Elevel=Elevel-2 Reg1=Storeop(Estktos,Estktosm1,0) ->wayout !* Op(EDUPSTORE): Elevel=Elevel-2 Reg1=Storeop(Estktos,Estktosm1,1) Push Operand(Estktosm1) ->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 CCSet#0 %then Establish Logical Reg1=Load Int(Stk(Elevel+1),R0,-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): ! ! This is the definitive version of calling formal procedures. It can cope with ! mixed langauge working between all 4 languages and the dynamic linking used ! in EMAS. There are 3 parameters ! ! (Etos) The number of bytes of parameters stacked. Only needed on 2900 ! and some UNIX machines. Always a literal constant ! ! (Etos-1) The environment. This is code generator specific and provided ! by Eprocref (qv). The front end has to arrange to keep this and ! provide it again at call (Here). A value of zero is used for ! external procedures including all C functions and Fortran procedures ! Thus these languages can discard the environment from Eprocref ! and substitute a literal zero. If they do this they can not cope ! receiving Imp or Pascal internal procedure. On Emas ! and dynamic linking systems this is also a dummy since ! Dynamic linking requires a procedure descriptor which ! contains the environment ! ! (Etos-2) This is an address, normally the procedure entry point. For ! dynamic linking is is the address of a proc descriptor. It is ! also provided by Eprocref; its content does not concern the frontend ! ! Bytes=Estktos_Intval Eop(DISCARD); ! Rid of bytes of params Free regs({X'FFC01E'}-1) ELevel = ELevel - 2 Reg2=Load Int(Stk(Elevel+1),-1,Dispptrreg) %if Language=Imp %or Language=Pascal %then %start ! ! If an Internal procedure is passed it assumes R11 points to its Gla ! and R10 points ti its consts. These are normally set right but not if ! the internal procedure comes from a separate module. Must reload from ! the frame pointer provided unless it is a dummy. These values will be ! restored by the exit sequence so the current values must be saved and ! restored. we are really fighting the Vax orded code here ! Do RR(MOVQ,R10,R8); ! r10&11 saved in R8&9 Reg1=Load Int(Estktosm1,Dispptrreg,-1) Einternallab=Einternallab-1 Pjump(Bcond,Einternallab,8); ! Must jump round dummy environments Popcode(MOVL); PBDisp(Longdispmode!Reg1,-8) PB(REgmode!R11); ! Gla pointer from display to R11 Popcode(MOVL); PBDisp(Longdispmode!R11,Ptr to Cnsts) PB(Regmode!r10); ! Const table base to r10 Plabel(Einternallab) %finish POpcode(CALLS); PLit((Bytes+3)>>2,4) PB(Regdefmode!Reg2) %if Language=Imp %or Language=Pascal %then %c Do RR(MOVQ,R8,R10) %if active calls>1 %Start %finish active calls=active calls-1 ->wayout !* op(pushbytes): bytes=stk(elevel)_intval abort %unless stk(elevel)_form=litval reg1=loadint(stk(elevel-1),-1,0) Do LitR(SUBW2,Bytes,2,SP) Freeregs(X'3f') POpcode(MOVC3) PLit(Bytes,2) PB(Regdefmode!REg1); PB(Regdefmode!SP) next param offset=next param offset+(bytes+3)&(-4) elevel=elevel-2 ->wayout Op(EAUXSF): Op(SFA): reg1=claimr(-1) Do RR(MOVL,SP,Reg1) stackr(reg1) ->wayout ! Op(EAUXADD): Op(ASF): elevel=elevel-1 %if parmbits1&X'10010'=0 %then %Start REg1=Claimr(-1) Reg2=LOad Int(Estktos,-1,Reg1) Do RR(MOVL,SP,Reg1) Do RR(ADDL2,Reg2,SP) Freeregs(X'3F'&(\(1<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 reg1=load int(stk(elevel+1),-1,0) Freeregs((X'3F'!!1<wayout Op(Eoldlnb): ! Stack previous LNB Reg1=claimr(-1) Forgetuse(Reg1) POpcode(MOVL); PBDisp(Longdispmode!FP,12) PB(Regmode!Reg1); ! Extract old value of fp frome save area Stackr(reg1) ->wayout Op(Ecdup): ! 'Orrible Frig till C improves ! It means in effect after the next iaddst(etc) ! Fetch back or leave the result stacked also ! C can obtian the same effetc without loss of speed ! by using the Estack version of the Operation ! and following by an Edupstore. 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(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) Do LitR(BICL2,-2,2,Reg2); ! AND =F'1' except no AND on VAX Do RR(ADDL2,Reg2,Reg2) Do R(DECL,Reg2) Do RR(MNEGL,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) Lab=Einternallab-1 Einternallab=lab Do R(TSTL,Reg1) Pjump(Bcond,Lab,4) Do RR(MNEGL,Reg1,Reg1); ! Make positive if negative Plabel(Lab) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) Lab=Einternallab-1 Einternallab=Lab Do R(TSTL,Reg2) Pjump(bcond,Lab,10) Do RR(MNEGL,Reg1,Reg1) PLabel(lab) Stackr(Reg1) ->wayout !* F77op(ESIGN): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=8 %then Adj=MOVG-MOVF %else adj=0 Do LitR(BICL2,X'80000000',4,Reg1); ! Clear sign bit Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) Lab=Einternallab-1 Einternallab=Lab Do R(TSTF+Adj,Reg2) Pjump(BCond,Lab,10) Do RR(MNEGF+Adj,Reg1,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMOD): Elevel=Elevel-2 Reg2=Load Int(Stk(Elevel+2),-1,-1) Reg1=Claimr(Reg2) Reg3=Load Int(Estktosm1,-1,Reg2) Do RR(MOVL,Reg3,Reg1) Do RR(DIVL2,Reg2,Reg3) Do RR(MULL2,Reg2,Reg3) Do RR(SUBL2,Reg3,Reg1) Stackr(Reg1) ->wayout !* F77op(ERMOD): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=8 %then ADj=MOVG-MOVF %else Adj=0 Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) D1=Newtemp(bytes) Work=0; Work_Form=Dirval; Work_Size=Bytes Work_Offset=D1 Do RX(MOVF+Adj,Reg2,Work) Do RR(MOVF+Adj,Reg1,reg2) Do XR(DIVF2+Adj,Work,reg2) 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 XR(MULF2+Adj,Work,Reg2) Do RR(SUBF2+Adj,Reg2,Reg1) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIDIM): ! res =etos-etos-1. If r<0 %then r=0 Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Do XR(SUBL2,Estktos,Reg1) Do R(TSTL,Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BCond,Lab,10) Do R(CLRL,Reg1) PLabel(lab) Stackr(Reg1) ->wayout !* F77op(ERDIM): ! Result =(etos-etos-1) %if <0 %then result=0 Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=8 %then ADj=MOVG-MOVF %and XAop=CLRQ %else Adj=0 %and XAop=CLRL Do XR(SUBF2+Adj,Stk(Elevel+2),Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BCond,Lab,10) DoR(XAop,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMIN): ! result = the lower of etos and etos-1 Relop=12 Iminmax: Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) Do RR(CMPL,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BCond,Lab,relop) Do RR(MOVL,Reg2,Reg1) Plabel(lab) Stackr(Reg1) ->wayout !* F77op(ERMIN): ! result = the lower of etos and etos-1 Relop=12 Rminmax: Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=8 %then ADj=MOVG-MOVF %else Adj=0 Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) Do RR(CMPF+Adj,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BCond,Lab,relop) Do RR(MOVF+Adj,Reg1,Reg2) Plabel(lab) Stackfr(Reg1,Bytes) ->wayout !* F77op(EIMAX): ! result = the higher of etos and etos-1 Relop=10 ->Iminmax !* F77op(ERMAX): ! result = the higher of etos and etos-1 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): ! Store char(Etos) into etos-1 Estklit(1) Eop(CVTII) Eop(EXCH) Eop(ESTORE) ->wayout !* F77op(EICHAR): ! Pick up byte and expand to int Abortm("Char>1 byte") %unless Estktos_size=1 Estklit(4) Eop(CVTII) ->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): ! Set Complex at ((Elevel-2)) to ((elevel-1),0) ! Flags in Etos give precision 0=32bits Elevel=Elevel-3 Flags=Stk(Elevel+3)_Intval ->Cx1 !* F77op(ECMPLX2): ! Set Complex at ((Elevel-3)) to the pair ! ((Etos-2),(Etos-1)). Etos as for ecmplx1. Elevel=Elevel-4 Flags=Stk(Elevel+4)_Intval Cx1: %if Flags=0 %then XAop1=MOVF %and XAop=CLRL %else XAop1=MOVG %and XAop=CLRQ Reg1=Load Int(Stk(Elevel),-1,-1) Lockreg(Reg1) Freg1=Load Real(Stk(Elevel+2),-1,-1,Bytes) POpcode(XAop1); PB(Regmode!Freg1); ! Store real part PB(Autoincmode!Reg1); ! Using Autoinc to update reg1 %if Opcode=ECMPLX1 %thenstart Freg2=Freg1 Do R(XAop,Freg2) %finishelsestart Freg2=Load Real(Stk(Elevel+3),-1,-1,Bytes) %finish POpcode(XAop1); PB(Regmode!Freg2);! Store Imaginary part PB(Regdefmode!Reg1); ! Using deferred mode Funlockreg(reg1) ->wayout !* F77op(EISHFT): ! General shift +ve=lef -ve=roght ! On Vax do not use trcik of reouting ! Because this is how shifts actually work Reg1=Load Int pair(Estktosm1,0,-1);! to lowest no Lockreg(Reg1); Lockreg(Reg+1) Do R(CLRL,reg1+1); ! Clear upper to avoid problems with sign bit MaskOflow; ! Mask Overflow Do XR(ASHQ,Estktos,Reg1) Funlockreg(reg1); Funlockreg(Reg1+1) UnmaskOflow Stackr(Reg1) ->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 Freeupreg(R0) Pcall(-D1,0); ! address to r0 Do r(PUSHL,R0) ! 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 Estklit(0); ! Dummy environment Eop(EXCH); ! into etos-1 Eop(ARGPROC); ! Now can use standard method ->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): ! Running total opern. Reg1 to be preserved and restacked 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 Reg3=Claimr(reg1) Do RR(MULL3,Reg1,Reg2) PB(Regmode!Reg3); ! # opnd form total to reg3 Do RR(ADDL2,Reg3,Reg2) Funlockreg(Reg3) Regclaimed(Reg1,Elevel) Regclaimed(Reg2,Elevel-1) ->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 ! ! ! The following section of code is for Pascal. All the Pascal specials ! are here unless they are not supported in this simple implementation ! !* Pasop(STRGT): Pasop(STRLT): Pasop(STREQ): Pasop(STRNE): Pasop(STRGE): Pasop(STRLE): %if Estktos_Form#LitVal %then Abortm("Epasop: string length") Eop(CPBGT+Opcode-STRGT) ->wayout !* Pasop(PTREQ): Pasop(PTRNE): Eop(IEQ+Opcode-PTREQ) ->wayout !* Pasop(SETI): Pasop(SETU): Pasop(SETD): ! intersection,unionand difference of sets ! 2 sets stacked as multi word items ! implement by repeated 32 bit ops ! Many sets are not more than 32 in size ! Pasacl compiler has option to use support proc ! for all these items or when set>1 word bytes=Estktos_size %if bytes=4 %Start %if opcode=setd %then eop(inot) %if opcode=setu %then eop(ior) %else eop(iand) ->wayout %finish d1=new Temp(bytes) dx=d1 J=bytes-4 Eop(Eaddress) Eop(EXCH) Eop(Eaddress) Eop(EXCH) ! ! now loop round preserving the addresses for all bar last iteration ! %For i=0,4,j %cycle Eop(DUPL) %unless I=J Erefer(I,4) %if I=J %then Eop(EXCH) %else Epromote(3) Eop(DUPL) %unless I=J Erefer(i,4) %if I=J %then Eop(EXCH) %else Epromote(3) ! Upper operand as originals %if Opcode=SETD %then Eop(INOT) %if Opcode=SETU %then Eop(IOR) %else EOP(IAND) Estkdir(0,DX-stackoffset+I,0,4); ! The temporary Eop(ESTORE) Eop(EXCH) %unless I=J; ! operand back to original order %repeat Estkdir(0,dx-stackoffset,0,bytes) ->wayout !* Pasop(SETEQ): Pasop(SETNE): bytes=Estktos_size %if bytes=4 %then eop(IEQ-seteq+opcode) %else %Start address(Estktosm1) address(Estktos) estklit(bytes) eop(CPBEQ-SETEQ+opcode) %finish ->wayout Pasop(SETIN): ! ! Chenck if element index (TOS-3) is in the set (TOS-2). TOS is the ! upper and (Tos-1) the lower bound of the set. Out of bound or not in the ! set results in false otherwise true. However bounds <0 indicate that ! the relevant bound check has been folded and need not be made. This operation ! is very tedious to implement in ECODES due to the restriction that jumps ! can not leave anything in the (conceptual) Estack. THe Pascal Compiler ! has an option to use a support procedure here and this is normally used ! when bootstrapping ! ! first remove the bounds up=Estktos low=Estktosm1 elevel=elevel-2 upper=up_intval lower=low_intval ! the set is the upper operand bytes=stk(elevel)_size Einternallab=Einternallab-1 reg2=load int(stk(elevel-1),-1,1) Lockreg(reg2) %if upper>0 %then Do RX(CMPL,reg2,up) %and pjump(bcond,Einternallab,2) %if lower >=0 %then Do RX(CMPL,reg2,low) %and pjump(bcond,Einternallab,4) ! ! On Vax can simply extract the relevant bit into reg with EXTZV ! Simplify Opnd(EXTZV,Stk(Elevel)) Reg1=claimr(Reg2) Popcode(EXTZV) PB(Regmode!Reg2) PLIT(1,1) Do Operand(Stk(Elevel),EXTZV,No) PB(Regmode!Reg1); ! Bit to reg1 Funlockreg(reg2) %if lower>=0 %or upper>0 %Start Do Litr(XORL2,1,1,Reg1) 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 ->wayout !* Pasop(SETLE): Eop(DUPL) Epromote(3) Epasop(SETU) Epasop(SETEQ) ->wayout !* Pasop(SETSING): ! ! ! Set up a singular set of size ETOs, Index in ETOS-1 ! %if Estktos_Form#LitVal %then Abortm("SETSING: size?") bytes=Estktos_intval %if bytes=4 %start Eop(DISCARD); ! Remove set size estklit(1) eop(EXCH) eop(ISHLL) ->wayout %finish d1=new temp(bytes) Estkaddr(0,d1-Stackoffset,0,4) Estklit(Bytes) Eop(EZERO); ! Zero temporary of set size Eop(DISCARD); ! Remove set size Eop(DUPL) Estklit(31) Eop(IAND) Estklit(1) Eop(EXCH); Eop(ISHLL) Eop(EXCH); Estklit(5); eop(ISHRL);! Word index Estkaddr(0,d1-Stackoffset,0,4) Eop(EXCH); Eop(INDEX4) Eop(ESTORE) estkdir(0,d1-Stackoffset,0,bytes) ->wayout !* Pasop(SETRANGE): %if Estktos_Form#Litval %then Abortm("SETRANGE Size?") Unsupported Opcode(Opcode) ->wayout !* Pasop(CAPMOVE): ! Params now as for move bytes Eop(MVB) ->wayout !* Pasop(INDEXP): Elevel=Elevel-2 Bit Index(Stk(Elevel+2),Stk(Elevel),Stk(Elevel+1)) ->wayout !* Pasop(EOFOP): Pasop(EOLOP): Expcall(Opcode-EOFOPT+10,Spprocs,Spproctype,Spprocref,Spprocpdesc) ->wayout !* Pasop(LAZYOP): Expcall(14,Spprocs,Spproctype,Spprocref,Spprocpdesc) ->wayout !* Pasop(ISQR): Eop(DUPL) Eop(IMULT) ->wayout !* Pasop(IODD): Pasop(UODD): Estklit(1) Eop(IAND) ->wayout !* Pasop(ISUCC): Pasop(USUCC): Estklit(1) Eop(IADD) ->wayout !* Pasop(IPRED): Pasop(UPRED): Estklit(1) Eop(ISUB) ->wayout !* 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(Estktos,-1,-1,BYtes) Elevel=Elevel-1 STackfr(reg,bytes) %if bytes=4 %then XAOp=MULF2 %else XAOp=MULG2 Do rr(XAop,reg,reg) ->wayout !* Pasop(CHKLT): Pasop(CHKGT): Pasop(UCHKLT): Pasop(UCHKGT): Pasop(UCHKNE): Pasop(CHKNE): trapno=Estktos_intval; ! err no always literal Eop(DISCARD); ! Rid of trapno Eop(EXCH) Eop(DUPL); ! copy for after check Epromote(3) Eop(Pchop(Opcode)) Etrapjump(JTRUE,Pastraplab,Trapno) ->wayout !* Pasop(CHKRNG): Pasop(UCHKRNG): trapno=Estktos_Intval Eop(DISCARD); ! Rid of trapno Epromote(3); Eop(DUPL); ! copy for after Check Epromote(3) Etrapjump(JIGT,Pastraplab,Trapno) Eop(DUPL); Epromote(3) Etrapjump(JILT,Pastraplab,Trapno) ->wayout Pasop(CHKSETRNG): Pasop(CHKSETGT): trapno=Estktos_intval lower=0 upper=Estktosm1_Intval Eop(DISCARD) Eop(DISCARD) %if OPcode=CHKSETRNG %then lower=Stk(elevel)_intval %and Eop(DISCARD) Abort %unless Stk(elevel)_size=4;! only for 1 word sets Eop(Dupl) d=0 d=d!(1<wayout !* Pasop(CHKNEW2): Unsupported Opcode(Opcode) ->wayout Pasop(CHKUNDEF): Elevel=Elevel-1; ! Appears to be a trap no here! Eop(UCHECK) ->wayout !* Pasop(SETUNDEF): Estkdir(Cnst,32,0,Estktos_size) Eop(EXCH) Eop(ESTORE) ->wayout !* Pasop(TRAP): Trapno=Estktos_Intval Eop(DISCARD) Etrapjump(JUMP,Pastraplab,Trapno) ->wayout !* Pasop(ICLCPTR): Pasop(ICLWPTR): ! ! Get word or byte address of operand to make a pointer ! Only different for Perq where two forms of addressing ! %if Estktos_Form&31wayout ! ! This section covers all the C specials unless not supported in this Generator ! ! The first three are logical manipulation for partial eavluation of ! Logiacl expressions. To enable control to jump around an unnecessary section ! The output is in kept in GR1. Difficult to get an Ecode method for this ! Cop(LOGNEG): %if CCset#0 %then CC=CC!!15 %else %start %if Elevel<1 %then Low Estack(Opcode,1) %and ->wayout Estklit(0) Eop(IEQ) %finish Establish Logical ->wayout !* Cop(LOGVAL): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1)%and ->wayout 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) ->wayout !* Cop(LOGSTK): Stackr(r1) ->wayout !* Cop(ECSTORE): ! ! This is an attempt by C to redefine MVB without using addresses. It was not ! originally envisaged that front ends would stack multi word items as itemas ! It is possible to implement this efficienctly by using Addrss and MVB ! However there is a frig for Fortran in address to enable a result in a register ! to be passed by reference. Must stop C falling over this Frig by a counterfrig ! To clean this area up :- ! 1) Fortran should allocate temps for refernce expressions(Like IMP&Pascal) ! 2) C should abandon this and use MVB ! I=Estktos_Size %unless Estktosm1_Size=I %then %monitor %and %stop %if Estktos_Form&31#Regval %then address(Estktosm1) Address(Estktos) Estklit(I) Eop(MVB) ->wayout !* Cop(ECPROCCALL): ! Call a procedure via a C pointer ! However C has dereferenced the the pointer ! os that it is the first word of the 4 ! Not a pointer to the 4 ! No provision for environment is made ! C can and should use the standard mechanism Address(Estktos); ! Now a pointer to 4 words (cde,gla,ep&env) Estklit(0); ! Dummy environment means external proc Estklit(0); ! Dummy bytes of params(not needed on EMAS) Eop(Argproc); ! Now the normal mechanism applies ->wayout !* Cop(EPUSHSTR): ! as pushbytes but must be aligned(is on IBM) ! Designed to push a Structure as value parameter ! Imp does the smae means of ! SFA,ASF N and MVB aligning as REQD ! Instrn should be generalised or abandonned Address(Estktosm1) EOP(Pushbytes) ->wayout !* Cop(ELDBITS): ! Extract a Bitfield of etos bits ! Starting at Bit Etos-1 (0=Sign bit) ! (etos-2)is word containing the field Nbits=Estktos_Intval; ! Must be a literal Bstart=Estktosm1_Intval; ! Also a literal Eop(DISCARD); ! Get rid of Nbits Eop(DISCARD); ! Get Rid of Starting bit no Bmask=Bmaskval((Nbits-1)&31) Bshift=32-Bstart-Nbits %if Bshift>0 %then Estklit(Bshift) %and Eop(ISHRL) Estklit(Bmask) Eop(IAND) ->wayout !* Cop(ESTBITS): ! Store a bit field ! (ETOS-3) the value to go into the field ! Top 3 Parameters as for ELDBITS Nbits=Estktos_Intval; ! The field size Bstart=Estktosm1_Intval; ! The field starting bit(0= Sign bit) Eop(DISCARD); ! Rid of field size Eop(DISCARD); ! Rid of staring posn Bmask=Bmaskval((Nbits-1)&31) Bshift=32-Bstart-Nbits Eop(DUPL); ! copy of store word Estklit((Bmask<0 %then Estklit(Bshift) %and Eop(ISHLL) %finish Eop(IOR) Eop(EXCH) Eop(ESTORE) ->wayout !* ! ! The following register to store operations are entirely reasonable and ! should be moved into the sstandard set. The use of Ecdupflag remains a horrible ! (temporay??) expedient which should be phased out as soon as possible ! Cop(UADDST): Cop(USUBST): Eop(EXCH); Eop(DUPL) Epromote(3) Eop(Uadd+Opcode-Uaddst) Eop(EXCH) Eop(Estore+Ecdupflag) Ecdupflag=0 ->wayout Cop(UMULTST): Eop(Uopst(Opcode-UADDST)) ->wayout !* Cop(RADDST): Cop(RSUBST): Cop(RMULTST): Cop(RDIVST): Cop(ISHLST): Cop(ISHRST): Cop(ISHRAST): Eop(EXCH) Eop(DUPL) Epromote(3) Eop(Ropst(Opcode-RADDST)) Eop(EXCH) Eop(ESTORE{{+Ecdupflag???}) {Ecduplflag=0?????????? } ->wayout !* ! ! It is sometimes necessary to force an evaluation to contain possible side ! effects in expressions. However C has reinvented the wheel here. ! EVAL is provided in the general set of operations ! Cop(Ceval): Eop(Eval) ->wayout ! ! The next two operations are also unnecessary. They exactly duplicate the ! Estack manipulation routines "EPROMOTE" and EDEMOTE" in the standard set ! These two operations should be phased out ! Cop(ECSAVE): Eop(DUPL) I=Elevel-1 %while I>0 %cycle Epromote(Elevel) I=I-1 %repeat Numcsave=Numcsave+1 ->wayout !* Cop(ECRESTORE): Epromote(Elevel-Numcsave+1) Numcsave=Numcsave-1 ->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 * !*********************************************************************** Eop(Opcode) %end;! EPasop !* %externalroutine Eccop {%alias"E#CCOP"}(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by C * !*********************************************************************** Eop(Opcode) %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); ! Uncomment for forwarc params Eop(PUSHVAL) I=I-1 %repeat I=procpdesc(Proc) Ecall2(J,1,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) Do XR(MOVL,Stk,Reg) 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,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 Aform= 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,MOVZBL,CVTWL,0,MOVL Bytes=Stk_Size %unless 00 %then sruse=ruse(lockedreg)_cl %and Lockreg(Lockedreg) Do XR(Lop(Bytes),Stk,Reg) %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 aMOVLeady 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 Bytes=4 %then XAop=MOVF %else XAop=MOVG %if Stk_Form&31=FregVal %thenstart Unlockfreg(Stk_Reg,Bytes) %if Reg>=0 %and Reg#Stk_Reg %thenstart Do RR(XAop,Stk_Reg,Reg) %result=Reg %finishelse %result=Stk_Reg %finish %if Reg<0 %then Reg=Claimfr(Lockedreg,Bytes) Do XR(XAop,Stk,Reg) %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,Newsize) XAop=CVTFG %finishelsestart;! 16 byte Abort; ! 16 bytes not yet supported %finish Do RR(XAop,Oldreg,Newreg) Unlockfreg(Oldreg,Bytes) %finishelsestart %if Newsize=8 %thenstart Newreg=Claimfr(-1,Newsize) XAop=CVTFG %finishelsestart;! 16 byte Abort; ! longlongs not yet supported %finish Do XR(XAop,Stk,Newreg) %finish %result=Newreg %end;! Load Real Extended !* %routine Push Operand(%record(Stkfmt)%name Operand) !*********************************************************************** !* create an Estack entry for a prepared operand * !*********************************************************************** %integer f %if Elevel=stkmax %then Abort F=Operand_form&31 Elevel=Elevel+1 Stk(Elevel)=Operand %if F=Regval %or F=Indregval %then REgclaimed(Operand_Reg,Elevel) %if F=Fregval %then Fregclaimed(operand_Reg,Elevel,Operand_Size) %if AddrDirMod<=f<=AddrDirModVal %and Operand_Modform&31=Regval %c %then Regclaimed(Operand_Modreg,Elevel) %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 Forgetuse(r) 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 Forgetfuse(FR,Bytes) FRegclaimed(FR,Elevel,Bytes) %end;! Stackfr !* %routine Establish Logical !*********************************************************************** !* called when a condition code has been set and required result is a * !* logical value (0 or 1). In c must not change the condition code * !* since a call of Ecjump may follow. Hence the less efficient coding * !* This is very hard since all instructions set the CC * !*********************************************************************** %integer Reg1 CCset=0 Reg1=Claimr(0) Einternallab=Einternallab-2 Pjump(BCond, Einternallab-1, CC) Do R(CLRL,Reg1) Pjump(Bcond,Einternallab,15) Plabel(Einternallab-1) Do Rlit(MOVL, Reg1, 1,4) PLabel(Einternallab) Stackr(Reg1); ! stack integer result in Reg1 %end;! Establish Logical %routine MaskOflow POpcode(BICPSW) Plit(32,1) %end %routine UnmaskOflow POpcode(BISPSW) Plit(32,1) %end !* %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, ADDL2,SUBL2,MULL2,DIVL2,0,0,0,BICL2,BISL2,0,XORL2,0(4),CMPL(6), 0(UADD-ILE-1),ADDL2,SUBL2,CMPL(6); %integer Lform,Rform,Lreg,Rreg,MCop,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(UADD): MaskOflow; ! For unsigned add Opcode(IADD): Opcode(IOR): Opcode(IXOR): 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=CMPL %and %c RHS_Form=Litval %and 0<=RHS_Intval<=255 %Start Simplify Opnd(CMPB,LHS) POpcode(CMPB) Do Operand(LHS,CMPB,No) PLit(RHS_Intval,1) CCset=1 CC=CC!16; ! Force unsigned jumps as bytes signed on Vax %return %finish %if LHS_Size=RHS_Size=4 %and {Eaddrform(Lform)<=128 %and Eaddrform(Rform)<=128 %and} %c Mcop=CMPL %start Do XX(CMPL,LHS,RHS) CCset=1 %return %finish Sizes %if Lform=RegVal %thenstart %if MCop=ADDL2 %and Rform=Litval %and RHS_Intval=1 %then %c Do R(INCL,Lreg) %else Do XR(MCop,RHS,Lreg) Wreg=Lreg %if MCop=CMPL %then CC=Invcc(CC) %finishelse %if Rform=RegVal %thenstart Do XR(MCop,LHS,RReg) Wreg=Rreg %finish %else %Start Wreg=Claimr(0) Do XXR(MCop+1,LHS,RHS,Wreg); ! Use 3 address form to operate and put into wreg %finish %if MCop=CMPL %then CCset=1 %and Unlockreg(wreg) %else Stackr(Wreg) %if Op=Uadd %then UnmaskOflow %return !* Opcode(Usub): MaskOflow Opcode(ISUB): Opcode(IDIV): Noncommop: ! Non commutable binary operation Sizes %if Lform=RegVal %thenstart %if MCop=SUBL2 %and Rform=Litval %and RHS_Intval=1 %then %c Do R(DECL,Lreg) %else Do XR(MCop,RHS,Lreg) %finishelsestart Lreg=Claimr(Rreg) Do XXR(Mcop+1,RHS,LHS,Lreg) %finish Stackr(Lreg) %if Op=Usub %then UnmaskOflow %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)!16; ! Force the unsigne jumps ->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 ->Commbinaryop Opcode(IAND): %if RHS_Form=Litval %then RHS_Intval=RHS_Intval!!(-1) %and ->Noncommop %if LHS_Form=Litval %then Int Binary Op(Op,RHS,LHS) %and %return Rreg=load Int(RHS,-1,-1) Do LitR(Xorl2,-1,4,Rreg) RHS_Form=Regval; Rform=Regval RHS_Reg=Rreg ->Noncommop Opcode(Irem): Sizes Pair=load int pair(LHS,1,-1) POpcode(ASHQ); Plit(-32,1) PB(Regmode!Pair); PB(Regmode!Pair) Simplify Opnd(Ediv,RHS) POpcode(EDIV) Do operand(RHS,EDIV,No) PB(Regmode!pair) PB(Regmode!pair) PB(Regmode!Pair+1); ! REmainder in pair+1 %if Language=Pascal %start; ! Pascal REM is strange Einternallab=Einternallab-1 pjump(BCond,Einternallab,10) Do XR(ADDL2,RHS,Pair+1) plabel(einternallab) %finish Funlockreg(Pair) Funlockreg(Pair+1) Stackr(Pair+1) %return %routine sizes !*********************************************************************** !* Operations do not work right on mixed size operands so * !* load smaller ones to registers first. * !*********************************************************************** %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 %result=1 shift: reg=load int(Stk,-1,-1) %if i=1 %then Do RR(ADDL2,reg,reg) %else %Start POpcode(ASHL); Plit(i,1); PB(Regmode!Reg); PB(Regmode!Reg) %finish 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 Reg1=Load Int(RHS,-1,0) %if {(Op=INOT %and language=Fortran) %or} Op=BNOT %thenstart {++++ temp while fortran change introduced +++} Do LitR(BICL2,-2,4,Reg1) %if op=inot Do LitR(XORL2,1,4,Reg1) Stackr(Reg1) %return %finish %if op=inot %Start; ! IMP logical not do LitR(XORL2,-1,4,reg1) stackr(reg1) %return %finish %if Op=IABS %then %start Do R(TSTL,Reg1); ! Not always needed Einternallab=Einternallab-1 PJUMP(Bcond,Einternallab,10) %finish Do RR(MNEGL,Reg1,Reg1) %if Op=IABS %then Plabel(Einternallab) 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) = ADDF2,SUBF2,MULF2,DIVF2 %constintegerarray RXdop(RADD:RDIV) = ADDG2,SUBG2,MULG2,DIVG2 %integer Lform,Rform,Lreg,Rreg,Wreg,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 RADD<=Op<=RDIV %thenstart %if Bytes=4 %thenstart XAXop=RXeop(Op) %finishelse %if Bytes=8 %thenstart XAXop=RXdop(Op) %finishelsestart Abortm("No Real*16") %finish %else; ! comparison %if Bytes=4 %then XAXop=CMPF %else XAXop=CMPG %finish ->Opcode(Op) !* Opcode(RADD): !* Opcode(RMULT): %if Lform=FregVal %thenstart Wreg=Lreg Do XR(XAXop,RHS,Lreg) %finishelse %if Rform=FregVal %thenstart Do XR(XAXop,LHS,Rreg) Wreg=RREg %finish %else %start Wreg=CLAIMfr(-1,Bytes) Do XXR(XAXop+1,LHS,RHS,Wreg) %finish Stackfr(Wreg,Bytes) %return !* Opcode(RSUB): !* Opcode(RDIV): %if Lform=FregVal %thenstart Do XR(XAXop,RHS,Lreg) %finishelsestart Lreg=Claimfr(Rreg,Bytes) Do XXR(XAXop+1,RHS,LHS,Lreg) %finish Stackfr(Lreg,Bytes) %return !* Opcode(RGT): Opcode(RLT): Opcode(REQ): Opcode(RNE): Opcode(RGE): Opcode(RLE): CC=Setcc(Op-RGT) Do XX(XAXop,LHS,RHS) 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,Oform Oform=RHS_Form&31 Bytes=RHS_Size Reg1=RHS_Reg %if bytes=4 %then XAop=0 %else XAop=MNEGG-MNEGF %if Op=RNEG %thenstart %if Oform#Fregval %then Reg1=Claimfr(-1,Bytes) Do XR(MNEGF+XAop,RHS,Reg1) %finishelse %if Op=RABS %thenstart %if Oform=Fregval %then DO R(TSTF+XAop,Reg1) %else %c Reg1=Load Real(RHS,-1,-1,Bytes) Einternallab=Einternallab-1 Pjump(Bcond,Einternallab,10) Do RR(MNEGF+XAop,Reg1,Reg1) Plabel(Einternallab) %finishelse Abort 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 unless newsize is negative * !*********************************************************************** %integer Reg,Val,Dontstack Dontstack=0 %if Newsize<0 %then Dontstack=1 %and Newsize=-Newsize 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) %if Dontstack=0 %else Reg=Load Int(Stk,-1,-1) Stackr(Reg) %if Dontstack=0 %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=Claimfr(-1,4) Do XR(CVTGF,Stk,Freg1) Bytes=4 ->Note !* Sw(2): ! CVTRQ !* Sw(6): ! CVTDQ Freg1=Load Real Extended(Stk,16) Bytes=16 ->Note !* Sw(8): ! CVTQR Freg1=Claimfr(-1,4) Do XR(CVTHG,Stk,Freg1) Bytes=4 ->Note !* Sw(9): ! CVTQD Freg1=Claimfr(-1,8) Do XR(CVTHG,stk,Freg1) Bytes=8 ->Note !* Sw(*): Push operand(Stk) %end;! Convert RR !* %routine raddhalf(%integer freg1,Bytes) !*********************************************************************** !* Service routine to perform rounding for convert ri etc !*********************************************************************** %integer Adj,Lab %if Bytes=4 %then Adj=0 %else Adj=ADDG2-ADDF2 Lab=Einternallab-2 Einternallab=Lab Do R(TSTF+Adj,Freg1) Pjump(BCond,Lab+1,10) Do LitR(SUBF2+adj,0,1,freg1); ! 0 is short Lit 0.5 also Pjump(bcond,Lab,15) PLabel(lab+1) Do LitR(ADDF2+adj,0,1,Freg1); ! 0 is short Lit 0.5 also 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 Freg1,Bytes,Adj,Op Freg1=Load Real(Stk,-1,-1,Bytes) %if Bytes=4 %then Adj=0 %else Adj=CVTGL-CVTFL Op=CVTFL %if Mode>0 %then Op=Op+1; ! Move to CVTRFL %if Mode=2 %then Do LitR(SUBF2+Adj,0,1,Freg1); ! Subtract 0.5 Do RR(Op+Adj,Freg1,Freg1) Funlockfreg(Freg1,Bytes) Stackr(Freg1) %end;! Convert RI %routine Convert RU(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between real and unsigned integer * !* descriptor to result on Estack * !*********************************************************************** Mask Oflow ConvertRI(Stk,Newsize,0) Unmask Oflow %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,D,Adj %ownreal Cshort=2****25 %ownlongreal Clong=2****54 %record(StkFmt) Temp Freg1=Load Real(Stk,-1,-1,Bytes) ! ! Theory of this conversion ! 1) Round if required by adding 0.5 ! 2) Then add 2****mantissa size to force off fractional bits ! 3) Subtract ditto ! Consts will not be set correctly while cross compiling but Imp does ! not need this conversion ! %if Mode=1 %then raddhalf(Freg1,Bytes) Temp=0 Temp_Size=Bytes; Temp_Base=10 Temp_Form=Dirval %if Bytes=4 %Start Adj=0 Store const(D,4,addr(Cshort)) %else Adj=ADDG2-ADDF2 store Const(D,8,addr(Clong)) %finish Temp_Offset=D Do Xr(ADDF2+Adj,Temp,Freg1) Do XR(SUBF2+Adj,Temp,Freg1) 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} %if newsize=4 %Start Do RR(CVTLF,Reg1,Reg1) Freg1=REg1 %else Freg1=claimfr(Reg1,Newsize) Do RR(CVTLG,Reg1,Freg1) %finish Funlockreg(REg1) Stackfr(Freg1,newsize) %end;! Convert IR %routine Convert UR(%record(Stkfmt)%name Stki,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Freg1,Adj %ownreal cshort=2****32 %ownlongreal clong=2****32 %record(StkFmt)Temp Temp=0 Convert IR(Stki,Newsize) Freg1=Stk(Elevel)_Reg %if Newsize=4 %then Adj=0 %and Store Const(Temp_Offset,4,addr(Cshort)) %c %else Adj=ADDG2-ADDF2 %and Store const(Temp_offset,8,addr(Clong)) Einternallab=Einternallab-1 Pjump(Bcond,Einternallab,10); ! Br if +ve Temp_Form=Dirval Temp_Size=Newsize Temp_Base=10 Do XR(ADDF2+Adj,Temp,Freg1) Plabel(Einternallab) Elevel=Elevel-1 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 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 Do RR(CVTWL,Reg,Reg) 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) %constbyteintegerarray Opc(1:4)=MOVB,MOVW,0,MOVL; %integer Bytes,Op,Reg,Form %record(StkFmt)Mleng %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 Form=Litval %and LHS_Size#Bytes %then Convertii(RHs,-LHS_Size) %if Bytes=1 %or Bytes=2 %or Bytes=4 %thenstart Op=Opc(LHS_Size) %if Dup#0 %or LHS_Size#RHS_Size %then %Start Reg=Load int(RHS,-1,-1) RHS_Form=Regval; RHS_Reg=REg %finish %else Reg=-1 Do XX(Op,RHS,LHS) %result=Reg %finish %else %if Bytes=8 %Start Op=MOVG %if Dup#0 %then %Start Reg=load real(RHS,-1,-1,Bytes) RHS_Form=Fregval; RHS_REg=Reg %finish %else Reg=-1 Do XX(Op,RHS,LHS) %result=Reg %finish %else %start Mleng=Litone Mleng_Intval=Bytes Fixed move(MOVC3,Mleng,RHS,LHS) %result=-1 %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,Form %record(StkFmt) Mleng,Dest %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 Form=AddrConst %or Form=AddrDir %or Form=AddrDirMod %start refer(stk,0) Do X(PUSHAL,Stk) %finish %else %if Bytes=4 %thenstart Do X(PUSHL,stk) %finish %else %if Bytes=8 %Start Do XR(MOVG,Stk,Autodecmode!SP) %finish %else %start Mleng=Litone; Mleng_Intval=Bytes Dest=0 Dest_Form=IndRegVal; Dest_Reg=SP Do LitR(SUBW2,(Bytes+3)&(-4),2,SP) Fixedmove(MOVC3,Mleng,Stk,Dest) %finish Next Param Offset=Next Param Offset+Bytes %end;! Push Param %integerfn Regumask(%record(stkFmt)%name Stk) !*********************************************************************** !* Returns a bit mask of the registers used by this operand * !*********************************************************************** %integer Mask,Form,Mform,I Mask=0; Form=Stk_Form&31 Mform=Stk_Modform&31 %if 1<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 Do XR(ADDL2,Index,Base_reg) 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 Address(Base) nOte Index(Scale,Base,Index) refer(Base,0) Base_Size=Bsize %return %finish Reg=Claimr(0) Do XR(MOVL,Base,Reg) Forgetuse(Reg) Regclaimed(Reg,Elevel) Base=0; Base_Size=Bsize 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,Size) !*********************************************************************** !* Lock a register so that it can not be dumped * !*********************************************************************** Ruse(Freg)_CL=LOcked %if Size=8 %then Ruse(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,Size) !*********************************************************************** !* Unlock a Register without changing its use * !*********************************************************************** Unlockreg(Freg) %if Size=8 %then Unlockreg(Freg+1) %end %routine Forgetuse(%integer reg) !*********************************************************************** !* Forget the contents of a register without changing its lockstate * !*********************************************************************** %integer Use Use=rUse(Reg)_Use Ruse(reg)_use=0 Ruse(Use)_Inf=0 %end %routine Forgetfuse(%integer freg,Size) !*********************************************************************** !* Forget the contents of a register without changing its lockstate * !*********************************************************************** Forgetuse(Freg) %if Size=8 %then Forgetuse(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,Size) !*********************************************************************** !* Unlock a reg and forget its use * !*********************************************************************** Funlockreg(Freg) %if Size=8 %then Funlockreg(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,Size) !*********************************************************************** !* Set the use fields of a register record * !*********************************************************************** SetUse(Freg,use,inf) %if Size=8 %then SetUse(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,Size) !*********************************************************************** !* Set a register to claimed ie dumpable by Freeupfreg * !*********************************************************************** Regclaimed(freg,Elevel) %if Size=8 %then Regclaimed(Freg+1,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,Size) !*********************************************************************** !* store the content of floating register R in temp space, modifying * !* Estack entries as necessary * !*********************************************************************** %integer I,J,XAop J=Ruse(R)_CL I=Ruse(r)_Elevel %if increports#0 %and report#0 %Start printstring("free up Freg"); write(r,2); write(J,5) newline %finish %if J=0 %thenstart Forgetfuse(R,Size) %return %finish %if J=Claimed %and Stk(I)_Form&31=FregVal %and %c (Stk(I)_Reg=R %or(Size=8 %and Stk(i)_reg=R-1)) %thenstart %if Size=4 %then XAop=MOVF %else XAop=MOVG R=Stk(I)_Reg J=New Temp(Size) Stk(I)_Form=TempVal Stk(I)_Offset=J Stk(I)_Base=0 Stk(I)_Reg=0 Do RX(XAop,R,Stk(I)) Funlockfreg(R,Size) %return %finish printstring("Request to free register");write(R,2);newline Abort %end;! Freeup Freg !* %integerfn New Temp(%integer Bytes) %integer I %if Language=Imp %then %result=Etempworkspace(Bytes) I=integer(Addrstackca) integer(Addrstackca)=I+(Bytes+3)&X'FFFFFFFC' %result=I+Stack offset %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 Lstk==stk(i) K=Lstk_Form&31 %if Lstk_Size=8 %and K=Fregval %then Freeup Freg(R,8) %and %return %if increports#0 %and report#0 %Start printstring("Free up reg "); write(r,2); write(k,2) newline %finish %if J=0 %thenstart Forgetuse(R) %return %finish J=New Temp(4) %if Lstk_Reg=R %thenstart %if K=RegVal %or K=Fregval %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 ! Not needed when low byte is addressed Lstk_Base=0 Store: Do R(MOVL,R) PBDisp(Longdispmode!FP,J) Funlockreg(R) %return %finishelsestart %if (K=regmodaddr %or k=Indregmodval) %and Lstk_modform&31=regval %Start Scalereg(Lstk_Modreg,Lstk_scale) Do RR(ADDL2,Lstk_modreg,r) 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) Do RR(ADDL2,Lstk_Reg,r) 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,J %cycle J=1,1,4; I=J&3 %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 %cycle I=0,1,9 %if 1<=min %START; ! do bound check Einternallab=Einternallab-1 Lab=Einternallab Bound=litone Bound_intval=min %IF min#0 %THEN Do XR(SUBL2,Bound,reg1) Bound=litone Bound_intval=max-min Do RX(CMPL,reg1,Bound) Pjump(BCond,Lab,2) %FINISH Regb=basereg(sst) Popcode(MOVL) PB(Indexmode!reg1) PBDisp(longdispmode!regb,SSTad) PB(Regmode!reg1); ! Move offset out of sst to reg1 Popcode(ADDL2) PBDisp(LOngdispmode!r11,4) PB(Regmode!Reg1); ! Add hd of code from gla Do R(JMP,Regdefmode!reg1); ! and jump to it %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,breg,I reg0=load int(Stk,0,-1) breg=Basereg(SST) %for I=0,1,entries-1 %cycle DO R(CMPL,reg0) PBDisp(Longdispmode!Breg,SSTBase+4*i) Pjump(BCond,Labbase+i,8) %repeat %end %routine Do r(%integer opcode,reg) !*********************************************************************** !* Plant an operation involving a single REgister * !*********************************************************************** Popcode(opcode) %if Reg&X'F0'=0 %then Reg=Reg!Regmode PB(reg) %end %routine Do RR(%integer opcode,Reg1,Reg2) !*********************************************************************** !* Plant an operation involving 2 Registers * !*********************************************************************** Popcode(opcode) %if Reg1&X'F0'=0 %then Reg1=Reg1!Regmode %if Reg2&X'F0'=0 %then Reg2=Reg2!Regmode PB(reg1) PB(Reg2) %end %routine Do RRR(%integer opcode,reg1,reg2,reg3) !*********************************************************************** !* As do RR but three registers for complex type operations * !*********************************************************************** Do RR(Opcode,Reg1,Reg2) %if Reg3&X'F0'=0 %then REg3=Reg3!Regmode PB(REg3) %end %routine Do RLit(%integer opcode,Reg,Literal,size) !*********************************************************************** !* Plant an operation involving a reg and a literal * !*********************************************************************** Dor(opcode,reg) Plit(Literal,size) %end %routine Do LitR(%integer Opcode,Literal,size,Reg) !*********************************************************************** !* As above but the Literal is the source * !*********************************************************************** Popcode(opcode) Plit(Literal,size) %if Reg&X'F0'=0 %then Reg=Reg!Regmode PB(Reg) %end %routine Do XR(%integer Op,%record(StkFmt)%name Stk,%integer Reg) !*********************************************************************** !* Inverted from of Do Rx * !*********************************************************************** Simplify Opnd(Op,Stk) Popcode(Op) Do operand(stk,Op,No) %if Reg&X'F0'=0 %then Reg=Reg!Regmode PB(reg) %end %routine Do RX(%integer Op,Reg,%record(StkFmt)%name Stk) !************************************************************************ !* Perform an operatand where the first operation is a register * !* and the second operand is general * !*********************************************************************** Simplify Opnd(Op,Stk) Popcode(Op) %if Reg&X'F0'=0 %then Reg=Reg!Regmode PB(Reg) Do operand(Stk,Op,Yes) %end;! Do RX %routine Do X(%integer op,%record(StkFmt)%name Stk1) !*********************************************************************** !* Operation with one general operand * !*********************************************************************** Simplify Opnd(Op,Stk1) POpcode(op) Do operand(stk1,Op,Yes) %end %routine Do XX(%integer op,%record(StkFmt)%name Stk1,Stk2) !*********************************************************************** !* Two operand form where both are general * !*********************************************************************** Simplify Opnd(Op,Stk1) Simplify Opnd(Op,Stk2) POpcode(op) Do operand(stk1,Op,No) Do operand(Stk2,Op,Yes) %end %routine Do XXR(%integer op,%record(StkFmt)%name Stk1,Stk2,%integer Reg) !*********************************************************************** !* Three opeand form whre the third is a register * !*********************************************************************** Simplify Opnd(Op,Stk1) Simplify Opnd(Op,Stk2) POpcode(op) Do operand(stk1,Op,No) Do operand(Stk2,Op,No) %if Reg&X'F0'=0 %then Reg=Reg!Regmode PB(Reg) %end !* %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) %and Stk_Scale=0 Stk_Modform=RegVal Stk_Modreg=reg %result=Reg %end;! Load Modifier !* %routine Do operand(%record(StkFmt)%name Stk,%integer Op,Dest) !*********************************************************************** !* Plant an operand specifier and operand for Stk * !* Simplify should have reduced complex forms * !*********************************************************************** %integer Form,B2,D2,Modform,Modreg,Xreg %switch F(0:21) D2=Stk_Offset Form=Stk_Form&31;! removing the reg marker bit Modform=Stk_Modform&31 ->F(Form) !* F(LitVal): { lit } %if 0<=d2<=63 %then PB(d2) %else plit(D2,stk_size) %return F(ConstVal): { const } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } F(TempVal): { (temp) } F(DirVal): { (dir) } %if Dest=Yes %and (Op=MOVl %or Op=CLRL %or Op=DECL %or Op=INCL) %Start; ! Check for store into recordbase %for modreg=4,1,9 %cycle %if ruse(modreg)_Use=Subareabase %and %c Ruse(Modreg)_Inf=stk_base<<16!(D2&X'FFFF') %then Forgetuse(modreg) %repeat %finish B2=Ca Xreg=basereg(Stk_base) %if CA#b2 %then Abortm("Opnd not simplifed enough") PBdisp(Longdispmode!Xreg,D2) %return F(RegAddr): { (reg) is @ } F(RegVal): { (reg) } PB(Regmode!Stk_Reg) Funlockreg(Stk_Reg) %return F(FregVal): { (freg) } PB(Regmode!Stk_reg) Funlockfreg(Stk_Reg,Stk_Size) %return F(IndRegVal): { ((reg)) } %if Stk_Cmval=0 %then PB(Regdefmode!Stk_Reg) %else %c PBDisp(Longdispmode!Stk_reg,Stk_Cmval) Unlockreg(Stk_Reg) %return F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } %if Stk_Cmval#0 %then Abortm("Opnd not simpilfied") B2=Basereg(Stk_base) PBDisp(Longdispdefmode!B2,D2) %return F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } F(AddrDirModVal): { (dir+M) } F(IndRegModVal): { ((reg)+M) } F(AddrDirMod): { @dir+M } F(RegModAddr): { (reg)+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } %if Modform#Regval %then Abortm("Bad index form") pB(Indexmode!Stk_ModReg) ->F(demodform(Form)) f(*): Abortm("Unexpected opform") %end;! Do operand !* %routine Simplify Opnd(%integer Op,%record(Stkfmt)%name Stk) !*********************************************************************** !* Reduce an operand such that it can be handled by Vax formats * !* Obviously Registers cannot be loaded in the middle of a complex * !* multioperand instruction so they must be loaded first and locked * !* In general everything comes down to simple area or regval or * !* Regdefmode (IndRegVal) or B&D (IndRegVal with Cmval as offset) * !* Modifed operands suitable for autoscaling have the modifiers * !* loaded. Op is provided in case specials are needed * !*********************************************************************** %integer Modreg,Reg,B,D,Form %constintegerarray Loada(0:4)=MOVAB,MOVAW,MOVAL,MOVAQ,MOVAO; %switch F(0:21) D=Stk_Offset B=Stk_Base; Form=Stk_Form&31 ->F(Form); ! removing the reg marker bit !* F(LitVal): ! lit F(ConstVal): ! const F(TempVal): ! (temp) %return F(DirVal): ! (dir) %if B=Stack %or B=Gla %or B=Params %then %return B=Basereg(Stk_Base) Stk_Form=IndregVal!Regflag Stk_Reg=B Stk_Cmval=Stk_Offset Stk_Offset=0 %return F(AddrDir): F(Addrconst): ! If rerefencing is allowed B=Basereg(B) %if Stk_Offset=0 %then %Start Reg=B %else Reg=Claimr(B) Do LItR(ADDL3,Stk_Offset,4,B) PB(REgmode!Reg) %finish Stk_Reg=Reg Stk_Form=Regval!regflag %return !* F(Regval): F(Fregval): F(Regaddr): F(IndRegVal): ! ((reg)) %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)) %if Stk_Cmval=0 %and (B=Stack %or B=Gla %or B=Params) %then %return B=Indbase(Stk_Base,D) Stk_Form=Regflag!IndRegVal Stk_Reg=b %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 Stk_Cmval=Stk_Modintval+Stk_Cmval Stk_Reg=B %finish %else %if Form<=Dirmodaddr %and Stk_Scale<=4 %Start Reg=claimr(B) Stk_Form=Stk_Form+3 Do XR(loada(Stk_scale),Stk,Reg) Stk_Cmval=0 Stk_Reg=Reg %else Modreg=Load Modifier(Stk,B) %if 1<=IndregModval %then Stk_Form=Indregval %else Stk_Form=Regval Cadjust: %if Stk_Cmval#0 %and Stk_Form&31=Regval %then %c Do LitR(ADDL2,Stk_Cmval,4,Stk_reg) %and Stk_Cmval=0 %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) B=Claimr(0) Stk_Form=DirVal Do Xr(MOVAW,Stk,B) Stk_Cmval=0 Forgetuse(B) Do RR(ADDl2,B,Modreg) Funlockreg(Modreg) Stk_Reg=MOdreg %if Form>=IndregModVal %then Stk_Form=IndRegVal %else Stk_Form=Regval!Regflag ->Cadjust !* 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,B2,XAop,spacech,Rmask 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 %Start ! ! Can improve the coding for 1 byte and 1 word moves ! %if Op=EASGNCHAR %then XAop=MOVC3 %else XAop=CMPC3 Fixed Move(XAop,LenC1,C2,C1) %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) B2=Load Int(LenC2,Pair2+1,-1) LOckreg(Pair2+1) !* %if Op=EASGNCHAR %then XAop=MOVC5 %and Rmask=X'3F' %else XAop=CMPC5 %and Rmask=X'F' i=3<>8 Size=Flags&3 %if Size=0 %thenstart D=4 Adj=0 %finishelsestart D=8 Adj=ADDG2-ADDF2; ! to be added to ADDF etc to give ADDG etc %finish %unless Op=4 %and Variant=0 %Start; ! Unless via support proc Reg1=Claimr(-1) Lockreg(Reg1) Reg2=Claimr(Reg1) Lockreg(Reg2) I=Load Int(LHS,REG1,-1) I=Load Int(RHS1,REG2,-1) %if Op<=4 %thenstart Reg3=Claimr(Reg1) I=Load Int(RHS2,Reg3,-1) %finish %else reg3=-1 %finish ->S(Op) !* S(1): ! CXADD Do RRR(ADDF3+Adj,Autoincmode!Reg3,Autoincmode!Reg2,Autoincmode!Reg1) Op1=MOVF+Adj %if variant=1 %then Do RR(Op1,Regdefmode!Reg2,REgdefmode!Reg1) %elsec Do RRR(ADDF3+Adj,Regdefmode!Reg3,Regdefmode!Reg2,Regdefmode!Reg1) unlock: Funlockreg(Reg1) Funlockreg(Reg2) %if reg3>=0 %then Funlockreg(Reg3) %return !* S(2): ! CXSUB Do RRR(SUBF3+Adj,Autoincmode!Reg3,Autoincmode!Reg2,Autoincmode!Reg1) Op1=MOVF+Adj %if Variant=2 %then Op1=MNEGF+Adj %if variant#0 %then Do RR(Op1,Regdefmode!Reg2,REgdefmode!Reg1) %elsec Do RRR(SUBF3+Adj,Regdefmode!Reg3,Regdefmode!Reg2,Regdefmode!Reg1) ->Unlock !* S(3): ! CXMULT %if variant=1 %start; ! Code specailly useing autoinc DoRRR(MULF3+Adj,REgdefmode!Reg3,Autoincmode!Reg2,Autoincmode!reg1) DoRRR(MULF3+Adj,REgdefmode!Reg3,Regdefmode!Reg2,Regdefmode!reg1) %finish %else %Start T1=Claimfr(-1,D); ! Work space for intermediates Do RRR(MULF3+adj,REgdefmode!Reg3,Regdefmode!Reg2,Regdefmode!Reg1) Do R(MULF3+adj,Autoincmode!Reg3) PBDisp(LongDispmode!Reg2,D) PBDisp(Longdispmode!Reg1,D) Do RRR(MULF3+Adj,Regdefmode!Reg3,Regdefmode!Reg2,T1) Do R(ADDF2+Adj,T1); PBDisp(Longdispmode!reg1,D) Do R(MULF3+Adj,Regdefmode!Reg3) PBDisp(Longdispmode!Reg2,D); PB(Regmode!T1) Do Rr(SUBF2+Adj,T1,Regdefmode!Reg1) Funlockfreg(T1,d) %finish ->Unlock !* 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 Do RRR(DIVF3+Adj,Regdefmode!Reg3,Autoincmode!Reg2,Autoincmode!Reg1) Do RRR(DIVF3+Adj,Regdefmode!Reg3,Regdefmode!Reg2,Regdefmode!Reg1) ->Unlock !* S(5): ! CXNEG Do RR(MNEGF+Adj,Autoincmode!Reg2,Autoincmode!Reg1) Do RR(MNEGF+Adj,Regdefmode!Reg2,Regdefmode!Reg1) ->Unlock !* S(6): ! CXASGN %if Flags&4=0 %then Dl=4 %else Dl=8 %if D=4 %and Dl=8 %then Op1=CVTFG %else %if D=8 %and Dl=4 %then Op1=CVTGF %c %else Op1=MOVF+Adj Do RR(Op1,Autoincmode!Reg2,Autoincmode!Reg1) %if Variant=0 %then %start Do RR(Op1,REgdefmode!Reg2,REgdefmode!Reg1) %else %if Variant=2 %then ->unlock; ! Real = Cx ! Cx = Real %if Dl=8 %then Op1=CLRQ %else Op1=CLRL Do R(OP1,Regdefmode!Reg1) %finish ->unlock S(7): ! CXEQ S(8): ! CXNE CC=Op!!15; ! 8 for CXEq 7 for CXNE Do RR(CMPF+Adj,AUTOincmode!Reg2,Autoincmode!Reg1) Einternallab=Einternallab-1 Pjump(BCond,Einternallab,7) %if Variant=1 %thenstart Do R(TSTF+Adj,Regdefmode!Reg1) %finishelsestart Do RR(CMPF+Adj,Regdefmode!Reg2,Regdefmode!Reg1) %finish PLabel(Einternallab) CCset=1 ->Unlock !* S(9): ! CONJG Do RR(MOVF+Adj,Autoincmode!Reg2,Autoincmode!Reg1) Do RR(MNEGF+Adj,Regdefmode!Reg2,Regdefmode!Reg1) ->Unlock %end;! Cx Operation !* %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 * !* The IBM code for finding 2 & 6 byte constants has been omitted * !* It was primarily to save space on instructions targeted by "EX" * !* There is little need for it on Vax and need rewriiten to * !* work on a swopped machine * !*********************************************************************** %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 ->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=4 %THEN %START J=CONST PTR ! %IF USE IMP=YES %THEN %START %FOR K=K,1,J-1 %CYCLE %IF CTABLE(K)=C1 %THEN D=4*K %AND %RETURN %REPEAT ! %FINISH %ELSE %START ! %FINISH %FINISH %ELSE %IF L=8 %or L=16 %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND (CONSTHOLE=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=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH Insert: ! insert new copy if room ->overrun %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 Do Rlit(MOVL,R0,error,4) ejump(JTRUE,Pastraplab) %end %externalroutine egenerateobject {%alias"E#GENERATEOBJECT"}(%stringname s) %end ! ! ! %endoffile