!* modified 21/08/85
!*
%ownstring(31) Versiontext="Fortran77 Compiler Version 0.1"
%owninteger Report=1
%owninteger Decode
%owninteger Language
%owninteger Nextprocid
!*
%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 Estkaddr(%integer Area, Offset, Adid, Bytes)
%routinespec Estkgaddr(%integer Area, Offset, Adid, Bytes)
%routinespec Estkpaddr(%integer Area, Offset, Adid, Bytes)
!*
%routinespec Elabel(%integer id)
%routinespec Eboundlab(%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"
!
!************************************************************************
!* *
!* G.E.Millard *
!* ECODES 10/08/85 *
!* *
!************************************************************************
!
{00} %constinteger HALT = 0
!
!--------------------------------------- 32-bit (Etos) ----------------
!
{01} %constinteger IADD = 1 { (Etos-1) + (Etos) => (Etos) }
{02} %constinteger ISUB = 2 { (Etos-1) - (Etos) => (Etos) }
{03} %constinteger IMULT = 3 { (Etos-1) * (Etos) => (Etos) }
{04} %constinteger IDIV = 4 { (Etos-1) / (Etos) => (Etos) }
{05} %constinteger INEG = 5 { - (Etos) => (Etos) }
{06} %constinteger IABS = 6 { abs( (Etos) ) => (Etos) }
{07} %constinteger IREM = 7 { remainder from }
{ (Etos-1) / (Etos)=> (Etos) }
!
{08} %constinteger IAND = 8 { (Etos-1) & (Etos) => (Etos) }
{09} %constinteger IOR = 9 { (Etos-1) ! (Etos) => (Etos) }
{0A} %constinteger INOT = 10 { ~ (Etos) => (Etos) }
{0B} %constinteger IXOR = 11 { (Etos-1) !! (Etos) => (Etos) }
{0C} %constinteger ISHLL = 12 { (Etos-1) << (Etos) => (Etos) }
{0D} %constinteger ISHRL = 13 { (Etos-1) >> (Etos) => (Etos) }
{0E} %constinteger ISHLA = 14 { arithmetic left shift }
{0F} %constinteger ISHRA = 15 { arithmetic right shift }
!
{10} %constinteger IGT = 16 { if }
{11} %constinteger ILT = 17 { (Etos-1) <relop> (Etos) }
{12} %constinteger IEQ = 18 { then }
{13} %constinteger INE = 19 { true (1) => (Etos) }
{14} %constinteger IGE = 20 { else }
{15} %constinteger ILE = 21 { false (0) => (Etos) }
!
{18} %constinteger JIGT = 24 { if }
{19} %constinteger JILT = 25 { (Etos-1) <relop> (Etos) }
{1A} %constinteger JIEQ = 26 { then }
{1B} %constinteger JINE = 27 { -> <label> }
{1C} %constinteger JIGE = 28 { else }
{1D} %constinteger JILE = 29 { continue }
!
!--------------------------------------- generic (Etos) ---------------
!
{1E} %constinteger JINTGZ = 30 { if (Etos) > 0 %then -> <lab> }
{1F} %constinteger JINTLZ = 31 { if (Etos) < 0 %then -> <lab> }
{20} %constinteger JINTZ = 32 { if (Etos) = 0 %then -> <lab> }
{21} %constinteger JINTNZ = 33 { if (Etos) # 0 %then -> <lab> }
{22} %constinteger JINTGEZ = 34 { if (Etos) >=0 %then -> <lab> }
{23} %constinteger JINTLEZ = 35 { if (Etos) <=0 %then -> <lab> }
!
{24} %constinteger ITWB = 36 { if (Etos) < 0 then -> <lab1> }
{ = 0 then -> <lab2> }
{ > 0 then -> <lab3> }
!
{26} %constinteger JUMP = 38 { -> <label> }
{29} %constinteger SFA = 41 { SF => (Etos) }
{2A} %constinteger RETURN = 42 { procedure exit }
{2B} %constinteger ASF = 43 { SF = SF + (Etos) }
!
{2C} %constinteger IPUSH = 44 { (Etos) => (Mstack) }
{2D} %constinteger IPOP = 45 { (Mstack) => (Etos) }
{2E} %constinteger EXCH = 46 { (Etos-1) <=> (Etos) }
{2F} %constinteger DUPL = 47 { replicate (Etos) }
{30} %constinteger DISCARD = 48 { discard (Etos) }
!
{33} %constinteger INDEX1 = 51 { (@ Etos-1) + (Etos) }
{ => (@ Etos) }
{34} %constinteger INDEX2 = 52 { (@ Etos-1) + (Etos)*2 }
{ => (@ Etos) }
{35} %constinteger INDEX4 = 53 { (@ Etos-1) + (Etos)*4 }
{ => (@ Etos) }
{36} %constinteger INDEX8 = 54 { (@ Etos-1) + (Etos)*8 }
{ => (@ Etos) }
{37} %constinteger INDEX = 55 { (@ Etos-2) }
{ + (Etos-1)*(Etos) }
{ => (@ Etos) }
!
{38} %constinteger MVB = 56 { move (Etos) bytes }
{ ((@ Etos-2)) => ((@ Etos-1)) }
!
{39} %constinteger CHK = 57 { check that }
{ (Etos-1)<=(Etos-2)<=(Etos) }
{ (Etos-2) => (Etos) }
!
{3A} %constinteger TMASK = 58 { (Etos-1) & (Etos) }
{ - to be followed by JI[N]Z }
!
{3E} %constinteger CPBGT = 62 { if (Etos) bytes }
{3F} %constinteger CPBLT = 63 { ((Etos-2)) <relop> ((Etos-1))}
{40} %constinteger CPBEQ = 64 { then }
{41} %constinteger CPBNE = 65 { true (1) => (Etos) }
{42} %constinteger CPBGE = 66 { else }
{43} %constinteger CPBLE = 67 { false (0) => (Etos) }
!
!-------------------------------------- generic real operations -------
!
{71} %constinteger RADD = 113 { (Etos-1) + (Etos) => (Etos) }
{72} %constinteger RSUB = 114 { (Etos-1) - (Etos) => (Etos) }
{73} %constinteger RMULT = 115 { (Etos-1) * (Etos) => (Etos) }
{74} %constinteger RDIV = 116 { (Etos-1) / (Etos) => (Etos) }
{75} %constinteger RNEG = 117 { - (Etos) => (Etos) }
{76} %constinteger RABS = 118 { abs( (Etos) ) => (Etos) }
!
{88} %constinteger CVTII = 136 { (int Etos-1) => int size(Etos) }
{89} %constinteger CVTIR = 137 { (int Etos-1) => real size(Etos)}
{8A} %constinteger CVTRR = 138 { (real Etos-1)=> real size(Etos)}
{8B} %constinteger TNCRI = 139 { (real Etos-1)=> int size(Etos) }
{8C} %constinteger RNDRI = 140 { (real Etos-1)=> int size(Etos) }
!
!--------------------------------------- generic real operations ------
!
{90} %constinteger RGT = 144 { if }
{91} %constinteger RLT = 145 { (Etos-1) <relop> (Etos) }
{92} %constinteger REQ = 146 { then }
{93} %constinteger RNE = 147 { 1 => (Etos) }
{94} %constinteger RGE = 148 { else }
{95} %constinteger RLE = 149 { 0 => (Etos) }
!
{96} %constinteger JRGT = 150 { if }
{97} %constinteger JRLT = 151 { (Etos-1) <relop> (Etos) }
{98} %constinteger JREQ = 152 { then }
{99} %constinteger JRNE = 153 { -> <label> }
{9A} %constinteger JRGE = 154 { else }
{9B} %constinteger JRLE = 155 { continue }
!
{9C} %constinteger JRGZ = 156 { if (Etos) > 0 %then -> <lab> }
{9D} %constinteger JRLZ = 157 { if (Etos) < 0 %then -> <lab> }
{9E} %constinteger JRZ = 158 { if (Etos) = 0 %then -> <lab> }
{9F} %constinteger JRNZ = 159 { if (Etos) # 0 %then -> <lab> }
{A0} %constinteger JRGEZ = 160 { if (Etos) >=0 %then -> <lab> }
{A1} %constinteger JRLEZ = 161 { if (Etos) <=0 %then -> <lab> }
!
{A2} %constinteger RTWB = 162 { if (Etos) < 0 then -> <lab1> }
{ = 0 then -> <lab2> }
{ > 0 then -> <lab3> }
{A3} %constinteger JTRUE = 163 { if (Etos) true then -> <lab }
{A4} %constinteger JFALSE = 164 { if (Etos) false then -> <lab> }
!
!----------------------------------------------------------------------
!
{B1} %constinteger UCHECK = 177 { if (Etos) unassigned diagnose }
{B8} %constinteger ESTORE = 184 { ((Etos)) = (Etos-1) }
{B9} %constinteger EDUPSTORE = 185 { ((Etos)) = (Etos-1) }
{ retain (Etos-1) as new (Etos) }
{BA} %constinteger PUSHVAL = 186 { push (Etos) as value param }
{BB} %constinteger PUSHADDR = 187 { push (Etos) as ref param }
{BC} %constinteger EVAL = 188 { force load of (Etos) }
{BD} %constinteger EVALADDR = 189 { force load of @ at (Etos) }
{BE} %constinteger EADDRESS = 190 { address(Etos) is required }
{BF} %constinteger EINTRES = 191 { (Etos) is integer fn result }
{C0} %constinteger EREALRES = 192 { (Etos) is real fn result }
{C1} %constinteger ESIZE = 193 { size of (Etos-1) is (Etos) }
{C2}%constinteger EPOWER = 194 { (Etos-3) @ result if cx }
{ (Etos-2) base (@ base if cx) }
{ (Etos-1) power(@ power if cx) }
{ (Etos) procindex }
{C3}%constinteger EPOWERI = 195 { (Etos-2) base }
{ (Etos-1) power (int) }
{ (Etos) procindex (0-3) }
{ procindex = 0 powii }
{ 1 powri }
{ 2 powdi }
{ 3 powqi }
{ 4 powci }
{ 5 powzi }
{ 6 powzzi }
{ 9 powrr }
{ 10 powdd }
{ 11 powqq }
{ 12 powcc }
{ 13 powzz }
{ 14 powzzz }
!
!***********************************************************************
!* *
!* Fortran specific codes *
!* *
!***********************************************************************
!
%constinteger CXADD = 257 { ((Etos-3)) = ((Etos-2)) }
%constinteger CXSUB = 258 { op }
%constinteger CXMULT = 259 { ((Etos-1))}
%constinteger CXDIV = 260 { (Etos) = variant<<8 ! sizecode }
%constinteger CXNEG = 261 { ((Etos-2)) = - ((Etos-1)) }
{ (Etos) = sizecode }
%constinteger CXASGN = 262 { ((Etos-2)) = ((Etos-1)) }
{ (Etos) = variant<<8 }
{ ! sizecode(RHS)<<2 }
{ ! sizecode(LHS) }
%constinteger CXEQ = 263 { (Etos) = ((Etos-2)) }
%constinteger CXNE = 264 { op ((Etos-1)) }
{ (Etos) = variant<<8 ! sizecode }
%constinteger ECMPLX2 = 287 { ((Etos-3))=((Etos-2),(Etos-2)) }
{ (Etos) = sizecode }
%constinteger ECONJG = 279 { ((Etos-2) = conjg((Etos-1)) }
{ (Etos) = sizecode }
{ variant = 0 cx op cx }
{ 1 cx op real }
{ 2 real op cx }
{ sizecode = 0 c*8 (r*4) }
{ 1 c*16 (r*8) }
{ 2 c*32 (r*16) }
%constinteger EM1EXP = 267 { (Etos) = (-1) ** (Etos) - int }
%constinteger EISIGN = 268 { (Etos) = sign(Etos) }
%constinteger ESIGN = 269 { * abs(Etos-1) }
%constinteger EIMOD = 270 { (Etos) = int(Etos-1)/(Etos) }
%constinteger ERMOD = 271 { * (Etos) }
%constinteger EIDIM = 272 { (Etos) = if (Etos-1) > (Etos) }
%constinteger ERDIM = 273 { then (Etos-1)-(Etos) }
{ else 0
%constinteger EIMIN = 274 { (Etos) = min( (Etos-1), }
%constinteger ERMIN = 275 { (Etos) ) }
%constinteger EIMAX = 276 { (Etos) = max( (Etos-1), }
%constinteger ERMAX = 277 { (Etos) ) }
%constinteger EDMULT = 278 { (Etos) = dble((Etos-1)*(Etos)) }
%constinteger ECHAR = 280 { ((Etos-1)) = char(Etos) }
%constinteger EICHAR = 281 { (Etos) = ichar((Etos-1)) }
%constinteger EINDEXCHAR = 282 { (Etos) = index( C1,C2 ) }
{ ((Etos-3)) = Charad(C1) }
{ (Etos-2) = Charlen(C1) }
{ ((Etos-1)) = Charad(C2) }
{ (Etos) = Charlen(C2) }
%constinteger ECONCAT = 283 { C1 = concat list }
{ ((Etos-3)) = Charad(C1) }
{ (Etos-2) = Charlen(C1) }
{ ((Etos-1)) = @ concat table }
{ (Etos) = no. items }
%constinteger EASGNCHAR = 284 { C1 = C2 }
{ ((Etos-3)) = Charad(C1) }
{ (Etos-2) = Charlen(C1) }
{ ((Etos-1)) = Charad(C2) }
{ (Etos) = Charlen(C2) }
%constinteger ECOMPCHAR = 285 { (Etos) = compare( C1,C2 ) }
{ ((Etos-4)) = Charad(C1) }
{ (Etos-3) = Charlen(C1) }
{ ((Etos-2)) = Charad(C2) }
{ (Etos-1) = Charlen(C2) }
{ (Etos) = relop }
{ relop = 0 > 1 < 2 = }
{ 3 # 4 >= 5 <= }
%constinteger EISHFT = 288 { (Etos) = (Etos-1) << (Etos) }
%constinteger EIBITS = 289 { (Etos) = (Etos) bits from }
{ bit (Etos-1) in (Etos-2) }
%constinteger EIBSET = 290 { (Etos) = (Etos-1)&(1<<(Etos)) }
%constinteger EIBTEST = 291 { (Etos) = (Etos-1)!(1<<(Etos)) }
%constinteger EIBCLR = 292 { (Etos) = (Etos-1)&\(1<<(Etos)) }
%constinteger EISHFTC = 293 { (Etos) = (Etos-1) <<c (Etos) }
%constinteger PROCARG = 294
%constinteger IPROCARG = 295
%constinteger CHARARG = 296
%constinteger IPROCCALL = 297
%constinteger ARGPROCCALL = 298
%constinteger CALLTPLATE = 299
%constinteger NOTEIORES = 300
%constinteger STKIORES = 301
%constinteger EFCVT = 302 { convert(Etos-1) }
{ (Etos) convert code }
%constinteger EFCVTASGN = 303 { (Etos-1) = convert(Etos-2) }
{ (Etos) convert code }
{ convert code=oldmode<<3!newmode}
{ mode =[0 bit - futures] }
{ 1 I1 (byte) }
{ 2 I2 }
{ 3 I4 }
{ 4 I8 }
{ 5 R4 }
{ 6 R8 }
{ 7 R16 }
%constinteger EARGLEN = 304 { (Etos) is char arg len }
{ - on Amdahl load bottom half }
%constinteger EFDVACC = 305 { dope vector special evaluation }
{ (Etos-1) => (Etos) }
{ (Etos-2) + (Etos-1)*(Etos) }
{ => (Etos-1) }
!
!*
!*
!***********************************************************************
!* 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","FLOOR","","",
{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", "","","","",
{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} "" ,"" ,"" ,""
!*
!***********************************************************************
!*
%constinteger CONST = 0
%constinteger INREG = 1
%constinteger INFREG = 2
%constinteger INTEMP = 3
%constinteger DIRECT = 4
%constinteger INDIRECT= 5
%constinteger MODIFIED= 8
%constinteger ADDRESSED=16
!*
%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
!*
!*
!***********************************************************************
!* 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:9)= 0,0,
X'4E000000', X'80000000',
X'4E000001', X'00000000',
X'4F000000', X'08000000',
X'82828282', X'82828282'
%constinteger TWO31 = 8
%constinteger TWO32 = 16
%constinteger TWO31R= 24
!*
!***********************************************************************
!*
%ownintegerarray Areabase(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 Stackframe
%owninteger Glaf77regs,Glawork,Curdiagca
%owninteger CurCnst
%owninteger Next Param Offset
!*
!*
!***********************************************************************
!* Code generation procedure specs *
!***********************************************************************
!*
!*
!*
!***********************************************************************
!*
%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
%integer I,J,K
%if Elevel<=0 %then %return
printstring("Estack:
")
I=Elevel
%while I>0 %cycle
J=addr(Stk(I))
%cycle K=0,4,16
Phex(integer(J+K))
space
%repeat
I=I-1
newline
%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
Elevel=0
%end;! Low Estack
!*
%routine Abort
%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
Report=options&1
Decode=Options&X'4000'
Language=Lang
%if Report#0 %thenstart
printstring("Einitialise ")
newline
%finish
Nextprocid=1000
%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
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255) *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name)
Newline
%finish
%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
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elinestart ");write(Lineno,4)
newline
%finish
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elinedecode ");
newline
%finish
%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
%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
%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); spaces(2)
phex(integer(ad)); space
%if len>4 %then phex(integer(ad+4))
newline
%finish
%end;! Estkconst
!*
%externalroutine Estkrconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkrconst ")
write(Len,4)
newline
%finish
%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
%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
%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
%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
%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
%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
%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
%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
%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
%end;! Epromote
!*
%externalroutine Edemote(%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("Edemote ");write(Level,4)
newline
%finish
%end;! Edemote
!*
%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkaddr ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%end;! Estkaddr
%externalroutine Estkgaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkgaddr ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%end;! Estkgaddr
%externalroutine Estkpaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkpaddr ".Areas(area)." +");write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%end;! Estkpaddr
!*
!*
!*
!* *********************
!* * Labels, Jumps *
!* *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elabel ");write(Id,4)
newline
%finish
%end;! Elabel
%externalroutine Eboundlab(%integer Id)
!***********************************************************************
!* register a label *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eboundlab ");write(Id,4)
newline
%finish
%end;! Eboundlab
!*
%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 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
%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
%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 *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eswitch ")
write(Lower,4);write(Upper,4);write(Switchid,4)
newline
%finish
%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 *
!***********************************************************************
%if Report#0 %thenstart
printstring("EfswitchJump ");write(switchid,4)
newline
%finish
%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)
newline
%finish
%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
%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
%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
%end;! Ed4
!*
%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data *
!***********************************************************************
%if Report#0 %thenstart
printstring("Edbytes ")
write(area,4)
write(disp,4)
write(len,4)
space; phex(integer(ad)); space
%if len>4 %then phex(integer(ad+4))
newline
%cycle
phex(ad); space
phex(integer(ad)); space
phex(integer(ad+4)); space
phex(integer(ad+8)); space
phex(integer(ad+12)); newline
ad=ad+16
len=len-16
%repeat %until len<=0
%finish
%if Area=10 %then %monitor;! should not be allocated any more
%end;! Edbytes
!*
%externalroutine Edpattern(%integer area, Disp, ncopies, len, ad)
!***********************************************************************
!* initialise using a 1,2,4 or 8 byte pattern *
!***********************************************************************
%if Report#0 %thenstart
printstring("Edpattern ")
newline
%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
%end
!*
!*
!*
!* *********************
!* * 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
Nextprocid=Nextprocid+1
%result=Nextprocid
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprecall ")
newline
%finish
%end;! Eprecall
!*
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ecall ");! write(id,6)
newline
%finish
%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);write(Level,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
Nextprocid=Nextprocid+1
%result=Nextprocid
%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,5); write(paramsize,5)
newline
%finish
%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
%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)
newline
%finish
%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
%switch Op(0:255)
%if Report#0 %thenstart
printstring("Eop ".Eopname(Opcode))
newline
Dump Estack
%finish
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran *
!***********************************************************************
%switch F77op(256:320)
%if Report#0 %thenstart
printstring("Ef77op ".Ef77opname(Opcode))
newline
Dump Estack
%finish
%end;! Ef77op
!*
%externalroutine Epasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal *
!***********************************************************************
%monitor
%end;! Epasop
!*
%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C *
!***********************************************************************
%monitor
%end;! Eccop
!*
!*
!*
!***********************************************************************
!*
!*
%externalroutine Egenerate Object(%stringname Objfilename)
!***********************************************************************
!***********************************************************************
%record(Stkfmt) E
%integer I
%if Report#0 %thenstart
printstring("Egenerate Object ")
newline
%finish
%end;! Egenerate Object
!*
%externalroutine Euchecklab(%integer Label)
%if Report#0 %thenstart
printstring("Euchecklab)")
write(Label,4)
%finish
%end;!Euchecklab
!*
%endoffile