!* modified 07/10/85 !* 21/10/85 - new ecodes PUSHBYTES, ARGPROC, update Eopname !* - new Pascal specific ecodes, update routine pasop, new array !* - Epasopname, update cfort_ecodes !* %ownstring(31) Versiontext="Fortran77 Compiler Version 0.1" %owninteger Report=1 %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 Demote(%integer Level) %routinespec Estkaddr(%integer Area, Offset, Adid, Bytes) %routinespec Estkgaddr(%integer Level,Offset,Adid,Bytes) %routinespec Estkpaddr(%integer Level,Offset,Adid,Bytes) !* %routinespec Elabel(%integer id) %routinespec Ediscardlabel(%integer id) %routinespec Ejump(%integer Opcode, Labelid) %routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3) %routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid, %integername SSTad) %routinespec EswitchJump(%integer Switchid) %routinespec EfswitchJump(%integer Switchid) %routinespec Eswitchentry(%integer Switchid, Entry) %routinespec Eswitchdef(%integer Switchid) %routinespec EswitchLabel(%integer Switchid, Entry, Labelid) !* %routinespec Ed1(%integer area, Disp, Val) %routinespec Ed2(%integer area, Disp, Val) %routinespec Ed4(%integer area, Disp, Val) %routinespec Edbytes(%integer area, Disp, len, ad) %routinespec Edpattern(%integer area, Disp, ncopies, len, ad) %routinespec Efix(%integer area, disp, tgtarea, tgtdisp) !* %integerfnspec EXname(%integer type, %string(255)%name Xref) %routinespec Eprecall(%integer Id) %routinespec Ecall(%integer Id, Numpars, Paramsize) %routinespec Eprocref(%integer Id, Level) %routinespec Esave(%integer Asave, %integername Key) %routinespec Erestore(%integer Asave, Key, Existing) !* %integerfnspec Enextproc %routinespec Eproc(%stringname Name, %integer Props, Numpars, Paramsize, Astacklen, %integername Id) %routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen) %routinespec Eentry(%integer Index,Numpars,Paramsize, Localsize, Diagdisp, %stringname Name) !* %routinespec Edataentry(%integer Area, Offset, Length, %stringname Name) %routinespec Edataref(%integer Area, Offset, Length, %stringname Name) !* %routinespec Eop(%integer Opcode) %routinespec Ef77op(%integer Opcode) %routinespec Epasop(%integer Opcode) %routinespec Eccop(%integer Opcode) !* !* !*********************************************************************** !* Imports * !*********************************************************************** !* %include "ercs12:ib4_specs" !%include "cfort_xaspecs" %include "cfort_ecodes" %include "cfort_xamnem" !* !* !*********************************************************************** !* Common declarations * !*********************************************************************** !* !* %conststring(9)%array Eopname(0:255) = %c {00} "HALT","IADD","ISUB","IMULT", "IDIV" ,"INEG" ,"IABS" ,"IREM" , {08} "IAND","IOR" ,"INOT","IXOR" , "ISHLL","ISHRL","ISHLA","ISHRA", {10} "IGT" ,"ILT" ,"IEQ" ,"INE" , "IGE" ,"ILE" ,"" ,"" , {18} "JIGT","JILT","JIEQ","JINE" , "JIGE" ,"JILE" ,"JINTGZ","JINTLZ", {20} "JINTZ","JINTNZ","JINTGEZ","JINTLEZ", "ITWB" ,"","JUMP","", {28} "" ,"SFA" ,"RETURN" ,"ASF" , "IPUSH" ,"IPOP" ,"EXCH" ,"DUPL", {30} "DISCARD","" ,"" ,"INDEX1", "INDEX2","INDEX4","INDEX8","INDEX", {38} "MVB" ,"CHK" ,"TMASK" ,"" , "" ,"" ,"CPBGT" ,"CPBLT", {40} "CPBEQ" ,"CPBNE","CPBGE","CPBLE" , "","","","", {48} "","","","", "","","","", {50} "","","","", "","","","", {58} "","","","", "","","","", {60} "","","","", "","","","", {68} "","","","", "","","","", {70} "" ,"RADD" ,"RSUB" ,"RMULT","RDIV" ,"RNEG" ,"RABS","" , {78} "","","","", "","","","", {80} "","","","", "","","","", {88} "CVTII","CVTIR","CVTRR","TNCRI", "RNDRI","","","", {90} "RGT" ,"RLT" ,"REQ" ,"RNE" ,"RGE" ,"RLE" ,"JRGT","JRLT", {98} "JREQ" ,"JRNE" ,"JRGE","JRLE" ,"JRGZ" ,"JRLZ","JRZ" ,"JRNZ", {A0} "JRGEZ","JRLEZ","RTWB","JTRUE","JFALSE","" ,"" ,"" , {A8} "" ,"" ,"" ,"" , "" ,"" ,"" ,"" , {B0} "" ,"UCHECK","FLTR","FLTD","FLTQ" ,"" ,"" ,"" , {B8} "ESTORE","EDUPSTORE","PUSHVAL","PUSHADDR", {BC} "EVAL" ,"EVALADDR","EADDRESS","EINTRES", {C0} "EREALRES","ESIZE","EPOWER" ,"EPOWERI", "ARGPROC","PUSHBYTES","","", {C8} "","","","", "","","","", {D0} "","","","", "","","","", {D8} "","","","", "","","","", {E0} "","","","", "","","","", {E8} "","","","", "","","","", {F0} "","","","", "","","","", {F8} "","","","", "","","","" !* %conststring(11)%array Ef77opname(256:319)= %c {100} "" ,"CXADD" ,"CXSUB" ,"CXMULT" , {104} "CXDIV" ,"CXNEG" ,"CXASGN" ,"CXEQ" , {108} "CXNE" ,"EPOWER" ,"EPOWERI" ,"EM1EXP" , {10C} "ESIGN" ,"ESIGN" ,"EIMOD" ,"ERMOD" , {110} "EIDIM" ,"ERDIM" ,"EIMIN" ,"ERMIN" , {114} "EIMAX" ,"ERMAX" ,"EDMULT" ,"ECONJG" , {118} "ECHAR" ,"EICHAR" ,"EINDEXCHAR" ,"ECONCAT" , {11C} "EASGNCHAR" ,"ECOMPCHAR" ,"" ,"ECMPLX2" , {120} "EISHFT" ,"EIBITS" ,"EIBSET" ,"EIBTEST" , {124} "EIBCLR" ,"EISHFTC" ,"PROCARG" ,"IPROCARG" , {128} "CHARARG" ,"IPROCCALL" ,"ARGPROCCALL","CALLTPLATE" , {12C} "NOTEIORES" ,"STKIORES" ,"EFCVT" ,"EFCVTASGN" , {130} "EARGLEN" ,"EFDVACC" ,"" ,"" , {134} "" ,"" ,"" ,"" , {138} "" ,"" ,"" ,"" , {13C} "" ,"" ,"" ,"" !* %conststring(8)%array Epasopname(512:541)= %c {200} "STRLT" ,"STRLE" ,"STRNE" ,"STREQ" , {204} "" ,"" ,"" ,"" , {208} "PTREQ" ,"PTRNE" ,"" ,"" , {20C} "" ,"" ,"" ,"" , {210} "" ,"" ,"SETI" ,"SETU" , {214} "SETSUB" ,"SETEQ" ,"SETEQ" ,"SETNE" , {218} "SETIN" ,"SETSING" ,"SETRANGE" ,"" , {21C} "INDEXCAP" ,"LOADCAP" !* !*********************************************************************** !* %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 Regflag = 32 {used to speedup search for reguse} !* %conststring(14)%array Eform(0:21) = %c "LitVal ","ConstVal ","RegVal ","FregVal ", "TempVal ","DirVal ","IndRegVal ","IndTempVal ", "IndDirVal ","ConstAddr ","AddrDir ","RegAddr ", "TempAddr ","DirAddr ","AddrDirMod ","RegModAddr ", "TempModAddr ","DirModAddr ","IndRegModVal ","IndTempModVal ", "IndDirModVal ","AddrDirModVal " !* %recordformat Stkfmt(%byteinteger Form,Size,Reg,Modreg, Base,Modbase,Scale,Modform, (%integer Offset %or %integer Intval), (%integer Modoffset %or %integer Modintval), %integer Adid) !* %ownrecord(Stkfmt)%array Stk(0:15) !* %owninteger Elevel %owninteger ProgFaulty %owninteger ProcProps !* %conststring(9)%array Expprocs(0:14)= %c "f_powii" ,"f_powri" ,"f_powdi" ,"f_powqi" ,"f_powci" , "f_powzi" ,"f_powzzi" ,"" ,"" ,"f_powrr" , "f_powdd" ,"f_powqq" ,"f_powcc" ,"f_powzz" ,"f_powzzz" !* %constintegerarray Expprocpdesc(0:14)= %c X'20008',X'20008',X'2000C',X'20008',X'3000C', X'3000C',X'3000C',0 ,0 ,X'20008', X'20010',X'20008',X'3000C',X'3000C',X'3000C' !* %constintegerarray Expproctype(0:14)= %c X'10401',X'10402',X'10802',X'11002',X'10000', X'10000',X'10000', 0, 0,X'10402', X'10802',X'11002',X'10000',X'10000',X'10000' !* %ownintegerarray Expprocref(0:14) !* %conststring(9)%array Spprocs(0:7)= %c "f_crmult" ,"f_cdmult" ,"f_cqmult", "f_crdiv" , "f_cddiv" ,"f_cqdiv" ,"f_index" ,"f_concat" !* %constintegerarray Spprocpdesc(0:7)= %c X'3000C',X'3000C',X'3000C',X'3000C', X'3000C',X'3000C',X'40010',X'40010' !* %constintegerarray Spproctype(0:7)= %c X'10000',X'10000',X'10000',X'10000', X'10000',X'10000',X'10000',X'10000' !* %ownintegerarray Spprocref(0:7) !* %owninteger Unasslab !* !* !*********************************************************************** !* Amdahl-specific declarations * !*********************************************************************** !* !* %constinteger R0 = 0 %constinteger R1 = 1 %constinteger R2 = 2 %constinteger R3 = 3 %constinteger R4 = 4 %constinteger R5 = 5 %constinteger R6 = 6 %constinteger R7 = 7 %constinteger R8 = 8 %constinteger R9 = 9 %constinteger R10 = 10 %constinteger R11 = 11 %constinteger R12 = 12 %constinteger R13 = 13 %constinteger R14 = 14 %constinteger R15 = 15 !* %constbyteintegerarray Setcc(0:5)=2,4,8,6,10,12 {GT LT EQ NE GE LE} %constbyteintegerarray Invcc(0:15)=0,1,4,5,2,3,6,7,8,9,12,13,10,11,14,15 !* %constinteger Stack Offset=64 %constinteger Param Offset=64 !* %constintegerarray Cnstinit(0:13)= 0,0, X'4E000000', X'80000000', X'4E000001', X'00000000', X'4F000000', X'08000000', X'81818181', X'81818181', X'40800000', X'00000000', X'00000000', X'00000000' %constinteger TWO31 = 8 %constinteger TWO32 = 16 %constinteger TWO31R= 24 %constinteger RHALF = 40 !* !*********************************************************************** !* %ownintegerarray Areabase(0:255) %ownintegerarray Areaprops(0:255) %ownintegerarray Ruse(0:15) %ownintegerarray Fruse(0:6) !* %owninteger Addrstackca, Addrglaca %owninteger Upperlineno %owninteger UsingR14, UsingR15, Lastreg, Lastbreg, Lastfreg, Max4k %owninteger CC, CCset %owninteger Glaf77regs,Glawork,Curdiagca %owninteger CurCnst %owninteger Next Param Offset %owninteger Curswitchad %owninteger Curswitchmax !* !* !*********************************************************************** !* 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 Stackr(%integer R) %routinespec Stackfr(%integer FR,Bytes) %routinespec Establish Logical %routinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) %routinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) %routinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) %routinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS) %routinespec Convert RR(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes) %routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode) %integerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) %routinespec Push Param(%integer Mode,%record(Stkfmt)%name Stk) %integerfnspec Load address(%record(Stkfmt)%name Stk) %routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index) %routinespec Expcall(%integer Proc) %routinespec Spcall(%integer Proc) !* %routinespec Clear Regs %routinespec Dropall %routinespec Freeup Freg(%integer R) %routinespec Freeup Reg(%integer R) %routinespec Freeregs %routinespec Reset Reguse(%integer Old,New) %integerfnspec Claimfr(%integer Curreg) %integerfnspec Claimfrpair(%integer Curreg) %integerfnspec Claimr(%integer Curreg) %integerfnspec Claimrpair(%integer Curreg) %integerfnspec Claimbr %integerfnspec New Temp(%integer Bytes) %routinespec Setint(%integer Val,Size,%integername B2,D2) %integerfnspec Basereg(%integer Area) %integerfnspec SetX2(%integername D2) %routinespec Range(%integername B,D) %integerfnspec Indbase(%integer Area,Disp) %routinespec Do Rx(%integer Op,Reg,Base,Offset) %integerfnspec Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg) %routinespec OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) %routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2) %routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2) %routinespec Set BD(%record(Stkfmt)%name Stk,%integername B,D) !* !*********************************************************************** !* %ownstring(8)%array Areas(0:255)= %c "Stack ","Code ","Gla ","","Ust ","Gst ","Diags ","Scalars", "Ioarea ","","Consts ",""(245) !* %routine Phex(%integer Val) %conststring(1)%array C(0:15)= %c "0","1","2","3","4","5","6","7", "8","9","A","B","C","D","E","F" %integer I %cycle I=28,-4,0 printstring(C((Val>>I)&15)) %repeat %end !* %routine Dump Estack %record(Stkfmt)%name E %integer I,J,K %routine Pform(%integer Form,Reg,Base,Offset) printstring(Eform(Form&31)) %if Form&Regflag#0 %then write(Reg,1) %and %return %if Form=Litval %thenstart write(Offset,4) %return %finish ! %if Base#0 %thenstart printstring(Areas(Base)) ! %finish ! %if Offset#0 %thenstart printstring(" + ") write(Offset,3) ! %finish %end;! Pform %if Elevel<=0 %then %return write(ruse(1),1);write(ruse(2),1);write(ruse(3),1);newline printstring("Estack: ") I=Elevel %while I>0 %cycle J=addr(Stk(I)) ! %cycle K=0,4,16 ! Phex(integer(J+K)) ! space ! %repeat E==record(J) write(I,1);printstring(":") Pform(E_Form,E_Reg,E_Base,E_offset) %if (E_Form&31)>=AddrDirMod %thenstart printstring(" mod by:") Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset) %if E_Scale>1 %thenstart printstring(" scaled by:") write(E_Scale,1) %finish %finish printstring(" size:") write(E_Size,1) newline I=I-1 %repeat %end;! Dump Estack !* !* !********************************************************************** !********************************************************************** !** Error reporting ** !********************************************************************** !********************************************************************** !* !* %routine Low Estack(%integer Opcode,Reqlevel) printstring("******* Estack error ****** Op = ".Eopname(Opcode)." actual/required levels:") write(Elevel,4) write(Reqlevel,4) newline %monitor %stop Elevel=0 %end;! Low Estack !* %routine Abort Dump Estack %monitor %stop %end;! Abort !* %routine Unsupported Opcode(%integer Opcode) %string(15) S %if Opcode<=255 %then S=Eopname(Opcode) %else S=Ef77opname(Opcode) printstring("******* Unsupported Opcode ****** ".S) newline %end;! Unsupported Opcode !* !* !*********************************************************************** !*********************************************************************** !** Externally visible procedures ** !*********************************************************************** !*********************************************************************** !* !* !* ********************* !* * Administration * !* ********************* !* !* %externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options) !*********************************************************************** !* called once at the start of compilation to initialise Eput * !*********************************************************************** %integer I,Flags ProgFaulty=0 ! Report=options&1 Decode=Options&X'4000' Language=Lang %if Report#0 %thenstart printstring("Einitialise ") newline %finish Addrstackca=Astackca Addrglaca=Aglaca Upperlineno=-1 UsingR14=0 UsingR15=0 Clear Regs CCset=0 Elevel=0 %cycle I=0,1,255 Areabase(I)=0 Areaprops(I)=0 %repeat %cycle I=4,1,10 Areabase(I)=I<<2+64 %repeat %cycle I=0,1,14 Expprocref(I)=0 %repeat %cycle I=0,1,7 Spprocref(I)=0 %repeat !* %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) Pfix(Gla,12,SST,0) Pd4(Gla,16,x'02000000') Pfix(Gla,20,Diags,0) I=integer(Addrglaca) Glaf77regs=I Pfix(Gla,I,Static,0) Pfix(Gla,I+4,Cnst,0) Glawork=I+8 integer(Addrglaca)=I+16 !* Pdbytes(Cnst,0,56,addr(Cnstinit(0))) Curcnst=56 Max4k=0 %end;! Einitialise !* %externalroutine Eterminate(%integer adareasizes) !*********************************************************************** !* called once at the end of compilation by the code generator * !*********************************************************************** %ownintegerarray S(1:10) %integer I,J %if Report#0 %thenstart printstring("Eterminate ") newline %finish %if ProgFaulty#0 %then %return J=0 %cycle I=1,1,9 S(I)=integer(Adareasizes+J) J=J+4 %repeat S(10)=CurCnst I=Pterminate(addr(S(1)), 0) integer(adareasizes)=S(1) %end;! Eterminate !* %externalroutine Ecommon(%integer area,%stringname Name) !*********************************************************************** !* define a common area (in range 11-255) * !*********************************************************************** %integer Prop %if Report#0 %thenstart printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name) Newline %finish %if ProgFaulty#0 %then %return Area=Area+256 %if Name="F#BLCM" %then Prop=1 %else Prop=2 Areaprops(Area-256)=Prop Pnewarea(Name,Area,Prop) %end;! Ecommon !* %externalroutine Eendcommon(%integer area,Length) !*********************************************************************** !* define length of previously defined common * !*********************************************************************** %if Report#0 %thenstart printstring("Eendcommon ");write(Area,1);write(Length,6) Newline %finish %if ProgFaulty#0 %then %return Area=Area+256 Pendarea(Area,Length,Areaprops(Area-256)) %end;! Eendcommon !* %externalroutine Elinestart(%integer lineno) !*********************************************************************** !* register start of a line * !*********************************************************************** %if Report#0 %thenstart printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4) newline %finish %if ProgFaulty#0 %then %return %if Decode#0 %then Plinedecode Plinestart(Lineno) %if lineno & X'FF00' # Upperlineno %thenstart PIX SI(MVI, lineno>>8, R10, 2) Upperlineno = lineno & X'FF00' %finish PIX SI(MVI, lineno&X'FF', R10, 3) %end;! Elinestart !* %externalroutine Elinedecode !*********************************************************************** !* decompile code generated from last Elinedecode or Elinestart * !*********************************************************************** %if Report#0 %thenstart printstring("Elinedecode "); newline %finish %if ProgFaulty#0 %then %return Plinedecode %end;! Elinedecode !* %externalintegerfn Estkmarker !*********************************************************************** !* turn on internal tracing * !*********************************************************************** %if Report#0 %thenstart printstring("Estkmarker ") newline %finish %result=0 %end;! Estkmarker !* %externalroutine Esetmarker(%integer Markerid,New Value) !*********************************************************************** !* turn off internal tracing * !*********************************************************************** %if Report#0 %thenstart printstring("Esetmarker ");write(Markerid,4) write(New Value,4) newline %finish %end;! Esetmarker !* %externalintegerfn Eswapmode !*********************************************************************** !* turn on internal tracing * !*********************************************************************** %if Report#0 %thenstart printstring("Eswapmode ") newline %finish %result=0 %end;! Eswapmode !* %externalroutine Emonon !*********************************************************************** !* turn on internal tracing * !*********************************************************************** Report=1 %end;! Emonon !* %externalroutine Emonoff !*********************************************************************** !* turn off internal tracing * !*********************************************************************** Report=0 %end;! Emonoff !* %externalroutine Efaulty !*********************************************************************** !* compilation has a fault - no object file to be generated * !*********************************************************************** %if Report#0 %thenstart printstring("Efaulty "); newline %finish ProgFaulty=1 Pfaulty %end;! Efaulty !* !* !* !* ********************* !* * Stack operations * !* ********************* !* !* %externalroutine Estklit(%integer Val) !*********************************************************************** !* stacks Val as a 32-bit integer literal * !*********************************************************************** %if Report#0 %thenstart printstring("Estklit ");write(Val,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=LitVal Stk(Elevel)_Intval=Val Stk(Elevel)_Size=4 %end;! Estklit !* %externalroutine Estkconst(%integer Len,Ad) !*********************************************************************** !* stacks the constant, allocating space for it if necessary * !*********************************************************************** %if Report#0 %thenstart printstring("Estkconst ") write(Len,4) newline %finish %if ProgFaulty#0 %then %return Pdbytes(Cnst,CurCnst,Len,Ad) Estkdir(Cnst,CurCnst,0,Len) CurCnst=Curcnst+((Len+3)>>2)<<2 %end;! Estkconst !* %externalroutine Estkdir(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkdir ".Areas(area)." +");write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return %if Area=0 %then Offset=Offset+Stack Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=Area Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkdir !* %externalroutine Estkind(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkind ".Areas(area)." +");write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return %if Area=0 %then Offset=Offset+Stack Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=IndDirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=Area Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkind !* %externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand local to an enclosing level * !*********************************************************************** %if Report#0 %thenstart printstring("Estkglobal ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=0 Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkglobal !* %externalroutine Estkglobalind(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect operand local to an enclosing level * !*********************************************************************** %if Report#0 %thenstart printstring("Estkglobalind ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=IndDirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=0 Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkglobalind !* %externalroutine Estkpar(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct parameter operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkpar ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=0 Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkpar !* %externalroutine Estkparind(%integer Level,Offset,Adid,Bytes) !*********************************************************************** !* stacks an indirect parameter operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkparind ");write(Level,1);write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return Offset=Offset+Param Offset %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=IndDirVal Stk(Elevel)_Size=Bytes Stk(Elevel)_Base=0 Stk(Elevel)_Offset=Offset Stk(Elevel)_Adid=Adid %end;! Estkparind !* %externalroutine Estkresult(%integer Class,Type,Bytes) !*********************************************************************** !* defines the result stacked by a function call * !* Type = 1 int * !* = 2 real * !*********************************************************************** %if Report#0 %thenstart printstring("Estkresult ") write(Class,4);write(Type,4);write(Bytes,4) newline %finish %if ProgFaulty#0 %then %return %if Type=2 %thenstart;! real Stackfr(0,Bytes) %finishelse Stackr(1) %end;! Estkresult !* %externalroutine Erefer(%integer Offset,Bytes) !*********************************************************************** !* stacks the address of a direct operand * !*********************************************************************** %if Report#0 %thenstart printstring("Erefer ");write(Offset,1);write(Bytes,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Abort %and %return Refer(Stk(Elevel),Offset) Stk(Elevel)_Size=Bytes %end;! Erefer !* %externalroutine Epromote(%integer Level) !*********************************************************************** !* move the entry at Level in Estack to the top of the Estack * !* - the top entry is at level 1 * !*********************************************************************** %record(Stkfmt) E %integer I %if Report#0 %thenstart printstring("Epromote ");write(Level,4) newline %finish %if ProgFaulty#0 %then %return %unless 00 %then Abort Upperlineno = -1 Dropall Plabel(id) %end;! Elabel !* %externalroutine Ediscardlabel(%integer Id) !*********************************************************************** !* advise that a label can now be discarded - i.e. no future ref * !*********************************************************************** %if Report#0 %thenstart printstring("Ediscardlabel ");write(Id,4) newline %finish %end;! Ediscardlabel !* %externalroutine Euchecklab(%integer Labid) Unasslab=Labid %end !* %externalroutine Ejump(%integer Opcode, Labelid) !*********************************************************************** !* generate specified conditional or unconditional jump * !*********************************************************************** %switch Op(0:164) %integer Reg1,Freg1,XAop,Bytes %if Report#0 %thenstart printstring("Ejump ".Eopname(Opcode));write(Labelid,4) newline %finish %if ProgFaulty#0 %then %return ->Op(Opcode) !* Op(*):%monitor %stop !* Op(JIGT): Op(JILT): Op(JIEQ): Op(JINE): Op(JIGE): Op(JILE): CC=Setcc(Opcode-JIGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2)) CCset=0 Pjump(BC,Labelid,CC,R14) %return !* Op(JINTGZ): Op(JINTLZ): Op(JINTZ): Op(JINTNZ): Op(JINTGEZ): Op(JINTLEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) Pjump(BC,Labelid,Setcc(Opcode-JINTGZ),R14) %return !* Op(JUMP): Pjump(BC,Labelid,15,R14) %return !* Op(JRGT): Op(JRLT): Op(JREQ): Op(JRNE): Op(JRGE): Op(JRLE): CC=Setcc(Opcode-JRGT) %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Real Binary Op(RGT+Opcode-JRGT,Stk(Elevel+1),Stk(Elevel+2)) CCset=0 Pjump(BC,Labelid,CC,R14) %return !* Op(JRGZ): Op(JRLZ): Op(JRZ): Op(JRNZ): Op(JRGEZ): Op(JRLEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then XAop=LTER %else XAop=LTDR PIX RR(XAop,Freg1,Freg1) Pjump(BC,Labelid,Setcc(Opcode-JRGZ),R14) %return !* Op(JTRUE): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) Pjump(BC,Labelid,6,R14) %return %finish CCset=0 Pjump(BC,Labelid,CC,R14) %return !* Op(JFALSE): %if CCset=0 %thenstart %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) Pjump(BC,Labelid,8,R14) %return %finish CCset=0 Pjump(BC,Labelid,14-CC,R14) %return %end;! Ejump !* %externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3) !*********************************************************************** !* generate the code for a Fortran three-way jump * !* opcode = ITWB or RTWB for integer or real expression on Estack * !* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0 * !* - if Labi <= 0 that jump is not required * !*********************************************************************** %integer Op,Reg1,Freg1,Bytes %if Report#0 %thenstart printstring("Etwjump ".Eopname(Opcode)) write(Lab1,4);write(Lab2,4);write(Lab3,4) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 %if Opcode=ITWB %thenstart Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LTR,Reg1,Reg1) %finishelsestart Freg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %then Op=LTER %else Op=LTDR PIX RR(Op,Freg1,Freg1) %finish %if Lab1>0 %then Pjump(BC,Lab1,4,R14);! if < 0 %if Lab2>0 %then Pjump(BC,Lab2,8,R14);! = 0 %if Lab3>0 %then Pjump(BC,Lab3,2,R14);! > 0 %end;! Etwjump !* %externalroutine Eswitch(%integer Lower, Upper, Switchid, Errlabid, %integername SSTad) !*********************************************************************** !* define a switch Switchid to be indexed in the range (Lower:Upper) * !* space may be claimed from SST fotr the switch table * !*********************************************************************** %integer Ad %if Report#0 %thenstart printstring("Eswitch ") write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4) newline %finish %if ProgFaulty#0 %then %return Ad=SSTad SSTad=SSTad+(Upper-Lower+1)<<2 Pswitch(Ad,Lower,Upper,4) Curswitchad=Ad Curswitchmax=Upper %end;! Eswitch !* %externalroutine EswitchJump(%integer Switchid) !*********************************************************************** !* jump to Switchid( (Etos) ) * !* if (Etos) is outside the bounds defined for Switchid then error * !*********************************************************************** %if Report#0 %thenstart printstring("EswitchJump ");write(switchid,4) newline %finish %end;! EswitchJump !* %externalroutine EfswitchJump(%integer Switchid) !*********************************************************************** !* jump to Switchid( (Etos) ) * !* if (Etos) is outside the bounds the jump has no effect. Note that * !* in this case Switchid(Lower) addresses the next instruction * !*********************************************************************** %integer Reg1,Reg2,Adtable %if Report#0 %thenstart printstring("EfswitchJump ");write(switchid,4) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Low Estack(JUMP,1) %and %return Elevel=Elevel-1 Adtable=integer(Addrglaca) integer(Addrglaca)=integer(Addrglaca)+4 Pfix(GLA,Adtable,SST,Curswitchad) Reg1=Load Int(Stk(Elevel+1),-1,0) %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15) Reg2=Indbase(GLA,Adtable) PIX RR(BASR,R14,0) PIX RR(LTR,Reg1,Reg1) PIX RX(BC,12,0,R14,28) PIX RX(LA,0,0,0,Curswitchmax) PIX RR(CR,Reg1,0) PIX RX(BC,2,0,R14,28) PIX RS(SLL,Reg1,0,0,2) PIX RX(L,R15,Reg1,Reg2,0) PIX RX(BC,15,R12,R15,0) %end;! EfswitchJump !* %externalroutine Eswitchentry(%integer Switchid, Entry) !*********************************************************************** !* define the current code address as Switchid(Entry) * !*********************************************************************** %if Report#0 %thenstart printstring("Eswitchentry ");write(Switchid,4);write(Entry,4) newline %finish %end;!Eswitchentry !* %externalroutine Eswitchdef(%integer Switchid) !*********************************************************************** !* define the current code address as Switchid(*) - the default * !*********************************************************************** %if Report#0 %thenstart printstring("Eswitchdef ");write(Switchid,4) newline %finish %end;!Eswitchdef !* %externalroutine EswitchLabel(%integer Switchid, Entry, Labelid) !*********************************************************************** !* define Labelid as Switchid(Entry) * !*********************************************************************** %if Report#0 %thenstart printstring("EswitchLabel ");write(switchid,4);write(entry,4) write(labelid,4) newline %finish %if ProgFaulty#0 %then %return Pswitchval(Curswitchad,Entry,Labelid) %end;! EswitchLabel !* !* !* !* ******************************* !* * Data initialisation, fixups * !* ******************************* !* !* %externalroutine Ed1(%integer area, Disp, Val) !*********************************************************************** !* intialise an 8-bit location * !*********************************************************************** %if Report#0 %thenstart printstring("Ed1 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish Pdbytes(area, Disp, 1, addr(Val)+3) %end;! Ed1 !* %externalroutine Ed2(%integer area, Disp, Val) !*********************************************************************** !* intialise a 16-bit location * !*********************************************************************** %if Report#0 %thenstart printstring("Ed2 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish Pdbytes(area, Disp, 2, addr(Val)+2) %end;! Ed2 !* %externalroutine Ed4(%integer area, Disp, Val) !*********************************************************************** !* intialise a 32-bit location * !*********************************************************************** %if Report#0 %thenstart printstring("Ed4 ".Areas(Area)." +");write(Disp,1) spaces(4);Phex(Val) newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 Pdpattern(Area,Disp,1,4,addr(Val)) %finishelsestart Pd4(area, Disp, Val) %finish %end;! Ed4 !* %externalroutine Edbytes(%integer area, Disp, len, ad) !*********************************************************************** !* intialise a block of data * !*********************************************************************** %if Report#0 %thenstart printstring("Edbytes ") newline %finish %if ProgFaulty#0 %then %return %if Area=10 %then %monitor;! should not be allocated any more %if len=8 %thenstart Ed4(area,disp,integer(ad)) Ed4(area,disp+4,integer(ad+4)) %return %finish %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish %if area<=10 %thenstart Pdbytes(area, disp, len, ad) %finishelse Pdpattern(area, Disp, 1, len, ad) %end;! Edbytes !* %externalroutine Edpattern(%integer area, Disp, ncopies, len, ad) !*********************************************************************** !* initialise using a 1,2,4 or 8 byte pattern * !*********************************************************************** %integer I %if Report#0 %thenstart printstring("Edpattern ") newline %finish %if ProgFaulty#0 %then %return %if Area>=11 %thenstart Areaprops(Area)=Areaprops(Area)!X'400' Area=Area+256 %finish %if Area<=10 %thenstart %cycle I=1,1,ncopies Pdbytes(Area,Disp,Len,Ad) Disp=Disp+Len %repeat %finishelsestart Pdpattern(area, Disp, ncopies, len, ad) %finish %end;!Edpattern !* %externalroutine Efix(%integer area,disp, tgtarea,tgtdisp) !*********************************************************************** !* relocate area+disp to tgtarea+tgtdisp (all are byte addresses) * !*********************************************************************** Area=Area&X'FFF';! in case 'byte' marker had been set (historic) %if Report#0 %thenstart printstring("Efix ".Areas(Area)." +");write(Disp,1) printstring(" => ".Areas(Tgtarea)." +");write(Tgtdisp,1) newline %finish %if ProgFaulty#0 %then %return %if 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=integer(Addrglaca) %if ProgFaulty#0 %then %result=Refad integer(Addrglaca)=Refad+16 I=PXname(0,Xref,Refad) %result=Refad %end;! EXname !* %externalroutine Eprecall(%integer Id) !*********************************************************************** !* called prior to planting parameters to a procedure call * !*********************************************************************** %if Report#0 %thenstart printstring("Eprecall ") newline %finish Next Param Offset=64 %end;! Eprecall !* %externalroutine Ecall(%integer Id,Numpars,Paramsize) !*********************************************************************** !* call the procedure defined by Id * !*********************************************************************** %if Report#0 %thenstart printstring("Ecall "); write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return Freeregs Pd4(GLA,Id+12,(Numpars<<16)!Paramsize);! for loader check PIX RS(STM, R4, R14, R11, 16) PIX RS(LM, R12, R14, R13, id) PIX RR(BASR, R15, R14) Pusing(R15) UsingR15 = 1 %end;! Ecall !* %externalroutine Eprocref(%integer Id, Level) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Eprocref ");write(Id,4) newline %finish %end;! Eprocref !* %externalroutine Esave(%integer Asave, %integername Key) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Esave ");write(Asave,4) newline %finish %end;! Esave !* %externalroutine Erestore(%integer Asave, Key, Existing) !*********************************************************************** !* obtain a pointer to a procedure for use as a parameter * !*********************************************************************** %if Report#0 %thenstart printstring("Erestore ");write(Asave,4) newline %finish %end;! Erestore !* !* !* !* ********************************** !* * Procedure definition and entry * !* ********************************** !* !* %externalintegerfn Enextproc !*********************************************************************** !* result is an Id to be used for a procedure first encountered as an * !* internal spec * !*********************************************************************** %if Report#0 %thenstart printstring("Enextproc ") newline %finish %result=0 %end;! Enextproc !* %externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize, Astacklen, %integername Id) !*********************************************************************** !* define the start of a procedure body * !* if Id > 0 this is the Id returned by a previous call of Enextproc * !* Astacklen is the address of the word noting the current local * !* stack-frame size * !*********************************************************************** %if Report#0 %thenstart printstring("Eproc ");printstring(Name) write(Numpars,4); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return ProcProps=Props %if Props&2#0 %then Props=X'80000001' %else Props=Props&1 Pproc(Name,Props,Numpars<<16!Paramsize,Id) Curdiagca=-1 Max4k=0 %end;! Eproc !* %externalroutine Eprocend(%integer Localsize,Diagdisp,Astacklen) !*********************************************************************** !* called at procedure end * !* Localsize is the total stack-frame requirement (excluding red tape) * !* Astacklen is the address of the word noting the current local * !* stack-frame size of th enclosing procedure * !*********************************************************************** %if Report#0 %thenstart printstring("Eprocend ");write(Localsize,6) newline %finish %if ProgFaulty#0 %then %return PMinMultiples(Max4k>>12) Pprocend %end;! Eprocend !* %externalroutine Eentry(%integer Index,Numpars,Paramsize, Localsize,Diagdisp,%stringname Name) !*********************************************************************** !* defines a side entry within the current procedure (used by Fortran) * !* Localsize is the total stack-frame requirement (excluding red tape) * !*********************************************************************** %if Report#0 %thenstart printstring("Eentry ".Name);write(Index,4) write(Numpars,4);write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return PIX RX(ST,R15,0,R11,60) PIX RR(LR,R10,R11) PIX RX(LA,11,0,11,64+Localsize) PIX RS(LM,8,9,R13,Glaf77regs) %if ProcProps&2#0 %thenstart;! main entry PIX RX(LA,R1,0,0,8) PIX RS(SLL,R1,0,0,24) PIX RR(SPM,R1,0) %finish PIX SI(MVI,Diagdisp>>8,R10,0) PIX SI(MVI,(Diagdisp&X'FF'),R10,1) %end;! Eentry !* !* !* !* ********************************* !* * Data definition and reference * !* ********************************* !* !* %externalroutine Edataentry(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* defines a data entry Name starting at Offset in Area * !*********************************************************************** %if Report#0 %thenstart printstring("Edataentry ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish %end;! Edataentry !* %externalroutine Edataref(%integer Area,Offset,Length,%stringname Name) !*********************************************************************** !* requests a data ref to Name (with at least Length)at Offset in Area * !*********************************************************************** %if Report#0 %thenstart printstring("Edataref ".Name);write(Area,4) write(Offset,4);write(Length,4) newline %finish %end;! Edataref !* !* !* !* ******************** !* * Ecode operations * !* ******************** !* !* %externalroutine Eop(%integer Opcode) !*********************************************************************** !* opcodes with general applicability * !*********************************************************************** %integer Reg1,Freg1,Bytes,B1,D1,XAop,Form %switch Op(0:255) %if Report#0 %thenstart printstring("Eop ".Eopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 !* ->Op(Opcode) !* Op(*):%monitor !* Op(HALT): Unsupported Opcode(Opcode) %return !* Op(IADD): Op(ISUB): Op(IMULT): Op(IDIV): !* Op(IAND): Op(IOR): Op(IXOR): !* Op(IGT): Op(ILT): Op(IEQ): Op(INE): Op(IGE): Op(ILE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2)) %return !* Op(INEG): Op(IABS): Op(INOT): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Int Unary Op(Opcode,Stk(Elevel+1)) %return !* Op(IREM): !* Op(ISHLL): !* Op(ISHRL): !* Op(ISHLA): !* Op(ISHRA): Unsupported Opcode(Opcode) %return !* Op(RETURN): PIX RS(LM,R4,R15,R10,16) PIX RR(BCR,15,R15) %return !* Op(SFA): !* Op(ASF): !* Op(IPUSH): !* Op(IPOP): Unsupported Opcode(Opcode) %return !* Op(EXCH): Epromote(2) %return !* Op(DUPL): Stk(Elevel+1)=Stk(Elevel) Elevel=Elevel+1 Form=Stk(Elevel)_Form&31 %if Form=RegVal %or Form=RegAddr %thenstart Reg1=Claimr(Stk(Elevel)_Reg) PIX RR(LR,Reg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Reg1 Ruse(Reg1)=-Elevel %finishelsestart %if Form=FregVal %thenstart Freg1=Claimfr(Stk(Elevel)_Reg) %if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR PIX RR(XAop,Freg1,Stk(Elevel)_Reg) Stk(Elevel)_Reg=Freg1 Fruse(Freg1)=-Elevel %finishelsestart %if Form=TempVal %then Stk(Elevel)_Form=DirVal %finish %finish %return !* Op(DISCARD): %if Elevel<1 %then Low Estack(Opcode,1) %and %return %if Stk(Elevel)_Form&31=RegVal %thenstart Ruse(Stk(Elevel)_Reg)=0 %finishelsestart %if Stk(Elevel)_Form&31=Fregval %then Fruse(Stk(Elevel)_Reg)=0 %finish Elevel=Elevel-1 %return !* Op(INDEX1): !* Op(INDEX2): !* Op(INDEX4): !* Op(INDEX8): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 Note Index(Opcode-INDEX1,Stk(Elevel),Stk(Elevel+1)) %return !* Op(INDEX): !* Op(MVB): !* Op(CHK): !* Op(TMASK): !* Op(CPBGT): !* Op(CPBLT): !* Op(CPBEQ): !* Op(CPBNE): !* Op(CPBGE): !* Op(CPBLE): Unsupported Opcode(Opcode) %return !* Op(RADD): Op(RSUB): Op(RMULT): Op(RDIV): !* Op(RGT): Op(RLT): Op(REQ): Op(RNE): Op(RGE): Op(RLE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Real Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2)) %return !* Op(RNEG): Op(RABS): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Real Unary Op(Opcode,Stk(Elevel+1)) %return !* Op(CVTII): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval) %return !* Op(CVTRR): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Convert RR(Stk(Elevel+1),Stk(Elevel+2)_Intval) %return !* Op(TNCRI): Op(RNDRI): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI) %return !* Op(CVTIR): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval) %return !* Op(UCHECK): %if Stk(Elevel)_Form=DirVal %thenstart Set BD(Stk(Elevel),B1,D1) %finishelsestart Reg1=Claimr(-1) Op RX(LA,Reg1,Stk(Elevel)) Stk(Elevel)_Form=IndRegVal!Regflag Stk(Elevel)_Reg=Reg1 Ruse(Reg1)=-Elevel B1=Reg1 D1=0 %finish PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32) Pjump(BC,Unasslab,8,R14) %return !* Op(ESTORE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),0) %return !* Op(EDUPSTORE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),1) Stackr(Reg1) %return !* Op(PUSHVAL): !* Op(PUSHADDR): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Push Param(Opcode-PUSHVAL,Stk(Elevel+1)) %return !* Op(EVAL): !* Op(EVALADDR): %return !* Op(EADDRESS): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Address(Stk(Elevel)) Stk(Elevel)_Size=4 %return !* Op(EPOWER): !* Op(EPOWERI): %if Elevel<3 %then Low Estack(Opcode,3) %and %return %if Stk(Elevel)_Form#Litval %then Abort Elevel=Elevel-1 Expcall(Stk(Elevel+1)_Intval) %return !* Op(EINTRES): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Int(Stk(Elevel+1),R1,-1) %return !* Op(EREALRES): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Reg1=Load Real(Stk(Elevel+1),R0,-1,Bytes) %return !* Op(ESIZE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 Stk(Elevel)_Size=Stk(Elevel+1)_Intval %return !* Op(ARGPROC): Unsupported Opcode(Opcode) %return !* Op(PUSHBYTES): Unsupported Opcode(Opcode) %return %end;! Eop !* %externalroutine Ef77op(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Fortran * !*********************************************************************** %integer Reg1,Reg2,Freg1,Freg2,XAop1,XAop2,XAop3,XAop4,XAop5,Bytes,Relop %integer B1,D1,Flags %switch F77op(256:320) %if Report#0 %thenstart printstring("Ef77op ".Ef77opname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1 !* ->F77op(Opcode) !* F77op(*):Abort !* F77op(CXADD): !* F77op(CXSUB): !* F77op(CXMULT): !* F77op(CXDIV): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-4 Opcode=Opcode&X'FF' Flags=Stk(Elevel+4)_Intval Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3)) %return !* F77op(CXNEG): !* F77op(CXASGN): !* F77op(CXEQ): !* F77op(CXNE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Opcode=Opcode&X'FF' Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(EM1EXP): Unsupported Opcode(Opcode) %return !* F77op(EISIGN): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) PIX RR(LPR,Reg1,Reg1) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) PIX RR(BASR,R14,0) PIX RR(LTR,Reg2,Reg2) PIX RX(BC,10,0,R14,8) PIX RR(LNR,Reg1,Reg1) Stackr(Reg1) %return !* F77op(ESIGN): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %thenstart XAop1=LPER XAop2=LNER XAop3=LTER %finishelsestart XAop1=LPDR XAop2=LNDR XAop3=LTDR %finish PIX RR(XAop1,Reg1,Reg1) Reg2=Load Real(Stk(Elevel+2),-1,-1,Bytes) PIX RR(BASR,R14,0) PIX RR(XAop3,Reg2,Reg2) PIX RX(BC,10,0,R14,8) PIX RR(XAop2,Reg1,Reg1) Stackfr(Reg1,Bytes) %return !* F77op(EIMOD): Elevel=Elevel-2 %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15) OpRX(L,R15,Stk(Elevel+2)) Reg1=Claimr(R1) OpRX(L,R0,Stk(Elevel+1)) PIX RR(LR,Reg1,R0) PIX RX(SRDA,0,0,0,32) PIX RR(DR,R0,R15) PIX RR(MR,R0,R15) PIX RR(SR,Reg1,R1) Stackr(Reg1) %return !* F77op(ERMOD): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %thenstart XAop1=LER XAop2=ME XAop3=DE XAop4=SER XAop5=STE %finishelsestart XAop1=LDR XAop2=MD XAop3=DD XAop4=SDR XAop5=STD %finish Reg2=Load Real(Stk(Elevel+2),-1,-1,Bytes) PIX RX(XAop5,Reg2,0,R11,0);! STE PIX RR(XAop1,Reg2,Reg1);! LER PIX RX(XAop3,Reg2,0,R11,0);! DE Stackfr(Reg2,Bytes) Elevel=Elevel-1 Convert RI(Stk(Elevel+1),4,0);! Truncate Elevel=Elevel-1 Lastfreg=Reg1;! to ensure it is not used Convert IR(Stk(Elevel+1),Bytes) Elevel=Elevel-1 Reg2=Load Real(Stk(Elevel+1),-1,-1,Bytes) PIX RX(XAop2,Reg2,0,R11,0);! ME PIX RR(XAop4,Reg1,Reg2);! SER Stackfr(Reg1,Bytes) %return !* F77op(EIDIM): Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) OpRX(S,Reg1,Stk(Elevel+2)) PIX RR(LTR,Reg1,Reg1) PIX RR(BASR,R14,0) PIX RX(BC,10,0,R14,6) PIX RR(SR,Reg1,Reg1) Stackr(Reg1) %return !* F77op(ERDIM): Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %thenstart XAop1=SE XAop2=LTER XAop3=SER %finishelsestart XAop1=SDR XAop2=LTDR XAop3=SDR %finish OpRX(XAop1,Reg1,Stk(Elevel+2)) PIX RR(XAop2,Reg1,Reg1) PIX RR(BASR,R14,0) PIX RX(BC,10,0,R14,6) PIX RR(XAop3,Reg1,Reg1) Stackfr(Reg1,Bytes) %return !* F77op(EIMIN): Relop=12 Iminmax: Elevel=Elevel-2 Reg1=Load Int(Stk(Elevel+1),-1,0) Reg2=Load Int(Stk(Elevel+2),-1,Reg1) PIX RR(CR,Reg1,Reg2) PIX RR(BASR,R14,0) PIX RX(BC,Relop,0,14,6) PIX RR(LR,Reg1,Reg2) Stackr(Reg1) %return !* F77op(ERMIN): Relop=12 Rminmax: Elevel=Elevel-2 Reg1=Load Real(Stk(Elevel+1),-1,-1,Bytes) %if Bytes=4 %thenstart XAop1=CER XAop2=LER %finishelsestart XAop1=CDR XAop2=LDR %finish Reg2=Load Real(Stk(Elevel+2),-1,Reg1,Bytes) PIX RR(XAop1,Reg1,Reg2) PIX RR(BASR,R14,0) PIX RX(BC,Relop,0,14,6) PIX RR(XAop2,Reg1,Reg2) Stackfr(Reg1,Bytes) %return !* F77op(EIMAX): Relop=10 ->Iminmax !* F77op(ERMAX): Relop=10 ->Rminmax !* F77op(EDMULT): !* F77op(ECONJG): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Opcode=9 Flags=Stk(Elevel+3)_Intval ->Cxop !* F77op(ECHAR): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 %if Stk(Elevel+2)_Form=LitVal %thenstart Set BD(Stk(Elevel+1),B1,D1) PIX SI(MVI,Stk(Elevel+2)_Intval&X'FF',B1,D1) %finishelsestart Reg1=Load Int(Stk(Elevel+2),-1,-1) Op RX(STC,Reg1,Stk(Elevel+1)) %finish %return !* F77op(EICHAR): %if Elevel<1 %then Low Estack(Opcode,1) %and %return %if Stk(Elevel)_Form =LitVal %thenstart Stk(Elevel)_Size=4 %return %finish Elevel=Elevel-1 Reg1=Claimr(-1) PIX RR(SR,Reg1,Reg1) Op RX(IC,Reg1,Stk(Elevel+1)) Stackr(Reg1) %return !* F77op(EINDEXCHAR): %if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3)) %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1)) {for Unix compatibility call requires A1,A2,L1,L2} {Epromote(3)} {Epromote(2)} {but for Amdahl we must have L1,A1,L2,A2} Epromote(4) Epromote(2) Epromote(3) Spcall(6) Stackr(R1) %return !* F77op(ECONCAT): Spcall(7) %return %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(ECMPLX2): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-4 Flags=Stk(Elevel+4)_Intval %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) Freg2=Load Real(Stk(Elevel+3),-1,-1,Bytes) PIX RX(XAop1,Freg2,0,Reg1,Bytes) %return !* F77op(EISHFT): !* F77op(EIBITS): !* F77op(EIBSET): !* F77op(EIBTEST): !* F77op(EIBCLR): !* F77op(EISHFTC): Unsupported Opcode(Opcode) %return !* F77op(PROCARG): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 D1=Stk(Elevel+1)_Intval Pd4(GLA,D1+12,-1) Do RX(LA,R0,R13,D1) PIX RX(ST,R0,0,R11,Next Param Offset) Next Param Offset=Next Param Offset+4 %return !* F77op(IPROCARG): !* F77op(CHARARG): %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1)) Estklit(X'20000');! Amdahl string type Eop(IADD) Eop(PUSHVAL) Eop(PUSHVAL) %return !* F77op(IPROCCALL): Unsupported Opcode(Opcode) %return !* F77op(ARGPROCCALL): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Op RX(L,R1,Stk(Elevel+1)) PIX RS(STM,R4,R14,R11,16) PIX RS(LM,R12,R14,R1,0) PIX RR(BASR,R15,R14) %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 be in regs} %unless Stk(Elevel-1)_Form&31=Regval %and %c Stk(Elevel)_Form&31=Regval %then Abort Reg2=Stk(Elevel-1)_Reg Reg1=Stk(Elevel)_Reg PIX RR(LR,R15,Reg1) %if Reg2#R2 %thenstart PIX RR(LR,R2,Reg2) Stk(Elevel-1)_Reg=R2 %finish %if Reg1#R1 %thenstart;! tidy this up too PIX RR(LR,R1,R15) Stk(Elevel)_Reg=R1 %finish Ruse(Reg1)=0 Ruse(Reg2)=0 Ruse(R1)=-Elevel Ruse(R2)=-Elevel+1 Reg1=R1 Reg2=R2;! leaving things in a state we understand OpRX(M,R0,Stk(Elevel+1)) PIX RR(AR,R2,R1) PIX RR(LR,R1,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 %end;! Ef77op !* %externalroutine Epasop(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Pascal * !*********************************************************************** %switch pasop(512:541) %if Report#0 %thenstart printstring("Epasop ".Epasopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return !* ->pasop(Opcode) !* pasop(STRLT):pasop(STRLE):pasop(STRNE):pasop(STREQ): Unsupported Opcode(Opcode) %return !* pasop(PTREQ):pasop(PTRNE): Unsupported Opcode(Opcode) %return !* pasop(SETI):pasop(SETU):pasop(SETD):pasop(SETSUB): pasop(SETEQ):pasop(SETNE):pasop(SETIN):pasop(SETSING):pasop(SETRANGE): Unsupported Opcode(Opcode) %return !* pasop(INDEXCAP):pasop(LOADCAP): Unsupported Opcode(Opcode) %return !* pasop(*): %monitor %end;! Epasop !* %externalroutine Eccop(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by C * !*********************************************************************** %monitor %end;! Eccop !* %routine Expcall(%integer Proc) !*********************************************************************** !* call an exponentiation routine * !*********************************************************************** %integer I,J,T %string(31) S T=Expproctype(Proc) J=Expprocref(Proc) %if J=0 %thenstart S=Expprocs(Proc) J=Exname(T,S) Expprocref(Proc)=J %finish Eprecall(J) I=Expprocpdesc(Proc)>>16 %while I>0 %cycle Epromote(I) Eop(PUSHVAL) I=I-1 %repeat I=Expprocpdesc(Proc) Freeregs Ecall(J,I>>16,I&X'FF') %if T&7#0 %thenstart;! function Estkresult(0,T&7,(T>>8)&255) %finish %end;! Expcall !* %routine Spcall(%integer Proc) !*********************************************************************** !* call a support procedure * !*********************************************************************** %integer I,J,T %string(31) S T=Spproctype(Proc) J=Spprocref(Proc) %if J=0 %thenstart S=Spprocs(Proc) J=Exname(T,S) Spprocref(Proc)=J %finish Eprecall(J) I=Spprocpdesc(Proc)>>16 %while I>0 %cycle Epromote(I) Eop(PUSHVAL) I=I-1 %repeat I=Spprocpdesc(Proc) Freeregs Ecall(J,I>>16,I&X'FF') %if T&7#0 %thenstart;! function Estkresult(0,T&7,(T>>8)&255) %finish %end;! Spcall !* !* !* !* !*********************************************************************** !*********************************************************************** !** Code generation support procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine Refer(%record(Stkfmt)%name Stk,%integer Offset) %integer Reg %switch F(0:21) ->F(Stk_Form&31);! removing the reg marker bit !* F(RegVal): { (reg) } %if Offset#0 %thenstart Stk_Form=IndRegModVal!Regflag Setoff: Stk_Modform=Litval Stk_Modintval=Offset Stk_Scale=0 %return %finish Stk_Form=IndRegVal!Regflag Ruse(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) ->F(RegVal) !* F(AddrConst): { @const } Stk_Form=ConstVal Stk_Offset=Stk_Offset+Offset %return !* F(AddrDir): { @dir } Stk_Form=DirVal Stk_Offset=Stk_Offset+Offset %return !* F(RegAddr): { (reg) is @ } ->F(RegVal) !* F(TempAddr): { (temp) is @} %if Offset#0 %thenstart Stk_Form=IndTempModVal ->Setoff %finish Stk_Form=IndTempVal %return !* F(DirAddr): { (dir) is @ } %if Offset#0 %thenstart Stk_Form=IndDirModVal ->Setoff %finish Stk_Form=IndDirVal %return !* F(RegModAddr): { (reg)+M } %if Offset=0 %thenstart Stk_Form=IndRegModVal!Regflag %return %finish ->Loadr !* F(TempModAddr): { (temp)+M } %if Offset=0 %thenstart Stk_Form=IndTempModVal %return %finish ->Loadr !* F(DirModAddr): { (dir)+M } %if Offset=0 %thenstart Stk_Form=InddirModVal %return %finish ->Loadr !* F(LitVal): { lit } F(ConstVal): { const } F(FregVal): { (freg) } printstring(" Invalid attempt to Refer ") Abort !* %end;! Refer !* %routine Address(%record(Stkfmt)%name Stk) %integer I,J,Reg,Op %switch F(0:21) ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } Setint(Stk_Intval,Stk_Size,I,J) Stk_Base=Cnst Stk_Offset=J F(ConstVal): { const } Stk_Form=AddrConst Size: Stk_Size=4 %return !* F(RegVal): { (reg) } I=New Temp(4) Op=ST Store:Do RX(Op,Stk_Reg,R10,I) Stk_Base=0 Stk_Offset=I Stk_Form=AddrDir ->Size !* F(FregVal): { (freg) } I=New Temp(Stk_Size) %if Stk_Size=4 %then Op=STE %else Op=STD ->Store !* F(TempVal): { (temp) } Stk_Form=AddrDir %return !* F(DirVal): { (dir) } Stk_Form=AddrDir %return !* F(IndRegVal): { ((reg)) } Stk_Form=RegAddr!Regflag %return !* F(IndTempVal): { ((temp)) } Stk_Form=TempAddr %return !* F(IndDirVal): { ((dir)) } Stk_Form=DirAddr %return !* F(AddrDirModVal): { (dir+M) } Stk_Form=AddrDirMod!(Stk_Form&Regflag) %return !* F(IndRegModVal): { ((reg)+M) } Stk_Form=RegModAddr!Regflag %return !* F(IndTempModVal): { ((temp)+M) } Stk_Form=TempModAddr!(Stk_Form&Regflag) %return !* F(IndDirModVal): { ((dir)+M) } Stk_Form=DirModAddr!(Stk_Form&Regflag) %return !* F(AddrConst): { @const } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @ } F(DirAddr): { (dir) is @ } F(AddrDir): { @dir } F(AddrDirMod): { @dir+M } F(RegModAddr): { (reg)+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } printstring(" Invalid attempt to Address ") Abort !* %end;! Address !* %integerfn Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg) !*********************************************************************** !* Stk describes an integer value (1,2 or 4 bytes) * !* if Reg is >= 0 then this register must be loaded * !* result is the general register to which the value has been loaded * !*********************************************************************** %integer Bytes %constbyteintegerarray Lop(0:4)=0,IC,LH,0,L Bytes=Stk_Size %unless 0= 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=LD %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 Stackr(%integer R) !*********************************************************************** !* create an Estack entry for a value held in a general register * !*********************************************************************** Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=RegVal!Regflag Stk(Elevel)_Reg=R Stk(Elevel)_Size=4 Ruse(R)=-Elevel %end;! Stackr !* %routine Stackfr(%integer FR,Bytes) !*********************************************************************** !* create an Estack entry for a value held in a floating register * !*********************************************************************** Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=FregVal!Regflag Stk(Elevel)_Reg=FR Stk(Elevel)_Size=Bytes Fruse(FR)=-Elevel %end;! Stackfr !* %routine Establish Logical !*********************************************************************** !* called when a condition code has been set and required result is a * !* logical value (0 or 1) * !*********************************************************************** %integer Reg1 CCset=0 PIX RR(BASR, R14, 0) Pusing(R14) UsingR14=1 Reg1=Claimr(0) PIX RR(SLR, Reg1, Reg1) PIX RX(BC, CC, 0, R14, 10) PIX RX(LA, Reg1, 0, 0, 1) Stackr(Reg1);! stack integer result in Reg1 %end;! Establish Logical !* %routine Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) !*********************************************************************** !* supports IADD,ISUB,IMULT,IDIV,IGT,ILT,IEQ,INE,IGE,ILE,IAND,IOR,IXOR * !* descriptor to result on Estack * !*********************************************************************** %constbyteintegerarray RRop(0:IXOR) = 0, AR,SR,MR,DR,0,0,0,NR,OR,0,XR %constbyteintegerarray RXop(0:IXOR) = 0, A,S,M,D,0,0,0,N,O,0,X %constintegerarray Shiftval(0:8)=-1,0,1,-1,2,-1,-1,-1,3 %integer Lform,Rform,Lreg,Rreg,Shift %switch Opcode(0:ILE) Lform=LHS_Form&31 Rform=RHS_Form&31 Lreg=LHS_Reg Rreg=RHS_Reg ->Opcode(Op) !* Opcode(IADD): Opcode(IAND): Opcode(IOR): Opcode(IXOR): %if Lform=RegVal %thenstart %if Rform=RegVal %thenstart PIX RR(RRop(Op),Lreg,Rreg) Ruse(Rreg)=0 %finishelse OpRX(RXop(op),Lreg,RHS) Stackr(Lreg) %finishelsestart %if Rform#RegVal %thenstart Rreg=Claimr(0) %if Lform=Litval %thenstart OpRX(L,Rreg,LHS) OpRX(RXop(Op),Rreg,RHS) Stackr(Rreg) %return %finish OpRX(L,Rreg,RHS) %finish OpRX(RXop(Op),Rreg,LHS) Stackr(Rreg) %finish %return !* Opcode(ISUB): %if Lform=RegVal %thenstart %if Rform=RegVal %thenstart PIX RR(SR,Lreg,Rreg) Ruse(Rreg)=0 %finishelse OpRX(S,Lreg,RHS) %finishelsestart %if Rform=RegVal %thenstart Lreg=Claimr(Rreg) OpRX(L,Lreg,LHS) PIX RR(SR,Lreg,Rreg) Ruse(Rreg)=0 %finishelsestart Lreg=Claimr(0) Op RX(L,Lreg,LHS) Op RX(S,Lreg,RHS) %finish %finish Stackr(Lreg) %return !* Opcode(IGT): Opcode(ILT): Opcode(IEQ): Opcode(INE): Opcode(IGE): Opcode(ILE): CC=Setcc(Op-IGT) %if Lform=RegVal %thenstart %if Rform=RegVal %thenstart PIX RR(CR,Lreg,Rreg) Ruse(Rreg)=0 %finishelse OpRX(C,Lreg,RHS) Ruse(Lreg)=0 %finishelsestart %if Rform=RegVal %thenstart CC=Invcc(CC) OpRX(C,Rreg,LHS) %finishelsestart Rreg=Claimr(0) OpRX(L,Rreg,LHS) OpRX(C,Rreg,RHS) %finish Ruse(Rreg)=0 %finish CCset=1 %return !* Opcode(IMULT): %if Lform=LitVal %thenstart %if 0<=LHS_Intval<=8 %thenstart Shift=Shiftval(LHS_Intval) %if Shift=0 %thenstart Elevel=Elevel+1 Stk(Elevel)=RHS %return %finish %if Shift>0 %thenstart Rreg=Load Int(RHS,-1,-1) PIX RX(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 RX(SLA,Rreg,0,0,Shift) Stackr(Rreg) %return %finish %finish %finish !* %if Lform=RegVal %thenstart %if Lreg#R1 %thenstart %unless Lreg=R3 %and Ruse(R2)=0 %thenstart %if Ruse(R1)#0 %thenstart %if Rform=RegVal %and Rreg=R1 %thenstart PIX RR(MR,R0,Lreg) Ruse(Lreg)=0 Stackr(R1) %return %finish Freeup Reg(R1) %finish PIX RR(LR,R1,Lreg) Ruse(Lreg)=0 Lreg=R1 %finish %finish %if Rform=RegVal %thenstart PIX RR(MR,Lreg-1,Rreg) Ruse(Rreg)=0 %finishelse OpRX(M,Lreg-1,RHS) %finishelsestart %if Rform=RegVal %thenstart Lreg=R1 %if Rreg#R1 %thenstart %if Rreg=R3 %thenstart %if Ruse(R2)#0 %then Freeup Reg(R2) Lreg=R3 %finishelsestart %if Ruse(R1)#0 %then Freeup Reg(R1) PIX RR(LR,R1,Rreg) Ruse(Rreg)=0 %finish %finish %finishelsestart %if Ruse(R1)=0 %thenstart Lreg=R1 %finishelsestart %if Ruse(R2)=0 %and Ruse(R3)=0 %thenstart Lreg=R3 %finishelsestart Freeup Reg(R1) Lreg=R1 %finish %finish %if Lform=LitVal %thenstart OpRX(L,Lreg,LHS) OpRX(M,Lreg-1,RHS) Stackr(Lreg) %return %finish OpRX(L,Lreg,RHS) %finish OpRX(M,Lreg-1,LHS) %finish Stackr(Lreg) %return !* Opcode(IDIV): %if Lform=RegVal %thenstart %if Lreg#R1 %thenstart %if Ruse(R1)#0 %thenstart %if Rform=RegVal %and Rreg=R1 %thenstart %if UsingR14#0 %then Pdrop(R14) %and UsingR14=0 PIX RR(LR,R14,R1) PIX RR(LR,R0,Lreg) PIX RX(SRDA,R0,0,0,32) PIX RR(DR,R0,R14) Ruse(Lreg)=0 Stackr(R1) %return %finish Freeup Reg(R1) %finish PIX RR(LR,R0,Lreg) Ruse(Lreg)=0 %finishelse PIX RR(LR,R0,R1) PIX RX(SRDA,0,0,0,32) %if Rform=RegVal %thenstart PIX RR(DR,R0,Rreg) Ruse(Rreg)=0 %finishelsestart OpRX(D,R0,RHS) %finish %finishelsestart %if Rform=RegVal %thenstart %if Rreg#R1 %thenstart %if Ruse(R1)#0 %then Freeup Reg(R1) Ruse(Rreg)=0 %finishelsestart %if UsingR14#0 %then Pdrop(R14) %and UsingR14=0 PIX RR(LR,R14,R1) Rreg=14 %finish OpRX(L,R0,LHS) PIX RX(SRDA,0,0,0,32) PIX RR(DR,R0,Rreg) %finishelsestart %if Ruse(R1)#0 %then Freeup Reg(R1) OpRX(L,R0,LHS) PIX RX(SRDA,0,0,0,32) OpRX(D,R0,RHS) %finish %finish Stackr(R1) %return %end;! Int Binary Op !* %routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports INEG,IABS * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,XAop Reg1=Load Int(RHS,-1,0) %if Op=INEG %then XAop=LCR %elsestart %if Op=INOT %thenstart PIX RX(LA,0,0,0,1) PIX RR(NR,Reg1,0) PIX RR(XR,Reg1,0) Stackr(Reg1) %return %finish %if Op=IABS %then XAop=LPR %else Abort %finish PIX RR(XAop,Reg1,Reg1) Stackr(Reg1) %end;! Int Unary Op !* %routine Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS) !*********************************************************************** !* supports RADD,RSUB,RMULT,RDIV,RGT,RLT,REQ,RNE,RGE,RLE * !* descriptor to result on Estack * !*********************************************************************** %constbyteintegerarray RReop(RADD:RDIV) = AER,SER,MER,DER %constbyteintegerarray RXeop(RADD:RDIV) = AE,SE,ME,DE %constbyteintegerarray RRdop(RADD:RDIV) = ADR,SDR,MDR,DDR %constbyteintegerarray RXdop(RADD:RDIV) = AD,SD,MD,DD %constbyteintegerarray RRxop(RADD:RDIV) = AXR,SXR,MXR,0 %integer Lform,Rform,Lreg,Rreg,Bytes,XARop,XAXop,Loadop %switch Opcode(RADD:RLE) Lform=LHS_Form&31 Rform=RHS_Form&31 Lreg=LHS_Reg Rreg=RHS_Reg Bytes=LHS_Size %if RADD<=Op<=RDIV %thenstart %if Bytes=4 %thenstart XARop=RReop(Op) XAXop=RXeop(Op) Loadop=LE %finishelsestart %if Bytes=8 %thenstart XARop=RRdop(Op) XAXop=RXdop(Op) %finishelsestart XARop=RRxop(Op) %finish Loadop=LD %finish %finishelsestart;! comparison %if Bytes=4 %thenstart XARop=CER XAXop=CE Loadop=LE %finishelsestart XARop=CDR XAXop=CD Loadop=LD %finish %finish ->Opcode(Op) !* Opcode(RADD): !* Opcode(RMULT): %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) Stackfr(Lreg,Bytes) %finishelsestart %if Rform#FregVal %thenstart Rreg=Claimfr(-1) OpRX(Loadop,Rreg,RHS) %finish OpRX(XAXop,Rreg,LHS) Stackfr(Rreg,Bytes) %finish %return !* Opcode(RSUB): !* Opcode(RDIV): %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) %finishelsestart %if Rform=FregVal %thenstart Lreg=Claimfr(Rreg) Op RX(Loadop,Lreg,LHS) PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelsestart Lreg=Claimfr(-1) Op RX(Loadop,Lreg,LHS) Op RX(XAXop,Lreg,RHS) %finish %finish Stackfr(Lreg,Bytes) %return !* Opcode(RGT): Opcode(RLT): Opcode(REQ): Opcode(RNE): Opcode(RGE): Opcode(RLE): CC=Setcc(Op-RGT) %if Lform=FregVal %thenstart %if Rform=FregVal %thenstart PIX RR(XARop,Lreg,Rreg) Fruse(Rreg)=0 %finishelse OpRX(XAXop,Lreg,RHS) Fruse(Lreg)=0 %finishelsestart %if Rform=FregVal %thenstart CC=Invcc(CC) OpRX(XAXop,Rreg,LHS) %finishelsestart Rreg=Claimfr(-1) OpRX(Loadop,Rreg,LHS) OpRX(XAXop,Rreg,RHS) %finish Fruse(Rreg)=0 %finish CCset=1 %return %end;! Real Binary Op !* %routine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports RNEG,RABS * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,XAop,Bytes Reg1=Load Real(RHS,-1,-1,Bytes) %if Op=RNEG %thenstart %if Bytes=4 %then XAop=LCER %else XAop=LCDR %finishelsestart %if Op=RABS %thenstart %if Bytes=4 %then XAop=LPER %else XAop=LPDR %finishelse Abort %finish PIX RR(XAop,Reg1,Reg1) Stackfr(Reg1,Bytes) %end;! Real Binary Op !* %routine Convert II(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between integer sizes * !* descriptor to result on Estack * !*********************************************************************** %integer Reg Reg=Load Int(Stk,-1,-1) Stackr(Reg) %end;! Convert II !* %routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between real sizes * !* descriptor to result on Estack * !*********************************************************************** %integer Freg1,Bytes,Oldsize %switch Sw(0:10) Oldsize=Stk_Size ->Sw(((Oldsize&24)>>1)!(Newsize>>3)) !* Sw(1):! CVTRD Freg1=Load Real Extended(Stk,8) Bytes=8 Note: Stackfr(Freg1,Bytes) %return !* Sw(4):! CVTDR Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRER,Freg1,Freg1) Bytes=4 ->Note !* Sw(2):! CVTRQ !* Sw(6):! CVTDQ Freg1=Load Real Extended(Stk,16) Bytes=16 ->Note !* Sw(8):! CVTQR Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRDR,Freg1,Freg1) PIX RR(LRER,Freg1,Freg1) Bytes=4 ->Note !* Sw(9):! CVTQD Freg1=Load Real(Stk,-1,-1,Bytes) PIX RR(LRDR,Freg1,Freg1) Bytes=8 ->Note !* Sw(*): Freg1=Load Real(Stk,-1,-1,Bytes) ->Note %end;! Convert RR !* %routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode) !*********************************************************************** !* converts between real and integer * !* Mode = 0 TNC * !* 1 RND * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1,Bytes Freg1=Load Real(Stk,-1,-1,Bytes) Reg1=Claimr(-1) %if Mode=1 %thenstart PIX RR(BASR,14,0) Pusing(R14) Using R14=1 %if Bytes=4 %thenstart PIX RR(LTER,Freg1,Freg1) PIX RX(BC,10,0,R14,14) PIX RX(SE,Freg1,0,R9,RHALF) PIX RX(BC,15,0,R14,18) PIX RX(AE,Freg1,0,R9,RHALF) %finishelsestart PIX RR(LTDR,Freg1,Freg1) PIX RX(BC,10,0,R14,14) PIX RX(SD,Freg1,0,R9,RHALF) PIX RX(BC,15,0,R14,18) PIX RX(AD,Freg1,0,R9,RHALF) %finish %finish PIX RX(SD,Freg1,0,R9,TWO31R);! X'4F00 0000 0800 0000' PIX RX(AW,Freg1,0,R9,TWO32) ;! X'4E00 0001 0000 0000' PIX RX(STD,Freg1,0,R13,Glawork) PIX SI(XI,X'80',R13,Glawork+4) PIX RX(L,Reg1,0,R13,Glawork+4) Stackr(Reg1) %end;! Convert RI !* %routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** %integer Reg1,Freg1,Bytes %switch Sw(0:2) Reg1=Load Int(Stk,-1,0) ->Sw(Newsize>>3) !* Sw(0):! FLTR Bytes=4 ->Flt !* Sw(1):! FLTD Bytes=8 Flt: Freg1=Claimfr(-1) PIX RX(X,Reg1,0,R9,TWO31+4);! X'8000 0000' PIX RX(ST,Reg1,0,R13,Glawork+4) PIX SS(MVC,0,4,R13,Glawork,R9,TWO31) ;! X'4E00 0000 8000 0000' PIX RX(LD,Freg1,0,R13,Glawork) PIX RX(SD,Freg1,0,R9,TWO31) Stackfr(Freg1,Bytes) %return !* Sw(2):! FLTQ Freg1=Claimfrpair(-1) PIX RR(SDR,Freg1+1,Freg1+1) Bytes=16 ->Flt %end;! Convert IR !* %integerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) !*********************************************************************** !* value defined by RHS is assigned to LHS. If Dup is non-zero then * !* value must be retainedin a reg * !* result is the reg used for retaining the value * !*********************************************************************** %constbyteintegerarray Ad(0:21)=0(9),1(9),0(4) %integer Bytes,Op,Reg,Form,B1,D1,B2,D2 Form=RHS_Form&31 Bytes=RHS_Size LHS_Form=LHS_Form&31;! remove Regflag bit if set %if Ad(LHS_Form)#0 %then Refer(LHS,0) %and LHS_Size=Bytes %if Bytes=4 %thenstart %if Form=RegVal %thenstart Op=ST Streg: Reg=RHS_Reg Ruse(Reg)=0 Pushit: Op RX(Op,Reg,LHS) %result=Reg %finish %if Form=FregVal %thenstart Op=STE Reg=RHS_Reg Fruse(Reg)=0 ->Pushit %finish %if Dup#0 %then Reg=Claimr(-1) %else Reg=0 Op RX(L,Reg,RHS) Op=ST ->Pushit %finishelsestart %unless Bytes=8 %thenstart %if Bytes=2 %and Form=RegVal %thenstart Op=STH ->Streg %finish Set Bd(LHS,B1,D1) Ruse(B1)=-255 Set Bd(RHS,B2,D2) PIX SS(MVC,0,Bytes,B1,D1,B2,D2) Ruse(B1)=0 %result=0 %finish Op=STD %if Form=FregVal %thenstart Reg=RHS_Reg Fruse(Reg)=0 ->Pushit %finish Reg=Claimfr(-1) Op RX(LD,Reg,RHS) ->Pushit %finish %end;! Storeop !* %routine Push Param(%integer Mode,%record(Stkfmt)%name Stk) !*********************************************************************** !* the value or address of Stk is added to the parameter list * !* result is the reg used for retaining the value * !* Mode = 0 push value !* 1 push address !*********************************************************************** %integer Bytes,Op,Reg,Form %if Mode=1 %thenstart Address(Stk) Stk_Size=4 %finish Form=Stk_Form&31 Bytes=Stk_Size ! %if Mode=0 %and Form&ADDRESSED=0 %thenstart %if Bytes=4 %thenstart %if Form=RegVal %thenstart Op=ST Reg=Stk_Reg Ruse(Reg)=0 Pushit: PIX RX(Op,Reg,0,R11,Next Param Offset) Next Param Offset=Next Param Offset+Bytes %return %finish %if Form=FregVal %thenstart Op=STE Reg=Stk_Reg Fruse(Reg)=0 ->Pushit %finish Op RX(L,0,Stk) Op=ST Reg=0 ->Pushit %finishelsestart %unless Bytes=8 %then %monitor %and %stop Op=STD %if Form=FregVal %thenstart Reg=Stk_Reg Fruse(Reg)=0 ->Pushit %finish Reg=Claimfr(-1) Op RX(LD,Reg,Stk) ->Pushit %finish ! %finishelsestart;! address required ! Reg=Load Address(Stk) ! Bytes=4 ! Op=ST ! ->Pushit ! %finish %end;! Push Param !* %integerfn Load address(%record(Stkfmt)%name Stk) !*********************************************************************** !* result is the reg holding the address of the item desribed by Stk * !*********************************************************************** %integer Reg,Form Form=Stk_Form&31 %if FormF(Base_Form&31) !* F(IndRegVal): { ((reg)) } F(IndTempVal): { ((temp)) } F(IndDirVal): { ((dir)) } Base_Form=Base_Form+12 Set: Base_Modreg=Index_Reg Base_Modbase=Index_Base Base_Modform=Index_Form Base_Modoffset=Index_Offset Base_Scale=Scale Form=Base_Modform&31 %if Form=RegVal %or Form=IndRegVal %thenstart Ruse(Base_Modreg)=-Elevel %finish %return !* F(AddrDir): { @dir } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } Base_Form=Base_Form+4 ->Set !* F(AddrDirMod): { @dir+M } F(RegModAddr): { (reg)+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } Reg=Claimr(0) OpRX(L,Reg,Base) Ruse(Reg)=-Elevel Base_Form=RegModAddr ->Set !* F(LitVal): { lit } F(ConstVal): { const } F(RegVal): { (reg) } F(FregVal): { (freg) } F(TempVal): { (temp) } F(DirVal): { (dir) } F(AddrConst): { @const } F(IndRegModVal): { ((reg)+M) } F(IndTempModVal): { ((temp)+M) } F(IndDirModVal): { ((dir)+M) } F(AddrDirModVal): { (@dir+M) } Abort !* %end;! Note Index !* !* !* !*********************************************************************** !*********************************************************************** !** Amdahl-specific procedures ** !*********************************************************************** !*********************************************************************** !* !* %routine Clear Regs !*********************************************************************** !* forget all previous use of registers * !*********************************************************************** %integer I %cycle I=0,1,15 Ruse(I)=0 %repeat %cycle I=0,2,6 Fruse(I)=0 %repeat Lastreg=0 Lastbreg=0 Lastfreg=-1 %end;! Clear Regs !* %routine Dropall !*********************************************************************** !* no dynamic addressing registers can have assumed values * !*********************************************************************** %integer I %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15) %if UsingR14#0 %then UsingR14=0 %and Pdrop(R14) %cycle I=0,1,7 Ruse(I)=0 %repeat %cycle I=0,2,6 Fruse(I)=0 %repeat Lastreg=-1 Lastfreg=-1 %end;! Dropall !* !* %routine Freeup Freg(%integer R) !*********************************************************************** !* store the content of general register R in temp space, modifying * !* Estack entries as necessary * !*********************************************************************** %integer I,J,XAop,Size I=-Fruse(R);! was held as -Elevel %if I<=0 %thenstart Fruse(R)=0 %return %finish %if Elevel>0 %thenstart %cycle I=1,1,Elevel %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 %repeat %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 floating register R in temp space, modifying * !* Estack entries as necessary * !* no dynamic addressing registers can have assumed values * !*********************************************************************** %integer I,J,K I=-Ruse(R);! was held as -Elevel %if I<=0 %thenstart Ruse(R)=0 %return %finish J=New Temp(4) ! %if Elevel>0 %thenstart ! %cycle I=1,1,Elevel %if Stk(I)_Form&31=RegVal %and Stk(I)_Reg=R %thenstart Stk(I)_Form=TempVal Stk(I)_Offset=J Stk(I)_Base=0 Store: Do RX(ST,R,R10,J) Ruse(R)=0 %return %finishelsestart %if Stk(I)_Modform&31=RegVal %and Stk(I)_Modreg=R %thenstart Stk(I)_Modform=TempVal Stk(I)_Modoffset=J Stk(I)_Modbase=0 ->Store %finish %finish ! %repeat ! %cycle I=1,1,Elevel %if Stk(I)_Reg=R %thenstart K=Stk(I)_Form&31 %if K=IndRegVal %or K=RegAddr %or K=RegModAddr %c %or K=IndRegModVal %thenstart Stk(I)_Form=K+1 Stk(I)_Offset=J Stk(I)_Base=0 ->Store %finish %finishelsestart %if Stk(I)_Modform&31=IndRegVal %and Stk(I)_Modreg=R %thenstart Stk(I)_Modform=IndTempVal Stk(I)_Modoffset=J Stk(I)_Modbase=0 ->Store %finish %finish ! %repeat ! %finish printstring("Request to free register");write(R,2);newline Abort %end;! Freeup Reg !* %routine Reset Reguse(%integer Old,New) %integer I %cycle I=1,1,3 %if Ruse(I)=-Old %thenstart Ruse(I)=-New %return %finish %repeat %cycle I=0,2,6 %if Fruse(I)=-Old %thenstart Fruse(I)=-New %return %finish %repeat %end;! Reset Reguse !* %routine Freeregs !*********************************************************************** !* save any general or floating registers * !*********************************************************************** %integer I %cycle I=1,1,3 %if Ruse(I)<0 %then Freeup Reg(I) Ruse(I)=0 %repeat %cycle I=0,2,6 %if Fruse(I)<0 %then Freeup Freg(I) %repeat Lastreg=-1 Lastfreg=-1 %end;! Freeregs !* %integerfn Claimfr(%integer Curreg) !*********************************************************************** !* result is a free floating register, other than Curreg * !*********************************************************************** %integer I %cycle I=0,2,6 %if Fruse(I)=0 %and I#Curreg %and I#Lastfreg %thenstart Lastfreg=I %result=I %finish %repeat %cycle I=0,2,6 %unless I=Curreg %or I=Lastfreg %thenstart Freeup Freg(I) Lastfreg=I %result=I %finish %repeat %end;! Claimfr !* %integerfn Claimfrpair(%integer Curreg) !*********************************************************************** !* result is the smaller of a free floating register pair, not * !*including Curreg * !*********************************************************************** %integer I %if Fruse(0)=0 %and Fruse(2)=0 %then %result=0 %if Fruse(4)=0 %and Fruse(6)=0 %then %result=4 %unless 0<=Curreg<=2 %thenstart %if Fruse(0)#0 %then Freeup Freg(0) %if Fruse(2)#0 %then Freeup Freg(2) %result=0 %finishelsestart %if Fruse(4)#0 %then Freeup Freg(4) %if Fruse(6)#0 %then Freeup Freg(6) %result=4 %finish %end;! Claimfrpair !* %integerfn Claimr(%integer Curreg) !*********************************************************************** !* result is a free general register, other than Curreg * !*********************************************************************** %integer I %cycle I=1,1,3 %if Ruse(I)=0 %and I#Curreg %and I#Lastreg %thenstart Lastreg=I %result=I %finish %repeat %cycle I=1,1,3 %unless I=Curreg %or I=Lastreg %or Ruse(I)=-255 %thenstart Freeup Reg(I) Lastreg=I %result=I %finish %repeat %if Lastreg>0 %and Lastreg#Curreg %thenstart Freeup Reg(Lastreg) %result=Lastreg %finishelsestart %if UsingR14#0 %then UsingR14=0 %and Pdrop(R14) %result=R14 %finish Abort %end;! Claimr !* %integerfn Claimbr !*********************************************************************** !* obtain a register, other than Lastbreg * !*********************************************************************** %integer I %cycle I=4,1,7 %if Ruse(I)=0 %then %result=I %repeat %cycle I=4,1,7 %unless I=Lastbreg %then Ruse(I)=0 %and %result=I %repeat %end;! Claimbr !* %routine Setint(%integer Val,Size,%integername B2,D2) !*********************************************************************** !* set B2, D2 to address a location containing Val * !*********************************************************************** %if Size<4 %thenstart %if Size=1 %then Val=Val<<24 %else Val=Val<<16 %finish Ed4(Cnst,CurCnst,Val) CurCnst=CurCnst+4 B2=R9 D2=CurCnst-4 %end;! Setint !* %integerfn Basereg(%integer Area) !*********************************************************************** !* result is the register addressing the nominated area * !*********************************************************************** %integer I %if Area=0 %then %result=R10;! stack %if Area=Static %then %result=R8 %if Area=Cnst %then %result=R9 %if Area=Gla %then %result=R13 %cycle I=7,-1,4 %if Ruse(I)=Area %then Lastbreg=I %and %result=I %repeat %cycle I=7,-1,4 %unless I=Lastbreg %thenstart PIX RX(L,I,0,R13,Areabase(Area)) Ruse(I)=Area Lastbreg=I %result=I %finish %repeat %end;! Basereg !* %integerfn SetX2(%integername D2) !*********************************************************************** !* result is a register containing an appropriate 4K multiple * !* D2 is adjusted accordingly * !*********************************************************************** %integer I,J %if D2>=4096 %thenstart J=D2&X'FFFFF000' D2=D2&X'FFF' %cycle I=4,1,7 %if Ruse(I)=J %then Lastbreg=I %and %result=I %repeat { %if J>Max4k %then Max4k=j} I=Claimbr { PIX RX(L,I,0,R12,J>>10)} PIX RX(LA,I,0,0,J>>12) PIX RS(SLL,I,0,0,12) Ruse(I)=J %result=I %finishelse %result=0 %end;! SetX2 !* %routine Range(%integername B,D) !*********************************************************************** !* if necessary modify B to ensure that D is less than 4096 * !* D is adjusted accordingly * !*********************************************************************** %integer X2 %if D>=4096 %thenstart X2=SetX2(D) PIX RR(AR,X2,B) B=X2 Ruse(X2)=0 %finish %end;! Range !* %integerfn Indbase(%integer Area,Disp) !*********************************************************************** !* result is a register containing the address held in the nominated * !* location * !*********************************************************************** %integer I,J,K J=(Area<<16)!Disp %cycle I=4,1,7 %if Ruse(I)=J %then Lastbreg=I %and %result=I %repeat I=Basereg(Area) K=Claimbr PIX RX(L,K,0,I,Disp) Ruse(K)=(Area<<16)!Disp %result=K %end;! Indbase !* %routine Do RX(%integer Op,Reg,Base,Offset) %integer X2 %if Offset>=4096 %then X2=SetX2(Offset) %else X2=0 PIX RX(Op,Reg,X2,Base,Offset) %end;! Do RX !* %integerfn Load Modifier(%record(Stkfmt)%name Stk,%integer Lockedreg) !*********************************************************************** !* result is a register loaded with the modifier (scaled if necessary) * !*********************************************************************** %integer Form,Reg,B2,D2 %switch F(0:21) Form=Stk_Modform&31 %if Form =RegVal %thenstart Reg=Stk_Modreg Ruse(Reg)=0 Scale: %if Stk_Scale#0 %thenstart PIX RS(SLL,Reg,0,0,Stk_Scale) %finish Stk_Modform=RegVal Stk_Scale=0 %result=Reg %finish %if Form=IndRegVal %thenstart Reg=Stk_Modreg PIX RX(L,Reg,0,Reg,0) Ruse(Reg)=0 ->Scale %finish Reg=Claimr(Lockedreg) D2=Stk_Modoffset ->F(Form);! removing the reg marker bit !* F(LitVal): { lit } %if 0<=D2<4096 %thenstart %if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart PIX RX(LA,Reg,0,0,D2) %finish %finishelsestart Setint(D2,Stk_Size,B2,D2) Do RX(L,Reg,B2,D2) %finish ->Scale !* F(ConstVal): { const } F(TempVal): { (temp) } F(DirVal): { (dir) } Do RX(L,Reg,Basereg(Stk_Modbase),D2) ->Scale !* F(IndTempVal): { ((temp)) } Do RX(L,Reg,Basereg(Stk_Modbase),D2) PIX RX(L,Reg,0,Reg,0) ->Scale !* F(IndDirVal): { ((dir)) } B2=Indbase(Stk_Modbase,D2) PIX RX(L,Reg,0,B2,0) ->Scale !* F(*): Abort !* %end;! Load Modifier !* %integerfn Negoffset(%integer Area,D) %integer B,D2 D2=integer(Addrglaca) Ed4(GLA,D2,D) integer(Addrglaca)=D2+4 Efix(GLA,D2,Area,0) B=Claimbr Do RX(L,B,R13,D2) %result=B %end;! Negoffset !* %routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) !*********************************************************************** !* generate an RX instruction appropriate to the operand * !*********************************************************************** %integer B2,D2,Modform,Modreg %switch F(0:21) D2=Stk_Offset ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } %if 0<=D2<4096 %and Op=L %thenstart %if D2=0 %then PIX RR(SR,Reg,Reg) %elsestart PIX RX(LA,Reg,0,0,D2) %finish %finishelsestart Setint(Stk_Intval,Stk_Size,B2,D2) Do RX(Op,Reg,B2,D2) %finish %return !* F(ConstVal): { const } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } F(TempVal): { (temp) } F(DirVal): { (dir) } Do RX(Op,Reg,Basereg(Stk_Base),D2) %return !* F(RegAddr): { (reg) is @ } F(RegVal): { (reg) } PIX RR(Op-X'40',Reg,Stk_Reg) Ruse(Stk_Reg)=0 %return !* F(FregVal): { (freg) } PIX RR(Op-X'40',Reg,Stk_Reg) Fruse(Stk_Reg)=0 %return !* F(IndRegVal): { ((reg)) } PIX RX(Op,Reg,0,Stk_Reg,0) Ruse(Stk_Reg)=0 %return !* F(IndTempVal): { ((temp)) } %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15) Do RX(L,R15,Basereg(Stk_Base),D2) PIX RX(Op,Reg,0,R15,0) %return !* F(IndTempModVal): { ((temp)+M) } %if UsingR15#0 %then UsingR15=0 %and Pdrop(R15) B2=R15 Do RX(L,B2,Basereg(Stk_Base),D2) ->Modify !* F(IndDirVal): { ((dir)) } B2=Indbase(Stk_Base,D2) PIX RX(Op,Reg,0,B2,0) %return !* F(IndDirModVal): { ((dir)+M) } B2=Indbase(Stk_Base,D2) Modify: %if Stk_Modform=LitVal %thenstart Do RX(Op,Reg,B2,Stk_Modintval) %return %finish Modreg=Load Modifier(Stk,Reg) PIX RX(Op,Reg,Modreg,B2,0) %return !* F(AddrDirModVal): { (dir+M) } Modreg=Load Modifier(Stk,Reg) %if 0<=Stk_Offset<4096 %thenstart PIX RX(Op,Reg,Basereg(Stk_Base),Modreg,Stk_Offset) %finishelsestart %if Stk_Offset<0 %thenstart B2=Negoffset(Stk_Base,Stk_Offset) %finishelsestart B2=Claimr(Reg) Do RX(LA,B2,Basereg(Stk_Base),Stk_Offset) %finish PIX RX(Op,Reg,B2,Modreg,0) %finish %return !* F(IndRegModVal): { ((reg)+M) } B2=Stk_Reg Ruse(B2)=0 Lastreg=B2;! to avoid possibility of a clash when modifying ->Modify !* F(AddrConst): { @const } F(AddrDir): { @dir } %if Op= L %then Op=LA %elsestart %unless Op=STC %or Op=IC %then Abort %finish ->F(DirVal) !* F(AddrDirMod): { @dir+M } %if Op=L %then Op=LA %elsestart %unless Op=STC %or Op=IC %then Abort %finish ->F(AddrDirModVal) !* F(RegModAddr): { (reg)+M } %if Op=L %then Op=LA %else Abort ->F(IndRegModVal) !* F(TempModAddr): { (temp)+M } %if Op=L %then Op=LA %else Abort ->F(IndTempModVal) !* Abort !* F(DirModAddr): { (dir)+M } %if Op=L %then Op=LA %else Abort ->F(IndDirModVal) !* %end;! OpRX !* %routine Set BD(%record(Stkfmt)%name Stk,%integername B,D) !*********************************************************************** !* provide Base and Dispacement values for accessing the operand * !*********************************************************************** %integer Modform,Modreg,D2 %switch F(0:21) D=Stk_Offset ->F(Stk_Form&31);! removing the reg marker bit !* F(LitVal): { lit } Setint(Stk_Intval,Stk_Size,B,D) %unless 0<=D<=4095 %then Range(B,D) %return !* F(ConstVal): { const } F(TempVal): { (temp) } F(DirVal): { (dir) } F(AddrDir): { @dir } %if D<0 %thenstart;! use a fixed up address B=Negoffset(Stk_Base,D) D=0 %return %finish B=Basereg(Stk_Base) %unless D<=4095 %then Range(B,D) %return !* F(IndRegVal): { ((reg)) } B=Stk_Reg D=0 Ruse(B)=0 %return !* F(IndTempVal): { ((temp)) } B=Claimr(0) Do RX(L,B,Basereg(Stk_Base),D) D=0 Ruse(B)=0 %return !* F(IndTempModVal): { ((temp)+M) } B=Claimr(0) Do RX(L,B,Basereg(Stk_Base),D) D=0 ->Modify !* F(IndDirVal): { ((dir)) } B=Indbase(Stk_Base,D) D=0 %return !* F(IndDirModVal): { ((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) } B=Stk_Reg Ruse(B)=0 ->Modify !* !* F(AddrConst): { @const } F(RegAddr): { (reg) is @ } F(TempAddr): { (temp) is @} F(DirAddr): { (dir) is @ } Abort !* F(AddrDirMod): { @dir+M } ->F(AddrDirModVal) !* F(RegModAddr): { (reg)+M } F(TempModAddr): { (temp)+M } F(DirModAddr): { (dir)+M } Abort !* %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 Set BD(C2,B2,D2) 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=integer(Addrglaca) integer(Addrglaca)=Apars+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 %switch S(0:9) Variant=Flags>>8 Size=Flags&3 %if Size=0 %thenstart D=4 Adj=0 %finishelsestart D=8 Adj=X'10';! to be subtracted from LE etc to give LD etc %finish %if 3<=Op<=4 %and Variant=0 %thenstart;! use support procedure Elevel=Elevel+3;! to allow operands to be pushed Spcall(3*(Op-3)+Size) %return %finish Reg1=Claimr(-1) Ruse(Reg1)=-255 Reg2=Claimr(Reg1) Ruse(Reg2)=-255 OpRX(L,Reg1,LHS) OpRX(L,Reg2,RHS1) %if Op<=4 %thenstart Lastreg=Reg2;! to ensure that both Reg1 and Reg2 are safe Reg3=Claimr(Reg1) OpRX(L,Reg3,RHS2) %finish Ruse(Reg1)=0 Ruse(Reg2)=0 ->S(Op) !* S(1): ! CXADD PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(AE-Adj,0,0,Reg3,0) %unless Variant=1 %then PIX RX(AE-Adj,2,0,Reg3,D) Store:PIX RX(STE-Adj,0,0,Reg1,0) PIX RX(STE-Adj,2,0,Reg1,D) %return !* S(2): ! CXSUB PIX RX(LE-Adj,0,0,Reg2,0) %if Variant=2 %then PIX RR(SER-Adj,2,2) %c %else PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(SE-Adj,0,0,Reg3,0) %unless Variant=1 %then PIX RX(SE-Adj,2,0,Reg3,D) ->Store !* S(3): ! CXMULT PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(ME-Adj,0,0,Reg3,0) PIX RX(ME-Adj,2,0,Reg3,0) { %if Variant=0 %thenstart } { PIX RX(LE-Adj,4,0,Reg2,0) } { PIX RX(LE-Adj,6,0,Reg2,D) } { PIX RX(ME-Adj,4,0,Reg3,D) } { PIX RX(ME-Adj,6,0,Reg3,D) } { PIX RR(SER-Adj,0,6) } { PIX RR(AER-Adj,2,4) } { %finish } ->Store !* S(4): ! CXDIV PIX RX(LE-Adj,0,0,Reg2,0) PIX RX(LE-Adj,2,0,Reg2,D) PIX RX(DE-Adj,0,0,Reg3,0) PIX RX(DE-Adj,2,0,Reg3,0) ->Store !* S(5): ! CXNEG PIX RR(SER-Adj,0,0) PIX RR(SER-Adj,2,2) PIX RX(SE-Adj,0,0,Reg2,0) PIX RX(SE-Adj,2,0,Reg2,D) ->Store !* S(6): ! CXASGN %if Variant#0 %thenstart;! not Cx = Cx PIX RX(LE-Adj,0,0,Reg2,0) %if Variant=2 %thenstart;! Real = Cx PIX RX(STE-Adj,0,0,Reg1,0) %return %finishelsestart;! Cx = Real PIX RR(SER-Adj,2,2) ->Store %finish %finish PIX SS(MVC,0,D<<1,Reg1,0,Reg2,0) %return !* S(7): ! CXEQ S(8): ! CXNE %if Op=7 %then CC=7 %else CC=8 PIX RX(LE-Adj,0,0,Reg1,0) PIX RR(BASR,R14,0) Pusing(R14) UsingR14=1 PIX RX(CE-Adj,0,0,Reg2,0) %if Variant=0 %then I=16 %else I=12 PIX RX(BC,CC,0,R14,I) %if Variant=1 %thenstart PIX RR(SER,0,0) PIX RR(CER,2,0) %finishelsestart PIX RX(LE-Adj,2,0,Reg1,D) PIX RX(CE-Adj,2,0,Reg2,D) %finish CCset=1 CC=CC!!15;! inverse test was used in the above %return !* S(9): ! CONJG PIX RX(LE-Adj,0,0,Reg2,0) PIX RR(SER-Adj,2,2) PIX RX(SE-Adj,2,0,Reg2,D) ->Store %end;! Cx Operation !* !* !*********************************************************************** !* !* %endoffile