!* modified 16/07/86 !* %owninteger Report=0 %owninteger Decode %owninteger Language !* %constinteger IMP = 1 %constinteger FORTRAN = 2 %constinteger CCOMP = 11 %constinteger PASCAL = 14 !* !*********************************************************************** !* Exports * !*********************************************************************** !* %routinespec Einitialise(%integer Lang, Avertext, Astackca, Aglaca, Options) %routinespec Eterminate(%integer adareasizes) %routinespec Ecommon(%integer area, %stringname Name) %routinespec Eendcommon(%integer area, Length) %routinespec Elinestart(%integer lineno) %routinespec Elinedecode %routinespec Emonon %routinespec Emonoff %routinespec Efaulty %integerfnspec Estkmarker %routinespec Esetmarker(%integer Markerid, New Value) %integerfnspec Eswapmode !* %routinespec Estklit(%integer Val) %routinespec Estkconst(%integer Len, Ad) %routinespec Estkdir(%integer Area, Offset, Adid, Bytes) %routinespec Estkind(%integer Area, Offset, Adid, Bytes) %routinespec Estkglobal(%integer Level, Offset, Adid, Bytes) %routinespec Estkglobalind(%integer Level, Offset, Adid, Bytes) %routinespec Estkpar(%integer Level, Offset, Adid, Bytes) %routinespec Estkparind(%integer Level, Offset, Adid, Bytes) %routinespec Estkresult(%integer Class, Type, Bytes) %routinespec Erefer(%integer Offset, Bytes) %routinespec Epromote(%integer Level) %routinespec Edemote(%integer Level) %routinespec Estkaddr(%integer Area, Offset, Adid, Bytes) !* %routinespec Elabel(%integer id) %routinespec Ediscardlabel(%integer id) %routinespec Ejump(%integer Opcode, Labelid) %routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3) %routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid, %integername SSTad) %routinespec EswitchJump(%integer Switchid) %routinespec EfswitchJump(%integer Switchid) %routinespec Eswitchentry(%integer Switchid, Entry) %routinespec Eswitchdef(%integer Switchid) %routinespec EswitchLabel(%integer Switchid, Entry, Labelid) !* %routinespec Ed1(%integer area, Disp, Val) %routinespec Ed2(%integer area, Disp, Val) %routinespec Ed4(%integer area, Disp, Val) %routinespec Edbytes(%integer area, Disp, len, ad) %routinespec Edpattern(%integer area, Disp, ncopies, len, ad) %routinespec Efix(%integer area, disp, tgtarea, tgtdisp) !* %integerfnspec EXname(%integer type, %string(255)%name Xref) %routinespec Eprecall(%integer Id) %routinespec Ecall(%integer Id, Numpars, Paramsize) %routinespec Ecall2(%integer Id,Extlevel,Numpars,paramsize) %routinespec Eprocref(%integer Id, Level) %routinespec Esave(%integer Asave, %integername Key) %routinespec Erestore(%integer Asave, Key, Existing) !* %integerfnspec Enextproc %routinespec Eproc(%stringname Name, %integer Props, Numpars, Paramsize, Astacklen, %integername Id) %routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen) %routinespec Eentry(%integer Index,Numpars,Paramsize, Localsize, Diagdisp, %stringname Name) !* %routinespec Edataentry(%integer Area, Offset, Length, %stringname Name) %routinespec Edataref(%integer Area, Offset, Length, %stringname Name) !* %routinespec Eop(%integer Opcode) %routinespec Ef77op(%integer Opcode) %routinespec Epasop(%integer Opcode) %routinespec Eccop(%integer Opcode) !* !* !*********************************************************************** !* Imports * !*********************************************************************** !* %include "ercs20:ib8.specs" !%include "ercs01:cfort_xaspecs" %include "ercs01:ebits_ecodes9" %include "ercs01:ebits_enames6" %include "ercs01:cfort_xamnem" !* !* !*********************************************************************** !* Common declarations * !*********************************************************************** !* !* !* !*********************************************************************** !* %constinteger Stack = 0 !* %constinteger LitVal = 0 { lit } %constinteger ConstVal = 1 { const } %constinteger RegVal = 2 { (reg) } %constinteger FregVal = 3 { (freg) } %constinteger TempVal = 4 { (temp) } %constinteger DirVal = 5 { (dir) } %constinteger IndRegVal = 6 { ((reg)) } %constinteger IndTempVal = 7 { ((temp)) } %constinteger IndDirVal = 8 { ((dir)) } %constinteger AddrConst = 9 { @const } %constinteger AddrDir = 10 { @dir } %constinteger RegAddr = 11 { (reg) is @ } %constinteger TempAddr = 12 { (temp) is @} %constinteger DirAddr = 13 { (dir) is @ } %constinteger AddrDirMod = 14 { @dir+M } %constinteger RegModAddr = 15 { (reg)+M } %constinteger TempModAddr = 16 { (temp)+M } %constinteger DirModAddr = 17 { (dir)+M } %constinteger IndRegModVal = 18 { ((reg)+M) } %constinteger IndTempModVal = 19 { ((temp)+M) } %constinteger IndDirModVal = 20 { ((dir)+M) } %constinteger AddrDirModVal = 21 { (@dir+M) } %constinteger RegBitAddr = 22 { (reg) is @ } %constinteger RegBitModAddr = 23 { (reg)+M } !* %constinteger Regflag = 32 {used to speedup search for reguse} !* ! ! 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) ! corresponding address forms:- AddrDir, AddrConst and AddrDir. ! ! The operand is at a known offset in an E-machine ! area. Constval implies Constant (read only) - ! TempVal implies local stack frame and single use ! so libraries can be taken like increment in situ. ! ! ! Indirect Forms ! -------------- ! ! IndDirVal, IndTempVal and IndRegVal ! corresponding address forms:- DirVal, TempVal & Regaddr ! ! There is a pointer to the item in an E-machine and ! (or register). Pointers are 32 bit items. ! ! Modified Forms ! -------------- ! ! Indreg Modval ! Corresponding address form:- Reg ModAddr ! ! The operand is somewhere in store; its address is ! computed by incrementing the register by a modifier ! - not always a literal. Used for array elements and ! items in mapped records. ! ! Ind DirModVal and IndTempModVal ! corresponding address forms:- DirModAddr and TempModAddr ! ! The operand is anywhere in store; its address is ! computed by loading a base pointer from an E-machine ! area (or temparray) and adding a modifier. Items in ! IMP and Pascal global stack frames are accessed thus; ! in these cases the modifier is a literal. Also dynamic ! arrays are via this mechanism. ! ! AddrDirModVal ! corresponding address form:- AddrDirMod ! ! The operand is part of an array with fixed bounds in ! an E-machine area. The first item (A(O)) is specified ! together with a modifier. The address of the item is ! the address of the base incremented by a modifier - ! optimisations are possible for constant modifiers. ! ! ! NOTES ! ----- ! ! A) Certain forms which do not logically have an address are given one ! by storing the value in a temporary; this is for Fortran but should ! not be part of the E-machine. Fortran should do this at a higher ! level. ! ! B) Where there is hardware assistance for a display it is desirable ! for display items to be distinguished from array access. Here ! IndDispModVal and DispModAddr are used. Logically the same ! as IndDirModVal (etc). ! %conststring(14)%array Eform(0:21) = %c "LitVal ","ConstVal ","RegVal ","FregVal ", "TempVal ","DirVal ","IndRegVal ","IndTempVal ", "IndDirVal ","ConstAddr ","AddrDir ","RegAddr ", "TempAddr ","DirAddr ","AddrDirMod ","RegModAddr ", "TempModAddr ","DirModAddr ","IndRegModVal ","IndTempModVal ", "IndDirModVal ","AddrDirModVal " !* %recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg, Base,Modbase,Scale,Modform, (%integer Offset %or %integer Intval), (%integer Modoffset %or %integer Modintval), %integer Size,Adid) !* %constinteger Stkmax=48 %ownrecord(Stkfmt)%array Stk(0:stkmax) %ownrecord(Stkfmt) LitZero %ownrecord(Stkfmt) LitOne !* %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,proclevel) %constinteger swmax=40 %ownrecord(swfmt)%array switches(1:swmax) %ownrecord(swfmt)%name Curswitch ! %OWN %INTEGER const ptr,const hole,half hole %CONST %INTEGER const limit=1023 %OWN %INTEGER %ARRAY ctable(0:const limit) !* %conststring(9)%array Expprocs(0:14)= %c "f_powii" ,"f_powri" ,"f_powdi" ,"f_powqi" ,"f_powci" , "f_powzi" ,"f_powzzi" ,"" ,"" ,"f_powrr" , "f_powdd" ,"f_powqq" ,"f_powcc" ,"f_powzz" ,"f_powzzz" !* %constintegerarray Expprocpdesc(0:14)= %c X'20008',X'20008',X'2000C',X'20008',X'3000C', X'3000C',X'3000C',0 ,0 ,X'20008', X'20010',X'20008',X'3000C',X'3000C',X'3000C' !* %constintegerarray Expproctype(0:14)= %c X'10401',X'10402',X'10802',X'11002',X'10000', X'10000',X'10000', 0, 0,X'10402', X'10802',X'11002',X'10000',X'10000',X'10000' !* %ownintegerarray Expprocref(0:14) !* %conststring(9)%array Spprocs(0:14)= %c "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv" , "f_cddiv" ,"f_cqdiv" ,"f_index" ,"f_concat", "p_stop" ,"P_trap" ,"" ,"p_eoft", "p_eof" ,"p_eol" ,"p_lazy" !* %constintegerarray Spprocpdesc(0:14)= %c X'3000C',X'3000C',X'3000C',X'3000C', X'3000C',X'3000C',X'40010',X'40010', 0 ,X'10004',0 ,X'10004', X'10004',X'10004',X'10004' !* %constintegerarray Spproctype(0:14)= %c X'10000',X'10000',X'10000',X'10000', X'10000',X'10000',X'10000',X'10000', 0 ,0 ,0 ,X'10001', X'10001',X'10001',X'10001' !* %ownintegerarray Spprocref(0:14) !* %constbyteintegerarray minelevel(0:202)=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(17),2(6),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; %owninteger Unasslab,Bounderr,Pastraplab,parmbits1 !* !* !*********************************************************************** !* Amdahl-specific declarations * !*********************************************************************** !* !* %constinteger R0 = 0 %constinteger R1 = 1 %constinteger R2 = 2 %constinteger R3 = 3 %constinteger R4 = 4 %constinteger R5 = 5 %constinteger R6 = 6 %constinteger R7 = 7 %constinteger R8 = 8 %constinteger R9 = 9 %constinteger R10 = 10 %constinteger R11 = 11 %constinteger R12 = 12 %constinteger R13 = 13 %constinteger R14 = 14 %constinteger R15 = 15 !* %constbyteintegerarray Setcc(0:5)=2,4,8,7,10,12 {GT LT EQ NE GE LE} %constbyteintegerarray Invcc(0:15)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15 !* %constinteger Stack Offset=64 %constinteger Param Offset=64 %ownintegerarray Display Offset(0:16) %owninteger Gla Offset !* %constinteger bytesofic=72 %constintegerarray Cnstinit(0:(bytesofic-1)>>2)= 0,0, X'4E000000', X'80000000', X'4E000001', X'00000000', X'4F000000', X'08000000', X'80808080', X'80808080', X'40800000', X'00000000', X'00000001', X'0000001F', x'48800000', X'00000000', X'4E000000', X'00000000' %constinteger TWO31 = 8 %constinteger TWO32 = 16 %constinteger TWO31R= 24 %constinteger RHALF = 40 %constinteger ONE=48,THIRTYONE=52 %constinteger maxiasr=56,zerononstd=64 !* !*********************************************************************** !* %owninteger SSTOffset %ownintegerarray Areabase(0:255) %ownintegerarray Areaprops(0:255) %ownintegerarray Ruse(0:15) %ownbyteintegerarray Using(0:15) %ownintegerarray Fruse(0:6) !* %owninteger Addrstackca, Addrglaca %owninteger Upperlineno %owninteger Lastreg, Lastbreg, Lastfreg, Max4k %owninteger Lockedb1 %owninteger CC, CCset, Store pending %owninteger Glaf77regs,Glawork,Curdiagca, OuterLNBDisp %owninteger CurCnst %owninteger Next Param Offset %ownintegerarray Save Param Offset(0:16) %owninteger Active Calls %constinteger elabbase=199999 %owninteger Einternallab %ownintegerarray Procmark(1:15) %owninteger Proclevel !* !* !*********************************************************************** !* Code generation procedure specs * !*********************************************************************** !* !* %routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset) %routinespec Address(%record(Stkfmt)%name Stk) %integerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg) %integerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg, %integername Bytes) %integerfnspec Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize) %routinespec Push Operand(%record(Stkfmt)%name Operand) %routinespec Stackr(%integer R) %routinespec Stackfr(%integer FR,Bytes) %routinespec Establish Logical %routinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) %routinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) %routinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) %routinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS) %routinespec Convert RR(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode) %routinespec Convert RIR(%record(Stkfmt)%name Stk,%integer mode) %integerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) %routinespec Push Param(%integer Mode,%record(Stkfmt)%name Stk) %routinespec fixedmove(%integer bytes,b1,d1,b2,d2) %routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index) %routinespec Expcall(%integer Proc,%stringarrayname procs,%integerarrayname proctype,procref,procpdesc) !* %routinespec Bit Index(%record(Stkfmt)%name Factor,Base,IndexValue) !* %routinespec Clear Regs %routinespec Dropall %routinespec Freeup Freg(%integer R) %routinespec Freeup Reg(%integer R) %routinespec Freeregs(%integer Mask) %routinespec Reset Reguse(%integer Old,New) %integerfnspec Claimfr(%integer Curreg) %integerfnspec Claimfrpair(%integer Curreg) %integerfnspec Claimr(%integer Curreg) %integerfnspec claimjumpreg(%integer locked) %integerfnspec claimgrpair(%integer notthis) %integerfnspec setlocalbase(%integer locked) %integerfnspec Claimbr %integerfnspec New Temp(%integer Bytes) %routinespec Setint(%integer Val,Size,%integername B2,D2) %integerfnspec Basereg(%integer Area) %integerfnspec SetX2(%integername D2) %integerfnspec fourkdisp(%Integer bigdisp) %routinespec Scalereg(%integer reg,scale) %routinespec Range(%integername B,D) %integerfnspec Indbase(%integer Area,Disp) %routinespec Do Rx(%integer Op,Reg,Base,Offset) %routinespec BOunded jump(%record(StkFmt)%name OP,%integer min,max,sstad) %integerfnspec Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg) %routinespec OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) %routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2) %ROUTINE %SPEC store const(%INTEGER %NAME d, %INTEGER l,ad) %INTEGER %FN %SPEC long const(%LONG %INTEGER value) %INTEGER %FN %SPEC word const(%INTEGER value) %INTEGER %FN %SPEC short const(%INTEGER value) %routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2) %routinespec Set BD(%record(Stkfmt)%name Stk,%integername B,D) !* !*********************************************************************** !* %ownstring(8)%array Areas(0:255)= %c "Stack ","Code ","Gla ","","Ust ","Gst ","Diags ","Scalars", "Ioarea ","","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 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 write(ruse(1),1);write(ruse(2),1);write(ruse(3),1);newline %if Elevel<=0 %then %return printstring("Estack: ") I=Elevel %while I>0 %cycle J=addr(Stk(I)) ! %cycle K=0,4,16 ! Phex(integer(J+K)) ! space ! %repeat E==record(J) write(I,1);printstring(":") Pform(E_Form,E_Reg,E_Base,E_offset) %if (E_Form&31)>=AddrDirMod %thenstart printstring(" mod by:") Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset) %if E_Scale>1 %thenstart printstring(" scaled by:") write(E_Scale,1) %finish %finish printstring(" size:") write(E_Size,1) newline I=I-1 %repeat %end;! Dump Estack !* !********************************************************************** !********************************************************************** !** Error reporting ** !********************************************************************** !********************************************************************** !* !* %routine Low Estack(%integer Opcode,Reqlevel) printstring("******* Estack error ****** Op = ".Eopname(Opcode)." actual/required levels:") write(Elevel,4) write(Reqlevel,4) newline %monitor %stop Elevel=0 %end;! Low Estack !* %routine Abort Dump Estack %monitor %stop %end;! Abort !* %routine abortm(%string(31) S) printstring(" *** Xgen abort - ".S." *** ") Dump Estack %monitor %stop %end;! abortm !* %routine Unsupported Opcode(%integer Opcode) %string(15) S %if Opcode<=255 %then S=Eopname(Opcode) %elseif %c Opcode<511 %then S=Ef77opname(Opcode) %else S=Epasopname(Opcode) printstring("******* Unsupported Opcode ****** ".S) newline %end;! Unsupported Opcode !* !* !*********************************************************************** !*********************************************************************** !** Externally visible procedures ** !*********************************************************************** !*********************************************************************** !* !* !* ********************* !* * Administration * !* ********************* !* !* %externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options) !*********************************************************************** !* called once at the start of compilation to initialise Eput * !*********************************************************************** %integer I,Flags %String(63) Verss ProgFaulty=0 ! Report=options&1; ! options go into gla+19 and can not be used as this frig uses them! Decode=Options&2 Language=Lang %if Report#0 %thenstart printstring("Einitialise"); write(Options,5) newline %finish Addrstackca=Astackca Addrglaca=Aglaca Upperlineno=-1 Using(i)=0 %for i=0,1,15 Clear Regs CCset=0; Store pending=0 Elevel=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 %cycle I=4,1,10 Areabase(I)=I<<2+64 %repeat %cycle I=0,1,14 Expprocref(I)=0 %repeat %cycle I=0,1,14 Spprocref(I)=0 %repeat !* parmbits1=comreg(27) %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 %else Gla Offset=0 !* %if Language=FORTRAN %then Flags=3 %else Flags=1 Pinitialise(-1,Flags,Aver) !* Pfix(Gla,4,Code,0);! initialise first six words of gla Pfix(Gla,8,Ust,0) Areabase(ust)=8 Pfix(Gla,12,SST,0) areabase(sst)=12 %if Lang=PASCAL %then Lang=15 {a communication problem} Pd4(Gla,16,(Lang<<24)!Options) Pfix(Gla,20,Diags,0) %if Language=PASCAL %thenstart I=32 %finishelsestart I=Glaspace(16) %finish Glaf77regs=I Pfix(Gla,I,Static,0) Pfix(Gla,I+4,Cnst,0) Glawork=I+8 PD4(Gla,Glawork,X'4E000000'); ! For fast floating transformations !* const ptr=bytesofic>>2 ctable(i)=cnstinit(i) %for i=0,1,const ptr-1 Curcnst=4*(const limit+1) const hole=0; half hole=0 Max4k=0 Lockedb1=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 pix rx(la,0,0,0,0); ! till bot fixed for labels at offset 0 %if language=Pascal %Start; ! set up pascal traps Einternallab=einternallab-2 Pastraplab=Einternallab unasslab=Pastraplab+1 Plabel(Unasslab) PIX RX(LA,0,0,0,343) PLabel(Pastraplab) I=Exname(0,spprocs(9)) spprocref(9)=i Eprecall(i) pix rx(St,R0,0,R11,64) Ecall2(i,1,1,4) %finish; ! must not return %end;! Einitialise !* %externalroutine Eterminate(%integer adareasizes) !*********************************************************************** !* called once at the end of compilation by the code generator * !*********************************************************************** %ownintegerarray S(1:10) %integer I,J %if Report#0 %thenstart printstring("Eterminate ") %finish %if ProgFaulty#0 %then %return J=0 !newline %cycle I=1,1,9 S(I)=integer(Adareasizes+J) !write(s(i),4) J=J+4 %repeat !newline %if Language=PASCAL %thenstart S(2)=S(2)+Gla Offset S(4) = SSTOffset %finish pdbytes(Cnst,0,4*const ptr,addr(ctable(0))) %if curcnst=4*(const limit+1) %then curcnst=4*const ptr; ! no table overflow S(10)=CurCnst %if language#Fortran %Then pminmultiples(max4k+1) I=Pterminate(addr(S(1)), 0) integer(adareasizes)=S(1) %end;! Eterminate !* %externalroutine Ecommon(%integer area,%stringname Name) !*********************************************************************** !* define a common area (in range 11-255) * !*********************************************************************** %integer Prop %if Report#0 %thenstart printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name) Newline %finish %if ProgFaulty#0 %then %return Area=Area+256 %if Name="F#BLCM" %then Prop=1 %else Prop=2 Areaprops(Area-256)=Prop Pnewarea(Name,Area,Prop) %end;! Ecommon !* %externalroutine Eendcommon(%integer area,Length) !*********************************************************************** !* define length of previously defined common * !*********************************************************************** %if Report#0 %thenstart printstring("Eendcommon ");write(Area,1);write(Length,6) Newline %finish %if ProgFaulty#0 %then %return Area=Area+256 Pendarea(Area,Length,Areaprops(Area-256)) %end;! Eendcommon !* %externalroutine Elinestart(%integer lineno) !*********************************************************************** !* register start of a line * !*********************************************************************** %if Report#0 %thenstart printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4) newline %finish %if ProgFaulty#0 %then %return %if Decode#0 %then Plinedecode Plinestart(Lineno) %if parmbits1&(1<<23)#0 %then %return PIX SI(MVI, lineno&X'FF', R10, 3) %if lineno & X'FF00' # Upperlineno %thenstart PIX SI(MVI, lineno>>8, R10, 2) Upperlineno = lineno & X'FF00' %finish %end;! Elinestart !* %externalroutine Elinedecode !*********************************************************************** !* decompile code generated from last Elinedecode or Elinestart * !*********************************************************************** %if Report#0 %thenstart printstring("Elinedecode "); %finish %if ProgFaulty#0 %then %return Plinedecode %end;! Elinedecode !* %externalintegerfn Estkmarker !*********************************************************************** !* 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 Report#0 %thenstart printstring("Estkmarker ") %finish markval=pmarker(4); ! reserve 4 halfwords reg=claimr(0); ! zero wont work psetopd(markval,0,x'580C'!reg<<4) psetopd(markval,2,x'4100'!reg<<4!reg) stackr(reg) %result=markval %end;! Estkmarker !* %externalroutine Esetmarker(%integer Markerid,New Value) !*********************************************************************** !* Nominate the value of the literal stacked by estkmarker(above) * !*********************************************************************** %integer j %if Report#0 %thenstart printstring("Esetmarker ");write(Markerid,4) write(New Value,4) newline %finish psetopd(markerid,1,Fourkdisp(Newvalue)); ! Fill the 4k multiple psetopd(markerid,3,newvalue&4095);! file the load address offset %end;! Esetmarker !* %externalintegerfn Eswapmode !*********************************************************************** !* turn on internal tracing * !*********************************************************************** %if Report#0 %thenstart printstring("Eswapmode ") %finish %result=0 %end;! Eswapmode !* %externalroutine Emonon !*********************************************************************** !* turn on internal tracing * !*********************************************************************** Report=1 %end;! Emonon !* %externalroutine Emonoff !*********************************************************************** !* turn off internal tracing * !*********************************************************************** %if report#0 %then printstring("Emonoff") %and newline Report=0 %end;! Emonoff !* %externalroutine Efaulty !*********************************************************************** !* compilation has a fault - no object file to be generated * !*********************************************************************** %if Report#0 %thenstart printstring("Efaulty "); %finish ProgFaulty=1 Pfaulty %end;! Efaulty !* !* !* !* ********************* !* * Stack operations * !* ********************* !* !* %externalroutine Estklit(%integer Val) !*********************************************************************** !* stacks Val as a 32-bit integer literal * !*********************************************************************** %if Report#0 %thenstart printstring("Estklit ");write(Val,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=LitVal Stk(Elevel)_Intval=Val Stk(Elevel)_Size=4 %end;! Estklit !* %externalroutine Estkconst(%integer Len,Ad) !*********************************************************************** !* stacks the constant, allocating space for it if necessary * !*********************************************************************** %integer at %if 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(%integer Len,Ad) !*********************************************************************** !* stacks the constant, allocating space for it if necessary * !*********************************************************************** %integer at %if Report#0 %thenstart printstring("EstkRconst ") write(Len,4) %if Len=4 %then Print(real(Ad),8,12) %else Print(longreal(Ad),8,12) newline %finish %if ProgFaulty#0 %then %return store const(at,len,ad) estkdir(cnst,at,0 ,len) %end;! Estkrconst !* %externalroutine Estkdir(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkdir ".Areas(area)." +");write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical %if Area=0 %then Offset=Offset+Stack Offset %if Area=Gla %then Offset=Offset+Gla Offset %if Elevel=stkmax %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=Area Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkdir !* %externalroutine Estkind(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkind ".Areas(area)." +");write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return %if Area=0 %then Offset=Offset+Stack Offset %if Area=Gla %then Offset=Offset+Gla Offset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=IndDirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=Area Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkind !* %externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand local to an enclosing level * !*********************************************************************** %if Report#0 %thenstart printstring("Estkglobal ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset = Offset + StackOffset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 %if Level=Proclevel %thenstart Stk(Elevel)_Form = DirVal Stk(Elevel)_Offset = Offset %finishelsestart { Global } Stk(Elevel)_Form=IndDirModVal Stk(Elevel)_Modform=LitVal Stk(Elevel)_Offset=DisplayOffset(proclevel)+(Level*4) Stk(Elevel)_ModIntVal=Offset %finish Stk(Elevel)_Size = Bytes Stk(Elevel)_Base = 0 Stk(Elevel)_Adid=Adid %end;! Estkglobal !* %externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes) %end !* %externalroutine Estkgind(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand local to an enclosing level * !*********************************************************************** %if Report#0 %thenstart printstring("Estkgind ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 %if Level=Proclevel %thenstart Stk(Elevel)_Form=IndDirVal Stk(Elevel)_Base = 0 %finishelsestart Stk(Elevel)_Form = IndRegModVal Stk(Elevel)_Reg = ClaimBR PIX RX(L,Stk(Elevel)_Reg,0,R10,DisplayOffset(proclevel)+Level<<2) Stk(Elevel)_Modform = LitVal Stk(Elevel)_Modintval = Offset %finish Stk(Elevel)_Size=Bytes Stk(Elevel)_Adid=Adid %end;! Estkgind !* %externalroutine Estkpar(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct parameter operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkpar ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 %if Level=ProcLevel %thenstart { Local parameter } Stk(Elevel)_Form=DirVal Stk(Elevel)_Offset=Offset %finishelsestart { Global parameter } Stk(Elevel)_Form=IndDirModVal Stk(Elevel)_Modform=LitVal Stk(Elevel)_Offset=DisplayOffset(proclevel)+(Level*4) Stk(Elevel)_ModIntVal=Offset %finish Stk(Elevel)_Size = Bytes Stk(Elevel)_Base = 0 Stk(Elevel)_Adid=Adid %end;! Estkpar !* %externalroutine Estkparind(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect parameter operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkparind ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=stkmax %then %monitor %and %stop %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Elevel=Elevel+1 Stk(Elevel)=0 %if Level=Proclevel %thenstart Stk(Elevel)_Form=IndDirVal Stk(Elevel)_offset=offset Stk(Elevel)_Base = 0 %finishelsestart Stk(Elevel)_Form = IndRegModVal Stk(Elevel)_Reg = ClaimBR PIX RX(L,Stk(Elevel)_Reg,0,R10,DisplayOffset(proclevel)+Level<<2) Stk(Elevel)_Modform = LitVal Stk(Elevel)_Modintval = Offset %finish Stk(Elevel)_Size=Bytes Stk(Elevel)_Adid=Adid %end;! Estkparind !* %externalroutine Estkresult(%integer Class,Type,Bytes) !*********************************************************************** !* defines the result stacked by a function call * !* Type = 1 int * !* = 2 real * !*********************************************************************** %if Report#0 %thenstart printstring("Estkresult ") write(Class,4);write(Type,4);write(Bytes,4) newline %finish %if ProgFaulty#0 %then %return %if Type=2 %thenstart;! real Stackfr(0,Bytes) %finishelse %if Type=3 %thenstart Elevel = Elevel + 1 %if Elevel>stkmax %then %monitor %and %stop Stk(Elevel) = 0 Stk(Elevel)_Form = IndRegVal Stk(Elevel)_Reg = R1 Ruse(R1) = -Elevel Stk(Elevel)_Size = Bytes %finishelsestart Stackr(R1) %finish %end;! Estkresult !* %externalroutine Erefer(%integer Offset,Bytes) !*********************************************************************** !* stacks the address of a direct operand * !*********************************************************************** %if Report#0 %thenstart printstring("Erefer ");write(Offset,1);write(Bytes,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Abort %and %return Refer(Stk(Elevel),Offset) Stk(Elevel)_Size=Bytes %end;! Erefer !* %externalroutine Epromote(%integer Level) !*********************************************************************** !* move the entry at Level in Estack to the top of the Estack * !* - the top entry is at level 1 * !*********************************************************************** %record(Stkfmt) E %integer I %if Report#0 %thenstart printstring("Epromote ");write(Level,4) newline %finish %if ProgFaulty#0 %then %return %unless 00 %then Abort Upperlineno = -1 Dropall Plabel(id) %end;! Elabel !* %externalroutine Eplabel(%integer Id) !*********************************************************************** !* register a private label * !*********************************************************************** %if Report#0 %thenstart printstring("Eplabel ");write(Id,4) newline %finish %if ProgFaulty#0 %then %return !? Dropall Plabel(id) %end;! Eplabel !* %externalroutine Ediscardlabel(%integer Id) !*********************************************************************** !* advise that a label can now be discarded - i.e. no future ref * !*********************************************************************** %if Report#0 %thenstart printstring("Ediscardlabel ");write(Id,4) newline %finish %end;! Ediscardlabel !* %externalroutine Euchecklab(%integer Labid) Unasslab=Labid %end !* %externalroutine Eboundlab(%integer Labid) Bounderr=Labid %end;! Eboundlab !* %externalroutine Ejump(%integer Opcode, Labelid) !*********************************************************************** !* generate specified conditional or unconditional jump * !*********************************************************************** %switch Op(0:164) %integer Reg1,Freg1,XAop,Bytes,Form,B,D %if Report#0 %thenstart printstring("Ejump ".Eopname(Opcode));write(Labelid,4) newline %finish %if ProgFaulty#0 %then %return %if ruse(r14)#0 %then freeup reg(R14) ->Op(Opcode) !* Op(*):%monitor %stop !* Op(JIGT): Op(JILT): Op(JIEQ): Op(JINE): Op(JIGE): Op(JILE): CC=Setcc(Opcode-JIGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2)) CCset=0 ->jump !* Op(JUGT): Op(JULT): Op(JUEQ): Op(JUNE): Op(JUGE): Op(JULE): CC = Setcc(Opcode-JUGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(UGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2)) CCset = 0 ->jump !* Op(JINTGZ): Op(JINTLZ): Op(JINTZ): Op(JINTNZ): Op(JINTGEZ): Op(JINTLEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) cc=Setcc(Opcode-JINTGZ) ->jump !* Op(JUGTZ): Op(JULTZ): Op(JUEQZ): Op(JUNEZ): Op(JUGEZ): Op(JULEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) CC=Setcc(Opcode-JUGTZ) ->jump !* Op(JUMP): CC=15 jump: Pjump(BC,Labelid,CC,R14) %if using(r14)#0 %then Pdrop(R14) %return !* Op(JRGT): Op(JRLT): Op(JREQ): Op(JRNE): Op(JRGE): Op(JRLE): CC=Setcc(Opcode-JRGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Real Binary Op(RGT+Opcode-JRGT,Stk(Elevel+1),Stk(Elevel+2)) CCset=0 ->jump !* Op(JRGZ): Op(JRLZ): Op(JRZ): Op(JRNZ): Op(JRGEZ): Op(JRLEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then XAop=LTER %else XAop=LTDR PIX RR(XAop,Freg1,Freg1) CC=Setcc(Opcode-JRGZ) ->jump !* Op(JTRUE): Op(JFALSE): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Form=Stk(Elevel+1)_form&31 %if language=Pascal %and (form=dirval %or form=tempval) %c %and Stk(elevel+1)_Offset<4095 %Start SetBD(Stk(elevel+1),B,D) pix si(CLI,0,B,D+Stk(elevel+1)_size-1) %else Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) %finish CC=7 %finish %else CCset=0 %If OPcode=JFALSE %then CC=CC!!15; ->jump %end;! Ejump !* %externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3) !*********************************************************************** !* generate the code for a Fortran three-way jump * !* opcode = ITWB or RTWB for integer or real expression on Estack * !* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0 * !* - if Labi <= 0 that jump is not required * !*********************************************************************** %integer Op,Reg1,Freg1,Bytes %if Report#0 %thenstart printstring("Etwjump ".Eopname(Opcode)) write(Lab1,4);write(Lab2,4);write(Lab3,4) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 %if Opcode=ITWB %thenstart Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) %finishelsestart Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then Op=LTER %else Op=LTDR PIX RR(Op,Freg1,Freg1) %finish %if Lab1>0 %then Pjump(BC,Lab1,4,R14);! if < 0 %if Lab2>0 %then Pjump(BC,Lab2,8,R14);! = 0 %if Lab3>0 %then Pjump(BC,Lab3,2,R14);! > 0 %end;! Etwjump !* %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 Eswitch(%integer Lower, Upper, Switchid, Errlabid, %integername SSTad) !*********************************************************************** !* define a switch Switchid to be indexed in the range (Lower:Upper) * !* space may be claimed from SST fotr the switch table * !*********************************************************************** %integer Ad %if Report#0 %thenstart printstring("Eswitch ") write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4) newline %finish %if ProgFaulty#0 %then %return Ad=SSTad SSTad=SSTad+(Upper-Lower+1)<<2 Pswitch(Ad,Lower,Upper,4) ! ! 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-4*lower curswitch_id=switchid curswitch_lower=lower curswitch_upper=upper curswitch_Proclevel=proclevel %end;! Eswitch !* %externalroutine EswitchJump(%integer Switchid) !*********************************************************************** !* jump to Switchid( (Etos) ) * !* if (Etos) is outside the bounds defined for Switchid then error * !*********************************************************************** %if Report#0 %thenstart printstring("EswitchJump ");write(switchid,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) %if elevel<1 %then low estack(jump,1) %and %return elevel=elevel-1 bounded jump(Stk(elevel+1),1,0,curswitch_SSTad) %end;! EswitchJump !* %externalroutine EfswitchJump(%integer Switchid) !*********************************************************************** !* jump to Switchid( (Etos) ) * !* if (Etos) is outside the bounds the jump has no effect. Note that * !* in this case Switchid(Lower) addresses the next instruction * !*********************************************************************** %if Report#0 %thenstart printstring("EfswitchJump ");write(switchid,4) newline %finish %if ProgFaulty#0 %then %return %If curswitch_id#switchid %then locate switch(switchid) %if Elevel<1 %then Low Estack(JUMP,1) %and %return Elevel=Elevel-1 bounded jump(Stk(elevel+1),0,curswitch_upper,curswitch_SSTad) eswitchdef(switchid); ! ensurre element 0 is set to here(saves a specific test) %end;! EfswitchJump !* %externalroutine Eswitchentry(%integer Switchid, Entry) !*********************************************************************** !* define the current code address as Switchid(Entry) * !*********************************************************************** %if Report#0 %thenstart printstring("Eswitchentry ");write(Switchid,4);write(Entry,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) Pslabel(curswitch_sstad,entry) drop all %end;!Eswitchentry !* %externalroutine Eswitchdef(%integer Switchid) !*********************************************************************** !* define the current code address as Switchid(*) - the default * !*********************************************************************** %if Report#0 %thenstart printstring("Eswitchdef ");write(Switchid,4) newline %finish %If curswitch_id#switchid %then locate switch(switchid) Einternallab=Einternallab-1 plabel(Einternallab) psdefault(curswitch_sstad,Einternallab) %end;!Eswitchdef !* %externalroutine EswitchLabel(%integer Switchid, Entry, Labelid) !*********************************************************************** !* define Labelid as Switchid(Entry) * !*********************************************************************** %if Report#0 %thenstart printstring("EswitchLabel ");write(switchid,4);write(entry,4) write(labelid,4) newline %finish %if ProgFaulty#0 %then %return %If curswitch_id#switchid %then locate switch(switchid) Pswitchval(curswitch_sstad,Entry,Labelid) %end;! EswitchLabel !* %externalroutine EcaseJump(%integer MinLab, MaxLab, ErrLab, WFlag, CaseId) !************************************************************************ !* Plant a case jump-table for the case-statement ideintified by CaseId * !************************************************************************ %integer Ad %if Report#0 %thenstart printstring("EcaseJump") write(MinLab,4); write(MaxLab,4); write(ErrLab,4); write(WFlag,4); write(CaseId,4); newline %finish %if ProgFaulty#0 %then %return Ad=SSTOffset SSTOffset=SSTOffset+(MaxLab-MinLab+1)<<2 Pswitch(Ad,0,MaxLab-MinLab,4) LOcate switch(0); ! find empty slot curswitch_Id = CaseId curswitch_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(%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 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(%integer ErrLab, CaseId) !************************************************************************ !* Fill blank entries in the case-table denoted by CaseId with the * !* address of the error-label ErrLab. * !************************************************************************ %if 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(%integer Labid, Offset) !************************************************************************ !* Declare a new statement label Labid at Offset within the stack-frame.* !************************************************************************ %integer I %if Report#0 %thenstart printstring("EnewLab"); write(Labid,4); write(Offset,4) newline %finish %if NestedProcs=0 %thenstart %if Proclevel=1 %thenstart %if OuterLNBDisp=-1 %then OuterLNBDisp=GlaSpace(4) PIX RX(ST,R10,0,R13,OuterLNBDisp) %finish PIX RX(ST,R11,0,R10,DisplayOffset(proclevel)+4) NestedProcs=1 %finish %for I = 1,1,MaxLabs %cycle %if Labs(I)_LabId=-1 %then -> Found %repeat AbortM("Too many labels") Found: Labs(I)_LabId = LabId Labs(I)_GlaAd = Offset+Gla offset %end;! EnewLab !* %externalroutine Egjump(%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 Report#0 %thenstart printstring("Egjump"); write(Level,4); write(Offset,4) newline %finish %if ProgFaulty#0 %then %return %if Level=1 %thenstart { Outermost level } %if OuterLNBDisp=-1 %then OuterLNBDisp = GlaSpace(4) PIX RX(L,R10,0,R13,OuterLNBDisp) { Loads LNB from Gla } %finishelsestart { Inner level } PIX RX(L,R10,0,R10,Display Offset(proclevel)+Level<<2) { Loads LNB } %finish PIX RX(L,R15,0,R13,Offset+GLaOffset) { Loads PC from GLa} PIX RR(BCR,15,R15) %end;! Egjump !* %externalroutine EstmtLabel(%integer Labid,Offset) !************************************************************************ !* Define a statement-label. * !************************************************************************ %integer I %if Report#0 %thenstart printstring("Estmtlabel"); write(Labid,4); write(Offset,4) newline %finish %if ProgFaulty#0 %then %return %if NestedProcs#0 %thenstart %for I = 1,1,MaxLabs %cycle %if Labs(I)_LabId=LabId %then -> Found %repeat AbortM("Label not found") Found: PFix(Gla,Labs(I)_GlaAd,Code,PMarker(0)) PIX RX(L,R11,0,R10,DisplayOffset(proclevel)+4) %finish ELabel(LabId) %end;! Estmtlabel !* !* !* !* ******************************* !* * Data initialisation, fixups * !* ******************************* !* !* %externalroutine Ed1(%integer area, Disp, Val) !*********************************************************************** !* intialise an 8-bit location * !*********************************************************************** %if area=0 %then area=1//area %if Report#0 %thenstart printstring("Ed1 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish Pdbytes(area, Disp, 1, addr(Val)+3) %end;! Ed1 !* %externalroutine Ed2(%integer area, Disp, Val) !*********************************************************************** !* intialise a 16-bit location * !*********************************************************************** %if area=0 %then area=1//area %if Report#0 %thenstart printstring("Ed2 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish Pdbytes(area, Disp, 2, addr(Val)+2) %end;! Ed2 !* %externalroutine Ed4(%integer area, Disp, Val) !*********************************************************************** !* intialise a 32-bit location * !*********************************************************************** %if area=0 %then area=1//area %if Report#0 %thenstart printstring("Ed4 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 Pdpattern(Area,Disp,1,4,addr(Val)) %finishelsestart Pd4(area, Disp, Val) %finish %end;! Ed4 !* %externalroutine Edbytes(%integer area, Disp, len, ad) !*********************************************************************** !* intialise a block of data * !*********************************************************************** %if area=0 %then area=1//area %if Report#0 %thenstart printstring("Edbytes ") %finish %if ProgFaulty#0 %then %return %if Area=10 %then %monitor;! should not be allocated any more %if len=8 %thenstart Ed4(area,disp,integer(ad)) Ed4(area,disp+4,integer(ad+4)) %return %finish %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish %if area<=10 %thenstart Pdbytes(area, disp, len, ad) %finishelsestart Pdpattern(area, Disp, 1, len, ad) %finish %end;! Edbytes !* %externalroutine Edpattern(%integer area, Disp, ncopies, len, ad) !*********************************************************************** !* initialise using a 1,2,4 or 8 byte pattern * !*********************************************************************** %integer I %if Report#0 %thenstart printstring("Edpattern ") printstring(areas(area)." ");write(disp,1);write(ncopies,8) write(len,8);write(ad,8) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish ! %if Area<=10 %thenstart ! %cycle I=1,1,ncopies ! Pdbytes(Area,Disp,Len,Ad) ! Disp=Disp+Len ! %repeat ! %finishelsestart Pdpattern(area, Disp, ncopies, len, ad) ! %finish %end;!Edpattern !* %externalroutine Efix(%integer area,disp, tgtarea,tgtdisp) !*********************************************************************** !* relocate area+disp to tgtarea+tgtdisp (all are byte addresses) * !*********************************************************************** Area=Area&X'FFF';! in case 'byte' marker had been set (historic) %if Report#0 %thenstart printstring("Efix ".Areas(Area)." +");write(Disp,1) printstring(" => ".Areas(Tgtarea)." +");write(Tgtdisp,1) newline %finish %if ProgFaulty#0 %then %return %if Area=Gla %then Disp=Disp+Gla Offset %if Tgtarea=Gla %then Tgtdisp=Tgtdisp+Gla Offset %if Tgtarea>=11 %thenstart %if Area=2 %and Tgtdisp=0 %then Areabase(Tgtarea)=Disp Tgtarea=Tgtarea+256 %finish PD4(Area,Disp,Tgtdisp) Tgtdisp=0 Pfix(area,disp, tgtarea,0) %end;! Efix !* !* !* !* ********************* !* * Procedure call * !* ********************* !* !* %externalintegerfn EXname(%integer type,%string(255)%name Xref) !*********************************************************************** !* generate an external reference, returning an Id for future reference* !*********************************************************************** %integer Refad,I %if Report#0 %thenstart printstring("EXname ".Xref);write(Type&15,4);write(Type>>4,4) newline %finish Refad=Glaspace(16) %if ProgFaulty#0 %then %result=Refad %if Language=Pascal %or language=Imp %then PD4(Gla,RefAd+12,-1) type=type!(parmbits1>>20&1); ! or in dynamic bit pro tem I=PXname(0,Xref,Refad) %result=Refad %end;! EXname !* %externalroutine Eprecall(%integer Id) !*********************************************************************** !* called prior to planting parameters to a procedure call * !*********************************************************************** %if Report#0 %thenstart printstring("Eprecall "); write(id,4); write(active calls,3) newline %finish %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 Active Calls = Active Calls + 1 %if Active Calls>1 %thenstart Save Param Offset(Active Calls) = Next Param Offset DO RX(LA,R11,R11,Next Param Offset&X'FFFF') %if Next Param Offset&X'FFFF'>64 %finish Next Param Offset=64 %end;! Eprecall !* %externalroutine Ecall2(%integer Id,Extlev,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %integer X2,top,btm %if Report#0 %thenstart printstring("Ecall2 "); write(Id,4); write(Extlev,4) write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return Freeregs({X'FFC01E'}-1); ! too drastic r5-r7 are preserved PIX RX(LA,R4,0,R10,DisplayOffset(proclevel)) %unless %c (id>0 %or extlev=1 %or (language=pascal %and extlev=2)) %and Next param offset>>24=0{rt param passed} Top=R14 %if store pending#0 %then Top=R0 %and storepending=0 btm=R4 %if next param offset>>24=0 %then btm=R8 PIX RS(STM, Btm, Top, R11, 4*Btm) %if Id>0 %then %Start Pd4(GLA,Id+12,(Numpars<<16)!Paramsize);! for loader check %if Id>=4096 %thenstart PIX RX(A,13,0,R12,Fourkdisp(Id)) Id=Id&x'FFF' %finish PIX RS(LM, R12, R14, R13, id) PIX RR(BASR, R15, R14) %finish %else pjump(BAS,Id+elabbase,15,r15) drop all Pusing(R15) Using(R15) = 1 %if Active Calls>1 %thenstart Next Param Offset = Save Param Offset(Active Calls) %if next Param Offset&X'FFFF'>64 %then %c DO RX(SH,R11,R9,short const(Next Param Offset&X'FFFF')) %finish Active Calls = Active Calls - 1 %end;! Ecall2 %externalroutine Ecall(%integer Id,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %integer X2 %if Report#0 %thenstart printstring("Ecall "); write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return %if language=fortran %then x2=1 %else x2=99 ecall2(id,x2,numpars,paramsize) %end;! Ecall !* !* %externalroutine Eprocref(%integer Id, Level) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %integer Ad, I, Rbase %if Report#0 %thenstart printstring("Eprocref ");write(Id,4) newline %finish %if Id>=0 %then Estkaddr(Gla,Id-glaoffset,0,4) %and %return Ad =New temp(16) { Make a copy of the entry descriptor } Rbase=R10 %if Ruse(R2)#0 %then Freeup Reg(R2) pjump(LA,Id+elabbase,r2,r1) DoRX(st,R2,rbase,Ad+8) DoRX(st,R12,rbase,Ad) DoRX(st,R13,rbase,Ad+4) Do RX(ST,R11,Rbase,Ad+12) Estkaddr(Stack,Ad-StackOffset,0,4);! Ad is offset of local copy of entry block Next Param Offset=Next Param Offset!x'01000000'{Note rt param} %end;! Eprocref !* %externalroutine Eprocenv(%integer Level) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Eprocenv ");write(Level,4) newline %finish {%if Level>1 %thenstart} {Estkdir(0,Display Offset(proclevel)+Level<<2,0,4)} {%finishelse} Estklit(0) { Dummy on Amdahl } %end;! Eprocenv !* %externalroutine Esave(%integer Asave, %integername Key) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Esave ");write(Asave,4) newline %finish %end;! Esave !* %externalroutine Erestore(%integer Asave, Key, Existing) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Erestore ");write(Asave,4) newline %finish %end;! Erestore !* !* !* !* ********************************** !* * Procedure definition and entry * !* ********************************** !* !* %externalintegerfn Enextproc !*********************************************************************** !* result is an Id to be used for a procedure first encountered as an * !* internal spec * !*********************************************************************** %integer Refad,I %if Report#0 %thenstart printstring("Enextproc ") %finish Einternallab=Einternallab-1 Refad=Einternallab-elabbase %if Report#0 %thenstart printstring(" key ="); write(Refad,1) newline %finish %result=Refad %end;! Enextproc !* %externalroutine Eproclevel(%integer Level) !*********************************************************************** !* record static nesting level of the current procedure * !*********************************************************************** %if Report#0 %thenstart printstring("Eproclevel ");write(Level,3) newline %finish ProcLevel = Level %end;! Eproclevel !* %externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize, Astacklen, %integername Id) !*********************************************************************** !* define the start of a procedure body * !* if Id > 0 this is the Id returned by a previous call of Enextproc * !* Astacklen is the address of the word noting the current local * !* stack-frame size * !*********************************************************************** %integer I,Baser %if Report#0 %thenstart printstring("Eproc ");printstring(Name) write(Numpars,4); write(Paramsize,4); write(Id,4); write(props,4) newline %finish %if ProgFaulty#0 %then %return Drop all %unless Language=PASCAL %then Proclevel=Proclevel+1 %if Language=PASCAL %or language=IMP %thenstart DisplayOffset(proclevel) = (ParamOffset + ParamSize + 3) & (\3) %finish Upperlineno = -1 ProcProps=Props %if Props&2#0 %then Props=X'80000001' %else Props=Props&1 %if Id=-1 %then Einternallab=Einternallab-1 %and Id=Einternallab-elabbase Plabel(Id+elabbase) NestedProcs = 0 Pproc(Name,Props,Numpars<<16!Paramsize,Id) Curdiagca=-1 %if Language#FORTRAN %thenstart %if Astacklen#-1 %then Addrstackca=Astacklen integer(addrstackca) = (integer(addrstackca)+3)&(\3) PIX RX(ST,R15,0,R11,60) PIX RR(LR,R10,R11) Procmark(proclevel)=PMarker(2) %if parmbits1>>4&1=0 %Start; ! unassigned checking not inhibited DO rx(LA,R0,R10,Displayoffset(proclevel)) pix rr(LR,R1,R11) pix rr(SR,R1,R0) pix rr(LR,R2,R0) pix rx(LA,R3,0,0,X'80') pix rs(sll,R3,0,0,24) pix rr(mvcl,r0,r2) %Finish %if (Language=Pascal %or language=IMP) %and ProcProps&4=0 %thenstart { Copy display } %if proclevel=1 %or props&1#0 %or (language=pascal %and proclevel=2)%Start PIX RX(ST,R10,0,R10,DisplayOffset(proclevel)+Proclevel<<2) %unless Procprops&256#0 PIX RX(ST,R13,0,R10,DisplayOffset(proclevel)) %unless %c parmbits1&X'800004'=X'800004' %finish %else %if proclevel>7 %Start pix ss(MVC,0,4*proclevel,R10,Display Offset(proclevel),R4,0) PIX RX(ST,R10,0,R10,DisplayOffset(proclevel)+Proclevel<<2) %unless Procprops&256#0 %else I=proclevel-1 Baser=R0 %if parmbits1&x'800004'=x'800004' %Then Baser=R0+2 pix rs(LM,Baser,R0+I,R4,4*Baser) pix rr(LR,R0+proclevel,R10) %and I=I+1 %unless Procprops&256#0 pix rs(STM,Baser,R0+I,R10,DisplayOffset(proclevel)+4*Baser) %Finish %finish PIX RS(LM,R8,R9,R13,Glaf77regs) %if proclevel=1 %or props&1#0 { @ statics and const area } %if ProcProps&2#0 %thenstart;! main entry PIX RX(LA,R1,0,0,8) PIX RS(SLL,R1,0,0,24) PIX RR(SPM,R1,0) %finish %finish %else max4k=0; ! Start count again for fortran %end;! Eproc !* %externalroutine Eprocend(%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 Report#0 %thenstart printstring("Eprocend ");write(Localsize,6) Write(DiagDisp,6) newline %finish %if ProgFaulty#0 %then %return %if Language#Fortran %thenstart %if language=pascal %and proclevel=1 %then LocalSize = LocalSize+16 ! Pascal does not allow for display at outer level LocalSize = (LocalSize+3)&(\3) %if LocalSize>integer(AddrStackCa) %then localsize = LocalSize + ParamOffset %c %else localsize = integer(AddrStackCa) + ParamOffset localsize=(localsize+15)&(-16) %if localsize<=4095 %Start PSetOpd(ProcMark(proclevel),0,X'41B0') PSetOpd(Procmark(proclevel),1,X'B000'!localsize) %else psetopd(procmark(proclevel),0,x'5ab0') psetopd(procmark(proclevel),1,x'c000'+Fourkdisp(localsize+4096)) %finish %if Astacklen#-1 %then Addrstackca=Astacklen %finish PDrop(R14) DropAll PDrop(R15) upperlineno=-1 FreeRegs(-1) %for I=1,1,SWmax %cycle %if Switches(i)_proclevel=proclevel %then switches(i)=0 %repeat Proclevel=Proclevel-1 PMinMultiples(Max4k+1) %if language=Fortran Pprocend %end;! Eprocend %externalroutine Eentry(%integer Index,Numpars,Paramsize, Localsize,Diagdisp,%stringname Name) !*********************************************************************** !* defines a side entry within the current procedure (used by Fortran) * !* Localsize is the total stack-frame requirement (excluding red tape) * !*********************************************************************** %if Report#0 %thenstart printstring("Eentry ".Name);write(Index,4) write(Numpars,4);write(Paramsize,4); write(LocalSize,4) newline %finish %if ProgFaulty#0 %then %return %unless Index=0 %then Pentry(Index,Name);! Amdahl put handles 0 incorrectly Dropall %if Language=Fortran %thenstart PIX RX(ST,R15,0,R11,60) PIX RR(LR,R10,R11) Localsize=Localsize+64 %if Localsize>=4096 %then PIX RX(A,R11,0,R12,fourkdisp(Localsize)) PIX RX(LA,R11,0,R11,Localsize&X'FFF') PIX RS(LM,8,9,R13,Glaf77regs) %if ProcProps&2#0 %thenstart;! main entry PIX RX(LA,R1,0,0,8) PIX RS(SLL,R1,0,0,24) PIX RR(SPM,R1,0) %finish %finish PIX SI(MVI,Diagdisp>>8,R10,0) PIX SI(MVI,(Diagdisp&X'FF'),R10,1) %end;! Eentry !* !* !* !* ********************************* !* * Data definition and reference * !* ********************************* !* !* %externalroutine Edataentry(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* defines a data entry Name starting at Offset in Area * !*********************************************************************** %if Report#0 %thenstart printstring("Edataentry ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish PDataEntry(Name,Area,(Length+3)&(\3),Offset) %end;! Edataentry !* %externalroutine Edataref(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* requests a data ref to Name (with at least Length)at Offset in Area * !*********************************************************************** %if Report#0 %thenstart printstring("Edataref ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish PDXRef((Length+3)&(\3),Area,Offset,Name) %end;! Edataref !* !* !* !* ******************** !* * Ecode operations * !* ******************** !* !* %externalroutine Eop(%integer Opcode) !*********************************************************************** !* opcodes with general applicability * !*********************************************************************** %constintegerarray ChOp(MVB:CPBLE) = MVCL<<16!MVC, 0(5), clcl<<16!CLC(6) %owninteger depth=0 %integer Reg1,Freg1,Bytes,B1,D1,B2,D2,XAop,Form,I,J %switch Op(0:255) %if Report#0 %thenstart %if depth>0 %then printstring("recursive ") printstring("Eop ".Eopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return %if Store pending#0 %then PIX RX(ST,R0,0,R11,64) %and Store pending=0 %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 j=minelevel(opcode) %if j>0 %and elevelOp(Opcode) !* Op(*):%monitor !* Op(HALT): Unsupported Opcode(Opcode) 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,Stk(Elevel+1),Stk(Elevel+2)) depth=depth-1; %return !* Op(INEG): Op(IABS): Op(INOT): Op(BNOT): Elevel=Elevel-1 Int Unary Op(Opcode,Stk(Elevel+1)) depth=depth-1; %return !* !* Op(IADDST): Op(ISUBST): Op(IMULTST): Op(IDIVST): !* Op(IANDST): Op(IORST): Op(IXORST): Epromote(2) !! Erefer(0,4) Eop(DUPL) Epromote(3) Eop(IADD+Opcode-IADDST) Epromote(2) Eop(Estore) !! Elevel=Elevel-2 !! Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2)) depth=depth-1; %return !* Op(INEGST): Op(INOTST): Elevel=Elevel-1 Int Unary Op(Opcode,Stk(Elevel+1)) depth=depth-1; %return !* !* Op(ISHLL): !* Op(ISHRL): !* Op(ISHLA): !* Op(ISHRA): %begin %constbyteintegerarray shop(ishll:ishra)=SLL,SRl,SLA,SRA; %integer rreg,lreg %record(stkfmt) shifted,shifter shifter=stk(elevel) shifted=stk(elevel-1) elevel=elevel-2 %if shifter_form&31=litval %Start rreg=load int(shifted,-1,-1) pix rs(shop(opcode),rreg,0,0,shifter_intval) %else lreg=load int(shifter,-1,0) rreg=load int(shifted,-1,lreg) pix rx(shop(opcode),rreg,0,lreg,0) %finish stackr(rreg) %end depth=depth-1; %return !* Op(RETURN): PIX RS(LM,R4,R15,R10,16) PIX RR(BCR,15,R15) depth=depth-1; %return !* Op(SFA): !* Op(ASF): !* Op(IPUSH): !* Op(IPOP): Unsupported Opcode(Opcode) depth=depth-1; %return !* Op(EXCH): Epromote(2) depth=depth-1; %return !* Op(DUPL): Form=Stk(Elevel)_Form&31 %if addrdirmod<=form<=indregmodval %or form=indregval %Start reg1=loadint(stk(elevel),-1,-1) elevel=elevel-1 stackr(reg1) %if form=indregmodval %then form=regval %else form=regaddr stk(elevel)_form=form %finish Stk(Elevel+1)=Stk(Elevel) Elevel=Elevel+1 %if Form=RegVal %or Form=RegAddr %thenstart Reg1=Claimr(Stk(Elevel)_Reg) PIX RR(LR,Reg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Reg1 Ruse(Reg1)=-Elevel ->dupexit %finish %if stk(elevel)_modform&31=regval %Start reg1=claimr(stk(elevel)_modreg) pix rr(lr,reg1,stk(elevel)_modreg) stk(elevel)_modreg=reg1 ruse(reg1)=-elevel ->dupexit %finish %if Form=FregVal %thenstart Freg1=Claimfr(Stk(Elevel)_Reg) %if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR PIX RR(XAop,Freg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Freg1 Fruse(Freg1)=-Elevel ->dupexit %finish %if Form=TempVal %then Stk(Elevel)_Form=DirVal %and ->dupexit dupexit: depth=depth-1; %Return !* Op(DISCARD): %if Stk(Elevel)_Form&31=RegVal %thenstart Ruse(Stk(Elevel)_Reg)=0 %finishelsestart %if Stk(Elevel)_Form&31=Fregval %then Fruse(Stk(Elevel)_Reg)=0 %finish Elevel=Elevel-1 depth=depth-1; %return !* Op(INDEX1): !* Op(INDEX2): !* Op(INDEX4): !* Op(INDEX8): Elevel=Elevel-1 I=Opcode-INDEX1 NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1)) depth=depth-1; %return !* Op(INDEX): Elevel=Elevel-2 %if Stk(Elevel+2)_Form=LitVal %thenstart I=Stk(Elevel+2)_Intval %if I=16 %or I=32 %thenstart I=I>>5+4 ->NoteI %finish %finish Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2)) Elevel=Elevel-1 I=0 ->NoteI !* Op(CHK): Elevel=Elevel-3 Reg1=Load Int(Stk(Elevel+1),-1,-1) Op RX(C,Reg1,Stk(Elevel+2)) Pjump(BC,Bounderr,4,R14) Op RX(C,Reg1,Stk(Elevel+3)) Pjump(BC,Bounderr,2,R14) Stackr(Reg1) depth=depth-1; %return !* Op(CPBGT): !* Op(CPBLT): !* Op(CPBEQ): !* Op(CPBNE): !* Op(CPBGE): !* Op(CPBLE): CC = SetCC(OpCode-CPBGT) !* Op(MVB): !* %begin %record(stkfmt)%name dest,srce,len %if opcode=MVB %then %Start; ! mvb op wrong way round! srce==stk(elevel-2) dest==stk(elevel-1) %else srce==stk(elevel-1) dest==stk(elevel-2) %finish B1=loadint(dest,-1,0) Ruse(B1) = -255 B2=loadint(srce,-1,0) Ruse(b2)=-255 len==stk(elevel) Bytes = len_IntVal %if len_form&31=litval %and bytes <=256 %Start; ! move by literal use mvc PIX SS(ChOp(OpCode)&255,0,Bytes,B1,0,B2,0) %else; ! need execute of mvc or mvcl %if language=imp %Start; ! For any case where lmax<=256 i=Chop(opcode)<<24!b1<<12 j=b2<<28 reg1=load int(len,-1,0); ! not gr0 for EX ruse(reg1)=-255 estkconst(6,addr(i)); ! target of EX into const table pix rr(bctr,reg1,0) op rx(ex,reg1,stk(elevel)) elevel=elevel-1 ruse(reg1)=0 %else pix rr(lr,r0,b1) ruse(b1)=0 %if b2#r2 %and ruse(b2)#0 %then freeup reg(r2) pix rr(lr,r2,b2) %unless r2=b2 ruse(b2)=0 %unless r2=b2 %if ruse(r1)#0 %and R1#len_reg %then free up reg(r1) %if ruse(r3)#0 %and R3#len_reg %then free up reg (r3) reg1=load int(len,r1,0) pix rr(lr,r3,r1) pix rr(chop(opcode)>>16,r0,r2) %Finish %finish Elevel = Elevel - 3 Ruse(B1) = 0 Ruse(b2)=0 CCSet = 1 %unless opcode=MVB %end depth=depth-1; %return !* Op(TMASK): unsupported opcode(opcode) depth=depth-1; %return 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,Stk(Elevel+1),Stk(Elevel+2)) depth=depth-1; %return !* Op(RNEG): Op(RABS): Elevel=Elevel-1 Real Unary Op(Opcode,Stk(Elevel+1)) depth=depth-1; %return !* Op(UCVTII): Elevel=Elevel-2 Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval) depth=depth-1; %return !* Op(CVTII): Elevel=Elevel-2 Bytes=Stk(Elevel+2)_Intval %if Bytes#Stk(Elevel+1)_size %Start Convert II(Stk(Elevel+1),Bytes) Stk(Elevel)_Size=Bytes %finish %else Elevel=Elevel+1 depth=depth-1; %return !* Op(CVTRR): Elevel=Elevel-2 Convert RR(Stk(Elevel+1),Stk(Elevel+2)_Intval) depth=depth-1; %return !* Op(TNCRI): Op(RNDRI): Op(EFLOOR): Elevel=Elevel-2 Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI) depth=depth-1; %return !* Op(CVTIR): Elevel=Elevel-2 Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval) depth=depth-1; %return !* Op(TNCRR): Op(RNDRR): Elevel=Elevel-1 Convert RIR(Stk(Elevel+1),Opcode-TNCRR) Depth=Depth-1 %return Op(UCHECK): %if Stk(Elevel)_Form=DirVal %thenstart Set BD(Stk(Elevel),B1,D1) %finishelsestart Reg1=Claimr(-1) Address(Stk(Elevel)) Op RX(L,Reg1,Stk(Elevel)) Stk(Elevel)_Form=IndRegVal!Regflag Stk(Elevel)_Reg=Reg1 Ruse(Reg1)=-Elevel B1=Reg1 D1=0 %finish PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32) Pjump(BC,Unasslab,8,R14) depth=depth-1; %return !* Op(ESTORE): Elevel=Elevel-2 Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0) depth=depth-1; %return !* Op(EDUPSTORE): Elevel=Elevel-2 Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),1) Stackr(Reg1) depth=depth-1; %return !* Op(PUSHVAL): !* Op(PUSHADDR): Elevel=Elevel-1 Push Param(Opcode-PUSHVAL,Stk(Elevel+1)) depth=depth-1; %return !* Op(EVAL): !* Op(EVALADDR): depth=depth-1; %return !* Op(EADDRESS): Address(Stk(Elevel)) Stk(Elevel)_Size=4 depth=depth-1; %return !* Op(EPOWER): !* Op(EPOWERI): %if Stk(Elevel)_Form#Litval %then Abort Elevel=Elevel-1 Expcall(Stk(Elevel+1)_Intval,Expprocs,Expproctype,Expprocref,Expprocpdesc) depth=depth-1; %return !* Op(EINTRES): Elevel=Elevel-1 %if Storepending#0 %then pix rx(St,R0,0,r11,64) %and storepending=0 %if CCSet#0 %then Establish Logical Reg1=Load Int(Stk(Elevel+1),R1,-1) depth=depth-1; %return !* Op(EREALRES): Elevel=Elevel-1 Reg1=Load Real(Stk(Elevel+1),R0,-1,Bytes) depth=depth-1; %return !* Op(ESIZE): Elevel=Elevel-1 Stk(Elevel)_Size=Stk(Elevel+1)_Intval depth=depth-1; %return !* Op(Argproc): Elevel=Elevel-1 %if language=pascal %then elevel=elevel-1;! Pascal apparently has xtra parm Free regs({X'FFC01E'}-1) Op RX(L,R1,Stk(Elevel)) ELevel = ELevel - 1 pix rx(la,R4,0,R10,Displayoffset(proclevel));! argproc may pass a proc PIX RS(STM,R4,R14,R11,16) PIX RS(LM,R12,R15,R1,0) PIX RR(LR,R2,R14) PIX RS(LM,R4,R10,R15,16); ! reset (possible IMP) environment PIX RX(L,R14,0,R15,56); ! reset (possible IMP) const PIX RR(BASR,R15,R2); ! and enter parametric proc %if active calls>1 %Start next param offset=save param offset(active calls) %if Next Param Offset&X'FFFF'>64 %Start pix rx(la,0,0,0,Next param offset&X'FFFF') pix rr(sr,r11,r0) %finish %finish active calls=active calls-1 Pusing(R15) Using(R15)=1 depth=depth-1; %return !* op(pushbytes): bytes=stk(elevel)_intval abort %unless stk(elevel)_form=litval reg1=loadint(stk(elevel-1),-1,0) fixedmove(bytes,r11,next param offset&X'FFFF',reg1,0) next param offset=next param offset+(bytes+3)&(-4) elevel=elevel-2 depth=depth-1; %Return Op(EAUXSF): reg1=claimr(-1) pix rr(lr,reg1,r11) stackr(reg1) depth=depth-1; %return ! Op(EAUXADD): elevel=elevel-1 %if stk(elevel+1)_form&31=litval %and stk(elevel+1)_intval<4095 %c %then pix rx(la,r11,0,r11,stk(elevel+1)_intval) %and depth=depth-1 %and %Return reg1=loadint(stk(elevel+1),-1,-1) pix rr(ar,r11,reg1) depth=depth-1; %return ! Op(EAUXRES): elevel=elevel-1 reg1=loadint(stk(elevel+1),r11,-1) ruse(r11)=255 depth=depth-1; %Return 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) %if bytes <=512 %Start pix si(MVI,b1,reg1,0) j=0 %if bytes>256 %then %start pix ss(mvc,0,256,reg1,1,reg1,0) j=256; bytes=bytes-256 %finish pix ss(mvc,0,bytes-1,reg1,j+1,reg1,j) %else ;! MVCL neede abort %finish depth=depth-1 %return %end;! Eop !* %externalroutine Ef77op(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Fortran * !*********************************************************************** %integer Reg1,Reg2,Freg1,Freg2,XAop1,Lab,Breg,Adj,Bytes,Relop %integer B1,D1,Flags %switch F77op(256:320) %if Report#0 %thenstart printstring("Ef77op ".Ef77opname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* %if Store pending#0 %then PIX RX(ST,R0,0,R11,64) %and Store pending=0 %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 !* ->F77op(Opcode) !* F77op(*):Abort !* F77op(CXADD): !* F77op(CXSUB): !* F77op(CXMULT): !* F77op(CXDIV): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-4 Opcode=Opcode&X'FF' Flags=Stk(Elevel+4)_Intval Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3)) %return !* F77op(CXNEG): !* F77op(CXASGN): !* F77op(CXEQ): !* F77op(CXNE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Opcode=Opcode&X'FF' Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(EM1EXP): Elevel=Elevel-1 Reg2=Load Int(Stk(Elevel+1),-1,-1) OpRX(N,Reg2,Litone) Pix RR(ALR,Reg2,Reg2) Pix RR(BCTR,Reg2,0) Stackr(Reg1) %return F77op(EINCR): Eop(IADDST) %return !* F77op(EDECR): Eop(ISUBST) %return !* !* F77op(EISIGN): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Breg=setlocalbase(reg1) PIX RR(LPR,Reg1,Reg1) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) Lab=Einternallab-1 Einternallab=Lab PIX RR(LTR,Reg2,Reg2) Pjump(bc,Lab,10,claimjumpreg(reg1)) PIX RR(LNR,Reg1,Reg1) PLabel(lab) Stackr(Reg1) %return !* F77op(ESIGN): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) Breg=setlocalbase(reg1) %if Bytes=4 %then Adj=LER-LDR %else adj=0 PIX RR(LPDR+Adj,Reg1,Reg1) Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) Lab=Einternallab-1 Einternallab=Lab PIX RR(LTDR+Adj,Reg2,Reg2) Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(LNDR+Adj,Reg1,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) %return !* F77op(EIMOD): Elevel=Elevel-2 %if Using(R15)#0 %then Using(R15)=0 %and Pdrop(R15) OpRX(L,R15,Stk(Elevel+2)) Reg1=Claimr(R1) Freeup Reg(R1) OpRX(L,R0,Stk(Elevel+1)) PIX RR(LR,Reg1,R0) PIX RX(SRDA,0,0,0,32) PIX RR(DR,R0,R15) PIX RR(MR,R0,R15) PIX RR(SR,Reg1,R1) Stackr(Reg1) %return !* F77op(ERMOD): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) D1=Newtemp(bytes) DO RX(STD+Adj,Reg2,R10,d1);! STE PIX RR(LDR+Adj,Reg2,Reg1);! LER DO RX(DD+Adj,Reg2,R10,d1);! DE Stackfr(Reg2,Bytes) Elevel=Elevel-1 Convert RI(Stk(Elevel+1),4,0);! Truncate Elevel=Elevel-1 Lastfreg=Reg1;! to ensure it is not used Convert IR(Stk(Elevel+1),Bytes) Elevel=Elevel-1 Reg2=Load Real(Stk(Elevel+1),-1,Reg1,Bytes) DO RX(MD+Adj,Reg2,R10,d1);! ME PIX RR(SDr+Adj,Reg1,Reg2);! SER Stackfr(Reg1,Bytes) %return !* F77op(EIDIM): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) OpRX(S,Reg1,Stk(Elevel+2)) Breg=setlocalbase(reg1) PIX RR(LTR,Reg1,Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(SR,Reg1,Reg1) PLabel(lab) Stackr(Reg1) %return !* F77op(ERDIM): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 OpRX(SD+Adj,Reg1,Stk(Elevel+2)) Breg=setlocalbase(reg1) PIX RR(LTDR+Adj,Reg1,Reg1) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,10,claimjumpreg(reg1)) PIX RR(SDR+Adj,Reg1,Reg1) PLabel(lab) Stackfr(Reg1,Bytes) %return !* F77op(EIMIN): Relop=12 Iminmax: Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Breg=setlocalbase(reg1) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) PIX RR(CR,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,relop,claimjumpreg(reg1)) PIX RR(LR,Reg1,Reg2) Plabel(lab) Stackr(Reg1) %return !* F77op(ERMIN): Relop=12 Rminmax: Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then ADj=LER-LDR %else Adj=0 Breg=setlocalbase(reg1) Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) PIX RR(CDR+Adj,Reg1,Reg2) Lab=Einternallab-1 Einternallab=Lab Pjump(BC,Lab,relop,claimjumpreg(reg1)) PIX RR(LDR+Adj,Reg1,Reg2) Plabel(lab) Stackfr(Reg1,Bytes) %return !* F77op(EIMAX): Relop=10 ->Iminmax !* F77op(ERMAX): Relop=10 ->Rminmax !* F77op(EDMULT): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Real Binary Op(RMULT,Stk(Elevel+1),Stk(Elevel+2)) Stk(Elevel)_Size=8 %return !* F77op(ECONJG): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Opcode=9 Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(ECHAR): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 %if Stk(Elevel+2)_Form=LitVal %thenstart Set BD(Stk(Elevel+1),B1,D1) PIX SI(MVI,Stk(Elevel+2)_Intval&X'FF',B1,D1) %finishelsestart Reg1=Load Int(Stk(Elevel+2),-1,-1) Set BD(Stk(Elevel+1),B1,D1) Do RX(STC,Reg1,B1,D1) {Op RX(STC,Reg1,Stk(Elevel+1))} %finish %return !* F77op(EICHAR): %if Elevel<1 %then Low Estack(Opcode,1) %and %return %if Stk(Elevel)_Form =LitVal %thenstart Stk(Elevel)_Size=4 %return %finish Elevel=Elevel-1 Reg1=Claimr(-1) PIX RR(SR,Reg1,Reg1) ruse(reg1)=-255 Set BD(Stk(Elevel+1),B1,D1) Do RX(IC,Reg1,B1,D1) {Op RX(IC,Reg1,Stk(Elevel+1))} Stackr(Reg1) %return !* F77op(EINDEXCHAR): %if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3)) %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1)) {for Unix compatibility call requires A1,A2,L1,L2} {Epromote(3)} {Epromote(2)} {but for Amdahl we must have L1,A1,L2,A2} Epromote(4) Epromote(2) Epromote(3) Expcall(6,Spprocs,Spproctype,Spprocref,Spprocpdesc) Stackr(R1) %return !* F77op(ECONCAT): Expcall(7,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return !* F77op(EASGNCHAR): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-4 Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4)) %return !* F77op(ECOMPCHAR): %if Elevel<5 %then Low Estack(Opcode,5) %and %return CC=Setcc(Stk(Elevel)_Intval) Elevel=Elevel-5 Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4)) CCset=1 %return !* F77op(ECMPLX1): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Flags=Stk(Elevel+3)_Intval ->Cx1 !* F77op(ECMPLX2): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-4 Flags=Stk(Elevel+4)_Intval Cx1: %if Flags=0 %then XAop1=STE %else XAop1=STD Reg1=Claimr(-1) OpRX(L,Reg1,Stk(Elevel+1)) Freg1=Load Real(Stk(Elevel+2),-1,-1,Bytes) PIX RX(XAop1,Freg1,0,Reg1,0) %if Opcode=ECMPLX1 %thenstart Freg2=Freg1 PIX RR(SDR,Freg2,Freg2) %finishelsestart Freg2=Load Real(Stk(Elevel+3),-1,-1,Bytes) %finish PIX RX(XAop1,Freg2,0,Reg1,Bytes) %return !* F77op(EISHFT): !* F77op(EIBITS): !* F77op(EIBSET): !* F77op(EIBTEST): !* F77op(EIBCLR): !* F77op(EISHFTC): Unsupported Opcode(Opcode) %return !* F77op(PROCARG): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 D1=Stk(Elevel+1)_Intval Pd4(GLA,D1+12,-1) Do RX(LA,R0,R13,D1) PIX RX(ST,R0,0,R11,Next Param Offset&X'FFFF') Next Param Offset=Next Param Offset+4 %return !* F77op(IPROCARG): !* F77op(CHARARG): %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1)) Estklit(X'20000');! Amdahl string type Eop(IADD) Eop(PUSHVAL) Eop(PUSHVAL) %return !* F77op(IPROCCALL): Unsupported Opcode(Opcode) %return !* F77op(ARGPROCCALL): ! bytes of params over pointer %if Elevel<2 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-2 Op RX(L,R1,Stk(Elevel+1)) PIX RS(STM,R4,R14,R11,16) PIX RS(LM,R12,R15,R1,0) PIX RR(LR,R2,R14); ! save entry point PIX RS(LM,R4,R10,R15,16); ! reset (possible IMP) display PIX RX(L,R14,0,R15,56); ! reset (possible IMP) const pointr PIX RR(BASR,R15,R2) Pusing(R15) Using(R15)=1 Active calls=Active calls-1 %return !* F77op(NOTEIORES): {no special action required here on Amdahl - result will stay in R1} %return !* F77op(STKIORES): Stackr(R1) %return !* F77op(CALLTPLATE): %return !* F77op(EFDVACC): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-1 { on Amdahl the two entries still on Estack will usually be in regs} Reg2=Load Int(Stk(Elevel-1),-1,-1) Stk(Elevel-1)_Form=RegVal!Regflag Stk(Elevel-1)_Reg=Reg2 Reg1=Load Int(Stk(Elevel),-1,Reg2) Stk(Elevel)_Form=RegVal!Regflag Stk(Elevel)_Reg=Reg1 %if Using(R14)#0 %then Pdrop(R14) %and Using(R14)=0 %if Using(R15)#0 %then Pdrop(R15) %and Using(R15)=0 PIX RR(LR,R15,Reg1) Ruse(Reg1)=-Elevel Ruse(Reg2)=-Elevel+1 OpRX(M,R14,Stk(Elevel+1)) PIX RR(AR,Reg2,R15) %return !* F77op(EARGLEN): {on Amdahl it may be necessary to mask out the upper half of char len } Stk(Elevel)_Offset=Stk(Elevel)_Offset+2 Stk(Elevel)_Size=2 Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,-1) Stackr(Reg1) %return !* F77op(EFNOTEVR): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),R1,-1) %return !* F77op(EFSETVR): Stackr(R1) %return %end;! Ef77op !* !* %externalroutine EPasop(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Pascal * !*********************************************************************** %switch Pasop(511:645) %integer Bytes,Reg,reg1,reg2,b,d,b1,d1,dx,op,upper,lower,trapno,i %constbyteintegerarray chop(CHKLT:CHKNE)=ILT,IGT,0(3),ULT,UGT,UNE,0,INE; %record(stkfmt) low,up %if Report#0 %thenstart printstring("Epasop ".Epasopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* %if Store pending#0 %then PIX RX(ST,R0,0,R11,64) %and Store pending=0 %if CCset # 0 %then Establish Logical; ! estsblish logical value 0 or 1 !* ->Pasop(Opcode) !* Pasop(*): %monitor !* Pasop(STRGT): Pasop(STRLT): Pasop(STREQ): Pasop(STRNE): Pasop(STRGE): Pasop(STRLE): %if Stk(Elevel)_Form#LitVal %then Abortm("Epasop: string length") bytes=Stk(Elevel)_Intval %if 04095 %then range(b1,d1); ! make work area addressable %if opcode=SETD %Start PIX SI(mvi,255,b1,d1) pix ss(mvc,0,bytes-1,b1,d1+1,b1,d1) op=XC %finish %else op=MVC pix ss(op,0,bytes,b1,d1,b,d) setbd(stk(elevel-1),b,d); ! second set addressable %if opcode=SETU %then op=OC %else op=NC pix ss(op,0,bytes,b1,d1,b,d) elevel=elevel-2 Estkdir(0,dx-stackoffset,0,bytes) %return !* Pasop(SETEQ): Pasop(SETNE): bytes=stk(elevel)_size %if bytes=4 %then eop(IEQ-seteq+opcode) %else %Start address(Stk(Elevel-1)) Stk(Elevel-1)_size=4 address(Stk(Elevel)) Stk(Elevel)_size=4 estklit(bytes) eop(CPBEQ-SETEQ+opcode) %finish %return Pasop(SETIN): ! first remove the bounds up=stk(elevel) low=stk(elevel-1) elevel=elevel-2 upper=up_intval lower=low_intval ! the set is the upper operand %if Elevel<2 %then Low Estack(Opcode,2) %and %return bytes=stk(elevel)_size Einternallab=Einternallab-1 reg=R0; Op=SRL reg2=load int(stk(elevel-1),-1,1) ruse(reg2)=-255 %if upper>0 %then oprx(c,reg2,up) %and pjump(bc,Einternallab,2,R14) %if lower >=0 %then oprx(c,reg2,low) %and pjump(bc,Einternallab,4,R14) %if bytes=4 %start reg1=load int(stk(elevel),0,reg2) %finish %else %if bytes=8 %Start %if ruse(r1)#0 %then freeup reg(R1) setbd(stk(elevel),b,d) pix rx(L,R1,0,b,d) d=d+4; %if d>4095 %then range(b,d) pix rx(L,R0,0,b,d) Op=SRDL; Reg=R1 %else setbd(stk(elevel),b,d) reg1=claimr(b) pix rr(lr,reg1,reg2) pix rx(SRL,reg1,0,0,5) pix rx(SLL,reg1,0,0,2) pix rx(l,0,reg1,b,d); ! pick up right set word pix rx(N,reg2,0,R9,THIRTYONE) %finish pix rx(OP,0,0,reg2,0) pix rx(N,Reg,0,R9,ONE) ruse(reg2)=0 %if lower>=0 %or upper>0 %Start pix rx(x,Reg,0,R9,ONE) plabel(Einternallab) cc=8 %finish %else cc=7 Elevel=Elevel-2 CCset=1 %if report#0 %then %Start printstring("After SETIN") newline; dump estack %finish %return !* Pasop(SETLE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Eop(DUPL) Epromote(3) Epasop(SETU) Epasop(SETEQ) %return !* Pasop(SETSING): %if Elevel<2 %then Low Estack(Opcode,2) %and %return %if Stk(Elevel)_Form#LitVal %then Abortm("SETSING: size?") bytes=Stk(elevel)_intval %if bytes=4 %start Elevel=Elevel-1 estklit(1) eop(EXCH) eop(ISHLL) %return %finish d1=new temp(bytes) b1=R10; dx=d1 %if bytes=8 %Start reg1=load int(Stk(elevel-1),-1,1) %if ruse(R1)#0 %then freeup reg(R1) pix rx(LA,R1,0,0,1) pix rr(SLR,R0,R0) pix rs(SLDL,R0,0,reg1,0) Dorx(ST,R1,b,d) Dorx(st,r0,b,d+4) %else range(b1,d1) %if d1>4095 pix ss(xc,0,bytes,b1,d1,b1,d1); ! zero set reg1=loadint(Stk(elevel-1),-1,0) reg2=claimr(reg1) pix rr(lr,reg2,reg1) pix rx(la,R0,0,0,1) pix rx(N,Reg2,0,R9,thirtyone) pix rs(sll,R0,0,Reg2,0) pix rs(SRL,Reg1,0,0,5) pix rs(SLL,reg1,0,0,2) pix rx(ST,R0,reg1,b1,d1) %finish Elevel= Elevel-2 estkdir(0,dx-Stackoffset,0,bytes) %return !* Pasop(SETRANGE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return %if Stk(Elevel)_Form#LitVal %then Abortm("SETRANGE: size?") Elevel= Elevel-3 !! Set Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3)_IntVal) %return !* Pasop(CAPMOVE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return ! Epromote(2); ! Params now as for move bytes Eop(MVB) %return !* Pasop(INDEXP): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Bit Index(Stk(Elevel+2),Stk(Elevel),Stk(Elevel+1)) %return !* Pasop(EOFOP): Pasop(EOLOP): Expcall(Opcode-EOFOPT+10,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return !* Pasop(LAZYOP): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Expcall(14,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return !* Pasop(ISQR): Eop(DUPL) Eop(IMULT) %return !* Pasop(IODD): Pasop(UODD): Push Operand(LitOne) Eop(IAND) %return !* Pasop(ISUCC): Pasop(USUCC): Push Operand(LitOne) Eop(IADD) %return !* Pasop(IPRED): Pasop(UPRED): Push Operand(LitOne) Eop(ISUB) %return !* Pasop(RSQR): ! Eop(DUPL) ! Eop(RMULT) ! ! The above simple code does not work on Amdahl since Dup can not know ! whether it should use FR or GR on 4 byte quantity ! reg=loadreal(Stk(Elevel),-1,-1,BYtes) Elevel=Elevel-1 STackfr(reg,bytes) %if bytes=4 %then Op=MER %else Op=MDR Pix rr(op,reg,reg) %return !* Pasop(CHKLT): Pasop(CHKGT): Pasop(UCHKLT): Pasop(UCHKGT): Pasop(UCHKNE): Pasop(CHKNE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return trapno=Stk(Elevel)_intval; ! err no always literal up=Stk(Elevel-1) Elevel=Elevel-3 reg=loadint(Stk(Elevel+1),-1,0) stackr(reg) PUshoperand(up) Eop(Chop(Opcode)) PIX RX(LA,R0,0,0,trapno) Ejump(JTRUE,Pastraplab) stackr(reg) %return !* Pasop(CHKRNG): Pasop(UCHKRNG): trapno=Stk(Elevel)_Intval Elevel=Elevel-4 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RX(LA,R0,0,0,trapno) Op RX(C,Reg1,Stk(Elevel+2)) Pjump(BC,pastraplab,4,R14) Op RX(C,Reg1,Stk(Elevel+3)) Pjump(BC,pastraplab,2,R14) Stackr(Reg1) %Return Pasop(CHKSETRNG): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Pasop(CHKSETGT): %if Elevel<3 %then Low estack(OPcode,4) %and %return trapno=Stk(Elevel)_intval lower=0 Elevel=Elevel-1 %if OPcode=CHKSETRNG %then lower=Stk(elevel)_intval %and Elevel=Elevel-1 upper=Stk(Elevel)_Intval Elevel=Elevel-1 Abort %unless Stk(elevel)_size=4;! only for 1 word sets Eop(Dupl) d=0 d=d!(1<>16 %while I>0 %cycle Epromote(I) Eop(PUSHVAL) I=I-1 %repeat I=procpdesc(Proc) Ecall(J,I>>16,I&X'FF') %if T&7#0 %thenstart;! function Estkresult(0,T&7,(T>>8)&255) %finish %end;! Expcall !* !* !* !* !*********************************************************************** !*********************************************************************** !** Code generation support procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine Refer(%record(Stkfmt)%name Stk,%integer Offset) %integer Reg %switch F(0:21) ->F(Stk_Form&31);! removing the reg marker bit !* F(RegVal): { (reg) } %if Offset#0 %thenstart Stk_Form=IndRegModVal!Regflag Setoff: Stk_Modform=Litval Stk_Modintval=Offset Stk_Scale=0 %return %finish Stk_Form=IndRegVal!Regflag Ruse(Stk_Reg)=-Elevel %return !* F(TempVal): { (temp) } %if Offset#0 %thenstart Stk_Form=IndTempModVal ->Setoff %finish Stk_Form=IndTempVal %return !* F(DirVal): { (dir) } %if Offset#0 %thenstart Stk_Form=IndDirModVal ->Setoff %finish Stk_Form=IndDirVal %return !* F(IndRegVal): { ((reg)) } PIX RX(L,Stk_Reg,0,Stk_Reg,0) ->F(RegVal) !* F(AddrDirMod): { @dir+M } %if Offset=0 %thenstart Stk_Form=AddrDirModVal %return %finish ->Loadr !* F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } F(AddrDirModVal): { (dir+M) } F(IndRegModVal): { ((reg)+M) } F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } Loadr:Reg=Claimr(0) OpRX(L,Reg,Stk) Stk_Reg=Reg Ruse(Stk_Reg)=-Elevel ->F(RegVal) !* F(AddrConst): { @const } Stk_Form=ConstVal Stk_Offset=Stk_Offset+Offset %return !* F(AddrDir): { @dir } Stk_Form=DirVal Stk_Offset=Stk_Offset+Offset %return !* F(RegAddr): { (reg) is @ } ->F(RegVal) !* F(TempAddr): { (temp) is @} %if Offset#0 %thenstart Stk_Form=IndTempModVal ->Setoff %finish Stk_Form=IndTempVal %return !* F(DirAddr): { (dir) is @ } %if Offset#0 %thenstart Stk_Form=IndDirModVal ->Setoff %finish Stk_Form=IndDirVal %return !* F(RegModAddr): { (reg)+M } %if Offset=0 %thenstart Stk_Form=IndRegModVal!Regflag %return %finish ->Loadr !* F(TempModAddr): { (temp)+M } %if Offset=0 %thenstart Stk_Form=IndTempModVal %return %finish ->Loadr !* F(DirModAddr): { (dir)+M } %if Offset=0 %thenstart Stk_Form=InddirModVal %return %finish ->Loadr !* F(LitVal): { lit } F(ConstVal): { const } F(FregVal): { (freg) } printstring(" Invalid attempt to Refer ") Abort !* %end;! Refer !* %routine Address(%record(Stkfmt)%name Stk) !*********************************************************************** !* Change operand from a var to an address * !* Addresses always have size 4 but this routine does not always * !* set the new size * !*********************************************************************** %integer I,J,Reg,Op %switch F(0:21) ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } Setint(Stk_Intval,Stk_Size,I,J) Stk_Base=Cnst Stk_Offset=J F(ConstVal): { const } Stk_Form=AddrConst Size: Stk_Size=4 %return !* F(RegVal): { (reg) } I=New Temp(4) Op=ST RUse(Stk_Reg) = 0 Store:Do RX(Op,Stk_Reg,R10,I) Stk_Base=0 Stk_Offset=I Stk_Form=AddrDir ->Size !* F(FregVal): { (freg) } I=New Temp(Stk_Size) %if Stk_Size=4 %then Op=STE %else Op=STD FRUse(Stk_Reg) = 0 ->Store !* F(TempVal): { (temp) } Stk_Form=AddrDir %return !* F(DirVal): { (dir) } Stk_Form=AddrDir %return !* F(IndRegVal): { ((reg)) } Stk_Form=RegAddr!Regflag %return !* F(IndTempVal): { ((temp)) } Stk_Form=TempAddr %return !* F(IndDirVal): { ((dir)) } Stk_Form=DirAddr %return !* F(AddrDirModVal): { (dir+M) } Stk_Form=AddrDirMod!(Stk_Form&Regflag) %return !* F(IndRegModVal): { ((reg)+M) } Stk_Form=RegModAddr!Regflag %return !* F(IndTempModVal): { ((temp)+M) } Stk_Form=TempModAddr!(Stk_Form&Regflag) %return !* F(IndDirModVal): { ((dir)+M) } Stk_Form=DirModAddr!(Stk_Form&Regflag) %return !* F(AddrConst): { @const } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @ } F(DirAddr): { (dir) is @ } F(AddrDir): { @dir } F(AddrDirMod): { @dir+M } F(RegModAddr): { (reg)+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } !* %end;! Address !* %integerfn Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg) !*********************************************************************** !* Stk describes an integer value (1,2 or 4 bytes) * !* if Reg is >= 0 then this register must be loaded * !* result is the general register to which the value has been loaded * !*********************************************************************** %integer Bytes,sruse %constbyteintegerarray Lop(0:4)=0,IC,LH,0,L Bytes=Stk_Size %unless 00 %then sruse=ruse(lockedreg) %and Ruse(Lockedreg)=-255 %if Stk_Size=1 %then PIX RR(SR,Reg,Reg) OpRX(Lop(Bytes),Reg,Stk) %if Lockedreg>0 %and ruse(lockedreg)=-255{Not freed by OpRX} %then Ruse(Lockedreg)=sruse %result=Reg %end;! Load Int !* %integerfn Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg, %integername Bytes) !*********************************************************************** !* Stk describes a real value * !* if Reg >= 0 this is the register to be loaded * !* result is the floating register to which the value has been loaded * !*********************************************************************** %integer XAop Bytes=Stk_Size %unless 4<=Bytes<=16 %then Abort %if Stk_Form&31=FregVal %thenstart Fruse(Stk_Reg)=0 %if Reg>=0 %and Reg#Stk_Reg %thenstart %if Bytes=4 %then XAop=LER %else XAop=LDR PIX RR(XAop,Reg,Stk_Reg) %result=Reg %finishelse %result=Stk_Reg %finish %if Reg<0 %then Reg=Claimfr(Lockedreg) %if Bytes=4 %then XAop=LE %else XAop=LD OpRX(XAop,Reg,Stk) %result=Reg %end;! Load Real !* %integerfn Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* Stk describes a real value to be loaded at extended precision * !* result is the floating register to which the value has been loaded * !*********************************************************************** %integer Oldreg,Newreg,XAop,Bytes Bytes=Stk_Size %unless 4<=Bytes<=16 %then Abort %if Stk_Form&31=FregVal %thenstart Oldreg=Stk_Reg %if Newsize=8 %thenstart Newreg=Claimfr(Oldreg) PIX RR(SDR,Newreg,Newreg) XAop=LER %finishelsestart;! 16 byte Newreg=Claimfrpair(Oldreg) PIX RR(SDR,Newreg+2,Newreg+2) %if Bytes=4 %thenstart PIX RR(SDR,Newreg,Newreg) XAop=LER %finishelse XAop=LDR %finish PIX RR(XAop,Newreg,Oldreg) Fruse(Oldreg)=0 %finishelsestart %if Newsize=8 %thenstart Newreg=Claimfr(-1) PIX RR(SDR,Newreg,Newreg) XAop=LE %finishelsestart;! 16 byte Newreg=Claimfrpair(-1) PIX RR(SDR,Newreg+2,Newreg+2) %if Bytes=4 %thenstart PIX RR(SDR,Newreg,Newreg) XAop=LE %finishelse XAop=LD %finish OpRX(XAop,Newreg,Stk) %finish %result=Newreg %end;! Load Real Extended !* %routine Push Operand(%record(Stkfmt)%name Operand) !*********************************************************************** !* create an Estack entry for a prepared operand * !*********************************************************************** %if Elevel=stkmax %then Abort Elevel=Elevel+1 Stk(Elevel)=Operand %end;! Push Operand !* %routine Stackr(%integer R) !*********************************************************************** !* create an Estack entry for a value held in a general register * !*********************************************************************** Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=RegVal!Regflag Stk(Elevel)_Reg=R Stk(Elevel)_Size=4 Ruse(R)=-Elevel %end;! Stackr !* %routine Stackfr(%integer FR,Bytes) !*********************************************************************** !* create an Estack entry for a value held in a floating register * !*********************************************************************** Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=FregVal!Regflag Stk(Elevel)_Reg=FR Stk(Elevel)_Size=Bytes Fruse(FR)=-Elevel %end;! Stackfr !* %routine Establish Logical !*********************************************************************** !* called when a condition code has been set and required result is a * !* logical value (0 or 1) * !*********************************************************************** %integer Reg1,jreg CCset=0 Reg1=Claimr(0) jreg=setlocalbase(reg1) jreg=claimjumpreg(reg1) Einternallab=Einternallab-1 PIX RX(LA, Reg1, 0, 0, 1) Pjump(BC, Einternallab, CC, Jreg) PIX rr(slr,reg1,reg1) PLabel(Einternallab) Stackr(Reg1);! stack integer result in Reg1 %end;! Establish Logical !* %routine Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) !*********************************************************************** !* supports IADD,ISUB,IMULT,IDIV,IREM,IGT,ILT,IEQ,INE,IGE,ILE,IAND,IOR,IXOR * !* descriptor to result on Estack * !*********************************************************************** %routinespec sizes %constbyteintegerarray RXop(0:ULE) = 0, A,S,M,D,0,0,0,N,O,0,X,0(4),C(6),0(UADD-ILE-1),AL,SL,CL(6); %constintegerarray Shiftval(0:8)=-1,0,1,-1,2,-1,-1,-1,3 %integer Lform,Rform,Lreg,Rreg,Shift,MCop,B1,D1,B2,D2,Wreg %switch Opcode(0:ULE) MCop=RXop(op) Lform=LHS_Form&31 Rform=RHS_Form&31 Lreg=LHS_Reg Rreg=RHS_Reg ->Opcode(Op) !* Opcode(IADD): Opcode(IAND): Opcode(IOR): Opcode(IXOR): OPcode(UADD): Commbinaryop: ! Commutative binary operation ! First pick off immediate operations %if LHS_Size=1 %and LHS_Form&31#Regval %and (MCop=C %or MCop=CL) %and %c RHS_Form=Litval %and 0<=RHS_Intval<=255 %Start SETBD(LHS,B1,D1) Pix SI(CLI,RHS_Intval,B1,D1) CCset=1 %return %finish %if LHS_Size=RHS_Size %and Lform#regval %and Rform#regval %and %c (MCop=CL %or (MCop=C %and (7<=CC<=8 %or LHS_Size=1))) %start SetBD(LHS,B1,D1) %if B1<8 %then Ruse(B1)=-255 SetBD(RHS,B2,D2) Pix SS(CLC,0,LHS_Size,B1,D1,B2,D2) %if B1<8 %then Ruse(b1)=0 CCset=1 %return %finish Sizes %if Lform=Litval %and Rform#REgval %Start Lreg=claimr(0) Op RX(L,Lreg,LHS) Lform=Regval %finish %if Lform=RegVal %thenstart %if Rform=RegVal %thenstart PIX RR(MCop-X'40',Lreg,Rreg) Ruse(Rreg)=0 %finishelse OpRX(MCop,Lreg,RHS) Wreg=Lreg %finishelsestart %if Rform#RegVal %thenstart Rreg=Claimr(0) OpRX(L,Rreg,RHS) %finish OpRX(MCop,Rreg,LHS) Wreg=Rreg %if MCop=C %or MCop=CL %then CC=Invcc(CC) %finish %if MCop=C %or MCop=CL %then CCset=1 %and Ruse(wreg)=0 %else Stackr(Wreg) %return !* Opcode(ISUB): Opcode(Usub): Sizes %if Lform=RegVal %thenstart %if Rform=RegVal %thenstart PIX RR(SR,Lreg,Rreg) Ruse(Rreg)=0 %finishelse OpRX(S,Lreg,RHS) %finishelsestart %if Rform=RegVal %thenstart Lreg=Claimr(Rreg) OpRX(L,Lreg,LHS) PIX RR(SR,Lreg,Rreg) Ruse(Rreg)=0 %finishelsestart Lreg=Claimr(0) Op RX(L,Lreg,LHS) Op RX(S,Lreg,RHS) %finish %finish Stackr(Lreg) %return !* Opcode(IGT): Opcode(ILT): Opcode(IEQ): Opcode(INE): Opcode(IGE): Opcode(ILE): CC=Setcc(Op-IGT) ->Commbinaryop Opcode(UGT): Opcode(ULT): Opcode(UEQ): Opcode(UNE): Opcode(UGE): Opcode(ULE): CC=Setcc(Op-UGT) ->Commbinaryop !* Opcode(IMULT): Sizes %if Lform=LitVal %thenstart %if 0<=LHS_Intval<=8 %thenstart Shift=Shiftval(LHS_Intval) %if Shift=0 %thenstart Elevel=Elevel+1 Stk(Elevel)=RHS %return %finish %if Shift>0 %thenstart Rreg=Load Int(RHS,-1,-1) PIX RS(SLA,Rreg,0,0,Shift) Stackr(Rreg) %return %finish %finish %finish %if Rform=LitVal %thenstart %if 0<=RHS_Intval<=8 %thenstart Shift=Shiftval(RHS_Intval) %if Shift=0 %thenstart Elevel=Elevel+1 Stk(Elevel)=LHS %return %finish %if Shift>0 %thenstart Rreg=Load Int(LHS,-1,-1) PIX RS(SLA,Rreg,0,0,Shift) Stackr(Rreg) %return %finish %finish %finish !* %if Lform=RegVal %thenstart %if Lreg#R1 %thenstart %unless Lreg=R3 %and Ruse(R2)=0 %thenstart %if Ruse(R1)#0 %thenstart %if Rform=RegVal %and Rreg=R1 %thenstart PIX RR(MR,R0,Lreg) Ruse(Lreg)=0 Lreg=R1; ->Multend %finish Freeup Reg(R1) %finish PIX RR(LR,R1,Lreg) Ruse(Lreg)=0 Lreg=R1 Ruse(Lreg)=-255 %finish %finish %if Rform=RegVal %thenstart PIX RR(MR,Lreg-1,Rreg) Ruse(Rreg)=0 %finishelse OpRX(M,Lreg-1,RHS) %finishelsestart %if Rform=RegVal %thenstart Lreg=R1 %if Rreg#R1 %thenstart %if Rreg=R3 %thenstart %if Ruse(R2)#0 %then Freeup Reg(R2) Lreg=R3 %finishelsestart %if Ruse(R1)#0 %then Freeup Reg(R1) PIX RR(LR,R1,Rreg) Ruse(R1)=Ruse(Rreg); Ruse(Rreg)=0 %finish %finish %finishelsestart %if Ruse(R1)=0 %thenstart Lreg=R1 %finishelsestart %if Ruse(R2)=0 %and Ruse(R3)=0 %thenstart Lreg=R3 %finishelsestart Freeup Reg(R1) Lreg=R1 %finish %finish %if Lform=LitVal %thenstart OpRX(L,Lreg,LHS) Ruse(Lreg)=-255 OpRX(M,Lreg-1,RHS) ->Multend %finish OpRX(L,Lreg,RHS) %finish Ruse(Lreg)=-255 OpRX(M,Lreg-1,LHS) %finish Multend: %if Parmbits1&16=0 %then Pix RS(SLDA,Lreg-1,0,0,32) %and Pix rr(LR,lreg,lreg-1) Stackr(Lreg) %return !* Opcode(IDIV):Opcode(Irem): Sizes %if Lform=RegVal %thenstart %if Lreg#R1 %thenstart %if Ruse(R1)#0 %thenstart %if Rform=RegVal %and Rreg=R1 %thenstart %if Using(R14)#0 %then Pdrop(R14) %and Using(R14)=0 PIX RR(LR,R14,R1) PIX RR(LR,R0,Lreg) PIX RX(SRDA,R0,0,0,32) PIX RR(DR,R0,R14) Ruse(Lreg)=0 ->divend %finish Freeup Reg(R1) %finish PIX RR(LR,R0,Lreg) Ruse(Lreg)=0 %finishelse PIX RR(LR,R0,R1) PIX RX(SRDA,0,0,0,32) %if Rform=RegVal %thenstart PIX RR(DR,R0,Rreg) Ruse(Rreg)=0 %finishelsestart Ruse(R1)=-255 OpRX(D,R0,RHS) %finish %finishelsestart %if Rform=RegVal %thenstart %if Rreg#R1 %thenstart %if Ruse(R1)#0 %then Freeup Reg(R1) Ruse(Rreg)=0 %finishelsestart %if Using(R14)#0 %then Pdrop(R14) %and Using(R14)=0 PIX RR(LR,R14,R1) Rreg=14 %finish OpRX(L,R0,LHS) PIX RX(SRDA,0,0,0,32) PIX RR(DR,R0,Rreg) %finishelsestart %if Ruse(R1)#0 %then Freeup Reg(R1) OpRX(L,R0,LHS) PIX RX(SRDA,0,0,0,32) Ruse(R1)=-255 OpRX(D,R0,RHS) %finish %finish divend: %if Op=IREM %Start pix rr(LTR,R1,R0) %if language=Pascal %Start; ! pascal rem is strange Einternallab=Einternallab-1 pjump(BC,Einternallab,10,15) %if rreg>0 %then pix rr(ar,r1,rreg) %else op rx(a,r1,rhs) plabel(einternallab) %finish %finish Stackr(R1) %return %routine sizes %if RHS_Size<4 %Start %if Rform#litval %then %start Rreg=load int(rhs,-1,-1) Ruse(Rreg)=-255 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) Ruse(Lreg)=-255 Lform=regval LHS_Form=Regval!Regflag LHS_Reg=Lreg %finish LHS_Size=4 %Finish %end %end;! Int Binary Op !* %routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports INEG,IABS * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,XAop,b,d Reg1=Load Int(RHS,-1,0) %if Op=INEG %then XAop=LCR %elsestart %if (Op=INOT %and language=Fortran) %or Op=BNOT %thenstart {++++ temp while fortran change introduced +++} PIX RX(LA,0,0,0,1) PIX RR(NR,Reg1,0) %if op=inot PIX RR(XR,Reg1,0) Stackr(Reg1) %return %finish %if op=inot %Start; ! IMP lgical not set int(-1,4,b,d) do rx(x,reg1,b,d) stackr(reg1) %return %finish %if Op=IABS %then XAop=LPR %else Abort %finish PIX RR(XAop,Reg1,Reg1) Stackr(Reg1) %end;! Int Unary Op !* %routine Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) !*********************************************************************** !* supports RADD,RSUB,RMULT,RDIV,RGT,RLT,REQ,RNE,RGE,RLE * !* descriptor to result on Estack * !*********************************************************************** %constbyteintegerarray RReop(RADD:RDIV) = AER,SER,MER,DER %constbyteintegerarray RXeop(RADD:RDIV) = AE,SE,ME,DE %constbyteintegerarray RRdop(RADD:RDIV) = ADR,SDR,MDR,DDR %constbyteintegerarray RXdop(RADD:RDIV) = AD,SD,MD,DD %constbyteintegerarray RRxop(RADD:RDIV) = AXR,SXR,MXR,0 %integer Lform,Rform,Lreg,Rreg,Bytes,XARop,XAXop,Loadop %switch Opcode(RADD:RLE) Lform=LHS_Form&31 Rform=RHS_Form&31 Lreg=LHS_Reg Rreg=RHS_Reg Bytes=LHS_Size %if RADD<=Op<=RDIV %thenstart %if Bytes=4 %thenstart XARop=RReop(Op) XAXop=RXeop(Op) Loadop=LE %finishelsestart %if Bytes=8 %thenstart XARop=RRdop(Op) XAXop=RXdop(Op) %finishelsestart XARop=RRxop(Op) %finish Loadop=LD %finish %finishelsestart;! comparison %if Bytes=4 %thenstart XARop=CER XAXop=CE Loadop=LE %finishelsestart XARop=CDR XAXop=CD Loadop=LD %finish %finish ->Opcode(Op) !* Opcode(RADD): !* Opcode(RMULT): %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) Stackfr(Lreg,Bytes) %finishelsestart %if Rform#FregVal %thenstart Rreg=Claimfr(-1) OpRX(Loadop,Rreg,RHS) %finish OpRX(XAXop,Rreg,LHS) Stackfr(Rreg,Bytes) %finish %return !* Opcode(RSUB): !* Opcode(RDIV): %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) %finishelsestart %if Rform=FregVal %thenstart Lreg=Claimfr(Rreg) Op RX(Loadop,Lreg,LHS) PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelsestart Lreg=Claimfr(-1) Op RX(Loadop,Lreg,LHS) Op RX(XAXop,Lreg,RHS) %finish %finish Stackfr(Lreg,Bytes) %return !* Opcode(RGT): Opcode(RLT): Opcode(REQ): Opcode(RNE): Opcode(RGE): Opcode(RLE): CC=Setcc(Op-RGT) %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) Fruse(Lreg)=0 %finishelsestart %if Rform=FregVal %thenstart CC=Invcc(CC) OpRX(XAXop,Rreg,LHS) %finishelsestart Rreg=Claimfr(-1) OpRX(Loadop,Rreg,LHS) OpRX(XAXop,Rreg,RHS) %finish Fruse(Rreg)=0 %finish CCset=1 %return %end;! Real Binary Op !* %routine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports RNEG,RABS * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,XAop,Bytes Reg1=Load Real(RHS,-1,-1,Bytes) %if Op=RNEG %thenstart %if Bytes=4 %then XAop=LCER %else XAop=LCDR %finishelsestart %if Op=RABS %thenstart %if Bytes=4 %then XAop=LPER %else XAop=LPDR %finishelse Abort %finish PIX RR(XAop,Reg1,Reg1) Stackfr(Reg1,Bytes) %end;! Real Binary Op !* %routine Convert II(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between integer sizes * !* descriptor to result on Estack * !*********************************************************************** %integer Reg,Val Val=stk_intval %if Stk_form=litval %and (newsize=4 %or (newsize=2 %and %c X'FFFF8000'<=val<=X'7FFF') %or (newsize=1 %and 0<=val<=255)) %Start Stk_size=newsize Push operand(Stk) %else Reg=Load Int(Stk,-1,-1) Stackr(Reg) %finish %end;! Convert II !* %routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between real sizes * !* descriptor to result on Estack * !*********************************************************************** %integer Freg1,Bytes,Oldsize %switch Sw(0:10) Oldsize=Stk_Size ->Sw(((Oldsize&24)>>1)!(Newsize>>3)) !* Sw(1):! CVTRD Freg1=Load Real Extended(Stk,8) Bytes=8 Note: Stackfr(Freg1,Bytes) %return !* Sw(4):! CVTDR Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRER,Freg1,Freg1) Bytes=4 ->Note !* Sw(2):! CVTRQ !* Sw(6):! CVTDQ Freg1=Load Real Extended(Stk,16) Bytes=16 ->Note !* Sw(8):! CVTQR Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRDR,Freg1,Freg1) PIX RR(LRER,Freg1,Freg1) Bytes=4 ->Note !* Sw(9):! CVTQD Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRDR,Freg1,Freg1) Bytes=8 ->Note !* Sw(*): Freg1=Load Real(Stk,-1,-1,Bytes) ->Note %end;! Convert RR !* %routine raddhalf(%integer freg1,Bytes) !*********************************************************************** !* Service routine to perform rounding for convert ri etc !*********************************************************************** %integer Op,Lab,Breg,Jreg %if Bytes=4 %then op=AE-AD %else op=0 BReg=setlocalbase(-1) Jreg=claimjumpreg(-1) Lab=Einternallab-2 Einternallab=Lab pix rr(LTDR+Op,Freg1,Freg1) Pjump(BC,Lab+1,10,Jreg) Pix rx(SD+Op,freg1,0,R9,Rhalf) Pjump(bc,Lab,15,Jreg) PLabel(lab+1) PIX RX(AD+Op,Freg1,0,R9,RHALF) Plabel(lab) %end %routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode) !*********************************************************************** !* converts between real and integer * !* Mode = 0 TNC (ie truncate towards zero) * !* 1 RND (ie the nearest integer) * !* 2 FLOOR (ie Truncate towards minus infinity) * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) ! ! Theory of fixing on IBM ! Fixing is the converse of floating with 3 stages ! 1) Make unsigned by adding 2**31 ! 2) Force the integer to bottom 32 bits by unnormalized operation ! which also loses the fractional bits. ! 3) Convert the unsigned integer back to signed by SL 2**31 (via XI) ! If the fractional bits are retained thro step 1 the effect is FLOOR ! If they are discarded first the effect is TNC hence the ordering ! and different unnormalised nos. ! RND involves an adjustment by 0.5 then a TNC ! Reg1=Claimr(-1) %if Mode=1 %then raddhalf(Freg1,Bytes) %if mode=2 %Start; ! floor only pix rx(ad,freg1,0,r9,maxiasr) pix rx(aw,freg1,0,r9,zerononstd) %else; ! tnc and Rnd PIX RX(SD,Freg1,0,R9,TWO31R);! X'4F00 0000 0800 0000' PIX RX(AW,Freg1,0,R9,TWO32) ;! X'4E00 0001 0000 0000' %finish PIX RX(STD,Freg1,0,R11,0) PIX SI(XI,X'80',R11,4) PIX RX(L,Reg1,0,R11,4) Stackr(Reg1) %end;! Convert RI %routine Convert RIR(%record(Stkfmt)%name Stk,%integer Mode) !*********************************************************************** !* converts between real and integer but leaves the result as a real * !* Mode = 0 TNCRR (ie truncate towards zero) * !* 1 RNDRR (ie the nearest integer) * !* descriptor to result on Estack * !*********************************************************************** %integer Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) %if Mode=1 %then raddhalf(Freg1,Bytes) pix rx(ad,freg1,0,r9,long const(X'4F00000000000000')) Stackfr(Freg1,Bytes) %end;! Convert RIR !* %routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1 Reg1=Load Int(Stk,-1,0) Abortm("Float target size??") %unless newsize=4 %or newsize=8 %or newsize=16 ! ! Theory of IBM floats ! An unsigned integer can be floated by prefixing with X'4E000000' and normalising ! Hence to float a signed integer we can add logically 2**31 (quickest via X) ! append the magic no already in glawork, normalise and subtracy 2**31 ! via a real operation to convert back to signed. The latter can be combined ! with the normalisation. ! %if newsize=16 %Start Freg1=Claimfrpair(-1) PIX RR(SDR,Freg1+1,Freg1+1) %finish %else Freg1=Claimfr(-1) PIX RX(X,Reg1,0,R9,TWO31+4); ! X'8000 0000' PIX RX(ST,Reg1,0,R13,Glawork+4) ! PIX SS(MVC,0,4,R13,Glawork,R9,TWO31); ! alread in glawork and undisturbed PIX RX(LD,Freg1,0,R13,Glawork) PIX RX(SD,Freg1,0,R9,TWO31); ! X'4E00 0000 8000 0000' Stackfr(Freg1,newsize) %end;! Convert IR !* %integerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) !*********************************************************************** !* value defined by RHS is assigned to LHS. If Dup is non-zero then * !* value must be retainedin a reg * !* result is the reg used for retaining the value * !*********************************************************************** %constbyteintegerarray Ad(0:21)=0(9),1(9),0(4) %integer Bytes,Op,Reg,Form,B1,D1,B2,D2 %If language=Pascal %and Rhs_base=Cnst %then %c Rhs_Size=(Rhs_size+3)&(-4);! ! Pascal literal strings have exact size ! but are stored in integral words. Bytes=RHS_Size Form=RHS_Form&31 LHS_Form=LHS_Form&31;! remove Regflag bit if set %if Ad(LHS_Form)#0 %then %Start %if report#0 %then printstring("Warning:- Store into an address ") Refer(LHS,0) LHS_Size=Bytes %finish %if LHS_SizePushit %finish %if Dup#0 %then Reg=Claimr(-1) %else Reg=0 Op RX(L,Reg,RHS) Op=ST ->Pushit %finishelsestart %unless Bytes=8 %thenstart %if Bytes=2 %and Form=RegVal %thenstart Op=STH ->Streg %finish %if Bytes=1 %and Form=Regval %thenstart Op=STC ->Streg %finish Set Bd(LHS,B1,D1) %if bytes=1 %and Form=litval %Start pix si(MVI,RHS_intval,b1,d1) %result=0 %Finish Ruse(B1)=-255 Set Bd(RHS,B2,D2) %if form=litval %then d2=d2+RHS_size-bytes Ruse(B1)=0 fixedmove(Bytes,B1,D1,B2,D2) %result=0 %finish Op=STD %if Form=FregVal %thenstart Reg=RHS_Reg Fruse(Reg)=0 ->Pushit %finish Reg=Claimfr(-1) Op RX(LD,Reg,RHS) ->Pushit %finish %end;! Storeop !* %routine Push Param(%integer Mode,%record(Stkfmt)%name Stk) !*********************************************************************** !* the value or address of Stk is added to the parameter list * !* result is the reg used for retaining the value * !* Mode = 0 push value * !* 1 push address * !*********************************************************************** %integer Bytes,Op,Reg,Form,B1,D1,B2,D2 %if Mode=1 %thenstart Address(Stk) Stk_Size=4 %finish %If language=Pascal %and Stk_base=Cnst %then %c Stk_Size=(Stk_size+3)&(-4);! ! Pascal literal strings have exact size ! but are stored in integral words. %if Stk_Size=1 %thenstart Elevel = Elevel + 1 EstkLit(4) Eop(CVTII) Elevel = Elevel - 1 %finish Form=Stk_Form&31 %if Form=RegVal %then Bytes = 4 %else Bytes=Stk_Size %if Bytes=4 %thenstart %if Form=RegVal %thenstart Op=ST Reg=Stk_Reg Ruse(Reg)=0 %finish %else %if Form=FregVal %thenstart Op=STE Reg=Stk_Reg Fruse(Reg)=0 %else Op RX(L,0,Stk) Op=ST Reg=0 %finish %finishelsestart %unless Bytes=8 %thenstart Set BD(Stk,B1,D1) fixedmove(Bytes,R11,Next Param Offset&X'FFFF',B1,D1) Next Param Offset=Next Param Offset + (Bytes+3)&(-4) %return %finish Op=STD %if Form=FregVal %thenstart Reg=Stk_Reg Fruse(Reg)=0 %else Reg=Claimfr(-1) Op RX(LD,Reg,Stk) %finish %finish %if next param offset=64 %and Op=ST %and reg=R0 %then %c Store pending=64 %else DO RX(Op,Reg,R11,Next Param Offset&X'FFFF') Next Param Offset=Next Param Offset+Bytes %end;! Push Param %routine fixedmove(%integer bytes,B1,D1,B2,D2) !*********************************************************************** !* Plant a MVC but deal with the case where bytes are >256 * !* Pascal records may involve very large moves * !*********************************************************************** %integer pair %if bytes>512 %and b1#b2{not overlapped} %and ruse(r1)>-255 %then ->lmove %cycle %return %if bytes<=0 %if d1>=4096 %Start ruse(B2)=-255 range(B1,D1) ruse(B2)=0 %finish %if D2>=4096 %Start Ruse(B1)=-255 range(B2,D2) Ruse(B1)=0 %finish %exit %if bytes<256 pix ss(MVC,0,256,B1,D1,B2,D2) bytes=bytes-256 D1=D1+256 D2=D2+256 %repeat pix ss(MVC,0,Bytes,B1,D1,B2,D2) %unless bytes<=0 %return Lmove: pair=claimgrpair(0) %if Ruse(R1)#0 %then freeupreg(R1) %if D1=0 %then pix rr(LR,R0,B1) %else Do RX(La,R0,B1,d1) %if D2=0 %Start pix rr(LR,Pair,b2) %unless pair=B2 %finish %else DO RX(LA,Pair,B2,D2) DO RX(LA,R1,0,Bytes) Pix rr(LR,Pair+1,R1) Pix RR(MVCL,R0,Pair) %end !* !* %routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index) !*********************************************************************** !* incorporate Index info into Base record * !*********************************************************************** %integer Reg,Form %record(Stkfmt) Mod %switch F(0:21) %if Index_Form=LitVal %thenstart Index_Intval=Index_Intval<F(Base_Form&31) !* F(IndRegVal): { ((reg)) } F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } Base_Form=Base_Form+12 Set: Base_Modreg=Index_Reg Base_Modbase=Index_Base Base_Modform=Index_Form Base_Modoffset=Index_Offset Base_Scale=Scale Form=Base_Modform&31 %if Form=RegVal %or Form=IndRegVal %thenstart Ruse(Base_Modreg)=-Elevel %finish %return !* F(AddrDir): { @dir } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } Base_Form=Base_Form+4 ->Set !* F(AddrDirMod): { @dir+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } F(RegModAddr): { (reg)+M } F(AddrDirModVal): { (@dir+M) } %if Base_Modform=Litval %and Index_Form=Litval %thenstart Base_Modoffset=Base_Modoffset+Index_Intval< Set F(IndRegModVal): { ((reg)+M) } F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } %if Language=Fortran %then ->f(RegModaddr) Reg=Claimr(0) OpRX(L,Reg,Base) Ruse(Reg)=-Elevel Base_Reg=Reg Base_Form=RegModAddr!Regflag ->Set !* F(LitVal): { lit } F(ConstVal): { const } F(FregVal): { (freg) } F(AddrConst): { @const } Abort F(RegVal): { (reg) } Abort F(TempVal): { (temp) } F(DirVal): { (dir) } %if language=Imp %then Base_form=base_form+12 %and ->Set Abort !* %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 Clear Regs !*********************************************************************** !* forget all previous use of registers * !*********************************************************************** %integer I %cycle I=0,1,15 Ruse(I)=0 %repeat %cycle I=0,2,6 Fruse(I)=0 %repeat Lastreg=0 Lastbreg=0 Lastfreg=-1 %end;! Clear Regs !* %routine Dropall !*********************************************************************** !* no dynamic addressing registers can have assumed values * !*********************************************************************** %integer I %if Using(R15)#0 %then Using(R15)=0 %and Pdrop(R15) %if Using(R14)#0 %then Using(R14)=0 %and Pdrop(R14) %cycle I=0,1,7 Ruse(I)=0 %repeat %cycle I=0,2,6 Fruse(I)=0 %repeat Lastreg=-1 Lastfreg=-1 %end;! Dropall !* !* %routine Freeup Freg(%integer R) !*********************************************************************** !* store the content of floating register R in temp space, modifying * !* Estack entries as necessary * !*********************************************************************** %integer I,J,XAop,Size I=-Fruse(R);! was held as -Elevel %if report#0 %Start printstring("free up REg"); write(r,2); write(ruse(r),5) newline %finish %if I<=0 %thenstart Fruse(R)=0 %return %finish %if Stk(I)_Form&31=FregVal %and Stk(I)_Reg=R %thenstart Size=Stk(I)_Size %if Size=4 %then XAop=STE %else XAop=STD J=New Temp(Size) Stk(I)_Form=TempVal Stk(I)_Offset=J Do RX(XAop,R,R10,J) Stk(I)_Base=0 Fruse(R)=0 %return %finish printstring("Request to free register");write(R,2);newline Abort %end;! Freeup Freg !* %integerfn New Temp(%integer Bytes) %integer I I=integer(Addrstackca) integer(Addrstackca)=I+(Bytes+3)&X'FFFFFFFC' %result=I+64 %end;! New Temp !* %routine Freeup Reg(%integer R) !*********************************************************************** !* store the content of general register R in temp space, modifying * !* Estack entries as necessary * !* no dynamic addressing registers can have assumed values * !*********************************************************************** %record(stkfmt)%name lstk %integer I,J,K I=-Ruse(R);! was held as -Elevel %if I<=0 %thenstart Ruse(R)=0 %return %finish J=New Temp(4) Lstk==stk(i) K=Lstk_Form&31 %if Lstk_Reg=R %thenstart %if K=RegVal %thenstart Lstk_Form=TempVal Lstk_Offset=J %if Lstk_size<4 %Then Lstk_offset=j+4-Lstk_size ! Register converted down prior to a store Lstk_Base=0 Store: Do RX(ST,R,R10,J) Ruse(R)=0 %return %finishelsestart %if (K=regmodaddr %or k=Indregmodval) %and Lstk_modform&31=regval %Start Scalereg(Lstk_Modreg,Lstk_scale) pix rr(ar,r,Lstk_modreg) Ruse(Lstk_modreg)=0 %if k=RegModaddr %then Lstk_Form=Tempaddr %else Lstk_form=IndTempVal Lstk_offset=J Lstk_base=0 Lstk_reg=0 ->store %finish %if K=IndRegVal %or K=RegAddr %or K=RegModAddr %c %or K=IndRegModVal %thenstart Lstk_Form=K+1 Lstk_Offset=J Lstk_Base=0 Lstk_reg=0 ->Store %finish %finish %finishelsestart %if Lstk_Modform&31=RegVal %and Lstk_Modreg=R %thenstart %if k=Regmodaddr %or k=Indregmodval %Start Scalereg(R,Lstk_Scale) pix rr(ar,r,Lstk_Reg) Ruse(lstk_reg)=0 %if k=RegMOdaddr %then Lstk_Form=Tempaddr %else Lstk_form=Indtempval Lstk_offset=j Lstk_base=0 Lstk_reg=0 Lstk_modreg=0 ->store %finish Lstk_Modform=TempVal Lstk_Modoffset=J Lstk_Modbase=0 ->Store %finish %if Lstk_Modform&31=IndRegVal %and Lstk_Modreg=R %thenstart Lstk_Modform=IndTempVal Lstk_Modoffset=J Lstk_Modbase=0 ->Store %finish %finish printstring("Request to free register");write(R,2);newline Abort %end;! Freeup Reg !* %routine Reset Reguse(%integer Old,New) %integer I %cycle I=1,1,3 %if Ruse(I)=-Old %thenstart Ruse(I)=-New %return %finish %repeat %cycle I=0,2,6 %if Fruse(I)=-Old %thenstart Fruse(I)=-New %return %finish %repeat %end;! Reset Reguse !* %routine Freeregs(%integer mask) !*********************************************************************** !* save any general or floating registers * !*********************************************************************** %integer I,fmask fmask=mask>>16; mask=mask&x'ffff' %cycle I=1,1,15 %if 1<0 %then freeup reg(reg) %if tries=3 %and ruse(reg)>-255 %then freeupreg(reg) %if ruse(reg)=0 %and using(reg)=0 %then %result=reg %repeat %repeat abortm("No jump work register") %end %integerfn claimgrpair(%integer notthis) !*********************************************************************** !* Claims a register pair for general use * !*********************************************************************** %constbyteintegerarray choice(0:2)=0,2,14; %integer tries,i,j,pair %for tries =0,1,3 %cycle %for i=0,1,2 %cycle pair=choice(i) %continue %if pair=notthis %if tries=1 %Start %if using(pair)#0 %then using(pair)=0 %and pdrop(pair) %If using(pair+1)#0 %then using(pair+1)=0 %and pdrop(pair+1) %finish %if tries=2 %Start %if ruse(pair)>0 %then freeupreg(pair) %if Ruse(pair+1)>0 %then freeup reg(pair+1) %finish %if tries=3 %start %if ruse(pair)>-255 %then freeupreg(pair) %if Ruse(pair+1)>-255 %Then freeupreg(pair+1) %finish %if ruse(pair)!ruse(pair+1)=0 %and using(pair)!using(pair+1)=0 %then %result=pair %repeat %repeat abortm("No gr pair available") %end %%integerfn setlocalbase(%integer notthis) !*********************************************************************** !* If there is no local base register set up then set one up * !*********************************************************************** %integer i %if using(R14)#0 %and R14#notthis %then %result=R14 %if using(r15)#0 %and R15#notthis %then %result=R15 i=claimjumpreg(notthis) pix rr(basr,i,0) Pusing(i) using(i)=1 %result=i %end %integerfn Claimfr(%integer Curreg) !*********************************************************************** !* result is a free floating register, other than Curreg * !*********************************************************************** %integer I %cycle I=0,2,6 %if Fruse(I)=0 %and I#Curreg %and I#Lastfreg %thenstart Lastfreg=I %result=I %finish %repeat %cycle I=0,2,6 %unless I=Curreg %or I=Lastfreg %thenstart Freeup Freg(I) Lastfreg=I %result=I %finish %repeat %end;! Claimfr !* %integerfn Claimfrpair(%integer Curreg) !*********************************************************************** !* result is the smaller of a free floating register pair, not * !*including Curreg * !*********************************************************************** %integer I %if Fruse(0)=0 %and Fruse(2)=0 %then %result=0 %if Fruse(4)=0 %and Fruse(6)=0 %then %result=4 %unless 0<=Curreg<=2 %thenstart %if Fruse(0)#0 %then Freeup Freg(0) %if Fruse(2)#0 %then Freeup Freg(2) %result=0 %finishelsestart %if Fruse(4)#0 %then Freeup Freg(4) %if Fruse(6)#0 %then Freeup Freg(6) %result=4 %finish %end;! Claimfrpair !* %integerfn Claimr(%integer Curreg) !*********************************************************************** !* result is a free general register, other than Curreg * !*********************************************************************** %integer I %cycle I=1,1,3 %if Ruse(I)=0 %and I#Curreg %and I#Lastreg %thenstart Lastreg=I %result=I %finish %repeat %if report#0 %Start printstring("Claimr"); write(ruse(i),5) %for i=1,1,3 newline %Finish %cycle I=1,1,3 %unless I=Curreg %or I=Lastreg %or Ruse(I)=-255 %thenstart Freeup Reg(I) Lastreg=I %result=I %finish %repeat %if Lastreg>0 %and Lastreg#Curreg %and Ruse(Lastreg)#-255 %thenstart Freeup Reg(Lastreg) %result=Lastreg %finishelsestart %if Using(R14)#0 %then Using(R14)=0 %and Pdrop(R14) %result=R14 %finish Abort %end;! Claimr !* %integerfn Claimbr !*********************************************************************** !* obtain a register, other than Lastbreg * !*********************************************************************** %integer I %cycle I=4,1,7 %if Ruse(I)=0 %and I#Lockedb1 %and i#Lastbreg %then %result=I %repeat %cycle I=4,1,7 %unless I=Lastbreg %or I=Lockedb1 %or Ruse(i)<0 %then Ruse(I)=0 %and %result=I %repeat Abortm("No free base register") %end;! Claimbr !* %routine Setint(%integer Val,Size,%integername B2,D2) !*********************************************************************** !* set B2, D2 to address a location containing Val * !*********************************************************************** %if Size=1 %then Val=Val<<8 B2=R9 %if size<=2 %then d2=short const(val) %else d2=word const(val) %end;! setint !* %integerfn Basereg(%integer Area) !*********************************************************************** !* result is the register addressing the nominated area * !*********************************************************************** %integer I %if Area=0 %then %result=R10;! stack %if Area=Static %then %result=R8 %if Area=Cnst %then %result=R9 %if Area=Gla %then %result=R13 %cycle I=7,-1,4 %if Ruse(I)=Area %then Lastbreg=I %and %result=I %repeat %cycle I=7,-1,4 %unless I=Lastbreg %thenstart DO RX(L,I,R13,Areabase(Area)) Ruse(I)=Area Lastbreg=I %result=I %finish %repeat %end;! Basereg !* %integerfn fourkdisp(%Integer bigdisp) !*********************************************************************** !* Returns the offset of the appropiate 4k mult * !*********************************************************************** %integer n n=bigdisp>>12 %if n>Max4k %then Max4k=n %result=4*n %end %routine scalereg(%integer reg,scale) !*********************************************************************** !* Performs a simple shift optimising shifts by 0 & 1 * !*********************************************************************** %if scale<=0 %then %return %if scale =1 %then pix rr(ALR,reg,reg) %else %c pix rs(SLL,reg,0,0,scale) %end %integerfn SetX2(%integername D2) !*********************************************************************** !* result is a register containing an appropriate 4K multiple * !* D2 is adjusted accordingly * !*********************************************************************** %integer I,J %if D2>=4096 %thenstart J=D2&X'FFFFF000' D2=D2&X'FFF' %cycle I=4,1,7 %if Ruse(I)=J %then Lastbreg=I %and %result=I %repeat I=Claimbr PIX RX(L,I,0,R12,Fourkdisp(j)) Ruse(I)=J %result=I %finishelse %result=0 %end;! SetX2 !* %routine Range(%integername B,D) !*********************************************************************** !* if necessary modify B to ensure that D is less than 4096 * !* D is adjusted accordingly * !*********************************************************************** %integer X2,U %if D>=4096 %thenstart u=ruse(b) %if 4<=B<=7 %then ruse(b)=-254 X2=SetX2(D) Ruse(B)=U PIX RR(AR,X2,B) B=X2 Ruse(X2)=0 %finish %end;! Range !* %integerfn Indbase(%integer Area,Disp) !*********************************************************************** !* result is a register containing the address held in the nominated * !* location * !*********************************************************************** %integer I,J,K J=(Area<<16)!Disp %cycle I=4,1,7 %if Ruse(I)=J %then Lastbreg=I %and %result=I %repeat I=Basereg(Area) K=Claimbr Do RX(L,K,I,Disp) Ruse(K)=(Area<<16)!Disp Lastbreg=K %result=K %end;! Indbase !* %ROUTINE bounded jump(%RECORD (Stkfmt) %NAME Op, %INTEGER min,max,sstad) !*********************************************************************** !* Performs a switch jump with bounds so that the flow of control * !* passes to the next instructio if bounds exceede as reqd by * !* Fortran computed gotos and Pascal cases * !* If the bounds are inside out omit the check(Imp) * !************************************************************************ %INTEGER I,reg1,regb,lab %RECORD (Stkfmt) Bound lab=0 reg1=load int(Op,-1,0); ! To any reg bar 0 %IF max>=min %START; ! do bound check i=setlocalbase(reg1) Einternallab=Einternallab-1 Lab=Einternallab Bound=litone Bound_intval=min %IF min#0 %THEN Oprx(S,reg1,Bound) Bound=litone Bound_intval=max-min OpRX(Cl,reg1,Bound) Pjump(BC,Lab,2,claimjumpreg(reg1)) %FINISH Pix RX(SLL,reg1,0,0,2) Regb=basereg(sst) %if sstad<0 %start bound=litone; bound_intval=-SSTad OP rx(s,reg1,bound) SSTad=0 %finish %IF SSTad>4095 %START Pix rx(a,reg1,0,R12,Fourkdisp(SSTad)) %FINISH Pix rx(L,reg1,reg1,regb,SSTad&4095) Pixrx(BC,15,reg1,R12,0) %IF lab#0 %THEN PLabel(Lab) %END %routine Do RX(%integer Op,Reg,Base,Offset) %integer X2 %if Offset>=4096 %then X2=SetX2(Offset) %else X2=0 PIX RX(Op,Reg,X2,Base,Offset) %end;! Do RX !* %integerfn Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg) !*********************************************************************** !* result is a register loaded with the modifier (scaled if necessary) * !*********************************************************************** %integer Form,Reg,B2,D2 %switch F(0:21) Form=Stk_Modform&31 %if Form =RegVal %thenstart Reg=Stk_Modreg Stk_Modreg=0 Ruse(Reg)=0 Scale: %if Stk_Scale#0 %thenstart scalereg(reg,Stk_Scale) %finish Stk_Modform=RegVal Stk_Scale=0 %result=Reg %finish %if Form=IndRegVal %thenstart Reg=Stk_Modreg Stk_Modreg=0 PIX RX(L,Reg,0,Reg,0) Ruse(Reg)=0 ->Scale %finish Reg=Claimr(Lockedreg) D2=Stk_Modoffset ->F(Form);! removing the reg marker bit !* F(LitVal): { lit } %if 0<=D2<4096 %thenstart %if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart PIX RX(LA,Reg,0,0,D2) %finish %finishelsestart Setint(D2,Stk_Size,B2,D2) Do RX(L,Reg,B2,D2) %finish ->Scale !* F(ConstVal): { const } F(TempVal): { (temp) } F(DirVal): { (dir) } Do RX(L,Reg,Basereg(Stk_Modbase),D2) ->Scale !* F(IndTempVal): { ((temp)) } Do RX(L,Reg,Basereg(Stk_Modbase),D2) PIX RX(L,Reg,0,Reg,0) ->Scale !* F(IndDirVal): { ((dir)) } B2=Indbase(Stk_Modbase,D2) PIX RX(L,Reg,0,B2,0) ->Scale !* F(*): Abort !* %end;! Load Modifier !* %integerfn Negoffset(%integer Area,D) %integer B,D2 %if area=stack %Start d2=imod(d)>>12+1 d2=d2<<12 b=set x2(d2) pix rr(lcr,b,b) pix rx(la,b,b,r10,(4096+d)&x'fff') ruse(b)=0 %result=b %finish D2=Glaspace(4) Efix(GLA,D2-Gla offset,Area,D) B=Claimbr Do RX(L,B,R13,D2) %result=B %end;! Negoffset !* %routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) !*********************************************************************** !* generate an RX instruction appropriate to the operand * !*********************************************************************** %integer B2,D2,Modform,Modreg,Exitl,Xreg %switch F(0:21) D2=Stk_Offset ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } %if 0<=D2<4096 %start %if Op=L %thenstart %if D2=0 %then PIX RR(SR,Reg,Reg) %else PIX RX(LA,Reg,0,0,D2) %return %finish %if Op=C %and D2=0 %then pix rr(LTR,Reg,REg) %and %return %if Op=S %and D2=1 %then pix rr(BCTR,reg,0) %and %return %finish %if X'FFFF8000'<=D2<=X'7FFF' %and %c (Op=L %or Op=C %or Op=A %or Op=S) %then Op=OP-16 %and Stk_size=2 Setint(Stk_Intval,Stk_Size,B2,D2) Do RX(Op,Reg,B2,D2) %return !* F(ConstVal): { const } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } F(TempVal): { (temp) } F(DirVal): { (dir) } B2=Basereg(Stk_Base) %if D2<0 %then B2=Negoffset(Stk_Base,D2) %and D2=0 Do RX(Op,Reg,B2,D2) %if op=st %Start; ! Check for store into recordbase %for modreg=4,1,7 %cycle %if ruse(modreg)=stk_base<<16!d2 %then ruse(modreg)=0 %repeat %finish %return !* F(RegAddr): { (reg) is @ } F(RegVal): { (reg) } PIX RR(Op-X'40',Reg,Stk_Reg) Ruse(Stk_Reg)=0 %return !* F(FregVal): { (freg) } PIX RR(Op-X'40',Reg,Stk_Reg) Fruse(Stk_Reg)=0 %return !* F(IndRegVal): { ((reg)) } PIX RX(Op,Reg,0,Stk_Reg,0) Ruse(Stk_Reg)=0 %return !* F(IndTempVal): { ((temp)) } %if Using(R14)#0 %then Using(R14)=0 %and Pdrop(R14) Do RX(L,R14,Basereg(Stk_Base),D2) PIX RX(Op,Reg,0,R14,0) %return !* F(IndTempModVal): { ((temp)+M) } %if Using(R15)#0 %then Using(R15)=0 %and Pdrop(R15) B2=R15 Do RX(L,B2,Basereg(Stk_Base),D2) ->Modify !* F(IndDirVal): { ((dir)) } B2=Indbase(Stk_Base,D2) PIX RX(Op,Reg,0,B2,0) %return !* F(IndDirModVal): { ((dir)+M) } B2=Indbase(Stk_Base,D2) Modify: %if Stk_Modform=LitVal %thenstart Do RX(Op,Reg,B2,Stk_Modintval) %return %finish Lockedb1=B2 Ruse(B2)=-255; ! B2 not necessarily a base register Modreg=Load Modifier(Stk,Reg) PIX RX(Op,Reg,Modreg,B2,0) Lockedb1=0 Ruse(b2)=0 %return !* F(AddrDirModVal): { (dir+M) } Modreg=Load Modifier(Stk,Reg) Ruse(Modreg)=-255 %if 0<=Stk_Offset<4096 %thenstart PIX RX(Op,Reg,Basereg(Stk_Base),Modreg,Stk_Offset) %finishelsestart %if Stk_Offset<0 %thenstart B2=Negoffset(Stk_Base,Stk_Offset) %finishelsestart B2=Claimr(Reg) Do RX(LA,B2,Basereg(Stk_Base),Stk_Offset) %finish PIX RX(Op,Reg,B2,Modreg,0) %finish Ruse(Modreg)=0 %return !* F(IndRegModVal): { ((reg)+M) } B2=Stk_Reg Ruse(B2)=0 Lastreg=B2;! to avoid possibility of a clash when modifying ->Modify !* F(AddrConst): { @const } F(AddrDir): { @dir } exitl=DirVal; ->alladdr !* F(AddrDirMod): { @dir+M } Exitl=AddrDirModVal; ->alladdr !* F(RegModAddr): { (reg)+M } Exitl=IndRegModVal; ->alladdr !* F(TempModAddr): { (temp)+M } Exitl=IndTempModVal; ->alladdr !* F(DirModAddr): { (dir)+M } Exitl=IndDirModVal; ->alladdr alladdr: %if Op=l %then Op=la %and ->f(exitl) %if Op=STC %or Op=IC %then %Start printstring(" Warning Call of Erefer missing. Erefer(0,1) supllied") ->F(exitl) %finish xreg=load int(stk,-1,reg) STk_reg=xreg ->f(regval) %end;! OpRX !* %routine Set BD(%record(Stkfmt)%name Stk,%integername B,D) !*********************************************************************** !* provide Base and Dispacement values for accessing the operand * !*********************************************************************** %integer Modform,Modreg,D2 %switch F(0:21) D=Stk_Offset ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } Setint(Stk_Intval,Stk_Size,B,D) %unless 0<=D<=4095 %then Range(B,D) %return !* F(ConstVal): { const } F(TempVal): { (temp) } F(DirVal): { (dir) } F(AddrDir): { @dir } %if D<0 %thenstart;! use a fixed up address B=Negoffset(Stk_Base,D) D=0 %return %finish B=Basereg(Stk_Base) %unless D<=4095 %then Range(B,D) %return !* F(IndRegVal): { ((reg)) } F(RegAddr): { (reg) is @ } B=Stk_Reg D=0 Ruse(B)=0 %return !* F(IndTempVal): { ((temp)) } F(TempAddr): { (temp) is @} B=Claimr(0) Do RX(L,B,Basereg(Stk_Base),D) D=0 Ruse(B)=0 %return !* F(IndTempModVal): { ((temp)+M) } F(TempModAddr): { (temp)+M } B=Claimr(0) Do RX(L,B,Basereg(Stk_Base),D) D=0 ->Modify !* F(IndDirVal): { ((dir)) } F(DirAddr): { (dir) is @ } B=Indbase(Stk_Base,D) D=0 %return !* F(IndDirModVal): { ((dir)+M) } F(DirModAddr): { (dir)+M } B=Indbase(Stk_Base,D) Modify: %if Stk_Modform=LitVal %thenstart D=Stk_Modintval Range(B,D) %return %finish Modreg=Load Modifier(Stk,B) PIX RR(AR,Modreg,B) Ruse(Modreg)=0 B=Modreg D=0 %return !* F(AddrDirModVal): { (dir+M) } %if D<0 %thenstart B=Negoffset(Stk_Base,D) %finishelsestart B=Claimr(0) Do RX(LA,B,Basereg(Stk_Base),D) %finish Modreg=Load Modifier(Stk,B) PIX RR(AR,Modreg,B) Ruse(Modreg)=0 B=Modreg D=0 %return !* F(IndRegModVal): { ((reg)+M) } F(RegModAddr): { (reg)+M } B=Stk_Reg Ruse(B)=0 ->Modify !* !* F(AddrConst): { @const } !* F(AddrDirMod): { @dir+M } ->F(AddrDirModVal) !* !* %end;! Set BD !* %routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2) %integer I,Len1,Len2,B1,D1,B2,D2,XAop,Apars,Reg %if C1_Form=LitVal %then C1_Size=1 %if C2_Form=LitVal %then C2_Size=1 %if LenC1_Form=Litval %and LenC2_Form=LitVal %thenstart %if LenC1_Intval=LenC2_Intval %and LenC1_Intval<=256 %thenstart Set BD(C1,B1,D1) %if C2_Form=Litval %thenstart %if Op=EASGNCHAR %then XAop=MVI %else XAop=CLI PIX SI(XAop,C2_Intval,B1,D1) %return %finish Ruse(B1)=-255 Lockedb1=B1 Set BD(C2,B2,D2) Lockedb1=0 Ruse(B1)=0 %if Op=EASGNCHAR %then XAop=MVC %else XAop=CLC PIX SS(XAop,0,LenC1_Intval,B1,D1,B2,D2) %return %finish %finish Apars=Glaspace(16) %cycle I=0,4,12 Pd4(GLA,Apars+I,0) %repeat !* %if C1_Form=AddrDir %thenstart;! establish fixup Efix(GLA,Apars,C1_Base,C1_Offset) %finishelsestart %if C1_Form=LitVal %thenstart Setint(C1_Intval,1,B1,D1) Pfix(GLA,Apars,Cnst,D1) %finishelsestart Set BD(C1,B1,D1) %if D1#0 %thenstart PIX RX(LA,R0,0,B1,D1) B1=R0 %finish Do RX(ST,B1,R13,Apars) %finish %finish !* %if LenC1_Form=LitVal %thenstart Pd4(GLA,Apars+4,LenC1_Intval) %finishelsestart Reg=Load Int(LenC1,-1,-1) Do RX(ST,Reg,R13,Apars+4) %finish !* %if C2_Form=AddrDir %thenstart;! establish fixup Efix(GLA,Apars+8,C2_Base,C2_Offset) %finishelsestart %if C2_Form=LitVal %thenstart Setint(C2_Intval,1,B1,D1) Pfix(GLA,Apars+8,Cnst,D1) %finishelsestart Set BD(C2,B1,D1) %if D1#0 %thenstart PIX RX(LA,R0,0,B1,D1) B1=R0 %finish Do RX(ST,B1,R13,Apars+8) %finish %finish !* %if LenC2_Form=LitVal %thenstart Pd4(GLA,Apars+12,X'20000000'!LenC2_Intval) %finishelsestart Reg=Load Int(LenC2,-1,-1) PIX RX(LA,0,0,0,X'20') PIX RS(SLL,R0,0,0,24) PIX RR(OR,R0,Reg) Do RX(ST,R0,R13,Apars+12) %finish !* %cycle I=1,1,3 %if Ruse(I)#0 %then Freeup Reg(I) %repeat Reg=R13 Range(Reg,Apars) PIX RS(LM,R0,R3,Reg,Apars) %if Op=EASGNCHAR %then XAop=MVCL %else XAop=CLCL PIX RR(XAop,R0,R2) %end;! Do Charop !* %routine Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2) !*********************************************************************** !* Op = 1 CXADD 5 CXNEG 9 CONJG * !* 2 CXSUB 6 CXASGN * !* 3 CXMULT 7 CXEQ * !* 4 CXDIV 8 CXNE * !* Flags = Variant<<8 ! Sizecode * !* Variant: 0 complex op complex * !* 1 complex op real * !* 2 real op complex * !* Sizecode: 0 8 * !* 1 16 * !* 2 32 * !*********************************************************************** %integer Adj,Variant,Size,D,Reg1,Reg2,Reg3,I,Op1,Adjl,Dl %switch S(0:9) %cycle I=0,2,6 %if Fruse(I)<0 %then Freeup Freg(I) %repeat Variant=Flags>>8 Size=Flags&3 %if Size=0 %thenstart D=4 Adj=0 %finishelsestart D=8 Adj=X'10';! to be subtracted from LE etc to give LD etc %finish %if 3<=Op<=4 %and Variant=0 %thenstart;! use support procedure Elevel=Elevel+3;! to allow operands to be pushed Expcall(3*(Op-3)+Size,Spprocs,Spproctype,Spprocref,Spprocpdesc) %return %finish Reg1=Claimr(-1) Ruse(Reg1)=-255 Reg2=Claimr(Reg1) Ruse(Reg2)=-255 OpRX(L,Reg1,LHS) OpRX(L,Reg2,RHS1) %if Op<=4 %thenstart Lastreg=Reg2;! to ensure that both Reg1 and Reg2 are safe Reg3=Claimr(Reg1) OpRX(L,Reg3,RHS2) %finish Ruse(Reg1)=0 Ruse(Reg2)=0 ->S(Op) !* S(1): ! CXADD PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(AE-Adj,0,0,Reg3,0) %unless Variant=1 %then PIX RX(AE-Adj,2,0,Reg3,D) Store:PIX RX(STE-Adj,0,0,Reg1,0) PIX RX(STE-Adj,2,0,Reg1,D) %return !* S(2): ! CXSUB PIX RX(LE-Adj,0,0,Reg2,0) %if Variant=2 %then PIX RR(SER-Adj,2,2) %c %else PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(SE-Adj,0,0,Reg3,0) %unless Variant=1 %then PIX RX(SE-Adj,2,0,Reg3,D) ->Store !* S(3): ! CXMULT PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(ME-Adj,0,0,Reg3,0) PIX RX(ME-Adj,2,0,Reg3,0) { %if Variant=0 %thenstart } { PIX RX(LE-Adj,4,0,Reg2,0) } { PIX RX(LE-Adj,6,0,Reg2,D) } { PIX RX(ME-Adj,4,0,Reg3,D) } { PIX RX(ME-Adj,6,0,Reg3,D) } { PIX RR(SER-Adj,0,6) } { PIX RR(AER-Adj,2,4) } { %finish } ->Store !* S(4): ! CXDIV PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(DE-Adj,0,0,Reg3,0) PIX RX(DE-Adj,2,0,Reg3,0) ->Store !* S(5): ! CXNEG PIX RR(SER-Adj,0,0) PIX RR(SER-Adj,2,2) PIX RX(SE-Adj,0,0,Reg2,0) PIX RX(SE-Adj,2,0,Reg2,D) ->Store !* S(6): ! CXASGN %if Flags&4=0 %thenstart;! assigning to single Adjl=0 Dl=4 %finishelsestart Adjl=X'10' Dl=8 %finish %if Variant#0 %thenstart;! not Cx = Cx %if D=4 %and Dl=8 %then PIX RR(LDR,0,0) PIX RX(LE-Adj,0,0,Reg2,0) %if Variant=2 %thenstart;! Real = Cx St6a: PIX RX(STE-Adjl,0,0,Reg1,0) %return %finishelsestart;! Cx = Real PIX RR(SER-Adj,2,2) St6b: PIX RX(STE-Adjl,2,0,Reg1,Dl) ->St6a %finish %finish %if D#Dl %thenstart;! unequal lengths being assigned %if D=4 %thenstart;! must zero regs PIX RR(SDR,0,0) PIX RR(SDR,2,2) %finish PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) ->St6b %finish PIX SS(MVC,0,D<<1,Reg1,0,Reg2,0) %return !* S(7): ! CXEQ S(8): ! CXNE %if Op=7 %then CC=7 %else CC=8 PIX RX(LE-Adj,0,0,Reg1,0) PIX RR(BASR,R14,0) Pusing(R14) Using(R14)=1 PIX RX(CE-Adj,0,0,Reg2,0) %if Variant=0 %then I=16 %else I=12 PIX RX(BC,7,0,R14,I) %if Variant=1 %thenstart PIX RR(SER,0,0) PIX RR(CER,2,0) %finishelsestart PIX RX(LE-Adj,2,0,Reg1,D) PIX RX(CE-Adj,2,0,Reg2,D) %finish CCset=1 CC=CC!!15;! inverse test was used in the above %return !* S(9): ! CONJG PIX RX(LE-Adj,0,0,Reg2,0) PIX RR(SER-Adj,2,2) PIX RX(SE-Adj,2,0,Reg2,D) ->Store %end;! Cx Operation !* %INTEGER %FN LONG CONST(%LONG %INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE DESCRIPTOR CONSTANT * !*********************************************************************** %INTEGER K STORE CONST(K,8,ADDR(VALUE)) %RESULT=K %END %INTEGER %FN WORD CONST(%INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS * !*********************************************************************** %INTEGER K STORE CONST(K,4,ADDR(VALUE)) %RESULT=K %END %INTEGER %FN SHORT CONST(%INTEGER VALUE) !*********************************************************************** !* STORE A 16 BIT CONSTANT VIA STORE CONST * !*********************************************************************** %INTEGER K STORE CONST(K,2,ADDR(VALUE)+2) %RESULT=K %END %ROUTINE STORE CONST(%INTEGER %NAME D, %INTEGER L,AD) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I,J,K,C1,C2,C3,C4,LP,Rl LP=(L+3)//4; C1=0; C2=0; C3=0; C4=0 rl=4; %IF l=8 %THEN rl=8 %IF l=2 %OR l=6 %THEN rl=2 ->insert %IF l>16; ! dont look up long strings %CYCLE I=0,1,L-1 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) %REPEAT K=0 %IF L=2 %START J=CONST PTR %FOR K=K,1,J-1 %CYCLE %IF k=consthole %THEN %CONTINUE %IF C1=CTABLE(K)&X'FFFF0000' %THEN D=4*K %AND %RETURN %IF C1=CTABLE(K)<<16 %AND k#halfhole %THEN D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %IF L=4 %THEN %START J=CONST PTR ! %IF USE IMP=YES %THEN %START %FOR K=K,1,J-1 %CYCLE %IF CTABLE(K)=C1 %AND CONSTHOLE#K#HALFHOLE %THEN D=4*K %AND %RETURN %REPEAT ! %FINISH %ELSE %START ! %FINISH %FINISH %ELSE %IF L=6 %START %FOR K=K,1,CONST PTR-2 %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)&X'FFFF0000'=C2 %AND %C (CONSTHOLEK+1) %AND (HALFHOLEK+1) %THEN D=4*K %AND %RETURN %IF CTABLE(K)<<16=C1&X'FFFF0000' %AND %C C1&X'FFFF'=CTABLE(K)>>16 %AND CTABLE(K+1)>>16=C2 %AND %C (CONSTHOLEK+1) %AND (HALFHOLEK+1) %THEN D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND (CONSTHOLE=K+LP) %AND (HALFHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %AND CTABLE(K+3)=C4) %THEN %C D=4*K %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=2 %START %IF HALFHOLE#0 %THEN %START CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) D=4*HALFHOLE+2 HALFHOLE=0 %RETURN %FINISH %IF CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 HALFHOLE=CONSTHOLE CONSTHOLE=0 D=4*HALFHOLE %RETURN %FINISH %IF const ptr>16 CTABLE(CONSTHOLE)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0; CONSTHOLE=0 %RETURN %FINISH %IF 0>16 CTABLE(CONSTPTR)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0 CONST PTR=CONST PTR+1 %RETURN %FINISH %IF const ptroverrun %IF lp+const ptr>const limit %IF rl=8 %AND CONST PTR&1#0 %THEN %C CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR %FOR i=0,1,l-1 %CYCLE byteinteger(addr(ctable(const ptr))+i)=byteinteger(ad+i) %REPEAT CONST PTR=CONST PTR+lp %RETURN overrun: ! table full hand excess to put curcnst=(curcnst+rl-1)&(-rl) pdbytes(cnst,curcnst,l,ad) d=curcnst curcnst=curcnst+l %END !* !*********************************************************************** !* %externalroutine Eclear { Dummy on Amdahl } %end { of Eclear } !* !* %externalroutine Ebrefer(%integer Offset,Bytes) { Dummy } %end !* %externalroutine estkpf(%Integer i,j) %end %externalroutine eprefer(%integer i,j) %end %externalroutine etrap(%integer Trapop,error) %if report#0 %Start printstring("Etrap "); write(Trapop,5); write(error,5) newline %Finish Int binary op(trapop,Stk(elevel-1),stk(elevel)) Elevel=Elevel-2 pix rx(la,R0,0,0,error) ejump(JTRUE,Pastraplab) %end %externalroutine egenerateobject(%stringname s) %end %endoffile