!* 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 !* 30/10/85 - changes to routines pasop & Unsupported Opcode !* 13/11/85 - new Pascal Specific ecodes, update cfort_ecodes !* 20/11/85 - changes for codefile boot to Amdhal !* 28/11/85 - further changes for boot !* 16/12/85 - update cfort_ecodes and Epasopnames. (agh) !* 08/01/86 - Eterminate, output from Area(1) for boot !* 14/01/86 - new include files ebits_ecodes2 & ebits_enames2 !* new eops, jumpops & pasops. Set up Nextproc to generate Id !* number for procedure calls & modify Exname, Enextproc, Eproc !* 15/01/86 - modify Estkconst !* correct stack level for ops INDEX, ARGPROC, PUSHBYTES !* 16/01/86 - write Id in Report for Exname,Eprecall & Ecall!* !* correct stack level for Eprocref !* 22/01/86 - inhibit printing in Unsupported Opcode if Codefile set !* 29/01/86 - correct stack level for Eop IREM !* 03/02/86 - remove body of LoadModifier & OpRX, modify Refer at F(RegVal) !* 10/02/86 - modify Stkfmt, new ecode routines added !* 11/02/86 - remove body of Pushparam !* 12/02/86 - simpilfy Ecall !* 16/02/86 - insert code for eop BNOT !* 19/02/86 - delete body of Expcall, Spcall,Load Real, Load Int, !* Load Real Extended, Establish Logical, Int Binary Op, !* Int Unary Op, Real Binary Op, Real Unary Op, Convert II, !* Convert RR, Convert RI, Convert IR, Storeop, Freeup Reg, !* Claimfr, Claimr, Claimbr, Claimfrpair, Setint, Basereg, !* SetX2, Range, Indbase, Do Rx, Set BD. !* Delete Do Charop, Cx Operation !* %ownstring(31) Versiontext="Fortran77 Compiler Version 0.1" %owninteger Report=1 %owninteger Decode %owninteger Language %owninteger Codefile=0 %owninteger GlaAddr !* %constinteger IMP = 1 %constinteger FORTRAN = 2 %constinteger CCOMP = 11 %constinteger PASCAL = 14 !* %constinteger Einit=1 %constinteger Eterm=2 %constinteger Elstart=5 %constinteger Estkl=13 %constinteger Estkc=14 %constinteger Estkd=15 %constinteger Estki=16 %constinteger Estkg=17 %constinteger Estkgi=18 %constinteger Estkp=19 %constinteger Estkpi=20 %constinteger Estkr=21 %constinteger Eref=22 %constinteger Estka=25 %constinteger Estkga=26 %constinteger Estkpa=27 %constinteger Elab=28 %constinteger Ejmp=30 %constinteger Exnam=44 %constinteger Epcall=45 %constinteger Ecal=46 %constinteger Eprcref=47 %constinteger Enproc=50 %constinteger Epr=51 %constinteger Eprend=52 %constinteger Edatent=54 %constinteger Edatref=55 %constinteger Eopp=56 %constinteger Epop=58 %constinteger Priv1=60 %constinteger Egjmp=61 %constinteger Ecjmp=62 %constinteger Ecent=63 %constinteger Estkpfs=64 %constinteger Epref=65 %constinteger Epsav=66 %constinteger Epres=67 %constinteger Epdis=68 %constinteger Etrp=69 %constinteger Eprclev=70 %constinteger Estkrc=71 ! !*********************************************************************** !* 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 "ebits_ecodes2" %include "cfort_xamnem" %include "ebits_enames2" !* !************************************************************************ !* %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,Dum,Reg,Modreg, Base,Modbase,Scale,Modform, %integer Size,(%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 %owninteger Nextproc %owninteger WithLevel %owninteger ProcLevel !* !* !*********************************************************************** !* Code generation procedure specs * !*********************************************************************** !* !* %routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset) %routinespec Address(%record(Stkfmt)%name Stk) %integerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg) %integerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg, %integername Bytes) %integerfnspec Load Real Extended(%record(Stkfmt)%name Stk,%integer Newsize) %routinespec 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 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 Codefile#1 %thenstart %if Opcode<=255 %then S=Eopname(Opcode) %elseif %c Opcode<511 %then S=Ef77opname(Opcode) %else S=Epasopname(Opcode) printstring("******* Unsupported Opcode ****** ".S) newline %finish %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 %if codefile#0 %thenstart write(Einit,1) write(Lang,1) write(Aver,1) write(Astackca,1) write(Aglaca,1) write(options,1) GlaAddr=Aglaca %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 %integerarrayname Area %integerarrayformat AF(1:10) %if Report#0 %thenstart printstring("Eterminate ") newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Eterm,1) Area==array(adareasizes,AF) %cycle i=1,1,10 write(Area(i),1) %repeat newline %finish 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 Codefile#0 %thenstart write(Elstart,1) write(lineno,1) %finish %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 Codefile#0 %thenstart write(Estkl,1) write(Val,1) %finish %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 * !*********************************************************************** %integer i %if Report#0 %thenstart printstring("Estkconst ") write(Len,4) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Estkc,1) write(Len,1) Ad=Ad<<1 write(byteinteger(Ad+i),1) %for i=0,1,Len-1 %finish Pdbytes(Cnst,CurCnst,Len,Ad) ! Estkdir(Cnst,CurCnst,0,Len) %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Len Stk(Elevel)_Base=Cnst Stk(Elevel)_Offset=CurCnst Stk(Elevel)_Adid=0 CurCnst=Curcnst+((Len+3)>>2)<<2 %end;! Estkconst !* %externalroutine Estkrconst(%integer Len,Ad) !*********************************************************************** !* stacks a real constant, allocating space for it if necessary * !*********************************************************************** %integer i %if Report#0 %thenstart printstring("Estkrconst ") write(Len,4) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Estkrc,1) write(Len,1) Ad=Ad<<1 write(byteinteger(Ad+i),1) %for i=0,1,Len-1 %finish Pdbytes(Cnst,CurCnst,Len,Ad) ! Estkdir(Cnst,CurCnst,0,Len) %if Elevel=15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=Len Stk(Elevel)_Base=Cnst Stk(Elevel)_Offset=CurCnst Stk(Elevel)_Adid=0 CurCnst=Curcnst+((Len+3)>>2)<<2 %end;! Estkrconst !* %externalroutine Estkdir(%integer Area,Offset,Adid,Bytes) !*********************************************************************** !* stacks a direct operand * !*********************************************************************** %if Report#0 %thenstart printstring("Estkdir ".Areas(area)." +");write(Offset,1) write(Bytes,6) %if Adid#0 %then spaces(4) %and printstring(string(Adid)) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Estkd,1) write(Area,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish %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 Codefile#0 %thenstart write(Estki,1) write(Area,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish %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 %if Codefile#0 %thenstart write(Estkg,1) write(Level,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish 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 %if Codefile#0 %thenstart write(Estkgi,1) write(Level,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish 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 %if Codefile#0 %thenstart write(Estkp,1) write(Level,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish 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 %if Codefile#0 %thenstart write(Estkpi,1) write(Level,1);write(Offset,1);write(Adid,1);write(Bytes,1) %finish 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 Codefile#0 %thenstart write(Estkr,1) write(Class,1);write(Type,1);write(Bytes,1) %finish %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 Codefile#0 %thenstart write(Eref,1) write(Offset,1);write(Bytes,1) %finish %if Elevel<1 %then Abort %and %return Refer(Stk(Elevel),Offset) Stk(Elevel)_Size=Bytes %end;! Erefer !* %externalroutine Estkpf(%integer FieldOffset,FieldSize) !*********************************************************************** !* stacks a descriptor to the packed field. (Etos) defined the * !* address of the word containing the field * !*********************************************************************** %if Report#0 %thenstart printstring("Estkpf ");write(FieldOffset,1) write(FieldSize,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Abort %if Codefile#0 %thenstart write(Estkpfs,1) write(FieldOffset,1);write(FieldSize,1) %finish %end;! Estkpf !* %externalroutine Eprefer(%integer FieldOffset,FieldSize) !*********************************************************************** !* adjust the descriptor for a packed field * !*********************************************************************** %if Report#0 %thenstart printstring("Eprefer ");write(FieldOffset,1) write(FieldSize,6) newline %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Abort %if Codefile#0 %thenstart write(Epref,1) write(FieldOffset,1);write(FieldSize,1) %finish %end;! Eprefer !* %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 020 %or Elevel<1 %then Abort %if codefile#0 %thenstart write(Epsav,1) write(WithLevel,1) %finish Base=WithLevel Elevel=Elevel-1 %end; ! Epsave !* %externalroutine Eprestore(%integer Base) !*********************************************************************** !* Restore the saved base address in (Etos) * !*********************************************************************** %if Report#0 %thenstart printstring("Eprestore ");write(Base,4) newline %finish %if codefile#0 %thenstart write(Epres,1) write(Base,1) %finish %if ProgFaulty#0 %then %return %if Elevel>15 %then %monitor %and %stop Elevel=Elevel+1 Stk(Elevel)=0 Stk(Elevel)_Form=DirVal Stk(Elevel)_Size=4 Stk(Elevel)_Base=2 Stk(Elevel)_Offset=0 Stk(Elevel)_Adid=0 %end; ! Eprestore !* %externalroutine Epdiscard(%integer Base) !*********************************************************************** !* Discard a saved base address * !*********************************************************************** %if Report#0 %thenstart printstring("Epdiscard ");write(Base,4) newline %finish %if ProgFaulty#0 %then %return %if WithLevel#Base %or WithLevel<1 %then Abort %if codefile#0 %thenstart write(Epdis,1) write(Base,1) %finish WithLevel=WithLevel-1 %end; ! Epsave !* !* ********************* !* * Labels, Jumps * !* ********************* !* !* %externalroutine Elabel(%integer Id) !*********************************************************************** !* register a label * !*********************************************************************** %if Report#0 %thenstart printstring("Elabel ");write(Id,4) newline %finish %if ProgFaulty#0 %then %return %if codefile#0 %thenstart write(Elab,1) write(Id,1) %finish %if Elevel>0 %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 Codefile#0 %thenstart write(Ejmp,1) write(Opcode,1);write(Labelid,1) %finish %if ProgFaulty#0 %then %return ->Op(Opcode) !* Op(*):%monitor %stop !* Op(JUGT): Op(JULT): Op(JUEQ): Op(JUNE): Op(JUGE): Op(JULE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 { Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2)) } { Op Jump(BRA+Setcc(Opcode-JIGT),Labelid) } CCset=0 %return !* Op(JUGTZ): Op(JULTZ): Op(JUEQZ): Op(JUNEZ): Op(JUGEZ): Op(JULEZ): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 { Op X(TST,Stk(Elevel+1)) } { Op Jump(BRA+Setcc(Opcode-JINTGZ),Labelid) } %return !* Op(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 EgJump(%integer Opcode,LevelOffset,Labelid) !*********************************************************************** !* generate global jump * !*********************************************************************** %if Report#0 %thenstart printstring("EgJump ".EopName(Opcode)) write(LevelOffset,4);write(Labelid,4) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(egjmp,1) write(Opcode,1);write(LevelOffset,1);write(Labelid,1) %finish %end; ! EgJump !* %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 !* %externalroutine EcaseJump(%integer Lower,Upper,Errlabid,Wflag) !*********************************************************************** !* * !*********************************************************************** %if Report#0 %thenstart printstring("EcaseJump ");write(Lower,4);write(Upper,4) write(Errlabid,4);write(Wflag,4) newline %finish %if Codefile#0 %thenstart write(Ecjmp,1) write(Lower,1);write(Upper,1);write(Errlabid,1);write(Wflag,1) %finish %if ProgFaulty#0 %then %return %if Elevel<1 %then Abort Elevel=Elevel-1 %end;! EcaseJump !* %externalroutine EcaseEntry(%integer Index,Labelid) !*********************************************************************** !* * !*********************************************************************** %if Report#0 %thenstart printstring("EcaseEntry ") write(Index,4);write(Labelid,4) newline %finish %if Codefile#0 %thenstart write(Ecent,1) write(Index,1);write(Labelid,1) %finish %end;! EcaseEntry !* %externalroutine ETrap(%integer Relop,Error) !*********************************************************************** !* * !*********************************************************************** %if Report#0 %thenstart printstring("ETrap ") write(Relop,4);write(Error,4) newline %finish %if Codefile#0 %thenstart write(Etrp,1) write(Relop,1);write(Error,1) %finish %if ProgFaulty#0 %then %return %if Elevel<2 %then Abort Elevel=Elevel-2 %end;! ETrap !* !* !* ******************************* !* * 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 Nextproc=Nextproc+1 %if Report#0 %thenstart printstring("EXname ".Xref);write(Nextproc,4) write(Type&15,4);write(Type>>4,4) newline %finish ! Refad=integer(Addrglaca) %if ProgFaulty#0 %then %result=Nextproc %if Codefile#0 %thenstart write(Exnam,1) write(Type,1);write(length(Xref),1);printstring(Xref) write(Nextproc,1) %finish ! integer(Addrglaca)=Refad+16 ! I=PXname(0,Xref,Refad) %result=Nextproc %end;! EXname !* %externalroutine Eprecall(%integer Id) !*********************************************************************** !* called prior to planting parameters to a procedure call * !*********************************************************************** %if Report#0 %thenstart printstring("Eprecall ");write(Id,4) newline %finish %if Codefile#0 %thenstart write(Epcall,1) write(Id,1) %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(Id,4) write(Numpars,6); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Ecal,1) write(Id,1);write(Numpars,1);write(paramsize,1) %finish ! 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 %if Codefile#0 %thenstart write(Eprcref,1) write(Id,1);write(Level,1) %finish Elevel=Elevel+1 Stk(elevel)_Form=LitVal Stk(Elevel)_Intval=0 Stk(Elevel)_Size=4 %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 * !*********************************************************************** Nextproc=Nextproc+1 %if Report#0 %thenstart printstring("Enextproc ");write(Nextproc,1) newline %finish %if Codefile#0 %thenstart write(Enproc,1) write(Nextproc,1) %finish %result=Nextproc %end;! Enextproc !* %externalroutine Eproclevel(%integer Level) !*********************************************************************** !*record static nesting level of the current procedure * !*********************************************************************** %if Report#0 %thenstart printstring("Eproclevel ");write(Level,4) newline %finish %if Codefile#0 %thenstart write(Eprclev,1) write(Level,1) %finish ProcLevel=Level %end;! Eproclevel !* %externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize, Astacklen, %integername Id) !*********************************************************************** !* define the start of a procedure body * !* if Id > 0 this is the Id returned by a previous call of Enextproc * !* Astacklen is the address of the word noting the current local * !* stack-frame size * !*********************************************************************** %integername GlaSize %if Id<0 %thenstart Nextproc=Nextproc+1 Id=Nextproc %finish %if Report#0 %thenstart printstring("Eproc ");printstring(Name);write(Id,4) write(Numpars,4); write(Paramsize,4) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart %if Props&2#0 %thenstart write(Priv1,1) Glasize==integer(GlaAddr) write(Glasize,1) %finish write(Epr,1) write(length(Name),1) printstring(Name) write(Props,1) write(Numpars,1) write(Paramsize,1) write(Astacklen,1) write(Id,1) %finish 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 * !*********************************************************************** %integername Stacklen %if Report#0 %thenstart printstring("Eprocend ");write(Localsize,6) newline %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Eprend,1) write(Localsize,1) write(Diagdisp,1) Stacklen==integer(Astacklen) write(Stacklen,1) %finish 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,Len,%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(Len,4) newline %finish %if Codefile#0 %thenstart write(Edatent,1) write(Area,1) write(Offset,1) write(Len,1) write(length(Name),1) printstring(Name) %finish %end;! Edataentry !* %externalroutine Edataref(%integer Area,Offset,Len,%stringname Name) !*********************************************************************** !* requests a data ref to Name (with at least Len)at Offset in Area * !*********************************************************************** %if Report#0 %thenstart printstring("Edataref ".Name);write(Area,4) write(Offset,4);write(Len,4) newline %finish %if Codefile#0 %thenstart write(Edatref,1) write(Area,1);write(Offset,1);write(Len,1) write(length(Name),1);printstring(Name) %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 Codefile#0 %thenstart write(Eopp,1) write(Opcode,1) %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(UADD): Op(USUB): !* Op(UGT): Op(ULT): Op(UEQ): Op(UNE): Op(UGE): Op(ULE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2)) %return !* Op(IADDST): Op(ISUBST): Op(IMULTST): Op(IDIVST): !* Op(IANDST): Op(IORST): Op(IXORST): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2)) %return !* Op(INEGST): Op(INOTST): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Int Unary Op(Opcode,Stk(Elevel+1)) %return !* Op(UCVTII): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval) %return !* Op(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): Op(BNOT): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Int Unary Op(Opcode,Stk(Elevel+1)) %return !* Op(IREM): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 !* 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): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return !* 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): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Unsupported Opcode(Opcode) %return !* Op(PUSHBYTES): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return %end;! Eop !* %externalroutine Epasop(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Pascal * !*********************************************************************** %switch Pasop(511:643) %if Report#0 %thenstart printstring("Epasop ".Epasopname(Opcode)) newline Dump Estack %finish %if ProgFaulty#0 %then %return %if Codefile#0 %thenstart write(Epop,1) write(Opcode,1) %finish !* %if CCset # 0 %then Establish Logical; ! estsblish logical value 0 or 1 !* ->Pasop(Opcode) !* Pasop(*): %monitor !* Pasop(STRGT): Pasop(STRLT): Pasop(STREQ): Pasop(STRNE): Pasop(STRGE): Pasop(STRLE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return !* Pasop(PTREQ): Pasop(PTRNE): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 Unsupported Opcode(Opcode) %return !* Pasop(SETI): Pasop(SETU): Pasop(SETD): Pasop(SETLE): Pasop(SETEQ): Pasop(SETNE): Pasop(SETIN): Pasop(SETSING): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 Unsupported Opcode(Opcode) %return !* Pasop(SETRANGE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return !* Pasop(CAPMOVE): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-3 Unsupported Opcode(Opcode) %return !* Pasop(INDEXP): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return !* Pasop(EOFOP): Pasop(EOLOP): Pasop(LAZYOP): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Unsupported Opcode(Opcode) %return !* Pasop(ISQR): Pasop(IODD): Pasop(ISUCC): Pasop(IPRED): Pasop(UODD): Pasop(USUCC): Pasop(UPRED): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Unsupported Opcode(Opcode) !* Pasop(RSQR): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Unsupported Opcode(Opcode) %return !* Pasop(CHKLT): Pasop(CHKGT): %if Elevel<3 %then Low Estack(Opcode,3) %and %return Elevel=Elevel-2 Unsupported Opcode(Opcode) %return !* Pasop(CHKRNG): Pasop(CHKSETGT): Pasop(CHKSETRNG): %if Elevel<4 %then Low Estack(Opcode,4) %and %return Elevel=Elevel-3 Unsupported Opcode(Opcode) %return !* Pasop(UCHKLT): Pasop(UCHKGT): Pasop(UCHKNE): Pasop(UCHKRNG): Pasop(CHKNE): Unsupported Opcode(Opcode) !* Pasop(CHKNEW2): Pasop(CHKUNDEF): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Unsupported Opcode(Opcode) %return !* Pasop(SETUNDEF): %if Elevel<1 %then Low Estack(Opcode,1) %and %return Elevel=Elevel-1 Unsupported Opcode(Opcode) %return !* Pasop(TRAP): Unsupported Opcode(Opcode) !* Pasop(ICLPSH): Pasop(ICLPROT): %if Elevel<2 %then Low Estack(Opcode,2) %and %return Elevel=Elevel-1 Unsupported Opcode(Opcode) %end;! Epasop !* %externalroutine Ef77op(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by Fortran * !*********************************************************************** %end;! Ef77op !* %externalroutine Eccop(%integer Opcode) !*********************************************************************** !* opcodes specifically defined for use by C * !*********************************************************************** %monitor %end;! Eccop !* %routine Expcall(%integer Proc) !*********************************************************************** !* call an exponentiation routine * !*********************************************************************** %end;! Expcall !* %routine Spcall(%integer Proc) !*********************************************************************** !* call a support procedure * !*********************************************************************** %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 * !*********************************************************************** %result=R1 %end;! Load Int !* %integerfn Load Real(%record(Stkfmt)%name Stk,%integer Reg,Lockedreg, %integername Bytes) !*********************************************************************** !* Stk describes a real value * !* if Reg >= 0 this is the register to be loaded * !* result is the floating register to which the value has been loaded * !*********************************************************************** %result=R2 %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 * !*********************************************************************** %result=R2 %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) * !*********************************************************************** Stackr(R1) %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 * !*********************************************************************** Stackr(R1) %end;! Int Binary Op !* %routine Int Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports INEG,IABS * !* descriptor to result on Estack * !*********************************************************************** Stackr(R1) %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 * !*********************************************************************** stackfr(R2,4) %end;! Real Binary Op !* %routine Real Unary Op(%integer Op,%record(Stkfmt)%name RHS) !*********************************************************************** !* supports RNEG,RABS * !* descriptor to result on Estack * !*********************************************************************** Stackfr(R2,4) %end;! Real Binary Op !* %routine Convert II(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between integer sizes * !* descriptor to result on Estack * !*********************************************************************** Stackr(R1) %end;! Convert II !* %routine Convert RR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts between real sizes * !* descriptor to result on Estack * !*********************************************************************** Stackfr(R1,Newsize) %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 * !*********************************************************************** Stackr(R1) %end;! Convert RI !* %routine Convert IR(%record(Stkfmt)%name Stk,%integer Newsize) !*********************************************************************** !* converts real to integer * !* descriptor to result on Estack * !*********************************************************************** Stackfr(R2,Newsize) %end;! Convert IR !* %integerfn Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup) !*********************************************************************** !* value defined by RHS is assigned to LHS. If Dup is non-zero then * !* value must be retainedin a reg * !* result is the reg used for retaining the value * !*********************************************************************** %result=1 %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 !*********************************************************************** %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 * !*********************************************************************** %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 * !*********************************************************************** %result=2 %end;! Claimfr !* %integerfn Claimfrpair(%integer Curreg) !*********************************************************************** !* result is the smaller of a free floating register pair, not * !*including Curreg * !*********************************************************************** %result=0 %end;! Claimfrpair !* %integerfn Claimr(%integer Curreg) !*********************************************************************** !* result is a free general register, other than Curreg * !*********************************************************************** %result=1 %end;! Claimr !* %integerfn Claimbr !*********************************************************************** !* obtain a register, other than Lastbreg * !*********************************************************************** %result=4 %end;! Claimbr !* %routine Setint(%integer Val,Size,%integername B2,D2) !*********************************************************************** !* set B2, D2 to address a location containing Val * !*********************************************************************** %end;! Setint !* %integerfn Basereg(%integer Area) !*********************************************************************** !* result is the register addressing the nominated area * !*********************************************************************** %result=5 %end;! Basereg !* %integerfn SetX2(%integername D2) !*********************************************************************** !* result is a register containing an appropriate 4K multiple * !* D2 is adjusted accordingly * !*********************************************************************** %result=6 %end;! SetX2 !* %routine Range(%integername B,D) !*********************************************************************** !* if necessary modify B to ensure that D is less than 4096 * !* D is adjusted accordingly * !*********************************************************************** %end;! Range !* %integerfn Indbase(%integer Area,Disp) !*********************************************************************** !* result is a register containing the address held in the nominated * !* location * !*********************************************************************** %result=7 %end;! Indbase !* %routine Do RX(%integer Op,Reg,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) * !*********************************************************************** %result=4 %end; ! Load Modifier !* %integerfn Negoffset(%integer Area,D) %integer B,D2 B=Claimbr %result=B %end;! Negoffset !* %routine OpRX(%integer Op,Reg,%record(Stkfmt)%name Stk) !*********************************************************************** !* generate an RX instruction appropriate to the operand * %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) %return 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 !* !*********************************************************************** !* !* %endoffile