! ggen67i4
! Changes to support new Imp front end including maked,splitd
! and proper handline of procedures called formally
! ggen67i3
! 31/12/87 - Estkparind to use local base if imp
! ggen67i2
! 23/11/87 - Take out SUI, and SRC
! ggen67
! 25/04/87 - update ERBIT, EWBIT to UTX definitions
! ggen65
! 17/04/87 - use correct np names div_jj, mpy_jj
! ggen64
! 16/04/87 - support unsigned int comparison
! ggen61
! 01/04/87 - support ERBIT, EWBIT
! ggen60
! 18/03/87 - correct pow_cc and pow_zz entries
! ggen59
! 28/02/87 - incorporate integer*8 support (ex ggen36u)
! - incorporate C support (ex ggen54c)
! ggen58
! 13/02/87 - support Ecxres
! 12/02/87 - Convert RI incorporate 'duke' change
! 11/02/87 - EREALRES to ensure regpair unlocked
! ggen55
! 27/12/86 - add inline code for **2 in Expcall
! 24/12/86 - C dev version ex Ft.L.
! - correct Reg1 => Reg3 in CAR in ERMOD
! ggen54
! 15/12/86 - correct Convert UI
! ggen53
! 13/12/86 - add ISHLST, ISHRST for C
! ggen51
! 11/12/86 - add ECDUP support
! 09/12/86 - add C support codes Epushstr, Eldbits, Estbits
! ggen50
! 08/12/86 - increase Stk array to 63 entries
! ggen46
! 03/12/86 - modify ERMOD code to handle NP1 reciprocal problem
! ggen45
! 01/12/86 - add support for CVTUI, CVTUR, CVTSBI, Eprocptr
! ggen44
! 01/12/86 - on NP1 PROCARG does not push the arg (for APS2)
! 29/11/86 - incorporate changes for F77 1.0 final (ggen33)
! ggen43
! 21/11/86 - ad Eprocptr and use ecodes10
! ggen42
! 18/11/86 - merge C and NP1 developements
! ggen40
! 25/10/86 - attemp to improve NP1 end of loop code
! ggen39
! 21/10/86 - change Egivename to a routine
! 20/10/86 - NP1 correct reg for STKIORES, EINDEXCHAR, EFSETVR, EFNOTEVR
! ggen38
! 14/11/86 - use Gould procs for cx div
! 07/11/86 - EINCRB, EDECRB check that literal<=32767
! 05/11/86 - lock reg in <complex> <op> <real>
! 04/11/86 - Clear Regs after EASGNCHAR in case equiv with ints
! - correct params to Gop Cpb in Cx Operation
! 31/10/86 - correct ECHAR for lit arg
! 30/10/86 - add ECSTORE
! 16/10/86 - complete operations to store for C
! - modify Eswitch for use by C case
! - add LOGNEG to Eccop
! ggen37
! 14/10/86 - call Note Reguse in Eswitch
! ggen36
! 10/10/86 - correct EXS instruction in Convert IR
! 08/10/86 - result in r2,r3 for NP1
! ggen35
! 27/09/86 - add NP1 code
! 26/09/86 - EDUPSTORE of DirVals (C)
! - add EloseRegs
! ggen30
! 21/09/86 - interpret EVAL as a call on Gop Mvlong (temp)
! ggen29
! 17/09/86 - use i_shftc for cyclic shift
! - ensure that int params to exp routines are 32 bit
! 12/09/86 - support C regvars
! ggen28
! 12/09/86 - support IADDST, ISUBST
! 08/09/86 - add support for Eadjl,Eadjr,Everify
! 06/09/86 - revise auxstack handling to use support proc
! ggen27
!* Alan increase auxst static allocation of BSS to 128k
! 04/09/86 - ensure reg pair used in Cx Operation for C*16 for CXNEG and CONJG
! ggen26
! 16/08/86 - EINCR to use ARM
! 17/08/86 - in-line code for complex*8 mult
! - improve code for CMPLX1 and CMPLX2
! ggen25
! 14/07/86 - correction to ECHAR
! 31/07/86 - changes for >64K procedures
! ggen23
!*
%constinteger Concept = 0
%constinteger NP1 = 1
!*
%constinteger Cpu = NP1
!*
%include "gbits_gcodes8"
%include "ebits_ecodes28"
%include "ebits_enames28"
!*
%constinteger IMP = 1
%constinteger fortran = 2
%constinteger ccomp = 11
%constinteger pascal = 14
!*
%constinteger Positive = 1
%constinteger Negative =-1
!*
%constinteger Stack Direction = Positive
!*
%externalinteger Report=0
%owninteger PrimeReport=0
%owninteger Decode
%owninteger Language
%externalintegerspec Initdataad
!*
!***********************************************************************
!* 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 Estkrconst(%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 Estkgind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkpar(%integer Level, Offset, Adid, Bytes)
%routinespec Estkparind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkresult(%integer Class, Type, Bytes)
%routinespec Erefer(%integer Offset, Bytes)
%routinespec Epromote(%integer Level)
%routinespec Edemote(%integer Level)
%routinespec Estkaddr(%integer Area, Offset, Adid, Bytes)
!*
%routinespec Elabel(%integer id)
%routinespec Ediscardlabel(%integer id)
%routinespec Ejump(%integer Opcode, Labelid)
%routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3)
%routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid,
%integername SSTad)
%routinespec EswitchJump(%integer Switchid)
%routinespec EfswitchJump(%integer Switchid)
%routinespec Eswitchentry(%integer Switchid, Entry)
%routinespec Eswitchdef(%integer Switchid)
%routinespec EswitchLabel(%integer Switchid, Entry, Labelid)
!*
%routinespec Ed1(%integer area, Disp, Val)
%routinespec Ed2(%integer area, Disp, Val)
%routinespec Ed4(%integer area, Disp, Val)
%routinespec Edbytes(%integer area, Disp, len, ad)
%routinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%routinespec Efix(%integer area, disp, tgtarea, tgtdisp)
!*
%integerfnspec EXname(%integer type, %string(255)%name Xref)
%routinespec Eprecall(%integer Id)
%routinespec Ecall(%integer Id, Numpars, Paramsize)
%routinespec Eprocref(%integer Id, Level)
%routinespec Esave(%integer Asave, %integername Key)
%routinespec Erestore(%integer Asave, Key, Existing)
!*
%integerfnspec Enextproc
%routinespec Eproclevel(%integer Level)
%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 Egivename(%integer Key,%stringname S)
!*
%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
!*
%recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg,
Base,Modbase,Scale,Modform,
(%integer Offset %or %integer Intval),
(%integer Modoffset %or %integer Modintval),
%integer Size,Adid)
!*
%externalrecord(Stkfmt)%array Stk(0:63)
%constinteger Stklimit = 63
%ownrecord(Stkfmt) Rstk
%ownrecord(Stkfmt) Frstk
%ownrecord(Stkfmt) LitZero
%ownrecord(Stkfmt) LitOne
!*
!*
!***********************************************************************
!* Imports *
!***********************************************************************
!*
%externalroutinespec Init Mcode(%integer codelist,lang,options)
%externalintegerfnspec Tidy Mcode(%integer Level,%integername pltsize)
%externalroutinespec Mcode Label(%integer Label)
%externalroutinespec Mcode Plabel(%integer Label)
%externalintegerfnspec mprivatelabel
!*
%externalroutinespec Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%externalroutinespec Gop RI(%integer Op,Reg,Lit)
%externalroutinespec Gop RR(%integer Op,Dreg,Sreg)
%externalroutinespec Gop RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop X(%integer Op,%record(Stkfmt)%name Stk)
%externalroutinespec Gop R(%integer Op,Reg)
%externalroutinespec Gop(%integer Op)
%externalroutinespec Gop Shift Lit(%integer Op,Reg,Lit)
%externalroutinespec Gop Shift(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop Jump(%integer Op,Label)
%externalroutinespec Gop Rnd(%integer Reg,Size,Const)
%externalroutinespec Gop Floor(%integer reg,size,consts)
%externalroutinespec Gop Call(%integer Id,Paramsize,numpars,Xlevel)
%externalroutinespec Gop Return
%externalroutinespec Gop Mvb(%record(Stkfmt)%name len,From,To)
%externalroutinespec Gop Mvlong(%record(Stkfmt)%name len,from,to,%integer units)
%externalroutinespec Gop Cpb(%integer Op,%record(Stkfmt)%name len,At,With)
%externalroutinespec CodeW(%integer h0,h1)
%externalroutinespec CodeH(%integer h0)
%externalroutinespec Mprecall
%externalroutinespec Mstartproc(%integer Props,Level,Paramsize)
%externalroutinespec Mtidyproc(%integer Markerid,Localsize,Diagdisp,
%integername Ca)
%externalintegerfnspec Mmarker
%externalroutinespec Msetopd(%integer Markerid,New Value)
%externalroutinespec Mline(%integer Lineno)
%externalintegerfnspec Mgetca(%integer mode)
%externalintegerfnspec Note Entry(%stringname Name,%integer Key,Ca,Main)
%externalintegerfnspec Get Prockey(%stringname S)
%externalroutinespec Mswitch(%integer Form,Refad,Base,Entries,Switchid,Errlab)
%externalroutinespec Mswitchentry(%integer Switchid,Entry)
%externalroutinespec Mswitchlabel(%integer Switchid,Entry,Labelid)
%externalroutinespec Minnerproc(%integer M)
%externalroutinespec Msetconst(%integer Ad,Len,%integername Area,Offset)
%externalroutinespec Msideentry(%integer ca)
%externalroutinespec Mr7updated
%externalroutinespec Eafix(%integer Area,Offset)
%externalintegerfnspec Pltspace(%integer len)
!*
!*
!***********************************************************************
!* Code generation procedure specs *
!***********************************************************************
!*
%externalintegerfnspec Load Reg(%integer Reg,%record(Stkfmt)%name Stk)
%externalintegerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg)
%externalintegerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Newsize)
%externalroutinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalintegerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
%externalroutinespec Push Param(%record(Stkfmt)%name Stk)
%externalroutinespec Push Struct(%record(Stkfmt)%name Stk,%integer size)
%routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%externalintegerfnspec Claim Reg
%externalintegerfnspec Claim Reg Pair(%integer Mode)
%externalroutinespec release reg(%integer reg)
%externalroutinespec Release Reg Pair(%integer Mode)
%externalintegerfnspec Claim Freg
%externalroutinespec Unlock Reg(%integer Reg)
%externalroutinespec Unlock Reg Pair(%integer Reg)
%externalroutinespec Lock Reg Pair(%integer Reg)
%externalroutinespec Reset Reguse(%integer Old,New)
%externalroutinespec Moptreguse(%integer reg,use)
%externalroutinespec Freeregs
%externalroutinespec Clear Regs
%externalroutinespec Dump Regs(%integer dlevel)
%externalroutinespec Note Reguse(%integer Reg,Use,Size)
%externalintegerfnspec Get Procref(%integer Id)
%externalroutinespec Mset Procref(%integer Area,Offset,%string(255)%name S)
%externalroutinespec Gop Bit(%integer Op,Mode,Treg,%record(Stkfmt) Loc,Adj)
!*
%routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Address(%record(Stkfmt)%name Stk)
%routinespec Stackr(%integer R,bytes)
%routinespec Stackfr(%integer FR,Bytes)
%routinespec Establish Logical
%routinespec Convert RR(%integer Mode,%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode)
%routinespec Convert SBI(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IU(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert UR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Expcall(%integer Proc)
%routinespec Spcall(%integer Proc)
!*
%routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2)
%routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!*
!*
!***********************************
!* Put Interface Passing of Data *
!***********************************
%externalroutinespec MDBYTES (%integer area, Disp, len, ad)
%externalroutinespec MD (%integer area, Disp, Databyte)
%externalroutinespec MD2 (%integer area, Disp, DataDoublebyte)
%externalroutinespec MD4 (%integer area, Disp, DataQuadbyte)
%externalroutinespec MDPATTERN (%integer area, Disp, ncopies, len, ad)
!**********************************************
!* Put Interface RELOCATION and REFERENCES *
!**********************************************
%externalintegerfnspec MXname (%integer type,%string(255)%name s)
%externalroutinespec Mfix (%integer area,disp, tgtarea,tgtdisp)
%externalroutinespec MDxref (%integer area,disp,id)
!**********************************
!* Put Interface - Miscellaneous *
!**********************************
%externalintegerfnspec Mcommon (%string(255)%name Name)
%externalroutinespec MendCommon (%integer id,length)
%externalroutinespec Mproc (%string(255)%name name, %integer props,codead,
%integername id,%integer lineno)
%externalintegerfnspec Mentry(%integer Index,Codedisp,%string(255) %name name)
%externalroutinespec Mprocend(%integername ca)
%externalroutinespec Mdataentry(%string(255)%name name, %integer area, maxlen, disp)
%externalroutinespec Minitialise (%integer version,release,language)
%externalroutinespec Mterminate (%integer adareasizes)
%externalroutinespec Mfaulty
%externalroutinespec Mmonon
!*
!*
!*
!***********************************************************************
!* Common declarations *
!***********************************************************************
!*
!*
%constinteger LitVal = 0 { lit }
%constinteger ConstVal = 1 { const }
%constinteger RegVal = 2 { (reg) }
%constinteger FregVal = 3 { (freg) }
%constinteger TempVal = 4 { (temp) }
%constinteger DirVal = 5 { (dir) }
%constinteger IndRegVal = 6 { ((reg)) }
%constinteger IndTempVal = 7 { ((temp)) }
%constinteger IndDirVal = 8 { ((dir)) }
%constinteger AddrConst = 9 { @const }
%constinteger AddrDir = 10 { @dir }
%constinteger RegAddr = 11 { (reg) is @ }
%constinteger TempAddr = 12 { (temp) is @}
%constinteger DirAddr = 13 { (dir) is @ }
%constinteger AddrDirMod = 14 { @dir+M }
%constinteger RegModAddr = 15 { (reg)+M }
%constinteger TempModAddr = 16 { (temp)+M }
%constinteger DirModAddr = 17 { (dir)+M }
%constinteger IndRegModVal = 18 { ((reg)+M) }
%constinteger IndTempModVal = 19 { ((temp)+M) }
%constinteger IndDirModVal = 20 { ((dir)+M) }
%constinteger AddrDirModVal = 21 { (@dir+M) }
%constinteger RegBitAddr = 22 { (reg) is @ }
%constinteger RegBitModAddr = 23 { (reg)+M }
%constinteger RegVar = 29 { var in reg }
%constinteger RegPtr = 30 { ptr in reg }
%constinteger TopOfStack = 31 { TOS }
!*
%constinteger Regflag = 32 {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:31) = %c
"LitVal ","ConstVal ","RegVal ","FregVal ",
"TempVal ","DirVal ","IndRegVal ","IndTempVal ",
"IndDirVal ","ConstAddr ","AddrDir ","RegAddr ",
"TempAddr ","DirAddr ","AddrDirMod ","RegModAddr ",
"TempModAddr ","DirModAddr ","IndRegModVal ","IndTempModVal ",
"IndDirModVal ","AddrDirModVal ","RegBitAddr ","RegBitModAddr ",
"" ,"" ,"" ,"" ,
"" ,"RegVar" ,"RegPtr" ,"TOS "
!*
%constinteger Stack = 0
%constinteger Code = 1
%constinteger Gla = 2
%constinteger Plt = 3
%constinteger Sst = 4
%constinteger Ust = 5
%constinteger Diags = 6
%constinteger Static = 7
%constinteger Iotab = 8
%constinteger Zust = 9
%constinteger Cnst =10
!*
%externalinteger Elevel
%owninteger ProgFaulty
%owninteger ProcLevel
%owninteger Savelineno
%owninteger Pltsize
%externalinteger Bitarea
%externalinteger Bitdisp
!*
%conststring(9)%array Expprocs(0:16)= %c
"pow_ii" ,"pow_ri" ,"pow_di" ,"pow_qi" ,"pow_ci" ,
"pow_zi" ,"pow_zzi" ,"" ,"" ,"pow_rr" ,
"pow_dd" ,"pow_qq" ,"pow_cc" ,"pow_zz" ,"pow_zzz",
"pow_jj" ,"pow_ji"
!*
%constintegerarray Expproctype(0:16)= %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',
x'10801',x'10801'
!*
%ownintegerarray Expprocref(0:16)
!*
%if Cpu=NP1 %thenstart
!*
%constintegerarray Expprocpdesc(0:16)= %c
X'20008',X'20008',X'2000C',X'20008',X'20008',
X'20008',X'3000C',0 ,0 ,X'20008',
X'20010',X'20008',X'20008',X'20008',X'3000C',
X'20008',x'20008'
!*
%conststring(9)%array Spprocs(0:30)= %c
"f_crmult" ,"f_cdmult" ,"f_cqmult" ,"div_cc" ,
"div_zz" ,"f_cqdiv" ,"f_index" ,"f_concat" ,
"p_stop" ,"f_cpystr" ,"f_cpstr" ,"p_eoft",
"p_eof" ,"p_eol" ,"p_lazy" ,"f_ishft",
"f_ibits" ,"f_ibset" ,"f_btest" ,"f_ibclr",
"i_shftc","i_auxst" ,"s_adjl" ,"s_adjr",
"i_vrfy" ,"lshift" ,"rshift", "mpy_jj",
"div_jj","#udiv" ,"#urem"
!*
%constintegerarray Spprocpdesc(0:30)= %c
X'3000C',X'3000C',X'3000C',X'20008',
X'20008',X'3000C',X'40010',X'40010',
0 ,X'40010',X'50014',X'10004',
X'10004',X'10004',X'10004',X'20008',
X'3000C',X'20008',X'20008',X'20008',
X'3000C',X'20008',X'40010',X'40010',
X'40010',X'20008',X'20008',X'20008',
X'20008',X'20008',X'20008'
!*
%finishelsestart {Concept}
!*
%constintegerarray Expprocpdesc(0:16)= %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',
X'20008',x'20008'
!*
%conststring(9)%array Spprocs(0:30)= %c
"f_crmult" ,"f_cdmult" ,"f_cqmult" ,"c_div" ,
"z_div" ,"f_cqdiv" ,"f_index" ,"f_concat" ,
"p_stop" ,"f_cpystr" ,"f_cpstr" ,"p_eoft",
"p_eof" ,"p_eol" ,"p_lazy" ,"f_ishft",
"f_ibits" ,"f_ibset" ,"f_btest" ,"f_ibclr",
"i_shftc" ,"i_auxst" ,"s_adjl" ,"s_adjr",
"i_vrfy" ,"lshift" ,"rshift", "ftnmpyjj_",
"ftndivjj_","#udiv" ,"#urem"
!*
%constintegerarray Spprocpdesc(0:30)= %c
X'3000C',X'3000C',X'3000C',X'3000C',
X'3000C',X'3000C',X'40010',X'40010',
0 ,X'40010',X'50014',X'10004',
X'10004',X'10004',X'10004',X'20008',
X'3000C',X'20008',X'20008',X'20008',
X'3000C',X'20008',X'40010',X'40010',
X'40010',X'20008',X'20008',X'20008',
X'20008',X'20008',X'20008'
!*
%finish
!*
%constintegerarray Spproctype(0:30)= %c
X'10000',X'10000',X'10000',X'10000',
X'10000',X'10000',X'10000',X'10000',
0 ,X'10000',X'10401',X'10401',
X'10401',X'10401',X'10401',X'10401',
X'10401',X'10401',X'10401',X'10401',
X'10401',X'10401',X'10000',X'10000',
X'10401',X'10401',X'10401',X'10801',
X'10801',X'10401',X'10401'
!*
%ownintegerarray Spprocref(0:30)
!*
%owninteger Unasslab,Bounderr
!*
%ownintegerarray Procprops(0:15); ! hold the props as passed to Eproc
%ownintegerarray Procstkmark(0:15)
%ownintegerarray Noteparamsize(0:15)
!*
%constintegerarray Bmaskval(0:31) = %c
x'1',x'3',x'7',x'f',x'1f',x'3f',x'7f',x'ff',
x'1ff',x'3ff',x'7ff',x'fff',x'1fff',x'3fff',x'7fff',x'ffff',
x'1ffff',x'3ffff',x'7ffff',x'fffff',
x'1fffff',x'3fffff',x'7fffff',x'ffffff',
x'1ffffff',x'3ffffff',x'7ffffff',x'fffffff',
x'1fffffff',x'3fffffff',x'7fffffff',x'ffffffff'
!*
!***********************************************************************
!* Gould-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 br0=8
%constinteger br1=9
%constinteger br2=10
%constinteger br3=11
%constinteger br4=12
%constinteger br5=13
%constinteger br6=14
%constinteger br7=15
!*
%constbyteintegerarray Falsecc(0:5)= 5,4,3,2,1,0 {LE GE NE EQ LT GT}
!*
%owninteger Stack Offset=0
%owninteger Param Offset=0
%owninteger Gla Offset =0
%owninteger Display Offset=0
!*
%recordformat cswfmt(%integer id,type,plt,index,count,lower)
%ownrecord(cswfmt)%array csw(0:63)
%owninteger numcsw
!*
!***********************************************************************
!*
%ownintegerarray Areabase(0:255)
%ownintegerarray Areaid(0:255)
%ownintegerarray Areaprops(0:255)
!*
%owninteger Addrstackca, Addrglaca
%owninteger CC, CCset
%owninteger Curdiagca
%owninteger CurCnst
%owninteger Curswitchad
%owninteger Visibleproc
%owninteger Auxaddr
%owninteger saveoptions; ! for holding the options given to Einitialise
%ownstring(7)auxsname="p_aux"; ! The name of aux stack data ref
%owninteger BSSlen
%owninteger consthalf,Nearhalf; ! Constant address for Convert RI
%owninteger Notediagdisp
%owninteger Keycommon
%owninteger Numregvars
%owninteger Ecdupflag
%owninteger numcsave
%ownintegerarray Regvaroffset(0:4)
%ownintegerarray Regvarsize(0:4)
%ownintegerarray Regvarclass(0:4)
%ownintegerarray Regvarval(0:4)
%ownintegerarray Regvarload(0:4)
!*
!***********************************************************************
!*
%ownstring(8)%array Areas(0:255)= %c
"Locals","Code","Static","Plt","Ust","Fardata","Diags","Params",
"Ioarea","Bss","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>=RegVar %then write(Reg,1) %and %return
%if Form=Litval %thenstart
write(Offset,4)
%return
%finish
printstring(Areas(Base))
%if Offset<0 %thenstart
printstring(" - ")
Offset=-Offset
%finishelse printstring(" + ")
write(Offset,0)
%end;! Pform
Dump Regs(0)
%if Elevel<=0 %then %return
I=Elevel
%while I>0 %cycle
J=addr(Stk(I))
E==record(J)
write(I,1);printstring(":")
Pform(E_Form,E_Reg,E_Base,E_offset)
%if RegVar>(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
!*
%externalroutine EGiveName(%integer Key,%stringname S)
S={"@".}Areas(Key)
%end;! EGiveName
!*
%externalintegerfn EGiveAreaId(%integer Area)
%if Area<=10 %then %result=Area
%result=AreaId(Area)
%end;! EGiveAreaId
!*
!*
%externalroutine Enote CC(%integer Cond)
CCset=1
CC=Cond
%end;! Enote CC
!*
%externalintegerfn Eglaspace(%integer size)
!***********************************************************************
!***********************************************************************
!* Obtain from the gla allocated by compiler. Can not trust *
!* the pointer to be word aligned *
%integer ad
ad=integer(Addrglaca)
%if size>1 %and ad&1#0 %then ad=ad+1
%if size>2 %and ad&2#0 %then ad=ad+2
%if size>4 %and ad&4#0 %then ad=ad+4
integer(Addrglaca)=ad+size
%result=ad
%end;! Eglaspace
!*
%externalintegerfn Estackspace(%integer size)
%integer ad
ad=integer(Addrstackca)
%if size>4 %and ad&4#0 %then ad=ad+4
integer(Addrstackca)=ad+size
%result=ad
%end;! Estackspace
!*
%externalintegerfn Estkrecad(%integer level)
%result=addr(Stk(level))
%end;! Estkrecad
!*
!**********************************************************************
!**********************************************************************
!** Error reporting **
!**********************************************************************
!**********************************************************************
!*
!*
%externalroutine Low Estack(%integer Opcode,Reqlevel)
printstring("******* Estack error ******
!! Op = ".Eopname(Opcode)." actual/required levels:")
write(Elevel,4)
write(Reqlevel,4)
newline
%monitor
%stop
Elevel=0
%end;! Low Estack
!*
%routine Abort
Dump Estack
%monitor
%stop
%end;! Abort
!*
%routine Abortm(%string(31) S)
printstring("
*** Mgen abort - ".S." ***
")
Dump Estack
%monitor
%stop
%end;! Abort
!*
%routine Unsupported Opcode(%integer Opcode)
%string(15) S
%if Opcode<=255 %then S=Eopname(Opcode) %else S=Ef77opname(Opcode)
printstring("******* Unsupported Opcode ****** ".S)
newline
%end;! Unsupported Opcode
!*
!*
!***********************************************************************
!***********************************************************************
!** Externally visible procedures **
!***********************************************************************
!***********************************************************************
!*
!*
!* *********************
!* * Administration *
!* *********************
!*
!*
%externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options)
!***********************************************************************
!* called once at the start of compilation to initialise Eput *
!* options: bit 1 emon *
!* 2 codeon *
!* 4 mmon *
!* 8) 00 no diags *
!* 16) 01 min diags *
!* 10 diags + line nos *
!* 11 sdb/dbx *
!* 256) (Imp) Unass checking on *
!* 512) (Imp) array checking on *
!***********************************************************************
%integer I
%if options&1 # 0 %then Emonon
%if options&4 # 0 %then Mmonon
Saveoptions=options
ProgFaulty=0
Decode=Options&2
Language=Lang
Stack Offset=0
Param Offset=0
Display Offset=0
Gla Offset=0
%if Language=IMP %thenstart
Report=0
%finishelsestart
Report=PrimeReport
%finish
%if Report#0 %thenstart
printstring("Einitialise ")
newline
%finish
Init Mcode(Decode,Lang,options)
Addrstackca=Astackca
Addrglaca=Aglaca
Clear Regs
CCset=0
Elevel=0
ProcLevel=0
%cycle I=0,1,255
Areabase(I)=0
Areaid(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,10
Areaid(I)=1
%repeat
%cycle I=0,1,26
Spprocref(I)=0
%repeat
!*
Minitialise(0,1,Language)
!*
Mfix(Gla,8,Ust,0)
Mfix(Gla,12,SST,0)
Md4(Gla,16,Language<<24)
Mfix(Gla,20,Diags,0)
!*
Curcnst=0
!*
Auxaddr=0
! BSSlen=0
!*
Rstk=0; Rstk_Form=RegVal; Rstk_Size=4
Frstk=0; Frstk_Form=FregVal
LitZero=0; LitZero_Form=LitVal
LitOne=0; LitOne_Form=LitVal; LitOne_IntVal=1
!8
consthalf=0; Nearhalf=0
Keycommon=-1
Numregvars=0
Ecdupflag=0
Numcsave=0
Bitarea=-1
Bitdisp=-1
!*
%end;! Einitialise
!*
%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator *
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J,ca
%if ProgFaulty#0 %then %return
J=0
%cycle I=1,1,9
S(I)=integer(Adareasizes+J)
J=J+4
%repeat
%if Language=Ccomp %thenstart
S(8)=S(5)
S(5)=0
%finish
ca=Tidy Mcode(1,Pltsize)
S(1) =ca
s(3)=Pltsize
! %if Language=IMP %then S(9)=BSSlen
S(10)=CurCnst
%if Report#0 %thenstart
printstring("Eterminate ")
write(S(I),1) %for I=1,1,10
newline
%finish
Mterminate(addr(S(1)))
integer(adareasizes)=S(1)
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255) *
!***********************************************************************
%string(31) S
%integer Prop
%if Report#0 %thenstart
printstring("Ecommon ");Write(Area,1);spaces(4);printstring(Name)
Newline
%finish
%if ProgFaulty#0 %then %return
S=Name
%if S="F#BLCM" %then Prop=1 %and S="_BLNK__" %else Prop=2
Areaprops(Area)=Prop
Areas(Area)<-S
Areaid(Area)=Mcommon(S)
%if Keycommon<0 %then Keycommon=area
%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
Mendcommon(Areaid(Area),Length)
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line *
!***********************************************************************
Report=PrimeReport
%if Report#0 %thenstart
printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4)
newline
Dump Regs(1)
%finish
%if ProgFaulty#0 %then %return
Savelineno=Lineno
Mline(Lineno)
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart *
!***********************************************************************
{ Plinedecode }
%end;! Elinedecode
!*
%externalintegerfn Estkmarker
!***********************************************************************
!* note marker for a literal value *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkmarker ")
newline
%finish
Estklit(X'0101');! to guarantee 16-bit hole for later plugging
%result=Mmarker
%end;! Estkmarker
!*
%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!* substitute value at a marker *
!***********************************************************************
%if Report#0 %thenstart
printstring("Esetmarker ");write(Markerid,4)
write(New Value,4)
newline
%finish
Msetopd(Markerid,New Value)
%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 *
!***********************************************************************
PrimeReport=1
Report=1
%end;! Emonon
!*
%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing *
!***********************************************************************
PrimeReport=0
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
Mfaulty
%end;! Efaulty
!*
!*
!*
!* *********************
!* * Stack operations *
!* *********************
!*
!*
%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal *
!***********************************************************************
%record(Stkfmt)%name Lstk
%if Report#0 %thenstart
printstring("Estklit ");write(Val,6)
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
%if Elevel=Stklimit %then %monitor %and %stop
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=LitVal
Lstk_Intval=Val
Lstk_Size=4
%end;! Estklit
!*
%externalroutine Estkconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary *
!***********************************************************************
%integer Area,Offset
%if Report#0 %thenstart
printstring("Estkconst ")
write(Len,4)
newline
%finish
%if ProgFaulty#0 %then %return
Msetconst(Ad,Len,Area,Offset)
Estkdir(Area,Offset,0,Len)
%end;! Estkconst
!*
%externalroutine Estkrconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary *
!***********************************************************************
%integer Area,Offset
%if Report#0 %thenstart
printstring("Estkconst ")
write(Len,4)
newline
%finish
%if ProgFaulty#0 %then %return
Msetconst(Ad,Len,Area,Offset)
Estkdir(Area,Offset,0,Len)
%end;! Estkrconst
!*
%externalroutine Estkdir(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand *
!***********************************************************************
%integer I
%record(Stkfmt)%name Lstk
%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 CCset#0 %then Establish Logical
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if Area=Gla %then Offset=Offset+Gla Offset
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=DirVal
Lstk_Size=Bytes
Lstk_Base=Area
%if Area=Stack %thenstart
Offset=Offset+Stack Offset
%if Numregvars>0 %thenstart
%cycle I=1,1,Numregvars
%if Regvaroffset(I)=Offset %thenstart
Lstk_Form=Regvarclass(I)
Offset=0
Lstk_Reg=Regvarval(I)
%exit
%finish
%repeat
%finish
%finish
Lstk_Offset=Offset
Lstk_Adid=Adid
%end;! Estkdir
!*
%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%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 CCset#0 %then Establish Logical
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if Area=Stack %then Offset=Offset+Stack Offset
%if Area=Gla %then Offset=Offset+Gla Offset
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirVal
Lstk_Size=Bytes
Lstk_Base=Area
Lstk_Offset=Offset
Lstk_Adid=Adid
%end;! Estkind
!*
%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand local to an enclosing level *
!***********************************************************************
%record(Stkfmt)%name Lstk
%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 CCset#0 %then Establish Logical
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirModVal
Lstk_Size=Bytes
Lstk_Base=Stack
Lstk_Offset=Display Offset + (Level*4)
Lstk_Modform=Litval
Lstk_Modoffset=Offset
Lstk_Adid=Adid
%end;! Estkglobal
!*
%externalroutine Estkgind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand local to an enclosing level *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkgind ");write(Level,1);write(Offset,1)
write(Bytes,6)
%if Adid#0 %then spaces(4) %and printstring(string(Adid))
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
%if Elevel=Stklimit %then Abort
Estkglobal(Level,Offset,Adid,4)
Erefer(0,Bytes)
%end;! Estkgind
!*
%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct parameter operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%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 CCset#0 %then Establish Logical
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=DirVal
Lstk_Size=Bytes
%if Language=IMP %and Procprops(Proclevel)&2****5=0 %thenstart
Lstk_Base=0
Lstk_Offset=Offset+Stack Offset
%finishelsestart
Lstk_Base=7
Lstk_Offset=Offset+Param Offset
%finish
Lstk_Adid=Adid
%end;! Estkpar
!*
%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect parameter operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%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 CCset#0 %then Establish Logical
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirVal
Lstk_Size=Bytes
%if Language=IMP %and Procprops(Proclevel)&2****5=0 %thenstart
Lstk_Base=0
Lstk_Offset=Offset+Stack Offset
%finishelsestart
Lstk_Base=7
Lstk_Offset=Offset+Param Offset
%finish
Lstk_Adid=Adid
%end;! Estkparind
!*
%externalroutine Estkresult(%integer Class,Type,Bytes)
!***********************************************************************
!* defines the result stacked by a function call *
!* Type = 1 int *
!* = 2 real *
!***********************************************************************
%integer reg
%if Report#0 %thenstart
printstring("Estkresult ")
write(Class,4);write(Type,4);write(Bytes,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Cpu=Concept %thenstart
reg=r0
%finishelsestart
reg=r2
%finish
%if Type=2 %thenstart;! real
Stackfr(reg,Bytes)
%finishelse Stackr(reg,bytes)
%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
Dump Estack
%finish
%if ProgFaulty#0 %then %return
%if Elevel<1 %then Abort
Refer(Stk(Elevel),Offset)
Stk(Elevel)_Size=Bytes
%end;! Erefer
!*
%externalroutine Epromote(%integer Level)
!***********************************************************************
!* move the entry at Level in Estack to the top of the Estack *
!* - the top entry is at level 1 *
!***********************************************************************
%record(Stkfmt) E
%integer I
%if Report#0 %thenstart
printstring("Epromote ");write(Level,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
%unless 0<Level<=Elevel %then abort
%if Level=1 %then %return
Level=Elevel-Level+1
E=Stk(Level)
Reset Reguse(Level,Elevel+1);! to avoid problems
%cycle I=Level,1,Elevel-1
Stk(I)=Stk(I+1)
Reset Reguse(I+1,I)
%repeat
Stk(Elevel)=E
Reset Reguse(Elevel+1,ELevel)
%end;! Epromote
!*
%externalroutine Edemote(%integer Level)
!***********************************************************************
!* move the entry at the top of the Estack to Level in Estack *
!* - the top entry is at level 1 *
!***********************************************************************
%record(Stkfmt) E
%integer I
%if Report#0 %thenstart
printstring("Edemote ");write(Level,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
%unless 0<Level<=Elevel %then abort
%if Level=1 %then %return
Level=Elevel-Level+1
E=Stk(Elevel)
Reset Reguse(Elevel,Elevel+1);! to avoid problems
%cycle I=Elevel,-1,Level+1
Stk(I)=Stk(I-1)
Reset Reguse(I-1,I)
%repeat
Stk(Level)=E
Reset Reguse(Elevel+1,Level)
%end;! Edemote
!*
%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%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
%if ProgFaulty#0 %then %return
%if CCset#0 %then Establish Logical
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if Area=Stack %then Offset=Offset+Stack Offset
%if Elevel=Stklimit %then %monitor %and %stop
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=AddrDir
Lstk_Size=4;! always 4 bytes for an address
Lstk_Base=Area
Lstk_Offset=Offset
Lstk_Adid=Adid
%end;! Estkaddr
!*
%externalroutine Estkgaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a global operand *
!***********************************************************************
%record(Stkfmt)%name Lstk
%if Report#0 %thenstart
printstring("Estkgaddr ")
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 CCset#0 %then Establish Logical
Offset=Offset+Param Offset
%if Elevel=Stklimit %then %monitor %and %stop
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=IndDirVal
Lstk_Size=4;! always 4 bytes for an address
Lstk_Base=0
Lstk_Offset=Display Offset + (Level*4)
Lstk_Modform=Litval
Lstk_Modoffset=Offset
Lstk_Adid=Adid
Eop(Eaddress)
%end;! Estkgaddr
!*
%externalroutine Estkreg(%integer reg,Offset)
!***********************************************************************
!* used by optimiser *
!***********************************************************************
%if Report#0 %thenstart
printstring("Estkreg ");write(Reg,4)
newline
%finish
%if ProgFaulty#0 %then %return
Stackr(reg,4)
Stk(Elevel)_Offset=Offset
Moptreguse(r6,0)
%end;! Estkreg
!*
%externalroutine Eregvar(%integer Offset,Size,Loadit)
!***********************************************************************
!* used by C *
!***********************************************************************
%integer I,Reg
%if Report#0 %thenstart
printstring("Eregvar");write(Offset,4);write(Size,4)
newline
%finish
%if ProgFaulty#0 %then %return
%return
%if Numregvars>0 %thenstart
%cycle I=1,1,Numregvars
%if Regvaroffset(I)=Offset %then %return
%repeat
%finish
%if Numregvars<4 %thenstart
I=Numregvars+1
Numregvars=I
Regvaroffset(I)=Offset
Regvarsize(I)=Size
Regvarclass(I)=RegVar
Regvarval(I)=8-I
Regvarload(I)=Loadit
%if Loadit#0 %thenstart
Numregvars=0 {to avoid mapping to reg}
Estkdir(Stack,Offset,0,Size)
Elevel=Elevel-1
Reg=Load Reg(Regvarval(I),Stk(Elevel+1))
%finish
%finish
%end
!*
%externalroutine Eloseregs(%integer Level)
%integer I,Count
%if Report#0 %thenstart
printstring("Eloseregs");write(Level,4);newline
%finish
Count=Numregvars
Numregvars=0
%if Count>0 %thenstart
%cycle I=1,1,Count
%if Regvarload(I)#0 %thenstart
Estkdir(Stack,Regvaroffset(I),0,Regvarsize(I))
Elevel=Elevel-1
Gop RX(ST,Regvarval(I),Stk(Elevel+1))
%finishelse Numregvars=I
%repeat
%finish
%end;! Eloseregs
!*
!*
!*
!* *********************
!* * Labels, Jumps *
!* *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label *
!***********************************************************************
%if Report#0 %thenstart
printstring("Elabel >>>>>>>>>>>>>>>>>>>>>>>>>>>>> L");write(Id,0)
newline
%finish
%if ProgFaulty#0 %then %return
{ %if Elevel>0 %then Abort}
Mcode label(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 Eboundlab(%integer Labid)
Bounderr=Labid
%end
!*
%externalroutine Ecjump(%integer Opcode,Labelid)
!* special for C - condition code set
%integer Op
%if Opcode=JFALSE %then Op=BEQ %else Op=BNE
Gop Jump(Op,Labelid)
%end;! Ecjump
!*
%routine Size8check
%if stk(Elevel-1)_size=8 %and Stk(Elevel)_size#8 %start
Estklit(8)
Eop(CVTII)
%finish
%if stk(Elevel-1)_size#8 %and stk(Elevel)_size=8 %start
Eop(Exch)
Estklit(8)
Eop(CVTII)
Eop(EXCH)
%finish
%end
!*
%externalroutine Ejump(%integer Opcode, Labelid)
!***********************************************************************
!* generate specified conditional or unconditional jump *
!***********************************************************************
%switch OpI(JIGT:JUMP),OpR(JRGT:JFALSE),OpU(JUGT:JULEZ)
%integer Reg1,Freg1,Bytes,Bcc,Bcond,I
%if Report#0 %thenstart
printstring("Ejump ".Eopname(Opcode));write(Labelid,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if CCset#0 %thenstart
%if Opcode=JINTZ %then Opcode=JFALSE
%if Opcode=JINTNZ %then Opcode=JTRUE
%if Opcode<JTRUE %then Establish Logical
%finish
%if Opcode<JRGT %thenstart
%if Opcode<JUGT %then ->OpI(Opcode) %else ->OpU(Opcode)
%finishelse ->OpR(Opcode)
!*
OpI(*):
OpI(*):
Abort
!*
OpI(JIGT):
OpI(JILT):
OpI(JIEQ):
OpI(JINE):
OpI(JIGE):
OpI(JILE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Size8check
Elevel=Elevel-2
Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2))
Gop Jump(BGT+CC,Labelid)
CCset=0
%return
!*
OpU(JUGT):
OpU(JULT):
OpU(JUEQ):
OpU(JUNE):
OpU(JUGE):
OpU(JULE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
{ Int Binary Op(IGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2)) }
{ Gop Jump(BGT+Opcode-JUGT,Labelid) }
CCset=0
%return
!*
OpI(JINTGZ):
OpI(JINTLZ):
OpI(JINTZ):
OpI(JINTNZ):
OpI(JINTGEZ):
OpI(JINTLEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Gop X(TST,Stk(Elevel+1))
Gop Jump(BGT+Opcode-JINTGZ,Labelid)
%return
!*
OpU(JUGTZ):
OpU(JULTZ):
OpU(JUEQZ):
OpU(JUNEZ):
OpU(JUGEZ):
OpU(JULEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
{ Gop X(TST,Stk(Elevel+1)) }
{ Gop Jump(BGT+Opcode-JUNTGZ,Labelid) }
%return
!*
OpI(JUMP):
Gop Jump(BU,Labelid)
%return
!*
OpR(JRGT):
OpR(JRLT):
OpR(JREQ):
OpR(JRNE):
OpR(JRGE):
OpR(JRLE):
%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))
Gop Jump(BGT+CC,Labelid)
CCset=0
%return
!*
OpR(JRGZ):
OpR(JRLZ):
OpR(JRZ):
OpR(JRNZ):
OpR(JRGEZ):
OpR(JRLEZ):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Gop X(TST,Stk(Elevel+1))
Gop Jump(BGT+Opcode-JRGZ,Labelid)
%return
!*
OpR(JTRUE):
Bcc=BGT+CC
Bcond=BNE
Jtf: %if CCset=0 %thenstart
%if Elevel=0 %and Language=Ccomp %then ->L1
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
%if Stk(Elevel+1)_Form=LitVal %thenstart
I=Stk(Elevel+1)_IntVal
%if (I=0 %and Bcond=BEQ) %or (I#0 %and Bcond=BNE) %thenstart
Gop Jump(BU,Labelid)
%return
%finish
%finish
Gop X(TST,Stk(Elevel+1))
L1: Gop Jump(Bcond,Labelid)
%return
%finish
Gop Jump(Bcc,Labelid)
CCset=0
%return
!*
OpR(JFALSE):
Bcc=BGT+Falsecc(CC)
Bcond=BEQ
->Jtf
%end;! Ejump
!*
%externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3)
!***********************************************************************
!* generate the code for a Fortran three-way jump *
!* opcode = ITWB or RTWB for integer or real expression on Estack *
!* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0 *
!* - if Labi <= 0 that jump is not required *
!***********************************************************************
%integer Op,Reg1,Freg1,Bytes
%if Report#0 %thenstart
printstring("Etwjump ".Eopname(Opcode))
write(Lab1,4);write(Lab2,4);write(Lab3,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Gop X(TST,Stk(Elevel+1))
%if Lab1>0 %then Gop Jump(BLT,Lab1);! if < 0
%if Lab2>0 %then Gop Jump(BEQ,Lab2);! = 0
%if Lab3>0 %then Gop Jump(BGT,Lab3);! > 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 for the switch table *
!***********************************************************************
%integer Refad,Base,Mode,Reg,Op,p,c,plab,plab1,i,numcases
%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
%if Ccset#0 %then Establish Logical
%if Language=CCOMP %thenstart
numcases=Errlabid
%if lower<0 %and upper>0 %thenstart {protect aggainst overflow}
i=(-lower)>>1 + upper>>1
%if i>>30=1 %then ->unsafe
%finish
%if upper-lower>256 %and upper-lower>10*numcases %thenstart
unsafe:
numcsw=numcsw+1
csw(numcsw)_id=switchid
csw(numcsw)_count=numcases
csw(numcsw)_lower=lower
csw(numcsw)_index=0
upper=numcases
lower=0
csw(numcsw)_plt=pltspace((numcases+1)<<2)
base=SSTad
Refad=SSTad
SSTad=SSTad+(Upper+1)<<2
note reguse(r0,0,4)
note reguse(r1,0,4)
elevel=elevel-1
reg=load int(Stk(Elevel+1),r0)
p=csw(numcsw)_plt
c=csw(numcsw)_count
plab1=mprivatelabel
%cycle I=1,1,c
Plab=mprivatelabel
eafix(PLT,0)
Gop RXB(CAM,r0,0,0,p,4)
Gop Jump(BNE,Plab)
Gop RI(LI,r1,I)
Gop Jump(BU,plab1)
Mcode Label(Plab)
p=p+4
%repeat
Gop Jump(BU,switchid)
Mcode Label(Plab1)
Mswitch(0,Refad,Base,Upper+1,switchid,switchid)
%return
%finishelsestart
numcsw=numcsw+1
csw(numcsw)_id=switchid
csw(numcsw)_plt=0
csw(numcsw)_lower=lower
%unless lower=0 %thenstart
Estklit(lower)
Eop(ISUB)
%finish
Upper=Upper-Lower
Lower=0
%finish
%finish
Base=SSTad
Refad=SSTad - (Lower*4)
SSTad=SSTad+(Upper-Lower+1)<<2
%if Language=FORTRAN %or Language=CCOMP %thenstart;! computed GOTO or C case
Elevel=Elevel-1
Note Reguse(r1,0,4) {ensure that reg is loaded for test}
Reg=Load Int(Stk(Elevel+1),r1) { load GOTO index }
%if Language=FORTRAN %then Op=BLE %else Op=BLT
Gop Jump(Op,Switchid)
Estklit(Upper)
Gop RX(CAM,Reg,Stk(Elevel))
Elevel=Elevel-1
Gop Jump(BGT,Switchid)
%if Language=FORTRAN %thenstart
Mswitch(1,Refad,Base,Upper,Switchid,0)
Mcode Label(Switchid)
%finishelsestart {C case}
Mswitch(0,Refad,Base,Upper+1,Switchid,Switchid)
%finish
%finishelsestart;! IMP switch
Mcode Label(Switchid)
Mswitch(0,Refad,Base,Upper-Lower+1,Switchid,Errlabid)
%finish
%end;! Eswitch
!*
%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) ) *
!* if (Etos) is outside the bounds defined for Switchid then error *
!***********************************************************************
%integer Reg
%if Report#0 %thenstart
printstring("EswitchJump ");write(switchid,4)
newline
%finish
%if Elevel<1 %then Low Estack(JUMP,1) %and %return
Elevel=Elevel-1
Reg=Load Int(Stk(Elevel+1),r1) { load switch index }
Ejump(JUMP,Switchid)
Note Reguse(r1,0,0)
%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 *
!* N.B. this procedure is only used on Amdahl *
!***********************************************************************
{ abortm("EfswitchJump") }
%end;! EfswitchJump
!*
%externalroutine Eswitchentry(%integer Switchid, Entry)
!***********************************************************************
!* define the current code address as Switchid(Entry) *
!***********************************************************************
%integer I
%if Report#0 %thenstart
printstring("Eswitchentry ");write(Switchid,4);write(Entry,4)
newline
%finish
Clear Regs
%if Language=Ccomp %thenstart
%if numcsw>0 %thenstart
%cycle i=1,1,numcsw
%if csw(i)_id=switchid %thenstart
%if csw(i)_plt=0 %thenstart {simple switch}
Entry=Entry-csw(i)_lower
%finishelsestart {multiple test}
Ed4(Plt,csw(i)_plt,entry)
csw(i)_plt=csw(i)_plt+4
entry=csw(i)_index+1
csw(i)_index=entry
%finish
%exit
%finish
%repeat
%finish
%finish
Mswitchentry(Switchid, Entry)
%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
Abort
%end;!Eswitchdef
!*
%externalroutine EswitchLabel(%integer Switchid, Entry, Labelid)
!***********************************************************************
!* define Labelid as Switchid(Entry) *
!***********************************************************************
%integer I
%if Report#0 %thenstart
printstring("EswitchLabel ");write(switchid,4);write(entry,4)
write(labelid,4)
newline
%finish
%if ProgFaulty#0 %then %return
Clear Regs
Mswitchlabel(Switchid,Entry,Labelid)
%end;! EswitchLabel
!*
!*
!*
!* *******************************
!* * Data initialisation, fixups *
!* *******************************
!*
!*
%externalroutine Ed1(%integer area, Disp, Val)
!***********************************************************************
!* intialise an 8-bit location *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ed1 ".Areas(Area)." +");write(Disp,1)
spaces(4);Phex(Val)
newline
%finish
%if ProgFaulty#0 %then %return
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if area>10 %then areaprops(area)=areaprops(area)!X'400' %c
%and area=areaid(area)
Md(area, Disp, Val)
%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 Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if area>10 %then areaprops(area)=areaprops(area)!X'400' %c
%and area=areaid(area)
Md2(area, Disp, Val)
%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 Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if area>10 %then areaprops(area)=areaprops(area)!X'400' %c
%and area=areaid(area)
Md4(area, Disp, Val)
%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 Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if Area=10 %then %monitor;! should not be allocated any more
%if area>10 %then areaprops(area)=areaprops(area)!X'400' %c
%and area=areaid(area)
Mdbytes(area, disp, 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 Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
%if area>10 %then areaprops(area)=areaprops(area)!X'400' %c
%and area=areaid(area)
Mdpattern(area, Disp, ncopies, len, ad)
%end;!Edpattern
!*
%externalroutine Edbits(%integer area, Disp, Bitoffset, Numbits, Val)
!***********************************************************************
!* intialise a bit field *
!***********************************************************************
%integer Mask1,Mask2,I,J
%if Report#0 %thenstart
printstring("Edbits ".Areas(Area)." +");write(Disp,1)
write(Bitoffset,4);write(Numbits,4);write(Val,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
I=(32-Bitoffset-Numbits)
Mask1=Bmaskval(Numbits-1)
Val=(Val&Mask1)<<I
Mask2=(Mask1<<I)!!(-1)
%if area=Bitarea %and Disp=Bitdisp %thenstart {add to existing init}
integer(Initdataad)=(integer(Initdataad)&Mask2)!Val
%finishelsestart {new bit initialisation}
%return %if Val=0
Bitarea=area
Bitdisp=disp
Md4(area,disp,Val)
%finish
%end;! Edbits
!*
%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 Language=Ccomp %thenstart
%if Area=5 %then Area=8
%if tgtarea=5 %then tgtarea=8
%finish
%if tgtarea>10 %then tgtarea=areaid(tgtarea)
%if tgtdisp#0 %then Md4(area,disp,tgtdisp)
Mfix(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 I
%if Report#0 %thenstart
printstring("EXname ".Xref);write(Type&15,4);write(Type>>4,4)
newline
%finish
%if ProgFaulty#0 %then %result=1
{ I=MXname(0,Xref) }
%result=Get Prockey(Xref)
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprecall ")
newline
%finish
Mprecall
%end;! Eprecall
!*
%externalroutine Ecall2(%integer Id,Xlevel,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id *
!* Xlevel is the level of the called routine 1=Global etc *
!* Numpars and paramsize(bytes) are obvious *
!***********************************************************************
%if Report#0 %thenstart
printstring("Ecall2 "); write(Id,4); write(xlevel,4)
write(Numpars,6); write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
Freeregs
Gop Call(Id,Paramsize,numpars,Xlevel)
%end;! Ecall2
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id *
!***********************************************************************
Ecall2(Id,99,Numpars,Paramsize)
%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
%unless Language=Ccomp %or Language=Pascal %thenstart
%if Language=IMp %thenstart
%if Level>1 %thenstart
Estkdir(Stack,Display Offset + (Level*4),0,4)
%finishelse Estklit(0)
%finishelse Estklit(0)
%finish
Stackr(Get Procref(Id),4)
%end;! Eprocref
!*
%externalroutine Eprocenv(%integer Level)
!**********************************************************************
!* stack the environment of a procedure being passed as a parameter *
!**********************************************************************
%if Report#0 %thenstart
printstring("Eprocenv "); write(Level,4)
newline
%finish
%if ProgFaulty#0 %then %return
%if Language=IMP %or Language=Pascal %thenstart
%if Level>1 %thenstart
%if Language=Pascal %thenstart
Estkdir(Stack,(Level-2)*8,0,4)
%finishelsestart
Estkdir(Stack,Display Offset+(Level*4),0,4)
%finish
%finishelse Estklit(0)
%finishelse Estklit(0)
%end;! Eprocenv
!*
!*
%externalroutine Eprocptr(%integer Area,Offset,%string(255)%name S)
!***********************************************************************
!* establish a pointer to a procedure at Offset in Area *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eprocptr ");write(Area,4);write(Offset,4)
printstring(" ".S)
newline
%finish
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
Mset Procref(Area,Offset,S)
%end;! Eprocptr
!*
%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* a (hopefully) redundant IMP requirement *
!***********************************************************************
%if Report#0 %thenstart
printstring("Esave ");write(Asave,4)
newline
%finish
%end;! Esave
!*
%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* a (hopefully) redundant IMP requirement *
!***********************************************************************
%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 *
!***********************************************************************
%string(3) S
%if Report#0 %thenstart
printstring("Enextproc ")
newline
%finish
S=""
%result=Get Prockey(S)
%end;! Enextproc
!*
%externalroutine Eproclevel(%integer Level)
!***********************************************************************
!* record static nesting level of the current procedure *
!***********************************************************************
%if Report#0 %thenstart
printstring("Eproclevel ");write(Level,3)
newline
%finish
ProcLevel = Level
%end;! Eproclevel
!*
%externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize,
Astacklen, %integername Id)
!***********************************************************************
!* define the start of a procedure body *
!* if Id > 0 this is the Id returned by a previous call of Enextproc *
!* Astacklen is the address of the word noting the current local *
!* stack-frame size *
!* *
!* PDS thinks props is as follows:? *
!* 2**0 Set if external *
!* 2**1 Set if main entry (2**31 is used by Fortran!) *
!* 2**2 Set if display not required (Implied for Fortran & C) *
!* 2**3 Set if there are no local variables *
!* 2**4 Set if ?? PDS has vague memories this was used on PNX*
!* 2**5 Set if there are no internal blocks or procedures *
!* 2**14 Set if first param is a word *
!* 2**15 Set if first param a Dword Used if Numpars = 1? *
!* 2**16-2**23 Byte giving nesting level of procedure *
!***********************************************************************
%integer Pprops,Ca,Disp,Putid,I,Reg
%record(Stkfmt) S1,S2
%if Report#0 %thenstart
printstring("Eproc ");printstring(Name);write(props&X'ffff',4)
write(Numpars,4); write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
Clear Regs
%unless Astacklen=-1 %then Addrstackca=Astacklen
%unless Language=PASCAL %then ProcLevel=ProcLevel+1
%if Language=PASCAL %and Proclevel=1 %then Props=2
%if Props&2#0 %then Pprops=X'80000001' %else Pprops=Props&1
Ca=Mgetca(0)
Minnerproc(0)
%if Props&3#0 %thenstart;! to be externally visible
Putid=-1
Mproc(Name,Pprops,Ca,Putid,Savelineno+1)
Visibleproc=Proclevel
%finish
Id=Note Entry(Name,Id,Ca,1)
Curdiagca=-1
Display Offset=Paramsize
Procprops(Proclevel)=Props
Procstkmark(ProcLevel)=Mmarker
Noteparamsize(Proclevel)=Paramsize
Mstartproc(Props,Proclevel,Paramsize)
%end;! Eproc
!*
%externalroutine Eprocend(%integer Localsize,Diagdisp,Astacklen)
!***********************************************************************
!* called at procedure end *
!* Localsize is the total stack-frame requirement (excluding red tape) *
!* Astacklen is the address of the word noting the current local *
!* stack-frame size of th enclosing procedure *
!***********************************************************************
%integer Ca
%if Report#0 %thenstart
printstring("Eprocend ");write(Localsize,6)
newline
%finish
%if ProgFaulty#0 %then %return
Keycommon=-1
Numregvars=0
%if Language=PASCAL %then Eop(RETURN)
%if Language=IMP %then Localsize=Localsize+Noteparamsize(Proclevel)
Mtidyproc(Procstkmark(Proclevel),Localsize,Notediagdisp,Ca)
%if Visibleproc=Proclevel %thenstart
Mprocend(Ca)
Visibleproc=0
%finish
Minnerproc(1)
ProcLevel=ProcLevel-1
Display Offset=Noteparamsize(Proclevel)
%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) *
!***********************************************************************
%integer Id,ca,Procid,Reg
%record(Stkfmt) S1,S2
%if Report#0 %thenstart
printstring("Eentry ".Name);write(Index,4)
write(Numpars,4);write(Paramsize,4)
newline
%finish
%if ProgFaulty#0 %then %return
Notediagdisp=Diagdisp
%if Index=0 %then %return;! prologue start in Eproc
Ca=Mgetca(1)
Id=Mentry(Index,ca,Name)
Procid=-1
Id=Note Entry(Name,Procid,Ca,0)
Msideentry(Ca)
%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
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
Mdataentry(Name,Area,Length,Offset)
%end;! Edataentry
!*
%externalroutine Edataref(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* requests a data ref to Name (with at least Length)at Offset in Area *
!***********************************************************************
%integer Id
%if Report#0 %thenstart
printstring("Edataref ".Name);write(Area,4)
write(Offset,4);write(Length,4)
newline
%finish
%if Language=Ccomp %thenstart
%if Area=5 %then Area=8
%finish
Id=Mxname(0,Name)
Mdxref(Area,Offset,Id)
%end;! Edataref
!*
!*
!*
!* ********************
!* * Ecode operations *
!* ********************
!*
%ownrecord(Stkfmt) Csavestk
!*
%externalroutine Eop(%integer Opcode)
!***********************************************************************
!* opcodes with general applicability *
!***********************************************************************
%integer Reg1,Reg2,Freg1,Bytes,Form,I
%constbyteintegerarray Logop(0:3)=SLL,SRL,SLA,SRA
%constbyteintegerarray DLogop(0:3)=SLLD,SRLD,SLAD,SRAD
%constbyteintegerarray Opst(0:11) = %c
IADD,ISUB,IMULT,IDIV,0,UREM,UDIV,IAND,IOR,0,IXOR,IREM
%constbyteintegerarray Gopst(0:10) = ADM,SUM,MPM,DVM,0,0,0,ANM,ORM,0,EOM
%if Cpu = NP1 %thenstart
%constbyteintegerarray IncOp(0:8) = 0, INCMB, INCMH, 0, INCMW, 0, 0, 0, INCMD
%finish
%switch Op(0:255)
%if Opcode>=768 %thenstart
Eccop(Opcode)
%return
%finish
%if Report#0 %thenstart
printstring("Eop ".Eopname(Opcode))
newline
Dump Estack
%finish
%if ProgFaulty#0 %then %return
!*
%if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
->Op(Opcode)
Op(HALT):
%if Elevel>=2 %and Stk(Elevel)_Form=Litval=Stk(Elevel-1)_Form %Start
Elevel=Elevel-2
I=Stk(Elevel+1)_Intval
%if Stk(Elevel+2)_Intval=4 %then CodeW(i>>16,i&X'FFFF') %else CodeH(i)
Clearregs
%return
%finish
Op(*):%monitor
Unsupported Opcode(Opcode)
%return
!*
Op(IADD):
Op(ISUB):
Op(IMULT):
Op(IDIV):
!*
Op(IREM):
!*
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
Size8check
%if (opcode=IMULT %or opcode=IDIV) %and stk(Elevel)_size=8 %start
%if opcode=IMULT %then spcall(27) %else spcall(28)
%return
%finish
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(UDIV):
Spcall(29)
%return
!*
Op(UREM):
Spcall(30)
%return
!*
Op(UADD):
Op(USUB):
Opcode=Opcode-UADD+IADD
%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(UGT):
Op(ULT):
Op(UEQ):
Op(UNE):
Op(UGE):
Op(ULE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Convert IU(Stk(Elevel+1),8)
Epromote(2)
Elevel=Elevel-1
Convert IU(Stk(Elevel+1),8)
Epromote(2)
Elevel=Elevel-2
Int Binary Op(Opcode-UGT+IGT,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(IADDST):
%if Ecdupflag#0 %or Stk(Elevel-1)_Form&31=Regval %then ->Op(ISUBST)
Elevel=Elevel-2
%if Stk(Elevel+1)_Form&31>=RegVar %thenstart
I=ADM
Regop: Gop RX(I,Stk(Elevel+1)_Reg,Stk(Elevel+2))
%return
%finish
%if Cpu = NP1 %thenstart
%if Stk(Elevel+2)_Form=LitVal %and 0<=Stk(Elevel+2)_IntVal<=8 %c
%and Stk(Elevel+1)_Size=4 %thenstart
I = IncOp(Stk(Elevel+2)_IntVal)
%if I # 0 %thenstart
Gop X(I,Stk(Elevel+1))
%return
%finish
%finish
%finish
Reg1=Load Int(Stk(Elevel+2),-1)
Gop RX(ARM,Reg1,Stk(Elevel+1))
Unlock Reg(Reg1)
%return
!*
Op(UDIVST):
Op(UREMST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST):
Op(IANDST):
Op(IORST):
Op(IXORST):
Op(IREMST):
%if Stk(Elevel-1)_Form&31>=RegVar %thenstart
Elevel=Elevel-2
I=Gopst(Opcode-IADDST)
->Regop
%finish
%if Stk(Elevel-1)_Form&31=Regval %thenstart;! C has coerced
Eop(Opst(Opcode-IADDST))
Elevel=Elevel+1
Stk(Elevel-1)_Size=Csavestk_Size
Stk(Elevel)=Csavestk
%finishelsestart
Eop(EXCH)
Eop(DUPL)
Epromote(3)
Eop(Opst(Opcode-IADDST))
Stk(Elevel)_Size=Stk(Elevel-1)_Size {to ensure STH when appropriate}
Eop(EXCH)
%finish
%if Ecdupflag#0 %thenstart
Ecdupflag=0
Eop(EDUPSTORE)
%finishelsestart
Eop(ESTORE)
%finish
%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(ISHLL):
!*
Op(ISHRL):
!*
Op(ISHLA):
!*
Op(ISHRA):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
%if stk(Elevel+1)_size=8 %and stk(elevel+2)_form=litval %and stk(elevel+2)_intval=32 %start
%if opcode=ISHLL %start
%if stk(Elevel+1)_form&31=regval %start
reg1=stk(elevel+1)_reg
Gop RR(TRR,reg1,reg1+1)
lock reg pair(reg1)
%finishelsestart
%if stk(Elevel+1)_form=Dirval %start
Stk(Elevel+1)_size=4
Stk(Elevel+1)_offset=Stk(Elevel+1)_Offset+4
reg1=Claim reg pair(1)
reg1=Load Int(stk(Elevel+1),reg1)
%finishelsestart
reg1=Claim reg pair(1)
reg1=Load Int(stk(Elevel+1),reg1)
Gop RR(TRR,reg1,reg1+1)
lock reg pair(reg1)
%finish
%finish
Gop R(Zr,reg1+1)
stackr(reg1,8)
%return
%finish
%finish
Reg1=Load Int(Stk(Elevel+1),-1)
%if stk(Elevel+1)_size=8 %then i=Dlogop(opcode-ISHLL) %c
%else i=logop(opcode-ISHLL)
Gop Shift(i,Reg1,Stk(Elevel+2))
Stackr(Reg1,Stk(Elevel+1)_size)
%return
!*
Op(RETURN):
Gop Return
%return
!*
Op(SFA):
Unsupported Opcode(Opcode) { auxiliary stack used on Gould }
%return
!*
Op(ASF):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Unsupported Opcode(Opcode) { auxiliary stack used on Gould }
%return
!*
Op(IPUSH):
!*
Op(IPOP):
Unsupported Opcode(Opcode)
%return
!*
Op(EXCH):
Epromote(2)
%return
!*
Op(DUPL):
I=Stk(Elevel)_Form&31
%if 14<=I<=17 %thenstart
Reg1=Load Int(Stk(Elevel),-1)
Elevel=Elevel-1
Stackr(Reg1,stk(elevel)_size)
%if I=18 %then I=RegVal %else I=RegAddr
Stk(Elevel)_Form=I!32
%finish
Stk(Elevel+1)=Stk(Elevel)
Elevel=Elevel+1
Form=Stk(Elevel)_Form&31
%if Form=RegVal %or Form=RegAddr %c
%or Form=IndRegModVal %thenstart
%if stk(Elevel)_size<=4 %start
Reg1=Claim Reg { (Stk(Elevel)_Reg) }
%finishelsestart
reg1=Claim reg pair(1)
Gop RR(TRR,reg1+1,stk(Elevel-1)_reg+1)
%finish
Stk(Elevel)_Reg=Reg1
Gop RR(TRR,Reg1,Stk(Elevel-1)_Reg)
Note Reguse(Reg1,-Elevel,stk(Elevel)_size)
%finishelsestart
%if Form=FregVal %thenstart
Freg1=Claim Freg
!?? %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
I=Stk(Elevel)_Form&31
%if I=RegVal %or I=FregVal %or I=IndRegVal %or I=IndRegModVal %thenstart
Note Reguse(Stk(Elevel)_Reg,0,Stk(Elevel)_Size)
%finish
%if I>=AddrDirMod %thenstart
%if Stk(Elevel)_Modform=RegVal %then Note Reguse(Stk(Elevel)_Modreg,0,4)
%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
I=Opcode-INDEX1
NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1))
%return
!*
Op(INDEX):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-2
%if Language=IMP %thenstart;! mixes 16 and 32 bit operands
Elevel=Elevel+2
%if Stk(Elevel)_Size=2 %thenstart
Estklit(4)
Eop(CVTII)
%finish
%if Stk(Elevel-1)_Size=2 %thenstart
Epromote(2)
Estklit(4)
Eop(CVTII)
Epromote(2)
%finish
Elevel=Elevel-2
%finish
Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2))
Elevel=Elevel-1
I=0
->NoteI
!*
Op(MVB):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Gop Mvb(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
%return
!*
Op(EZERO):
Elevel=Elevel-2
%return
!*
Op(CHK):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
bytes=stk(Elevel-2)_size
%if bytes>4 %Start; ! longinteger chk difficult
Eop(DISCARD); Eop(DISCARD)
%return
%finish
Elevel=Elevel-3
Reg1=Load Int(Stk(Elevel+1),-1)
Gop RX(CAM,Reg1,Stk(Elevel+2))
Gop Jump(BLT,Bounderr)
Gop RX(CAM,Reg1,Stk(Elevel+3))
Gop Jump(BGT,Bounderr)
Stackr(Reg1,4)
%return
!*
Op(TMASK):
Unsupported Opcode(Opcode)
%return
!*
Op(CPBGT):
!*
Op(CPBLT):
!*
Op(CPBEQ):
!*
Op(CPBNE):
!*
Op(CPBGE):
!*
Op(CPBLE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Gop Cpb(Opcode-CPBGT,Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
CCset=1
CC=Opcode-CPBGT
%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(CVTSBI):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert SBI(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(CVTIU):
Op(CVTUI):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
%if Language=Ccomp %then Csavestk=Stk(Elevel-1)
Elevel=Elevel-2
Convert IU(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(CVTUR):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Convert UR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(CVTRU):
Elevel=Elevel-1
%return
!*
Op(UCVTII):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
%if Language = Ccomp %then Csavestk=Stk(Elevel-1)
Elevel=Elevel-2
Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(CVTII):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
%if Language = Ccomp %then Csavestk=Stk(Elevel-1)
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(0,Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Op(TNCRI):
Op(RNDRI):
Op(EFLOOR):
%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(TNCRR):
%if Elevel<1 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Convert RR(1,Stk(Elevel+1),Stk(Elevel+1)_Size)
%return
!*
Op(RNDRR):
%if Elevel<1 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-1
Convert RR(2,Stk(Elevel+1),Stk(Elevel+1)_Size)
%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=Claim Reg
!?? Op RX(LA,Reg1,Stk(Elevel))
Stk(Elevel)_Form=IndRegVal!Regflag
Stk(Elevel)_Reg=Reg1
!! dreguse(Reg1)=-Elevel
%finish
!?? PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32)
!?? Pjump(BC,Unasslab,8,R14)
%return
!*
!
! PDS found the coding for EDUPSTORE worked only for very simple cases
! and woulf not support IMP parm opt which uses this feature extensively
! The code has been rewritten and combined with that for ESTORE (Jan89)
!
Op(EDUPSTORE):
Op(ESTORE):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
%if AddrConst<=Stk(Elevel+2)_Form&31<=DirModAddr %thenstart
Refer(Stk(Elevel+2),0)
Stk(Elevel+2)_Size=Stk(Elevel+1)_Size
%finish
Bytes=Stk(Elevel+2)_Size
Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),Opcode-Estore)
%if Opcode=EDUPSTORE %then %start
%if Stk(Elevel+1)_Form=RegVar %then Elevel=Elevel+1 %else Stackr(Reg1,bytes)
%finish
%return
Op(PUSHADDR):
Address(Stk(Elevel))
!*
Op(PUSHVAL):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Push Param(Stk(Elevel+1))
%return
!*
Op(EVAL):
%if Elevel<1 %then low estack(opcode,1) %and %return
Release reg(r0)
reg1=load reg(r0,stk(Elevel))
Elevel=Elevel-1
Stackr(reg1,Stk(Elevel+1)_Size)
%return
Op(MVW):
%if Elevel<3 %then Low estack(Opcode,3) %and %return
Elevel=Elevel-3
Gop Mvlong(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2),4)
%return
!*
Op(EVALADDR):
Op(EADDRESS):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Address(Stk(Elevel))
Stk(Elevel)_Size=4
%if Opcode=EADDRESS %then %return
Release reg(r1)
Reg1=load reg(R1,stk(Elevel))
Elevel=Elevel-1
Stackr(Reg1,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
%if stk(elevel)_form&31#regval %then free regs %And Note reguse(R2,-255,4)
Elevel=Elevel-1
%if Cpu=Concept %thenstart
Reg1=r0
%finishelsestart
Reg1=r2
%finish
Bytes=Stk(Elevel+1)_Size
Reg1=Load Int(Stk(Elevel+1),Reg1)
Note Reguse(Reg1,0,bytes)
%if cpu=concept %then notereguse(R2,0,0)
%return
!*
Op(EREALRES):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Bytes=Stk(Elevel)_Size
%if stk(elevel)_form&31#fregval %then free regs %and note reguse(R2,-255,Bytes)
Elevel=Elevel-1
%if Cpu=Concept %thenstart
Reg1=r0
%finishelsestart
Reg1=r2
%finish
Reg1=Load Real(Stk(Elevel+1),Reg1,Stk(Elevel+1)_Size)
Note reguse(Reg1,0,Bytes)
%if cpu=concept %then note reguse(R2,0,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<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Freeregs
Reg1=Load Int(Stk(Elevel+1),r0)
%if (Language=Pascal %or Language=IMp) %and Stk(Elevel+2)_Form %c
#Litval %start
%if Cpu=Concept %then Reg1=r1 %else Reg1=r7
Gop RX(L,Reg1,Stk(Elevel+2)); ! Load display pointer
%finish
Gop Call(0,Stk(Elevel+3)_Intval,0,0)
%return
!*
Op(EAUXSF):
%if auxaddr=0 %then auxaddr=Eglaspace(4) %and %c
Edataref(Gla,auxaddr,4,auxsname)
Estkind(Gla,auxaddr,0,4)
%return
!*
Op(EAUXADD):
%if auxaddr=0 %then auxaddr=Eglaspace(4) %and %c
Edataref(Gla,auxaddr,4,auxsname)
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
%if Saveoptions&256#0 %start; ! Imp Unass checking on
Estklit(1)
Eop(EXCH)
Spcall(21); ! support procedure will fill with X80s
Eop(Discard); ! Stack pointer not wanted
%else
Estkind(Gla,auxaddr,0,4)
Eop(IADD)
Estkind(Gla,auxaddr,0,4)
%if Saveoptions&512#0 %and Language=Imp %start
Eop(EDUPSTORE)
Estkdir(Gla,auxaddr,0,4)
Erefer(4,4)
Ejump(JIGT,Bounderr)
%finish %else Eop(ESTORE)
%finish
%return
!*
Op(EAUXRES):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Gop RXB(ST,R2,BR2,0,16,8); ! result may be loeded
Estkind(Gla,auxaddr,0,4)
EOP(ESTORE)
Gop RXB(L,R2,BR2,0,16,8); ! result may be loeded
%return
!*
Op(EOLDLNB):
Gop RXB(L,r1,br1,0,0,4)
Gop RXB(LA,r1,br2,r1,0,0)
Stackr(r1,4)
%return
!*
Op(Ecdup):
Ecdupflag=1
%return
!*
Op(EMAKED): ! make a double integer out of two singles
! etos is the MSh
Reg1=claim reg pair(1)
Elevel=Elevel-2
Reg2=load int(Stk(Elevel+2),reg1)
Reg2=load int(Stk(Elevel+1),Reg1+1)
UNlock reg pair(REg1)
Stackr(Reg1,8)
%return
Op(ESPLITD): ! Split a long int converse of EMAKED
Elevel=Elevel-1
Reg1=load int(Stk(Elevel+1),-1)
UNlock reg pair(Reg1)
Stackr(Reg1+1,4)
Stackr(Reg1,4)
%return
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran *
!***********************************************************************
%integer Reg1,Reg2,Reg3,Freg1,Freg2,Bytes,Relop,Lab1,Lab2,Op,Shift,Val
%integer B1,D1,Flags,SceReg,DestReg
%record(Stkfmt) Tstk,Regstk,Fregstk
%switch F77op(256:322)
%if Report#0 %thenstart
printstring("Ef77op ".Ef77opname(Opcode))
newline
Dump Estack
%finish
%if ProgFaulty#0 %then %return
!*
%if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
Bytes=Stk(Elevel)_Size
->F77op(Opcode)
!*
F77op(*):Abort
!*
F77op(CXADD):
!*
F77op(CXSUB):
!*
F77op(CXMULT):
!*
F77op(CXDIV):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Opcode=Opcode&X'FF'
Flags=Stk(Elevel+4)_Intval
Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3))
%return
!*
F77op(CXNEG):
!*
F77op(CXASGN):
!*
F77op(CXEQ):
!*
F77op(CXNE):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Opcode=Opcode&X'FF'
Flags=Stk(Elevel+3)_Intval
->Cxop
!*
F77op(EM1EXP):
Elevel=Elevel-1
Reg1=claim reg
Gop RI(LI,Reg1,1)
Reg2=Load Int(Stk(Elevel+1),-1)
%if Reg2=r7 %thenstart
Reg2=claim reg
Gop RR(TRR,Reg2,r7)
Note Reguse(r7,0,0)
%finish
%if bytes<=4 %then Gop RR(ANR,Reg2,Reg1) %else Gop RR(ANR,reg2+1,reg1)
Lab1=Mprivatelabel
Gop Jump(BEQ,Lab1)
Gop RR(TRN,Reg1,Reg1)
Mcode Plabel(Lab1)
Note Reguse(Reg2,0,0)
Stackr(Reg1,bytes)
%return
!*
F77op(EISIGN):
Elevel=Elevel-1
Eop(IABS)
Reg1=Stk(Elevel)_Reg
Elevel=Elevel-1
%if Stk(Elevel+2)_Form&31=Regval %thenstart
Reg2=Stk(Elevel+2)_Reg
Gop RR(TRR,Reg2,Reg2);! to set condition
%finishelse Reg2=Load Int(Stk(Elevel+2),-2)
Lab1=Mprivatelabel
Gop Jump(BGE,Lab1)
%if bytes<=4 %start
Gop RR(TRN,Reg1,Reg1)
%finishelsestart
Release reg pair(reg1)
reg1=Claim reg pair(1)
Gop R(zr,reg1); gop r (Zr,reg1+1)
Gop RX(SUM,reg1,stk(Elevel+2))
%finish
Mcode Plabel(Lab1)
unlock reg(Reg2)
Stackr(Reg1,bytes)
%return
!*
F77op(ESIGN):
Elevel=Elevel-1
Eop(RABS)
Reg1=Stk(Elevel)_Reg
Note Reguse(Reg1,-255,bytes)
Elevel=Elevel-1
%if Stk(Elevel+2)_Form&31=Fregval %thenstart
Reg2=Stk(Elevel+2)_Reg
Gop RR(TRR,Reg2,Reg2);! to set condition
%finishelse Reg2=Load Real(Stk(Elevel+2),-2,Bytes)
Lab1=Mprivatelabel
%if Bytes=4 %thenstart
Gop Jump(BGE,Lab1)
Gop RR(TRN,Reg1,Reg1)
unlock reg(Reg2)
%finishelsestart
Gop Jump(BGE,Lab1)
%if Cpu = NP1 %thenstart
Gop RR(TRND,Reg1,Reg1)
%finishelsestart
Gop RR(TRC,Reg1,Reg1)
Gop RR(TRC,Reg1+1,Reg1+1)
%finish
unlock reg pair(Reg2)
%finish
Mcode Plabel(Lab1)
Stackfr(Reg1,Stk(Elevel+1)_Size)
%return
!*
F77op(EIMOD):
Elevel=Elevel-2
Int Binary Op(IREM,Stk(Elevel+1),Stk(Elevel+2))
%return
!*
F77op(ERMOD):
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
Reg2=Load Real(Stk(Elevel+2),-1,Bytes)
%if Bytes=4 %thenstart
Reg3=claim reg
%if Cpu = NP1 %thenstart
Gop RR(Trr,reg3,reg2)
Gop R(RRFW,Reg3) { Reg3 = 1/a2 }
Gop RR(MPRFW,Reg3,Reg1) { Reg3 = a1/a2 }
%finishelsestart
Gop RR(TRR,Reg3,Reg1) { Reg3 = a1 }
Gop RR(DVRFW,Reg3,Reg2) { Reg3 = a1/a2 }
%finish
Gop RR(FIXW,Reg3,Reg3)
Gop RR(FLTW,Reg3,Reg3)
Gop RR(MPRFW,Reg3,Reg2)
Gop RR(SURFW,Reg1,Reg3)
%if Cpu=NP1 %thenstart {additional check for reciprocal error}
Gop RR(TRABS,Reg3,Reg1)
Gop RR(TRABS,Reg2,Reg2)
Lab1=Mprivatelabel
Gop RR(CAR,Reg2,Reg3)
Gop Jump(BNE,Lab1)
Gop R(ZR,Reg1)
Mcode Plabel(Lab1)
%finish
unlock reg(Reg2)
unlock reg(Reg3)
%finishelsestart {8 bytes}
Reg3=claim reg pair(1)
%if Cpu = NP1 %thenstart
Gop RR(Trr,reg3,reg2)
Gop RR(Trr,reg3+1,reg2+1)
Gop R(RRFD,Reg3) { Reg3 = 1/a2 }
Gop RR(MPRFD,Reg3,Reg1) { Reg3 = a1/a2 }
%finishelsestart
Gop RR(TRR,Reg3,Reg1)
Gop RR(TRR,Reg3+1,Reg1+1) { Reg3 = a1 }
Gop RR(DVRFD,Reg3,Reg2) { Reg3 = a1/a2 }
%finish
Gop RR(FIXD,Reg3,Reg3)
Gop RR(FLTD,Reg3,Reg3)
Gop RR(MPRFD,Reg3,Reg2)
Gop RR(SURFD,Reg1,Reg3)
%if Cpu=NP1 %thenstart {additional check for reciprocal error}
Gop RR(TRABSD,Reg3,Reg1)
Gop RR(TRABSD,Reg2,Reg2)
Lab1=Mprivatelabel
Gop RR(CARD,Reg2,Reg3)
Gop Jump(BNE,Lab1)
Gop R(ZR,Reg1)
Gop R(ZR,Reg1+1)
Mcode Plabel(Lab1)
%finish
unlock reg pair(Reg2)
unlock reg pair(Reg3)
%finish
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIDIM):
Eop(ISUB)
%if Stk(Elevel)_Form=Litval %thenstart {both operands literal - compile-time evaluation}
%if Stk(Elevel)_Intval<0 %then Stk(Elevel)_Intval=0
%return
%finish
Reg1=Stk(Elevel)_Reg
Elevel=Elevel-1
Lab1=Mprivatelabel
Gop Jump(BGE,Lab1)
Gop R(ZR,Reg1)
%if bytes=8 %then Gop R(ZR,Reg1+1)
Mcode Plabel(Lab1)
Stackr(Reg1,bytes)
%return
!*
F77op(ERDIM):
Eop(RSUB)
Reg1=Stk(Elevel)_Reg
Elevel=Elevel-1
Lab1=Mprivatelabel
%if Bytes=4 %thenstart
Gop Jump(BGE,Lab1)
Gop R(ZR,Reg1)
%finishelsestart
Gop Jump(BGE,Lab1)
Gop R(ZR,Reg1)
Gop R(ZR,Reg1+1)
%finish
Mcode Plabel(Lab1)
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIMIN):
Relop=BLE
Iminmax:
Elevel=Elevel-2
Reg1=Load Int(Stk(Elevel+1),-1)
%if bytes<=4 %start
Reg2=Load Int(Stk(Elevel+2),-1)
Gop RR(CAR,Reg1,Reg2)
%finishelsestart
Gop RX(CAM,reg1,stk(Elevel+2))
%finish
Lab1=Mprivatelabel
Gop Jump(Relop,Lab1)
%if bytes<=4 %start
Gop RR(TRR,Reg1,Reg2)
%finishelsestart
reg1=Load Int(stk(Elevel+2),reg1)
%finish
Mcode Plabel(Lab1)
%if bytes<=4 %then unlock reg(Reg2)
Stackr(Reg1,bytes)
!! Reg2=Load Int(Stk(Elevel+2),-1)
!! !%if Cpu = NP1 %thenstart
!! !%if Opcode = EIMIN %thenstart
!! !SceReg = Reg1
!! !DestReg= Reg2
!! !%finishelsestart
!! !SceReg = Reg2
!! !DestReg= Reg1
!! !%finish
!! !Gop RR(CXCR,DestReg,SceReg)
!! !%finishelsestart
!! Gop RR(CAR,Reg1,Reg2)
!! Lab1=Mprivatelabel
!! Gop Jump(Relop,Lab1)
!! Gop RR(TRR,Reg1,Reg2)
!! Mcode Plabel(Lab1)
!! !%finish
!! unlock reg(Reg2)
!! Stackr(Reg1)
%return
!*
F77op(ERMIN):
Relop=BLE
Rminmax:
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
Reg2=Load Real(Stk(Elevel+2),-1,Bytes)
!%if Cpu = NP1 %thenstart
!%if Opcode = ERMIN %thenstart
!SceReg = Reg1
!DestReg= Reg2
!%finishelsestart
!SceReg = Reg2
!DestReg= Reg1
!%finish
!%if Bytes = 4 %then Op = CXCR %else Op = CXCRD
!Gop RR(Op,DestReg,SceReg)
!%if Bytes = 4 %thenstart
!Unlock Reg(Reg2)
!%finishelsestart
!Unlock Reg Pair(Reg2)
!%finish
!%finishelsestart
Gop RR(CAR,Reg1,Reg2)
Lab1=Mprivatelabel
Gop Jump(Relop,Lab1)
Gop RR(TRR,Reg1,Reg2)
%if Bytes=4 %thenstart
Gop(NOP)
unlock reg(Reg2)
%finishelsestart
Gop RR(TRR,Reg1+1,Reg2+1)
unlock reg pair(Reg2)
%finish
Mcode Plabel(Lab1)
!%finish
Stackfr(Reg1,Bytes)
%return
!*
F77op(EIMAX):
Relop=BGE
->Iminmax
!*
F77op(ERMAX):
Relop=BGE
->Rminmax
!*
F77op(EDMULT):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Reg1=Load Real(Stk(Elevel+1),-1,8)
Reg2=Load Real(Stk(Elevel+2),-1,8)
Gop RR(MPRFD,Reg1,Reg2)
unlock reg pair(Reg2)
Stackfr(Reg1,8)
%return
!*
F77op(ECONJG):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Opcode=9
Flags=Stk(Elevel+3)_Intval
->Cxop
!*
F77op(ECHAR):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
%if Stk(Elevel)_Form=LitVal %thenstart
Reg1=claim reg
Gop RI(LI,Reg1,Stk(Elevel)_Intval&255)
%finishelsestart
Reg1=Load Int(Stk(Elevel),-1)
%finish
Elevel=Elevel-1
Refer(Stk(Elevel),0)
Stk(Elevel)_Size=1
Gop RX(ST,Reg1,Stk(Elevel))
Elevel=Elevel-1
Note Reguse(Reg1,0,0)
%return
!*
F77op(EICHAR):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
%if Stk(Elevel)_Form =LitVal %thenstart
Stk(Elevel)_Size=4
%return
%finish
Refer(Stk(Elevel),0)
Stk(Elevel)_Size=1
Reg1=claim reg
Gop RX(L,Reg1,Stk(Elevel))
Elevel=Elevel-1
Stackr(Reg1,4)
%return
!*
F77op(EINDEXCHAR):
%if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3))
%if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
{for Unix compatibility call requires A1,A2,L1,L2}
Epromote(3)
Epromote(2)
Spcall(6)
%if CPU=Concept %thenstart
Stackr(r0,4)
%finishelsestart
Stackr(r2,4)
%finish
%return
!*
F77op(ECONCAT):
Spcall(7)
%return
!*
F77op(EASGNCHAR):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
Clear Regs {in case characters equiv with ints - lose reg memory}
%return
!*
F77op(ECOMPCHAR):
%if Elevel<5 %then Low Estack(Opcode,5) %and %return
CC=Stk(Elevel)_Intval
Elevel=Elevel-5
Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
%return
!*
F77op(ECMPLX1):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Elevel=Elevel-3
Flags=Stk(Elevel+3)_Intval
->CXcmn
!*
F77op(ECMPLX2):
%if Elevel<4 %then Low Estack(Opcode,4) %and %return
Elevel=Elevel-4
Flags=Stk(Elevel+4)_Intval
CXcmn:%if Flags=0 %then Bytes=4 %else Bytes=8
Reg1=Load Reg(-3,Stk(Elevel+1));! address(target)
Freg1=Load Real(Stk(Elevel+2),-1,Bytes)
Gop RXB(ST,Freg1,0,Reg1,0,Bytes)
Note Reguse(Freg1,0,Bytes)
%if Opcode=ECMPLX1 %thenstart
Gop RXB(ZM,0,0,Reg1,Bytes,Bytes)
%finishelsestart
Freg1=Load Real(Stk(Elevel+3),-1,Bytes)
Gop RXB(ST,Freg1,0,Reg1,Bytes,Bytes)
Note Reguse(Freg1,0,Bytes)
%finish
Unlock Reg(Reg1)
%return
!*
F77op(EISHFT):
%if Stk(Elevel)_Form=Litval %thenstart
Shift=Stk(Elevel)_Intval
Litshift:%if Shift=0 %then Elevel=Elevel-1 %and %return
%if Shift<0 %thenstart
%if Opcode=EISHFT %then Op=SRL %else Op=SRA
Shift=-Shift
%finishelse Op=SLL
Shift=Shift&31
Elevel=Elevel-2
%if bytes<=4 %and Stk(Elevel+1)_Form=Litval %and Op#SRA %thenstart
Val=Stk(Elevel+1)_Intval
%if Op=SLL %then Val=Val<<Shift %else Val=Val>>Shift
Estklit(Val)
%return
%finish
Reg1=Load Int(Stk(Elevel+1),-1)
%if Stk(Elevel+1)_Size=2 %and Opcode=EISHFT %thenstart
Estklit(X'FFFF')
Elevel=Elevel-1
%if Op=SRL %thenstart
Gop RX(ANM,Reg1,Stk(Elevel+1))
Gop Shift Lit(SRL,Reg1,Shift)
%finishelsestart
Gop Shift Lit(SLL,Reg1,Shift)
Gop RX(ANM,Reg1,Stk(Elevel+1))
%finish
%finishelsestart
Gop Shift Lit(Op,Reg1,Shift)
%finish
Stackr(Reg1,bytes)
%return
%finishelse ->Spc
!*
F77op(EIBTEST):
Eop(ISHRL)
Estklit(1)
Eop(IAND)
%return
!*
F77op(EIBSET):
%if Stk(Elevel)_Form=Litval %thenstart
Stk(Elevel)_Intval=1<<Stk(Elevel)_Intval
%finishelsestart
Estklit(1)
Epromote(2)
Eop(ISHLL)
%finish
Eop(IOR)
%return
!*
F77op(EIBCLR):
%if Stk(Elevel)_Form=Litval %thenstart
Stk(Elevel)_Intval=(1<<Stk(Elevel)_Intval)!!(-1)
%finishelsestart
Estklit(1)
Epromote(2)
Eop(ISHLL)
Eop(INOT)
%finish
Eop(IAND)
%return
!*
F77op(EIBITS):
!*
F77op(EISHFTC):
Spc: Spcall(15+Opcode-EISHFT)
%return
!*
F77op(PROCARG):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
Reg1=Get Procref(Stk(Elevel+1)_Intval)
Stackr(Reg1,4)
%if Cpu=Concept %thenstart
Eop(Pushval)
%finish
%return
!*
F77op(IPROCARG):
!*
F77op(CHARARG):
!*
F77op(IPROCCALL):
Unsupported Opcode(Opcode)
%return
!*
F77op(ARGPROCCALL):
%if Elevel<2 %then Low Estack(Opcode,2) %and %return
Elevel=Elevel-2
Reg1=Load Int(Stk(Elevel+1),r0)
Gop Call(0,Stk(Elevel+2)_Intval,0,0)
%return
!*
F77op(NOTEIORES):
{no special action required here on Gould - result will stay in r0}
%return
!*
F77op(STKIORES):
%if Cpu=Concept %thenstart
Stackr(r0,4)
%finishelsestart
Stackr(r2,4)
%finish
%return
!*
F77op(CALLTPLATE):
%return
!*
F77op(EFDVACC):
%if Elevel<3 %then Low Estack(Opcode,3) %and %return
Reg1=claim reg pair(1)
Reg2=Load Int(Stk(Elevel),Reg1+1)
Reg2=Load Int(Stk(Elevel-1),-1)
%if cpu=concept %start
Gop RR(MPR,Reg1,Reg2)
%finishelsestart
Gop RR(MPR,Reg1+1,Reg2)
%finish
Elevel=Elevel-2
unlock reg pair(Reg1)
Stackr(Reg1+1,4)
Eop(IADD)
Stackr(Reg2,4)
%return
!*
F77op(EARGLEN):
%return
!*
F77op(EFNOTEVR):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Elevel=Elevel-1
%if Cpu=Concept %thenstart
Reg1=Load Int(Stk(Elevel+1),r0)
%finishelsestart
Reg1=Load Int(Stk(Elevel+1),r2)
%finish
%return
!*
F77op(EFSETVR):
%if Cpu=Concept %thenstart
Stackr(r0,4)
%finishelsestart
Stackr(r2,4)
%finish
%return
!*
F77op(ELOADB):
Elevel=Elevel-1
Moptreguse(r7,1)
%if Stk(Elevel+1)_Form&31=Regval %thenstart
Reg1=Stk(Elevel+1)_Reg
Gop RR(TRR,r7,Reg1)
Note Reguse(Reg1,0,0)
%finishelsestart
Gop RX(L,r7,Stk(Elevel+1))
%finish
%if Keycommon>0 %then moptreguse(r6,Keycommon)
%return
!*
F77op(ESTOREB):
Elevel=Elevel-1
Gop RX(ST,r7,Stk(Elevel+1))
Mr7updated
Moptreguse(r6,0)
%return
!*
F77op(EINCRB):
Elevel=Elevel-1
%if Stk(Elevel+1)_Form=Litval %and 0<=Stk(Elevel+1)_Intval<=32767 %thenstart
Gop RI(ADI,r7,Stk(Elevel+1)_Intval)
%finishelsestart
Gop RX(ADM,r7,Stk(Elevel+1))
%finish
Mr7updated
%return
!*
F77op(EDECRB):
Elevel=Elevel-1
%if Stk(Elevel+1)_Form=Litval %and 0<=Stk(Elevel+1)_Intval<=32767 %thenstart
Gop RI(ADI,r7,-Stk(Elevel+1)_Intval)
%finishelsestart
Gop RX(SUM,r7,Stk(Elevel+1))
%finish
Mr7updated
%return
!*
F77op(EINCR):
Eop(IADDST)
%return
!*
F77op(EDECR):
Eop(ISUBST)
%return
!*
F77op(ELSHIFT):
%if Stk(Elevel)_Form=Litval %thenstart
Shift=Stk(Elevel)_Intval
->Litshift
%finish
Spcall(25)
%return
!*
F77op(ERSHIFT):
%if Stk(Elevel)_Form=Litval %thenstart
Shift=-Stk(Elevel)_Intval
->Litshift
%finish
Spcall(26)
%return
!*
F77op(EADJL):
Spcall(22)
%return
!*
F77op(EADJR):
Spcall(23)
%return
!*
F77op(EVERIFY):
Spcall(24)
%return
!*
F77op(ECXRES):
Elevel=Elevel-2
Reg1=claim reg
Gop RX(L,Reg1,Stk(Elevel+2))
Gop RXB(ST,r2,0,Reg1,0,4)
Gop RXB(ST,r3,0,Reg1,4,4)
Notereguse(Reg1,0,0)
unlock reg pair(r2)
%return
!*
F77op(ERBIT):
Elevel=Elevel-2
Reg1=claim reg
Gop R(ZR,Reg1)
Gop Bit(TBM,0,0,Stk(Elevel+1),Stk(Elevel+2))
Lab1=Mprivatelabel
Gop Jump(BCF,Lab1)
Gop RI(LI,Reg1,1)
Mcode Plabel(Lab1)
Stackr(Reg1,4)
%return
!*
F77op(EWBIT):
Elevel=Elevel-3
%if Stk(Elevel+1)_form=LitVal %thenstart
Reg1=Stk(Elevel+1)_IntVal&1
Gop Bit(SBM,0,Reg1,Stk(Elevel+2),Stk(Elevel+3))
%finishelsestart
Reg1=Load Reg(-2,Stk(Elevel+1))
Gop Bit(SBM,1,Reg1,Stk(Elevel+2),Stk(Elevel+3))
unlock reg(Reg1)
%finish
%return
!*
%end;! Ef77op
!*
%externalroutine Epasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal *
!***********************************************************************
Abortm("Epasop")
!*
%end;! Epasop
!*
%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C *
!***********************************************************************
%constintegerarray Uopst(0:3) = IADDST,ISUBST,IMULTST,IDIVST
%constintegerarray Ropst(0:9) = RADD,RSUB,RMULT,RDIV,ISHLL,ISHRL,0,0,0,ISHRA
%integer I,Reg1,Reg2,Bstart,Nbits,Bmask,Bshift,Bitval
%switch Cop(768:790)
%if Report#0 %thenstart
printstring("Cop ".Ecopname(Opcode))
newline
Dump Estack
%finish
%if progfaulty#0 %then %return
->Cop(Opcode)
!*
Cop(LOGNEG):
%if Elevel<1 %then Low Estack(Opcode,1) %and %return
Estklit(0)
Eop(IEQ)
Establish Logical
%return
!*
Cop(LOGVAL):
%if CCset=0 %thenstart
%if Elevel<1 %then Low Estack(Opcode,1)%and %return
Estklit(0)
Eop(INE)
%finish
Note Reguse(r1,0,4) {to ensure r1 is used}
Establish Logical
Elevel=Elevel-1 {use of r1 will be presumed by LOGSTK}
Note Reguse(r1,0,4)
%return
!*
Cop(LOGSTK):
Stackr(r1,4)
%return
!*
Cop(ECSTORE):
I=Stk(Elevel)_Size
%unless Stk(Elevel-1)_Size=I %then %monitor %and %stop
Epromote(2)
%if Stk(Elevel)_Form&31=Regval %thenstart
Stk(Elevel)_Form=Regaddr
%finishelsestart
Eop(EADDRESS)
%finish
Epromote(2)
Eop(EADDRESS)
Estklit(I)
%if I&3=0 %thenstart {use word copy}
Eop(EVAL)
%finishelsestart
Eop(MVB)
%finish
%return
!*
Cop(ECPROCCALL):
%if Stk(Elevel)_Size=0 %thenstart
Stk(Elevel)_Size=4
%finish
Eop(EADDRESS)
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),r0)
Gop Call(0,0,0,0)
%return
!*
Cop(EPUSHSTR):
Elevel=Elevel-2
Push Struct(Stk(Elevel+1),Stk(Elevel+2)_Intval)
%return
!*
Cop(ELDBITS):
Elevel=Elevel-3
Nbits=Stk(Elevel+3)_Intval
Bstart=Stk(Elevel+2)_Intval
Bmask=Bmaskval((Nbits-1)&31)
Bshift=32-Bstart-Nbits
Reg1=Load Int(Stk(Elevel+1),-1)
%if Bshift>0 %then Gop Shift Lit(SRL,Reg1,Bshift)
Stackr(Reg1,4)
Estklit(Bmask)
Eop(IAND)
%return
!*
Cop(ESTBITS):
Elevel=Elevel-2
Nbits=Stk(Elevel+2)_Intval
Bstart=Stk(Elevel+1)_Intval
Bmask=Bmaskval((Nbits-1)&31)
Bshift=32-Bstart-Nbits
Eop(DUPL)
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1)
Stackr(Reg1,4)
Estklit((Bmask<<Bshift)!!(-1))
Eop(IAND)
Epromote(3) {value to be set}
Elevel=Elevel-1
%if Stk(Elevel+1)_Form=Litval %thenstart
Bitval=(Stk(Elevel+1)_Intval&Bmask)<<Bshift
%if Ecdupflag#0 %thenstart
Ecdupflag=0
Estklit(Stk(Elevel+1)_Intval&Bmask)
Epromote(3)
Epromote(3)
%finish
Estklit(Bitval)
%finishelsestart
Reg2=Load Int(Stk(Elevel+1),-1)
Stackr(Reg2,4)
Estklit(Bmask)
Eop(IAND)
%if Ecdupflag#0 %thenstart
Ecdupflag=0
Eop(DUPL)
Epromote(3)
Epromote(3)
%finish
Estklit(Bshift)
Eop(ISHLL)
%finish
Eop(IOR)
Eop(EXCH)
%if Ecdupflag#0 %thenstart
Ecdupflag=0
Eop(EDUPSTORE)
%finishelsestart
Eop(ESTORE)
%finish
%return
!*
Cop(UADDST):
Cop(USUBST):
Cop(UMULTST):
Eop(Uopst(Opcode-UADDST))
%return
!*
Cop(RADDST):
Cop(RSUBST):
Cop(RMULTST):
Cop(RDIVST):
Cop(ISHLST):
Cop(ISHRST):
Cop(ISHRAST):
%if Stk(Elevel-1)_Form&31=Regval %thenstart
Eop(Ropst(Opcode-RADDST))
Stk(Elevel)_Size=Csavestk_Size
Elevel=Elevel+1
Stk(Elevel)=Csavestk
%finishelsestart
Eop(EXCH)
Eop(DUPL)
Epromote(3)
Eop(Ropst(Opcode-RADDST))
Eop(EXCH)
%finish
%if Ecdupflag#0 %thenstart
Ecdupflag=0
Eop(EDUPSTORE)
%finishelsestart
Eop(ESTORE)
%finish
%return
!*
Cop(CEVAL):
Elevel=Elevel-1
Reg1=Load Int(Stk(Elevel+1),-1)
Stackr(Reg1,4)
%return
!*
Cop(ECSAVE):
Eop(DUPL)
I=Elevel-1
%while I>0 %cycle
Epromote(Elevel)
I=I-1
%repeat
Numcsave=Numcsave+1
%return
!*
Cop(ECRESTORE):
Epromote(Elevel-Numcsave+1)
Numcsave=Numcsave-1
%return
!*
Cop(*):
%monitor
%end;! Eccop
!*
%routine Expcall(%integer Proc)
!***********************************************************************
!* call an exponentiation routine *
!***********************************************************************
%integer I,J,T,Reg1
%string(31) S
%if Proc<=2 %thenstart
%if stk(elevel+1)_size#8 %and Stk(Elevel)_form=Litval %c
%and Stk(Elevel)_Intval=2 %thenstart
Elevel=Elevel-2
%if Proc=0 %thenstart {I**2}
I=Load Int(Stk(Elevel+1),-1)
%if Cpu=Concept %thenstart
Reg1=claim reg pair(1)
Gop RR(TRR,Reg1+1,I)
Gop RR(MPR,Reg1,I)
Note reguse(Reg1,0,4)
Note reguse(I,0,4)
Stackr(Reg1+1,4)
%finishelsestart {NP1}
Gop RR(MPR,I,I)
Stackr(I,4)
%finish
%return
%finishelsestart
%if Proc=1 %thenstart {R**2}
J=MPRFW
T=4
%finishelsestart {D**2}
J=MPRFD
T=8
%finish
I=Load Real(Stk(Elevel+1),-1,T)
Gop RR(J,I,I)
Stackfr(I,T)
%return
%finish
%finish
%finish
T=Expproctype(Proc)
J=Expprocref(Proc)
%if J=0 %thenstart
S=Expprocs(Proc)
J=Exname(T,S)
Expprocref(Proc)=J
%finish
Eprecall(J)
I=Expprocpdesc(Proc)>>16
%while I>0 %cycle
%if STACK DIRECTION=POSITIVE %thenstart
Epromote(I)
%finish
%if Stk(Elevel)_Size<4 %thenstart
Estklit(4)
Eop(CVTII)
%finish
Address(Stk(Elevel))
Stk(Elevel)_Size=4
Eop(PUSHVAL)
I=I-1
%repeat
I=Expprocpdesc(Proc)
Freeregs
Ecall(J,I>>16,I&X'FF')
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%if Cpu=NP1 %thenstart
%if Proc=4 %or Proc=12 %thenstart ;! c**i, c**c
Stackfr(r2,8)
Epromote(2)
Ef77op(Ecxres)
%finish
%finish
%end;! Expcall
!*
%externalroutine Spcall(%integer Proc)
!***********************************************************************
!* call a support procedure *
!***********************************************************************
%integer I,J,T
%string(31) S
T=Spproctype(Proc)
J=Spprocref(Proc)
%if J=0 %thenstart
S=Spprocs(Proc)
J=Exname(T,S)
Spprocref(Proc)=J
%finish
Eprecall(J)
I=Spprocpdesc(Proc)>>16
%while I>0 %cycle
%if STACK DIRECTION=POSITIVE %thenstart
Epromote(I)
%finish
%if Proc=27 %or Proc=28 %thenstart {integer*8 proc}
Eop(Pushaddr)
%finishelse Eop(PUSHVAL)
I=I-1
%repeat
I=Spprocpdesc(Proc)
Freeregs
Ecall(J,I>>16,I&X'FF')
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%end;! Spcall
!*
!*
!*
!*
!***********************************************************************
!***********************************************************************
!** Code generation support procedures **
!***********************************************************************
!***********************************************************************
!*
!*
%externalroutine Epush Operand(%record(Stkfmt)%name Operand)
%if Elevel=Stklimit %then Abort
Elevel=Elevel+1
Stk(Elevel)=Operand
%end;! Push Operand
!*
%externalroutine Refer(%record(Stkfmt)%name Stk,%integer Offset)
%integer Reg
%record(Stkfmt) S1
%switch F(0:31)
->F(Stk_Form&31);! removing the reg marker bit
!*
F(RegVar):
Stk_Form=Regptr
%return
!*
F(RegVal): { (reg) }
%if stk_Reg=0 %thenstart
Reg=claim reg
Gop RR(TRR,Reg,0)
Note Reguse(0,0,0)
Stk_Reg=Reg
%finish
%if Offset#0 %thenstart
Stk_Form=IndRegModVal!Regflag
Note Reguse(Stk_Reg,-Elevel,4)
Setoff: Stk_Modform=Litval
Stk_Modintval=Offset
Stk_Scale=0
%return
%finish
Stk_Form=IndRegVal!Regflag
Note Reguse(Stk_Reg,-Elevel,4)
%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)) }
Gop RXB(L,Stk_Reg,0,Stk_Reg,0,4)
->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=Load Int(stk,-1)
Stk_Reg=Reg
->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
!*
%externalroutine Address(%record(Stkfmt)%name Stk)
%integer I,J,Reg,Op,Area,Offset
%record(Stkfmt) S1
%switch F(0:21)
->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal): { lit }
I=Stk_Intval
J=addr(I)
%if Stk_Size#4 %thenstart
%if Stk_Size=2 %then J=J+2 %else J=J+3
%finish
Msetconst(J,Stk_Size,Area,Offset)
Stk_Base=Area
Stk_Offset=Offset
F(ConstVal): { const }
Stk_Form=AddrConst
Size: Stk_Size=4
%return
!*
F(RegVal): { (reg) }
Stk_Base=Stack
Stk_Offset=Estackspace(Stk_size)
Streg:Stk_Form=DirVal
Gop RX(ST,Stk_Reg,Stk)
Stk_Form=AddrDir
Note Reguse(Stk_Reg,0,Stk_Size)
->Size
!*
F(FregVal): { (freg) }
Stk_Base=Stack
Stk_Offset=Estackspace(Stk_Size)
->Streg
!*
F(TempVal): { (temp) }
Stk_Form=AddrDir
->Size
!*
F(DirVal): { (dir) }
Stk_Form=AddrDir
->Size
!*
F(IndRegVal): { ((reg)) }
Stk_Form=RegAddr!Regflag
->Size
!*
F(IndTempVal): { ((temp)) }
Stk_Form=TempAddr
->Size
!*
F(IndDirVal): { ((dir)) }
Stk_Form=DirAddr
->Size
!*
F(AddrDirModVal): { (dir+M) }
Stk_Form=AddrDirMod!(Stk_Form&Regflag)
->Size
!*
F(IndRegModVal): { ((reg)+M) }
Stk_Form=RegModAddr!Regflag
->Size
!*
F(IndTempModVal): { ((temp)+M) }
Stk_Form=TempModAddr!(Stk_Form&Regflag)
->Size
!*
F(IndDirModVal): { ((dir)+M) }
Stk_Form=DirModAddr!(Stk_Form&Regflag)
->Size
!*
F(AddrConst): { @const }
F(RegAddr): { (reg) is @ }
F(TempAddr): { (temp) is @}
F(DirAddr): { (dir) is @ }
F(AddrDir): { @dir }
F(AddrDirMod): { @dir+M }
F(RegModAddr): { (reg)+M }
F(TempModAddr): { (temp)+M }
F(DirModAddr): { (dir)+M }
!*
%end;! Address
!*
%externalroutine Stackr(%integer R,size)
!***********************************************************************
!* create an Estack entry for a value held in a general register *
!***********************************************************************
%record(Stkfmt)%name Lstk
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=RegVal!Regflag
Lstk_Reg=R
Lstk_Size=size
Note Reguse(R,-Elevel,size)
%end;! Stackr
!*
%externalroutine Stackfr(%integer FR,Bytes)
!***********************************************************************
!* create an Estack entry for a value held in a floating register *
!***********************************************************************
%record(Stkfmt)%name Lstk
Elevel=Elevel+1
Lstk==Stk(Elevel)
Lstk=0
Lstk_Form=FregVal!Regflag
Lstk_Reg=FR
Lstk_Size=Bytes
Note Reguse(FR,-Elevel,Bytes)
%end;! Stackfr
!*
%externalroutine Establish Logical
!***********************************************************************
!* called when a condition code has been set and required result is a *
!* logical value (0 or 1) *
!***********************************************************************
%integer Reg1,Lab1,Lab2
Lab1=Mprivatelabel
Lab2=Mprivatelabel
Reg1=Claim Reg
Gop Jump(BGT+CC,Lab1)
Gop R(ZR,Reg1)
Gop(NOP)
Gop Jump(BU,Lab2)
Mcode Plabel(Lab1)
Gop RI(LI,Reg1,1)
Mcode Plabel(Lab2)
Stackr(Reg1,4);! stack integer result in Reg1
CCset=0
%end;! Establish Logical
!*
%routine Convert II(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts between integer sizes *
!* descriptor to result on Estack *
!***********************************************************************
%integer data1,data2
%integer Reg,Bytes,Op,i
Bytes=Lstk_Size
%if Bytes=Newsize %then Elevel=Elevel+1 %and %return
%if Lstk_Form=LitVal %thenstart
%if bytes=2 %and newsize=4 %start
%if Lstk_Intval&x'8000'#0 %then Lstk_intval=Lstk_Intval!x'ffff0000'
%finish
%if newsize=8 %start
data2=Lstk_intval
%if data2>>31#0 %then data1=-1 %else data1=0
Estkconst(8,addr(data1))
%finishelsestart
Lstk_Size=Newsize
Elevel=Elevel+1
%finish
%return
%finish
%if bytes<=4 %and newsize=8 %start
reg=Claim reg pair(1)
i=Load Int(Lstk,reg+1)
%if Cpu=NP1 %thenstart
Gop RR(EXS,Reg,Reg+1)
%finishelsestart
Gop R(ES,Reg)
%finish
%finishelsec
Reg=Load Int(Lstk,-1)
%if bytes=8 %and newsize<=4 %start { DO we worry about overflow???}
Unlock reg pair(reg)
reg=reg+1
Note reguse(reg,-255,4)
%finish
%if Lstk_Form&31=regval %and bytes=2 %start
Gop Shift Lit(SLL,reg,16)
Gop Shift Lit(SRA,reg,16)
%finish
Stackr(Reg,newsize)
%end;! Convert II
!*
%routine Convert RR(%integer Mode,%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* 0 converts between real sizes *
!* 1 TNCRR *
!* 2 RNDRR *
!* descriptor to result on Estack *
!***********************************************************************
%integer Freg1
Freg1=Load Real(Stk,-1,Newsize)
Stackfr(Freg1,Newsize)
%if Mode=0 %then %return
%if Mode=1 %thenstart
Estklit(4)
Eop(TNCRI)
Estklit(Newsize)
Eop(CVTIR)
%finishelsestart
Estklit(4)
Eop(RNDRI)
Estklit(Newsize)
Eop(CVTIR)
%finish
%end;! Convert RR
!*
%routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode)
!***********************************************************************
!* converts between real and integer *
!* Mode = 0 TNC Round towards zero (Fortran) *
!* 1 RND Round towards the nearest integer *
!* 2 EFLOOR round towards - infinity *
!* descriptor to result on Estack *
!* Theory of fixing on NP *
!* The only instruction acts by fixing towards zero so :- *
!* For round we add or subtarct 0.5 and use TNC *
!* For efloor if positive treat as TNC *
!* If negative add maxint TNC and subtract maxint *
!***********************************************************************
%ownintegerarray Half(0:5)=X'40800000',0,X'4E000000',X'80000000',
X'50800000',0;
%integer Reg,Area,size,reg2
size=stk_size
%if Mode>=1 %and consthalf=0 %then %c
Msetconst(addr(Half(0)),8,Area,consthalf)
%if Mode=2 %and Nearhalf=0 %then %start
Msetconst(addr(Half(2)),8,Area,Nearhalf)
Msetconst(addr(Half(4)),8,Area,reg2); ! Will be consecuitve
%finish
%if newsize=8 %then Size=8;! Avoid oflow prob if real*4->i*8
Reg=Load Real(Stk,-1,Size)
%if Mode=2 %then %start
Gop Floor(Reg,Newsize,Nearhalf)
%else
%if Mode>=1 %then Gop Rnd(Reg,Size,consthalf)
%if Size<=4 %thenstart
Gop RR(FIXW,Reg,Reg)
%finishelsestart
Gop RR(FIXD,Reg,Reg)
%finish
%finish
%if newsize<=4 %start
unlock reg pair(Reg)
Reg=Reg+1
%finish
Stackr(Reg,newsize)
%end;! Convert RI
!*
%routine Convert IR(%record(Stkfmt)%name PStk,%integer Newsize)
!***********************************************************************
!* converts real to integer *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg,Reg1,Op,bytes
bytes=Pstk_size
%if Newsize=8 %thenstart
%if bytes=8 %and Pstk_form&31=regval %then reg=Pstk_reg %c
%else Reg=claim reg pair(1)
%if bytes<=4 %start
Reg1=Load Int(Pstk,Reg+1)
%if Cpu=NP1 %thenstart
Gop RR(EXS,Reg,Reg+1)
%finishelsestart
Gop R(ES,Reg)
%finish
%finishelse reg1=Load Int(pstk,reg)
Op=FLTD
%finishelsestart
Reg=Load Int(PStk,-1)
%if bytes<=4 %then Op=FLTW %else Op=FLTD
%finish
Gop RR(Op,Reg,Reg)
%if bytes=8 %and newsize<=4 %start
Unlock reg pair(reg)
reg=reg+1
Note reguse(reg,-255,4)
%finish
Stackfr(Reg,Newsize)
%return
%end;! Convert IR
!*
%routine Convert SBI(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts signed byte to integer *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg,Bytes,Op
Bytes=Lstk_Size
%if Bytes=Newsize %then Elevel=Elevel+1 %and %return
%if Lstk_Form=LitVal %thenstart
Lstk_Size=Newsize
%if Lstk_Intval&128#0 %then Lstk_Intval=Lstk_Intval!X'FFFFFF00'
Elevel=Elevel+1
%return
%finish
Reg=Load Int(Lstk,-1)
Gop Shift Lit(SLL,Reg,24)
Gop Shift Lit(SRA,Reg,24)
Stackr(Reg,4)
Stk(Elevel)_Size=Newsize
%end;! Convert SBI
!*
%routine Convert IU(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts integer to unsigned integer *
!* descriptor to result on Estack *
!***********************************************************************
%integer data1,data2
%integer Reg,Bytes,Op,I
Bytes=Lstk_Size
%if Bytes=Newsize %then Elevel=Elevel+1 %and %return
%if Lstk_Form=LitVal %thenstart
%if Newsize=2 %thenstart
Lstk_Intval=Lstk_Intval&X'FFFF'
%finishelsestart
%if Newsize=1 %thenstart
Lstk_Intval=Lstk_Intval&X'FF'
%finish
%finish
%if newsize=8 %start
data2=Lstk_intval
data1=0
Estkconst(8,addr(data1))
%finishelsestart
Lstk_Size=Newsize
Elevel=Elevel+1
%finish
%return
%finish
%if bytes<=4 %and newsize=8 %start
reg=Claim reg pair(1)
I=Load Int(Lstk,reg+1)
Gop RR(EOR,Reg,Reg)
%finishelse Reg=Load Int(Lstk,-1)
%if bytes=8 %and newsize<=4 %start
Unlock reg pair(reg)
reg=reg+1
Note reguse(reg,-255,4)
%finish
Stackr(Reg,Newsize)
%if Newsize=1 %thenstart
Estklit(X'FF')
Eop(IAND)
%finishelsestart
%if Bytes=2 %or Newsize=2 %thenstart
Estklit(X'FFFF')
Eop(IAND)
%finish
%finish
Stk(Elevel)_Size=Newsize
%end;! ConvertIU
!*
%routine Convert UR(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts unsigned integer to real *
!* descriptor to result on Estack *
!***********************************************************************
%integer Reg,Bytes,Op
Bytes=Lstk_Size
Reg=Load Int(Lstk,-1)
Stackr(Reg,4)
%if Bytes=2 %thenstart
Estklit(X'FFFF')
Eop(IAND)
%finish
Stk(Elevel)_Size=4
Estklit(Newsize)
Eop(CVTIR)
%end;! Convert UR
!*
!*
!***********************************************************************
!***********************************************************************
!** Pascal-specific support procedures **
!***********************************************************************
!***********************************************************************
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
%routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2)
%integer I,Len1,Len2,B1,D1,B2,D2,XAop,Apars,Reg
%if C1_Form=LitVal %then C1_Size=1
%if C2_Form=LitVal %then C2_Size=1
Len1=LenC1_Intval
Len2=LenC2_Intval
%if LenC1_Form=Litval %and LenC2_Form=LitVal %and Len1=Len2 %thenstart
%if Op=EASGNCHAR %thenstart
%if Len1=1 %thenstart
Refer(C1,0)
C1_Size=1
Refer(C2,0)
C2_Size=1
Reg=claim reg
Gop RX(L,Reg,C2)
Gop RX(ST,Reg,C1)
Note Reguse(Reg,0,0)
%finishelsestart
Gop Mvb(LenC1,C2,C1)
%finish
%finishelsestart
%if Len1=1 %thenstart
Refer(C1,0)
C1_Size=1
Refer(C2,0)
C2_Size=1
Reg=claim reg
Gop RX(L,Reg,C1)
Gop RX(CAM,Reg,C2)
Note Reguse(Reg,0,0)
%finishelsestart
Gop Cpb(CC,LenC1,C1,C2)
%finish
CCset=1
%finish
%finishelsestart
%if Op=EASGNCHAR %thenstart
Elevel=Elevel+4
Spcall(9)
%finishelsestart
Elevel=Elevel+5
Spcall(10)
%finish
%finish
%end;! Do Charop
!*
%routine Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!***********************************************************************
!* Op = 1 CXADD 5 CXNEG 9 CONJG *
!* 2 CXSUB 6 CXASGN 10 CMPLX1 *
!* 3 CXMULT 7 CXEQ 11 CMPLX2 *
!* 4 CXDIV 8 CXNE *
!* Flags = Variant<<8 ! Sizecode *
!* Variant: 0 complex op complex *
!* 1 complex op real *
!* 2 real op complex *
!* Sizecode: 0 8 *
!* 1 16 *
!* 2 32 *
!***********************************************************************
%integer Variant,Size,D,NewD,Freg1,Freg2,I,Op1,Ax,Ay,Az,saver6r7
%record(Stkfmt) Xr,Xi,Yr,Yi,Zr,Zi
%switch S(0:11)
Variant=Flags>>8
Size=Flags&3
%if Size=0 %then D=4 %else D=8
%if ((Op=3 %and Size#0) %or Op=4) %and Variant=0 %thenstart;! use support procedure
Elevel=Elevel+3;! to allow operands to be pushed
%if Op=3 %thenstart
saver6r7=Estackspace(8)
Eafix(Stack,0)
Gop RXB(ST,r6,br2,0,saver6r7,8)
%finish
Spcall(3*(Op-3)+Size)
%if Cpu=NP1 %thenstart
%if Size=0 %thenstart ;! c*4/c*4
Stackfr(r2,8)
Epromote(2)
Ef77op(Ecxres)
%finish
%finish
%if Op=3 %thenstart
Eafix(Stack,0)
Gop RXB(L,r6,br2,0,saver6r7,8)
%finish
%return
%finish
!*
Ax=-1
Ay=-1
Az=-1
Freg1=-1
Freg2=-1
!*
%unless 7<=Op<=8 %thenstart
%if RHS1_Form=Addrdir {%and RHS1_Base#Stack} %thenstart
RHS1_Form=Dirval
Xr=RHS1
Xr_Size=D
Xi=RHS1
Xi_Size=D
Xi_Offset=Xi_Offset+D
%finishelsestart
Xr=0
Xr_Form=Indregval
Xr_Size=D
Xi=0
Xi_Form=Indregmodval
Xi_Size=D
Xi_Modform=Litval
Xi_Modintval=D
Ax=Load Reg(-3,RHS1)
Xr_Reg=Ax
Xi_Reg=Ax
%finish
!*
%if Op<=4 %or Op=11 %thenstart
%if RHS2_Form=Addrdir {%and RHS2_Base#Stack} %thenstart
RHS2_Form=Dirval
Yr=RHS2
Yr_Size=D
Yi=RHS2
Yi_Size=D
Yi_Offset=Yi_Offset+D
%finishelsestart
Yr=0
Yr_Form=Indregval
Yr_Size=D
Yi=0
Yi_Form=Indregmodval
Yi_Size=D
Yi_Modform=Litval
Yi_Modintval=D
Ay=Load Reg(-3,RHS2)
Yr_Reg=Ay
Yi_Reg=Ay
%finish
%finish
!*
%if LHS_Form=Addrdir {%and LHS_Base#Stack} %thenstart
LHS_Form=Dirval
Zr=LHS
Zr_Size=D
Zi=LHS
Zi_Size=D
Zi_Offset=Zi_Offset+D
%finishelsestart
Zr=0
Zr_Form=Indregval
Zr_Size=D
Zi=0
Zi_Form=Indregmodval
Zi_Size=D
Zi_Modform=Litval
Zi_Modintval=D
Az=Load Reg(-3,LHS)
Zr_Reg=Az
Zi_Reg=Az
%finish
%finish
!*
->S(Op)
!*
S(1): ! CXADD
Freg1=Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(ADF,Freg1,Yr)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
Freg2=Load Real(Xi,-1,D)
%if Variant=0 %thenstart
Gop RX(ADF,Freg2,Yi)
%finish
Store:%if Freg2>=0 %thenstart
Gop RX(ST,Freg2,Zi)
Note Reguse(Freg2,0,D)
%finish
Free: %if Ax>=0 %then Unlock Reg(Ax)
%if Ay>=0 %then Unlock Reg(Ay)
%if Az>=0 %then Unlock Reg(Az)
%return
!*
S(2): ! CXSUB
Freg1=Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(SUF,Freg1,Yr)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
%if Variant=2 %thenstart
%if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
Gop RX(LN,Freg2,Yi)
%finishelsestart
Freg2=Load Real(Xi,-1,D)
%if Variant=0 %thenstart
Gop RX(SUF,Freg2,Yi)
%finish
%finish
->Store
!*
S(3): ! CXMULT
%if Variant=0 %thenstart;! complex*8
Freg1=Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0)
Gop RX(MPF,Freg1,Yr)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Freg2=Load Real(Xi,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0)
Gop RX(MPF,Freg2,Yi)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Gop RR(SURFW,Freg1,Freg2)
Gop RX(ST,Freg1,Zr)
%if Az>0 %then Note Reguse(Az,-255,0)
Note Reguse(Freg1,0,D)
Note Reguse(Freg2,0,D)
Freg1=Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0)
Gop RX(MPF,Freg1,Yi)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Freg2=Load Real(Xi,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0)
Gop RX(MPF,Freg2,Yr)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Gop RR(ADRFW,Freg1,Freg2)
Gop RX(ST,Freg1,Zi)
Note Reguse(Freg1,0,D)
Note Reguse(Freg2,0,D)
->Free
%finish
Op1=MPF
Mdiv: Freg1=Load Real(Xr,-1,D)
Mdiv2:%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(Op1,Freg1,Yr)
%if Ay>0 %then Note Reguse(Ay,-255,0)
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
Freg2=Load Real(Xi,-1,D)
Yi=Yr
Gop RX(Op1,Freg2,Yi)
->Store
!*
S(4): ! CXDIV
%if Cpu = NP1 %thenstart
Freg1 = Load Real(Yr,-1,D)
%if D = 4 %thenstart
Op = RRFW
Op1 =MPRFW
%finishelsestart
Op = RRFD
Op1 =MPRFD
%finish
Gop RR(Op,Freg1,Freg1) { reciprocal }
Freg2 = Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0)
Gop RR(Op1,Freg2,Freg1)
Gop RX(ST,Freg2,Zr)
Note Reguse(Freg2,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
Gop RX(MPF,Freg1,Xi)
Gop RX(ST,Freg1,Zi)
Note Reguse(Freg1,0,D)
->Free
%finishelsestart
Op1=DVF
->Mdiv
%finish
!*
S(5): ! CXNEG
%if D=4 %then Freg1=claim reg %else Freg1=claim reg pair(1)
Gop RX(LN,Freg1,Xr)
%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
%if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
Gop RX(LN,Freg2,Xi)
->Store
!*
S(10):! CMPLX1
Variant=1;! for complex = real
S(11):! CMPLX2
NewD=D
->Ass
!*
S(6): ! CXASGN
%if Flags&4=0 %thenstart;! assigning to single
NewD=4
%finishelsestart
NewD=8
%finish
Ass: Zr_Size=NewD
Zi_Size=NewD
Zi_Modintval=NewD
Freg1=Load Real(Xr,-1,NewD)
%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,NewD)
%if Az>0 %then Note Reguse(Az,-255,0)
%if Variant#0 %thenstart;! not Cx = Cx
%if Variant=2 %thenstart;! Real = Cx
{no action required}
%finishelsestart;! Cx = Real
Zi_Offset=Zi_Offset+NewD-D
Gop RX(ZM,0,Zi)
%finish
%finishelsestart;! Cx = Cx
%if D#NewD %thenstart;! unequal lengths being assigned
Freg2=Load Real(Xi,-1,NewD)
Zi_Offset=Zi_Offset+NewD-D
%finishelsestart
%if Op=11 %thenstart
Freg2=Load Real(Yr,-1,D)
%finishelsestart
Freg2=Load Real(Xi,-1,D)
%finish
%finish
%finish
D=NewD {to release appropriate register(s)}
->Store
!*
S(7): ! CXEQ
S(8): ! CXNE
Zr=0
Zr_Form=Litval
Zr_Intval=D*2
Zr_Size=4
CC=Op-5;! 2 EQ 3 NE
Gop Cpb(CC,Zr,LHS,RHS1)
CCset=1
%return
!*
S(9): ! CONJG
Freg1=Load Real(Xr,-1,D)
%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
Gop RX(ST,Freg1,Zr)
Note Reguse(Freg1,0,D)
%if Az>0 %then Note Reguse(Az,-255,0)
%if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
Gop RX(LN,Freg2,Xi)
->Store
%end;! Cx Operation
!*
!*
!***********************************************************************
!*
!*
%routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
!***********************************************************************
!* incorporate Index info into Base record *
!***********************************************************************
%integer Reg,Form
%switch F(0:21)
%if Index_Size#4 %thenstart
Convert II(Index,4)
Elevel=Elevel-1
%finish
%if Index_Form&31>=AddrDirMod %thenstart
Reg=Load Int(Index,-1)
Note Reguse(Reg,-Elevel,4)
Index_Reg=Reg
Index_Form=RegVal!Regflag
%finish
%if Index_Form=LitVal %thenstart
Index_Intval=Index_Intval<<Scale
Scale=0
%if Base_Form=AddrDir %thenstart
Base_Offset=Base_Offset+Index_Intval
%return
%finish
%finish
->F(Base_Form&31)
!*
F(IndRegVal): { ((reg)) }
F(IndTempVal): { ((temp)) }
F(IndDirVal): { ((dir)) }
Base_Form=Base_Form+12
Set: Base_Modreg=Index_Reg
Base_Modbase=Index_Base
Base_Modform=Index_Form
Base_Modoffset=Index_Offset
Base_Scale=Scale
%if Base_Modform&31=Regval %thenstart
Note Reguse(Base_Modreg,-Elevel,4)
Base_Modoffset=Base_Modoffset<<Scale
%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 }
F(LitVal): { lit }
F(ConstVal): { const }
F(RegVal): { (reg) }
F(TempVal): { (temp) }
F(AddrConst): { @const }
F(IndRegModVal): { ((reg)+M) }
F(IndTempModVal): { ((temp)+M) }
F(IndDirModVal): { ((dir)+M) }
F(AddrDirModVal): { (@dir+M) }
Reg=Load Int(Base,-1)
Note Reguse(Reg,-Elevel,4)
Base_Reg=Reg
Base_Form=RegModAddr!regflag
->Set
!*
F(DirVal): { (dir) }
->F(IndDirVal) { IMP failing to Refer }
!*
F(FregVal): { (freg) }
Abort
!*
%end;! Note Index
!*
%endoffile