{*********************} {* EMAS 370 *} {* PUT INTERFACE *} {* April 22 1985 *} {*********************} {*Date of Change:13 Feb 86*} {*Description of Change:Correction to fixups to code area*} {*Name of Person Responsible:Rob Pooley*} {*User Number:ercs20*} %CONST %STRING (31) PutVersion= "PUT: version 13th February 1986" { These are the low level code and object generation routines which are common} { to our XA compilers in the EMAS 370 environment. } {April 22nd - Began move to new object file format. Incorporated LPUT functions} { April 18th - added Fortran features: Switch Val and Entry } { Tracing control } %CONST %INTEGER On= 1, Off = 2 %CONST %INTEGER Tracing= Off { Controls conditional compilation } { Trace all significant calls on interface if: } { comreg(26)&1#0 (Major calls) or } { ComReg(26)&2#0 (Code planting calls) } { as directed by calls on procs. Pmonon/Pmonon } { Seldom required info controlled by bits of comreg(26) as follows: } { 128 - Decode each instruction as planted } { 256 - Give a full recode of code area at end of compilation } %CONST %INTEGER EMAS=0 %CONST %INTEGER Amdahl= 1 %CONST %INTEGER Target= Amdahl {* External/system declarations *} %EXTERNAL %ROUTINE %SPEC Move %ALIAS "S#MOVE"(%INTEGER Length,From,To) %EXTERNAL %ROUTINE %SPEC Fill %ALIAS "S#FILL"(%INTEGER Length,From,Filler) %EXTERNAL %ROUTINE %SPEC newgen %ALIAS "S#NEWGEN"(%STRING (255) f,g, %INTEGER %NAME flag) %EXTERNAL %INTEGER %FN %SPEC UInfI %ALIAS "S#UINFI"(%INTEGER I) %EXTERNAL %ROUTINE %SPEC UCTranslate %ALIAS "S#UCTRANSLATE"(%INTEGER NA,NL) %EXTERNAL %ROUTINE %SPEC OutFile %ALIAS "S#OUTFILE"(%STRING (255) Name, %INTEGER LENGTH,MAXBYTES,PROTECTION, %INTEGER %NAME CONAD,FLAG) %EXTERNAL %INTEGER %MAP %SPEC ComRegMap %ALIAS "S#COMREGMAP"(%INTEGER I) %EXTERNAL %STRING (255) %FN %SPEC FAILUREMESSAGE %ALIAS "S#FAILUREMESSAGE"(%INTEGER FMST) %EXTERNAL %ROUTINE %SPEC IBMRecode %ALIAS "S#NCODE"(%INTEGER Start,End,Offset) {* Constant declarations *} %CONST %INTEGER Main= X'80000000' %CONST %INTEGER MainorExt= X'80000001' {* Area management constants *} %CONST %INTEGER code=1, gla=2, {free3} sst=4, Ust=5, diags=6, static=7, iotab=8, ZUST=9, Cnst=10 { Order of writing out areas } %CONST %INTEGER %ARRAY NextArea(1:9)= Code, Cnst, Sst, Diags, Gla, Static, UST, IOTab, ZUST %CONST %STRING (6) %ARRAY Areas(1:10)="Code", "Gla", "Unused", "Sst", "Ust", "Diags", "Static", "Iotab", "zust", "Cnst" { Properties of areas in object file map } %CONST %INTEGER %ARRAY AProps(Code:Cnst)= 0,1<<31,1<<31,0,1<<31,0,1<<31(3),0 { Internal control variables } { Properties bits for area definitions } %CONST %INTEGER BlankCommon= 1, NamedCommon = 1<<1, ZeroFilled = 1<<8, Unassigned = 1<<9, MultipleInit = 1<<10 %OWN %INTEGER Zero= 0 %OWN %INTEGER ImpFlag %OWN %STRING (255) LangVers { Compiler version string } %OWN %INTEGER GlobalAdjustment %OWN %INTEGER LinkorMod { 1 if PCodeBytes used } %OWN %INTEGER XAFlag { 1 for use BASR, 0 for use BALR } %OWN %INTEGER mon=0 { Put call monitoring control } %OWN %INTEGER AddMultiples { PUT to add correct number of multiples to code } %OWN %INTEGER ProcessbyProcs { Process Ca determined entries at end of each proc } %OWN %INTEGER Faulty { Errors have been detected } %OWN %INTEGER Ca { Code offset } %OWN %INTEGER TotCa { Running total of code size } %OWN %INTEGER ThisBaseCa { @ of record holding Ca after last code processing } %OWN %INTEGER LastCa { Last decode ended here } %OWN %INTEGER LastCaOffset { Used by PLineStart/Decode } %OWN %INTEGER CurrentLine { Updated by PLineStart } %OWN %INTEGER CurLexLev { Current nesting of blocks } %OWN %INTEGER NextSym { Next symbol table entry } %OWN %INTEGER SafeCode { Safe limit for 4 byte jumps from R12 } {* Identifier tables *} %CONST %INTEGER Fragment= 0 { Record contains a pure code fragment } %CONST %INTEGER ECRefType= 1, { Entry is a code ref } EDRefType = 2, { Entry is a data ref } LabelType = 3, { Entry is a Label } ECDefType = 4, { Entry is a code EP } JumpType = 5, { Entry is a Jump } UsingType = 6, { Entry is a PUsing } EDDefType = 8, { Entry is a data EP } CNOpType = 9, { Entry is a PCNOp } SwLabType =10, { Entry is a switch ent linked to a label } SwIndType =11, { Entry is a switch index } FixUpType=12, { Entry is a code fixup } AStart =13 { Entry is a base Ca for a new Proc } {* IBM XA Opcodes etc. *} %INCLUDE "ercs20:ib7.mnemonics" %INCLUDE "ercs20:ib7.props" %IF Tracing=On %THEN %START %INCLUDE "ercs20:ib7.names" %FINISH {* Service routines *} { RR equivalents of RX jumps for 2 and 6 byte jumps } %CONST %INTEGER %ARRAY RREqv(BAL:BAS)= BALR, BCTR, BCR, 0(5), BASR %STRING (255) %FN Itos(%INTEGER N) %STRING (255) S %INTEGER Sign S="" %IF N<0 %THEN %START N=-N Sign=1 %FINISH %ELSE Sign=0 %CYCLE S=Tostring((N-(N//10*10))+'0').S N=N//10 %REPEAT %UNTIL N=0 %IF Sign=1 %THEN S="-".S %RESULT=S %END { of Itos } %CONST %STRING (1) %ARRAY Hex(0:15)= "0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F" %EXTERNAL %ROUTINE dumptable(%INTEGER add,length) !*********************************************************************** !* Used for dumping the constant table after compilation * !*********************************************************************** %CONST %BYTE %INTEGER %ARRAY hexds(0:15)='0','1','2','3','4','5','6','7', '8','9','A','B','C','D','E','F' %INTEGER i,j,k,ad,end,sptr,val,sadd %STRING (132) s ad=addr(s) add=add&(-4) sadd=add newline end=add+length; i=1 s=" " %UNTIL add>=end %CYCLE j=add+31 %IF i=0 %AND add+32on %IF integer(k)#integer(k-32) %REPEAT s="O"; ->up %FINISH on: byteinteger(ad+2)='('; sptr=3 %CYCLE i=28,-4,0 byteinteger(ad+sptr)=hexds(((add-sadd)>>i)&15) sptr=sptr+1 %REPEAT byteinteger(ad+sptr)=')' byteinteger(ad+sptr+1)=' ' sptr=sptr+2 %CYCLE k=add,4,add+28 val=integer(k) %CYCLE i=28,-4,0 byteinteger(ad+sptr)=hexds((val>>i)&15) sptr=sptr+1 %REPEAT byteinteger(ad+sptr)=' ' sptr=sptr+1 %REPEAT byteinteger(ad+sptr)=' ' sptr=sptr+1 %CYCLE k=add,1,add+31 i=byteinteger(k)&x'7f' %UNLESS 32<=i<127 %THEN i=' ' byteinteger(ad+sptr)=i sptr=sptr+1 %REPEAT byteinteger(ad+sptr)=nl byteinteger(addr(s))=sptr printstring(s) s=" " up: add=add+32 i=0 %REPEAT %END; !routine dump %STRING (8) %FN Htos(%INTEGER I,Size) %INTEGER j %STRING (8) s s="" %CYCLE j=(size*4)-4,-4,0 s=s.hex((i>>j)&15) %REPEAT %RESULT=s %END { of Htos } %IF Tracing=On %THEN %START %ROUTINE PHexByte(%INTEGER I) !*********************************************************************** !* Print the Hex value of a single byte * !*********************************************************************** Printstring(Hex((I>>8)&15).Hex(I&15)) %END { of PHexByte } %STRING (5) %FN ENames(%INTEGER OP) %INTEGER Op1,Op2 Op1=Op>>8 Op2=Op&255 %IF Op=X'80' %OR Op=X'82' %OR Op=X'93' %THEN %RESULT=Names(Op1) %IF Op1=X'E5' %THEN %START %IF Op2=1 %THEN %RESULT="LASP" %IF Op2=2 %THEN %RESULT="TPROT" %FINISH %IF Op1=X'B2' %THEN %START %IF Op2<=60 %THEN %RESULT=ExNames(Op2) %IF Op2=X'F0' %THEN %RESULT="PPG" %IF Op2=X'F1' %THEN %RESULT="PSU" %FINISH %IF Op1=X'9C' %THEN %START %IF Op2=0 %THEN %RESULT="SIO" %IF Op2=1 %THEN %RESULT="SIOF" %IF Op2=2 %THEN %RESULT="RIO" %FINISH %IF Op1=X'9E' %THEN %START %IF Op2=0 %THEN %RESULT="HIO" %IF Op2=1 %THEN %RESULT="HDV" %FINISH %IF Op1=X'9D' %AND Op2=1 %THEN %RESULT="CLRIO" %IF Op1=X'9F' %AND Op2=1 %THEN %RESULT="CLRCH" %RESULT="?????" %END { of ENames } %FINISH %INTEGER %FN EProps(%INTEGER Op) { Checks the format for an extended opcode } %INTEGER Op1,Op2 Op1=Op>>8 Op2=Op&255 %IF Op2=X'80' %OR Op2=X'82' %OR Op2=X'93' %THEN %RESULT=SPROP %IF Op1=X'E5' %THEN %START %IF 0<=Op2<=1 %THEN %RESULT=SSE %RESULT=0 %FINISH %IF X'9C'<=Op1<=X'9F' %AND Op2=1 %THEN %RESULT=SPROP %IF X'9C00'<=Op<=X'9C02' %OR X'9D00'<=Op<=X'9E00' %THEN %RESULT=SPROP %IF Op1=X'B2' %THEN %START %IF X'F0'<=Op2<=X'F1' %THEN %RESULT=SProp %IF Op2>60 %THEN %RESULT=0 %RESULT=EXProps(Op2) %FINISH %RESULT=0 %END { of EProps } %ROUTINE PError(%STRING (255) S, %INTEGER GoOn) Printstring(" * Put Interface Error/ ".s." ") Faulty=1 ComRegMap(24)=1 %IF Tracing=On %THEN %START %MONITOR %FINISH SelectOutput(0) Printstring("Put error: ".S." ") SelectOutput(82) %RETURN %IF GoOn=0 {try to keep going to allow report of multiple faults } %STOP %END { of PError } {* Local service routines *} {* Area initialisation *} {* Fixup Manipulation *} %OWN %INTEGER FileSize { Running total of object file size } %OWN %INTEGER Multsize {Passes Msize to process code} %OWN %INTEGER TopDict { Size of dictionary } %OWN %INTEGER ADict { Start of dictionary } %OWN %INTEGER NDict { Current start of free space } %OWN %INTEGER LFixups, { Head of label fixup list }XProcList, { Head of ext proc EP list }XRefList, { Head of ext code refs }FFixups, { Head of relocation requests }XDEPList, { Head of ext data EPs }XDList, { Head of ext data refs }SwList, { Head of switch list }CurrSwEnd, { Tail of switches for current procedure }ThruList, { List ordered by Ca for optimisation }ThruLink, { Tail of ThruList }CodeList, { List of code area fragments ordered by Ca }CodeLink, { Tail of CodeList }HistList, { Head of list of history records }HistLink, { Tail of list of history records }AreaList, { Head of list of area definitions }InitList, { Head of list of initialisation records }BoundRelocs, { Head of list of satisfied relocations in a bound file }LastUsed { Address of last active Using record } %OWN %INTEGER %ARRAY AreaHead(Gla:Cnst) { Heads of area fragment lists } %OWN %INTEGER %ARRAY AreaTail(Gla:Cnst) { Tails of area fragment lists } %OWN %INTEGER %ARRAY IntList(Gla:Cnst) { Heads of area initialisation lists } %RECORD %FORMAT LabFmt(%SHORT %INTEGER Type,Flags, %INTEGER ThruLink,Link,Label,Ca) %RECORD %FORMAT ECRefFmt(%INTEGER Link,Id,GlaAd, %STRING (31) Name) %RECORD %FORMAT ECDefFmt(%SHORT %INTEGER Type,Dum, %INTEGER ThruLink,Link,W0,W1,Ca,ParamW, %STRING (31) Name) %RECORD %FORMAT FixUpFmt(%SHORT %INTEGER Type,Dum, %INTEGER Thrulink,Link,Tgt,Host) %RECORD %FORMAT EDHeadFmt(%INTEGER Link,XDLink,Len, %STRING (31) Name) %RECORD %FORMAT EDRefFmt(%INTEGER Link,ADisp) %RECORD %FORMAT EDDefFmt(%INTEGER Link,Disp,Props, %STRING (31) Name) %RECORD %FORMAT UsingFmt(%SHORT %INTEGER Type,Dum, %INTEGER ThruLink,Link,Reg,Ca) %RECORD %FORMAT CNOpFmt(%SHORT %INTEGER Type,B, %INTEGER ThruLink,Link,W,Ca) %RECORD %FORMAT SwFmt(%SHORT %INTEGER Size,Sad, %INTEGER Lower,Upper,Link,Def,Labs) %RECORD %FORMAT SwElFmt(%SHORT %INTEGER Type,Index,(%INTEGER ThruLink,RLink,LLink,Ca %OR %INTEGER Link,Lab)) %RECORD %FORMAT AreaFmt(%INTEGER Area,Len,Offset,Link) %RECORD %FORMAT InitFmt(%INTEGER Link,Disp, %SHORT %INTEGER NCopies,Area,Len) %RECORD %FORMAT AreaDefFmt(%SHORT %INTEGER Iin,Props, %INTEGER Link,Len, %STRING (31) Name) %RECORD %FORMAT HFormat(%INTEGER Link,Type,Depth, %STRING (255) S) %RECORD %FORMAT CodeFragFmt(%SHORT %INTEGER Type,Line, %INTEGER ThruLink,Offset,Link,Ca,Reg,Len,(%INTEGER Label, Used %OR %INTEGER B,W)) %OWN %RECORD (CodeFragFmt) %NAME CodeBuffer %OWN %INTEGER BuffStart %OWN %INTEGER CurLabs,CurLabsTop %OWN %INTEGER MinMults { Multiples of 4096 for head of Code } %CONST %INTEGER Multmax= 128 %CONST %INTEGER %ARRAY Multiples(0:Multmax)= 0, 1*4096, 2*4096, 3*4096, 4*4096, 5*4096, 6*4096, 7*4096, 8*4096, 9*4096,10*4096,11*4096,12*4096,13*4096,14*4096,15*4096,16*4096, 17*4096,18*4096,19*4096,20*4096,21*4096,22*4096,23*4096,24*4096, 25*4096,26*4096,27*4096,28*4096,29*4096,30*4096,31*4096,32*4096, 33*4096,34*4096,35*4096,36*4096,37*4096,38*4096,39*4096,40*4096, 41*4096,42*4096,43*4096,44*4096,45*4096,46*4096,47*4096,48*4096, 49*4096,50*4096,51*4096,52*4096,53*4096,54*4096,55*4096,56*4096, 57*4096,58*4096,59*4096,60*4096,61*4096,62*4096,63*4096,64*4096, 65*4096,66*4096,67*4096,68*4096,69*4096,70*4096,71*4096,72*4096, 73*4096,74*4096,75*4096,76*4096,77*4096,78*4096,79*4096,80*4096, 81*4096,82*4096,83*4096,84*4096,85*4096,86*4096,87*4096,88*4096, 89*4096,90*4096,91*4096,92*4096,93*4096,94*4096,95*4096,96*4096, 97*4096,98*4096,99*4096,100*4096,101*4096,102*4096,103*4096,104*4096, 105*4096,106*4096,107*4096,108*4096,109*4096,110*4096,111*4096,112*4096, 113*4096,114*4096,115*4096,116*4096,117*4096,118*4096,119*4096,120*4096, 121*4096,122*4096,123*4096,124*4096,125*4096,126*4096,127*4096,128*4096 { The adjustment needed to compact the 3 * halfwords of NOP planted for } { every PCNOP with W = 8. Ca&7 is the adjusted offset from a double word } { boundary after compaction of preceding code. B is the byte offset given } { to the PCNOP call. } %CONST %INTEGER %ARRAY Adj(0:15)= { Ca&7 = 0 } 0, 2, 4, 6, { Ca&7 = 2 } 6, 0, 2, 4, { Ca&7 = 4 } 4, 6, 0, 2, { Ca&7 = 6 } 2, 4, 6, 0 { B = 0 2 4 6 } { Area buffer manipulation } %OWN %INTEGER %ARRAY BuffAd(Gla:Cnst) %RECORD %FORMAT AreaBuffFmt(%SHORT %INTEGER Area,Len, %INTEGER Offset,Link, %BYTE %INTEGER %ARRAY Data(1:4096)) %OWN %RECORD (AreaBuffFmt) %ARRAY %FORMAT AreaBuffArrayFmt(Gla:Cnst) %OWN %RECORD (AreaBuffFmt) %ARRAY %NAME AreaBuffer %ROUTINE FlushData(%INTEGER Area) !*********************************************************************** !* Flush out the current contents of the buffer for Area * !*********************************************************************** %RECORD (AreaFmt) %NAME Rec,NewRec,LastRec %INTEGER Here,Len Rec==AreaBuffer(Area) Len=Rec_Len %RETURN %IF Len=0 %IF NDict+Sizeof(Rec)+Len>TopDict %THEN PError("Work file full",1) Here=ADict+NDict NewRec==Record(Here) NewRec=Rec Move(Len,BuffAd(Area),Here+Sizeof(Rec)) NDict=(NDict+Len+Sizeof(Rec)+3)&(\3) NewRec_Link=0 %IF AreaHead(Area)#0 %THEN %START LastRec==record(AreaTail(Area)) LastRec_Link=Here %FINISH %ELSE AreaHead(Area)=Here AreaTail(Area)=Here Rec_Offset=Rec_Offset+Len Rec_Len=0 %END { of FlushData } {* Output to code area *} %ROUTINE FlushCode(%INTEGER Type) !*********************************************************************** !* Move the current contents of CodeBuffer to the heap and reset Cod*eBuffer !*********************************************************************** %RECORD (CodeFragFmt) %NAME Rec,Rec1 %INTEGER Here,Len Here=ADict+NDict Rec==Record(Here) Len=CodeBuffer_Len %IF Len#0 %THEN %START %IF NDict+Sizeof(Rec)+Len>TopDict %THEN PError("Work file full",1) Rec=CodeBuffer %IF LastCa=0 %THEN LastCa=Here Move(Len,BuffStart,Here+Sizeof(Rec)) NDict=(NDict+Len+Sizeof(Rec)+3)&(\3) %IF ThruList=0 %THEN ThruList=Here %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_ThruLink=Here %FINISH Rec_ThruLink=0 ThruLink=Here %IF CodeList=0 %THEN CodeList=Here %IF CodeLink#0 %THEN %START Rec1==Record(CodeLink) Rec1_Link=Here %FINISH Rec_Link=0 CodeLink=Here %FINISH CodeBuffer_Ca=Ca CodeBuffer_Type=Type CodeBuffer_Len=0 CodeBuffer_Offset=0 CodeBuffer_Line=CurrentLine %END { of FlushCode } %ROUTINE IPUT312(%INTEGER Val) !*********************************************************************** !* Equivalent to IPUT(31,2,Ca,Val) * !*********************************************************************** %IF 4096-CodeBuffer_Len<2 %THEN FlushCode(Fragment) Byteinteger(BuffStart+CodeBuffer_Len)=Val>>8 Byteinteger(BuffStart+CodeBuffer_Len+1)=Val&255 %IF ComRegMap(26)&128#0 %THEN IBMRecode(CodeBuffer_Len+BuffStart,CodeBuffer_Len+BuffStart+2,Ca) CodeBuffer_Len=CodeBuffer_Len+2 Ca=Ca+2 %END { of IPUT312 } %ROUTINE IPUT314(%INTEGER Val) !*********************************************************************** !* Equivalent to IPUT(31,4,Ca,Val) * !*********************************************************************** %INTEGER I %IF 4096-CodeBuffer_Len<4 %THEN FlushCode(Fragment) %FOR I=0,1,3 %CYCLE Byteinteger(BuffStart+CodeBuffer_Len+I)=(Val>>(24-8*I))&255 %REPEAT %IF ComRegMap(26)&128#0 %THEN IBMRecode(CodeBuffer_Len+BuffStart,CodeBuffer_Len+BuffStart+4,Ca) CodeBuffer_Len=CodeBuffer_Len+4 Ca=Ca+4 %END { of IPUT314 } %ROUTINE IPUT316(%INTEGER AdVal) !*********************************************************************** !* Equivalent to IPUT(31,6,Ca,AdVal) * %IF 4096-CodeBuffer_Len<6 %THEN FlushCode(Fragment) Move(6,AdVal,BuffStart+CodeBuffer_Len) %IF ComRegMap(26)&128#0 %THEN IBMRecode(CodeBuffer_Len+BuffStart,CodeBuffer_Len+BuffStart+6,Ca) CodeBuffer_Len=CodeBuffer_Len+6 Ca=Ca+6 %END; ! of IPUT316 %ROUTINE IPUT31N(%INTEGER Len,Ad) !*********************************************************************** !* Equivalent to IPUT(31,Len,Ca,Ad) * !*********************************************************************** %IF 4096-CodeBuffer_Len1 %THEN %START Printstring("PIXRR ".Names(Op)." ".Regs(R1)." ".Regs(R2)." ") %FINISH %FINISH PError("Inappropiate opcode",0) %IF Props(Op)&15#RR IPUT312(((Op&255)<<8)!((R1&15)<<4)!(R2&15)) %END { of PIX RR } %EXTERNAL %ROUTINE PIXRRE(%INTEGER Op,R1,R2) %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXRRE ".ENames(Op)." ".Regs(R1)." ".Regs(R2)." ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF EProps(Op)#RRE IPUT314((Op<<16)!((R1&15)<<4)!(R2&15)) %END { of PIX RRE } %EXTERNAL %ROUTINE PIX RX(%INTEGER Op,R1,X2,B2,D2) %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXRX ".Names(Op)." ".Regs(R1)." ".Regs(X2)." ") Printstring(Regs(B2)." ".Htos(D2,8)." ") %IF Props(Op)&15=RS %THEN Printstring("*** RS used in RX *** ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF Props(Op)&15#RX %AND Props(Op)&15#RS IPUT314((Op<<24)!((R1&15)<<20)!((X2&15)<<16)!((B2&15)<<12)!(D2&X'FFF')) %END { of PIX RX } %EXTERNAL %ROUTINE PIX RS(%INTEGER Op,R1,R3,B2,D2) %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXRS ".Names(Op)." ".Regs(R1)." ".Regs(R3)) Printstring(" ".Regs(B2)." X'".Htos(D2,8)."' ") %IF Props(Op)&15=RX %THEN Printstring("*** RX used for RS *** ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF Props(Op)&15#RS %AND Props(Op)&15#RX IPUT314((Op<<24)!((R1&15)<<20)!((R3&15)<<16)!((B2&15)<<12)!(D2&X'FFF')) %END { of PIX RS } %EXTERNAL %ROUTINE PIX SI(%INTEGER Op,I2,B1,D1) %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIX ".Names(Op)." X'".Htos(I2,8)."' ".Regs(B1)." X'") Printstring(Htos(D1,8)."' ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF Props(Op)&15#SI IPUT314((Op<<24)!((I2&255)<<16)!((B1&15)<<12)!(D1&X'FFF')) %END { of PIX SI } %EXTERNAL %ROUTINE PIX S(%INTEGER Op,B2,D2) %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXS ".ENames(Op)." ".Regs(B2)." X'".Htos(D2,8)."' ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF EProps(Op)#SPROP %IF Op<=255 %THEN Op=Op<<8 IPUT314((Op<<16)!((B2&15)<<12)!(D2&X'FFF')) %END { of PIX S } %EXTERNAL %ROUTINE PIX SS(%INTEGER Op,L1,L2,B1,D1,B2,D2) %INTEGER Val1,Val2 %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXSS ".Names(Op)." ".Itos(L1)." ".Itos(L2)." ") Printstring(Regs(B1)." X'".Htos(D1,8)."' ".Regs(B2)." X'".Htos(D2,8)."' ") %FINISH %FINISH PError("Inappropriate opcode",0) %IF Props(Op)#SS %IF L1#0 %THEN L1=L1-1 %IF L2#0 %THEN L2=L2-1 Val1=(Op<<24)!((L1&15)<<20)!((L2&255)<<16)!((B1&15)<<12)!(D1&X'FFF') Val2=((B2&15)<<28)!((D2&X'FFF')<<16) IPUT316(Addr(Val1)) %END { of PIX SS } %EXTERNAL %ROUTINE PIX SSE(%INTEGER Op,B1,D1,B2,D2) %INTEGER Val1,Val2 %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PIXSSE ".ENames(Op)." ".Regs(B1)." X'".Htos(D1,8)."' ") Printstring(Regs(B2)." X'".Htos(D2,8)."'") %FINISH %FINISH PError("Inappropriate opcode",0) %IF EProps(Op)#SSE Val1=(Op<<16)!((B1&15)<<12)!(D1&X'FFF') Val2=((B2&15)<<28)!((D2&X'FFF')<<16) IPUT316(Addr(Val1)) %END {* List handling in heap *} %ROUTINE NoteL(%INTEGER Label,Ca) { Associate the Label with Ca } %INTEGER I %RECORD (LabFmt) %NAME Rec,Rec1 %IF CurLabs+Sizeof(Rec)>CurLabsTop %THEN %START I=((NDict+4095)&(\4095))+4096 { Page aligned label space } %IF I>TopDict %THEN PError("New label causes table overflow",1) CurLabs=ADict+NDict CurLabsTop=I+ADict NDict=I %FINISH Rec==Record(CurLabs) Rec_Type=LabelType Rec_Link=LFixups LFixups=CurLabs Rec_Label=Label Rec_Ca=Ca %IF CA#-1 %THEN %START { Avoid adding forward ref to Ca ordered list } %IF ThruList=0 %THEN ThruList=CurLabs { First on the Ca ordered list } %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_ThruLink=CurLabs %FINISH ThruLink=CurLabs Rec_ThruLink=0 %FINISH CurLabs=CurLabs+Sizeof(Rec) %END { of NoteL } %INTEGER %FN LocateL(%INTEGER N, %INTEGER %NAME La) { Returns the addr of the label record associated with label N } %RECORD (LabFmt) %NAME Rec La=LFixups %WHILE La#0 %CYCLE Rec==Record(La) %IF Rec_Label=N %THEN %RESULT=0 La=Rec_Link %REPEAT %IF CurLabs+Sizeof(Rec)<=CurLabsTop %THEN La=CurLabs %ELSE La=ADict+NDict %RESULT=1 %END { of LocateL } %INTEGER %FN LocateSw(%INTEGER SAd, %INTEGER %NAME At) { Find the location of the entry for a switch at Sad in SST } %RECORD (SwFmt) %NAME Rec At=SwList %WHILE At#0 %CYCLE Rec==Record(At) %IF Rec_SAd=SAd %THEN %RESULT=0 At=Rec_Link %REPEAT %RESULT=1 %END { of Locate Sw } %EXTERNAL %INTEGER %FN PMarker(%INTEGER HalfWords) %INTEGER Here,I %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Marker at ".htos(Ca,8)." len ") Printstring(itos(HalfWords)." ") %FINISH %FINISH { Associate the Marker with Ca } %IF HalfWords=0 %THEN %START { Marker used to mark a relocation } %RESULT=Ca %FINISH %ELSE %START %IF CodeBuffer_Len+(HalfWords<<1)>4096 %THEN FlushCode(Fragment) Here=ADict+NDict+Sizeof(CodeBuffer)+CodeBuffer_Len IPut312(0) %FOR I=1,1,HalfWords FlushCode(Fragment) %RESULT=Here %FINISH %END { of PMarker } {* Process red tape part of file *} {* Relocation primitives *} %EXTERNAL %ROUTINE PSetOpD(%INTEGER MarkValue,Offset,HalfWord) %INTEGER At,I %RECORD (CodeFragFmt) %NAME CRec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PSetOpd, mark ".Itos(MarkValue)." offset ".itos(Offset)) Printstring(" value ".itos(HalfWord)." ") %FINISH %FINISH I=MarkValue+(Offset<<1) byteinteger(I)=HalfWord>>8 byteinteger(I+1)=HalfWord&255 %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("Set in record at ".Htos(I,8)." ") %FINISH %FINISH %END { of PSetOpD } %EXTERNAL %ROUTINE PLabel(%INTEGER LabelId) { Note a label at CA, LabelId being assigned by the code generator } %INTEGER Flag,Val,I %RECORD (LabFmt) %NAME Lab,Last %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("Plabel called for ".Itos(LabelId)." ") %FINISH %FINISH FlushCode(Fragment) %IF LocateL(LabelId,I)=0 %THEN %START { Forward jump } Lab==Record(I) %IF Lab_Ca#-1 %THEN PError("Label ".Itos(LabelId)." set twice",1) Lab_Ca=Ca Last==Record(ThruLink) Last_ThruLink=I { Add record to Ca ordered list, which } Lab_ThruLink=0 ThruLink=I { was not done by NoteL for a forward ref } %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("Forward label at:".Htos(Ca,8)." ") %FINISH %FINISH %FINISH %ELSE %START NoteL(LabelId,Ca) %FINISH %END { of PLabel } %EXTERNAL %ROUTINE PUsing(%INTEGER Reg) %INTEGER I %RECORD (UsingFmt) %NAME Rec,Rec1,Next %IF Tracing=On %THEN %START %IF Mon#0 %THEN Printstring("PUsing, reg ".regs(Reg)." ") %FINISH %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) %IF LastUsed#0 %THEN %START Rec==Record(LastUsed) %IF Rec_Reg=Reg %THEN %START LastUsed=Rec_Link %FINISH %ELSE %START %WHILE Rec_Link#0 %CYCLE Next==Record(Rec_Link) %IF Next_Reg=Reg %THEN %START Rec_Link=Next_Link %FINISH Rec==Next %REPEAT %FINISH %FINISH FlushCode(Fragment) I=ADict+NDict Rec==Record(I) Rec_Ca=Ca Rec_Reg=Reg Rec_Type=UsingType %IF ThruList=0 %THEN ThruList=I %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_Thrulink=I %FINISH Rec_ThruLink=0 ThruLink=I Rec_Link=LastUsed Lastused=I NDict=NDict+Sizeof(Rec) %END { of P Using } %EXTERNAL %ROUTINE PDrop(%INTEGER Reg) %INTEGER I,Found %RECORD (UsingFmt) %NAME Used,NRec Found=0 %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Drop ".Regs(Reg)." ") %IF LastUsed=0 %THEN Printstring("*** Using list empty *** ") %FINISH %FINISH %IF LastUsed#0 %THEN %START Used==Record(LastUsed) %IF Used_Reg=Reg %THEN %START LastUsed=Used_Link Found=1 %FINISH %ELSE %START %WHILE Used_Link#0 %CYCLE NRec==Record(Used_Link) %IF NRec_Reg=Reg %THEN %START Used_Link=NRec_Link Found=1 %FINISH Used==NRec %REPEAT %FINISH %FINISH %IF Tracing=On %THEN %START %IF Mon#0 %AND Found=0 %THEN Printstring("*** Unmatched drop *** ") %FINISH %END { of PDrop } %EXTERNAL %ROUTINE PJump(%INTEGER Op,LabelId,Mask,Reg) { Plant jump instruction, filling in address for backward jumps } %RECORD (LabFmt) %NAME Lab %RECORD (UsingFmt) %NAME Used %INTEGER I,Tem %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Jump:".Names(Op)." ".Itos(LabelId)." Mask:") Printstring(Itos(Mask)." ".Regs(Reg)." ") %FINISH %FINISH Tem=LastUsed %IF LocateL(LabelId,I)=0 %THEN %START { Backward jump } Lab==Record(I) ! %IF Lab_Ca=0 %THENSTART { Plant 2 byte form } ! PIXRR(RREqv(Op),Mask,12) { No need to adjust } ! %RETURN ! %FINISH I=LastUsed %IF Lab_Ca>=0 %THEN %START { Not a forward ref to label } %IF Lab_CaOut I=Used_Link %REPEAT %UNTIL I=0 %FINISH %FINISH Out: LastUsed=I %FINISH %ELSE %START NoteL(LabelId,-1) Lab==Record(I) %FINISH { Add a jump ref to the list attached to label record at Ad } FlushCode(JumpType) CodeBuffer_Used=LastUsed CodeBuffer_Reg=Reg CodeBuffer_Label=Addr(Lab) LastUsed=Tem %IF Reg>0 %THEN PIX RX(L,Reg&15,12,0,0) %IF Reg<0 %THEN PIXRX(Op,Mask,0,-Reg,0) %ELSE PIXRX(Op,Mask,12,Reg&15,0) %END { of PJump } %EXTERNAL %ROUTINE PJIndex(%INTEGER Op,Label,Reg1,Reg2) { Plant a Branch on Index form of jump to Label } %INTEGER Reg,I %RECORD (LabFmt) %NAME Lab %RECORD (UsingFmt) %NAME Used %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Jump on Index:".Names(Op)." ".Itos(Label)) Printstring(" Regs ".Regs(Reg1)." ".Regs(Reg2)." ") %FINISH %FINISH Reg=0 %IF LocateL(Label,I)=0 %THEN %START { Backward jump } Lab==Record(I) %IF LastUsed#0 %THEN %START Used==Record(LastUsed) %IF 0<=Lab_Ca-Used_Ca<4096 %THEN Reg=-Used_Reg %FINISH %ELSE %START %IF Lab_Ca>=4096 %THEN PError("No Using for Jump on Index",0) %ELSE Reg=-12 %FINISH %FINISH %ELSE %START NoteL(Label,-1) Lab==Record(I) %FINISH { Add a jump ref to the list attached to label record at Ad } FlushCode(JumpType) CodeBuffer_Line=CurrentLine CodeBuffer_Used=LastUsed CodeBuffer_Reg=Reg CodeBuffer_Label=Addr(Lab) PIXRS(Op,Reg1,Reg2,0,0) %END { of PJIndex } {* Switch support *} %EXTERNAL %ROUTINE PSwitch(%INTEGER SSTAd,Lower,Upper,Size) { Note that a switch with bounds Lower and Upper is at SSTAd } { in the SST. Size is the entry size - 2 or 4 bytes. } %INTEGER Here %RECORD (SwFmt) %NAME Rec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Switch at ".Htos(SSTAd,6)." in SST, Size=".Itos(Size)." Bounds = ".Itos(Lower).":".Itos(Upper)." ") %FINISH %FINISH { Note a switch table at SSTAd in SST } %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) Rec=0 Rec_Link=SWList Rec_SAd=SSTAd Rec_Lower=Lower Rec_Upper=Upper Rec_Size=Size Rec_Labs=0 Rec_Def=0 SwList=Here NDict=NDict+Sizeof(Rec) %END { of PSwitch } %EXTERNAL %ROUTINE PSwitchVal(%INTEGER SSTAd,Index,Label) { Note a match between Index in switch table at SSTAd and Label } %INTEGER Here,SwAd %RECORD (SwElFmt) %NAME Rec %RECORD (SwFmt) %NAME Sw %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PSwitchVal ".Htos(SSTAd,6)." Index = ".Itos(Index)) Printstring(" Label = ".Itos(Label)." ") %FINISH %FINISH %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) Rec=0 %IF LocateSw(SSTAd,SwAd)#0 %THEN PError("Switch ".ITos(SSTAd)." missing",0) Sw==Record(SwAd) Rec_Index=Index Rec_Lab=Label Rec_Link=Sw_Labs Sw_Labs=Here NDict=NDict+Sizeof(Rec) %END { of PSwitchVal } %EXTERNAL %ROUTINE PSLabel(%INTEGER SSTAd,Index) { Fill in an element of the switch at SSTAd with Ca } %INTEGER At,Here %RECORD (SwElFmt) %NAME Rec,Rec1 %RECORD (SwFmt) %NAME Sw %ROUTINE AddTo(%INTEGER %NAME Link) { Add the element to a tree sorted list } %RECORD (SwElFmt) %NAME Node %IF Link=0 %THEN Link=Here %AND %RETURN Node==Record(Link) %IF Node_Index=Index %THEN %START { Replace earlier entry } Rec_LLink=Node_LLink Rec_RLink=Node_RLink Link=Here %RETURN %FINISH %IF Node_Index>Index %THEN AddTo(Node_RLink) %ELSE AddTo(Node_LLink) %END { of AddTo } %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Switch Label ".Itos(Index)." ".Htos(SSTAd,6)." ") %FINISH %FINISH FlushCode(Fragment) %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) Rec=0 %IF LocateSw(SSTAd,At)#0 %THEN PError("Switch ".ITos(SSTAd)." missing",0) Sw==Record(At) Rec_Index=Index Rec_Type=SwIndType AddTo(Sw_Labs) Rec_Ca=Ca %IF ThruList=0 %THEN ThruList=Here { First on Ca ordered list } %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_ThruLink=Here %FINISH Rec_ThruLink=0 ThruLink=Here NDict=NDict+Sizeof(Rec) %END { of P S Label } %EXTERNAL %ROUTINE PSDefault(%INTEGER SSTAd,Label) { Fill any unfilled elements of the switch with Label's Ca } %INTEGER At,I,DefLab,At2 %RECORD (LabFmt) %NAME Rec2 %RECORD (SwFmt) %NAME Rec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Switch Deft. for ".Htos(SSTAd,6)." label=".Itos(Label)." ") %FINISH %FINISH %IF LocateSw(SSTAd,At)#0 %THEN PError("Switch ".Htos(SSTAd,6)." missing",0) Rec==Record(At) %IF Label=0 %THEN Rec_Def=-Ca { Label =0, default is at Ca } %ELSE %C Rec_Def=Label { Label < 0, default is value of Label } %END { of P S Default } {* Put Interface Passing of Data * *} %EXTERNAL %ROUTINE PCodeHalf(%INTEGER Val) { Write two bytes to the Code area unchecked at Ca } %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Code Half ".Htos(Val,4)." ") %FINISH %FINISH %IF Val>>16#0 %THEN PError("Val too big in PCodeHalf",0) %IF 4096-CodeBuffer_Len<2 %THEN FlushCode(Fragment) Byteinteger(BuffStart+CodeBuffer_Len)=Val>>8 Byteinteger(BuffStart+CodeBuffer_Len+1)=Val&255 CodeBuffer_Len=CodeBuffer_Len+2 Ca=Ca+2 %END { of PCode Half } %EXTERNAL %ROUTINE PCodeWord(%INTEGER Val) { Write four bytes to the Code area at current position } %INTEGER I %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Code Word: ".Htos(Val,8)." ") %FINISH %FINISH %IF 4096-CodeBuffer_Len<4 %THEN FlushCode(Fragment) %FOR I=3,-1,0 %CYCLE Byteinteger(BuffStart+CodeBuffer_Len+I)=Val&255 Val=Val>>8 %REPEAT CodeBuffer_Len=CodeBuffer_Len+4 Ca=Ca+4 %END { of PCodeWord } %EXTERNAL %ROUTINE PCodeBytes(%INTEGER Len,Ad) { Write Len bytes to the code area } %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PCodeBytes, Len ".Itos(Len)." ") %FINISH %FINISH LinkorMod=1 FlushCode(Fragment) %WHILE Len>4096 %CYCLE Iput31N(4096,Ad) Len=Len-4096 Ad=Ad+4096 %REPEAT Iput31N(Len,Ad) %END { of PCodeBytes } %EXTERNAL %ROUTINE PDBytes(%INTEGER Area,Disp,Len,Ad) %INTEGER I %RECORD (AreaFmt) %NAME Buffer %IF Tracing=On %THEN %START %IF mon#0 %START printstring(" PD ( ".itos(Area)." len = ".itos(len)." Disp=") write(disp,5) space ! PHexByte(Byteinteger(I)) %FOR I = Ad,1,Ad+Len-1 newline %FINISH %FINISH %RETURN %IF area=zust Buffer==AreaBuffer(Area) ! %IF Disp>Buffer_Offset %AND Disp+LenBuffer_Offset+Buffer_Len %THEN %C ! Buffer_Len = Disp+Len-Buffer_Offset ! %FINISHELSESTART FlushData(Area) Buffer_OffSet=Disp %WHILE Len>4096 %CYCLE Move(4096,Ad,BuffAd(Area)) Len=Len-4096 Ad=Ad+4096 Buffer_Len=4096 FlushData(Area) %REPEAT Buffer_Len=Len Move(Len,Ad,BuffAd(Area)) ! %FINISH %END { of PDBytes } %EXTERNAL %ROUTINE PD4(%INTEGER Area,Disp,Value) %RECORD (AreaFmt) %NAME Buffer { Plant a 4 byte value at Disp in Area, using unbuffered areas } %IF Tracing=On %THEN %START %IF Mon>1 %THEN %START Printstring("PD4, Area=".Itos(Area)." Disp=".Itos(Disp)."Val=".Itos(Value)." ") %FINISH %FINISH %RETURN %IF area=zust Buffer==AreaBuffer(Area) ! %IF Disp>=Buffer_Offset %AND Disp+4<=Buffer_Offset+4096 %START ! Move(4,Addr(Value),BuffAd(Area)+Disp-Buffer_Offset) ! %IF Disp+4>Buffer_Offset+Buffer_Len %THEN Buffer_Len = Disp+4-Buffer_Offset ! %FINISHELSESTART FlushData(Area) Integer(BuffAd(Area))=Value Buffer_Offset=Disp Buffer_Len=4 ! %FINISH %END { of PD4 } %EXTERNAL %ROUTINE PDPattern(%INTEGER Area,Disp,NCopies,Len,Ad) %RECORD (InitFmt) %NAME Rec %INTEGER I,Here %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring(" PDPattern( area = "); Write(area,1) Printstring(", disp = "); Write(disp,1) Printstring(", ncopies = "); Write(ncopies,1) Printstring(" filler = ") PHexByte(byteinteger(i)) %FOR i=ad,1,ad+len-1 Newline %FINISH %FINISH %RETURN %IF area=zust %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) %IF Gla<=Area<=Cnst %THEN %START Rec_Link=IntList(Area) IntLIst(Area)=Here %FINISH %ELSE %START Rec_Link=InitList InitList=Here %FINISH Rec_NCopies=NCopies Rec_Area=Area Rec_Disp=Disp Rec_Len=Len Move(Len,Ad,Here+Sizeof(Rec)) NDict=NDict+((Len+3)&(\3))+Sizeof(Rec) FileSize=FileSize+((Len+3)&(\3))+24 %END { of PDPattern } {* Put Interface RELOCATION and REFERENCES *} %EXTERNAL %INTEGER %FN PXname(%INTEGER Type, %STRING (255) %NAME XName, %INTEGER GlaAd) { Create an external code reference } { Xrefs are used many times so establish mapping to integer ID early} { and save on holding/passing of strings } %RECORD (ECRefFmt) %NAME Rec %INTEGER I,J %STRING (31) Name %IF Tracing=On %THEN %START %IF mon#0 %THEN printstring("Xname: ".XName." symID = ".itos(nextsym)." ") %FINISH Name<-XName I=Addr(Name)+1 J=Length(Name) UCTranslate(I,J) %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) NextSym=NextSym+1 %IF Type=1 %THEN GlaAd=GlaAd!X'80000000' { Note that a code reference is to be planted at GlaAd } I=ADict+NDict Rec==Record(I) Rec_Link=XRefList Rec_Id=NextSym Rec_GlaAd=GlaAd Rec_Name<-Name XRefList=I FileSize=FileSize+8+(Length(Name)+4)&(\3) NDict=NDict+Sizeof(Rec) %RESULT=NextSym %END { of PXName } %ROUTINE %SPEC PDXRef(%INTEGER I,J,K, %STRING (31) %NAME XName) %EXTERNAL %ROUTINE Pfix(%INTEGER Hostarea,HostDisp,TgtArea,TgtDisp) { A relocation request: set word in area, displacement = 'disp' bytes, } { the address of area 'targetareaid', displacement = TgtDisp.} %INTEGER Here %RECORD (FixUpFmt) %NAME Rec,Rec2 %RECORD (AreaDefFmt) %NAME ARec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PFix(".Itos(HostArea)."/".Htos(HostDisp,6)."->") Printstring(Itos(TgtArea)."/".Htos(TgtDisp,6)." ") %FINISH %FINISH { Check for common and call PDXRef } %IF TgtArea>255 %THEN %START { Can only be common } Here=AreaList %WHILE Here#0 %CYCLE ARec==Record(Here) %IF ARec_Iin=TgtArea %THEN ->Found Here=ARec_Link %REPEAT PError("Common not defined for fixup",0) Found: PDXRef(4,HostArea,HostDisp,ARec_Name) %RETURN %FINISH %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) TgtDisp=TgtDisp&X'FFFFFF' %IF FFixups=0 %THEN FileSize=FileSize+8 { Allow for header first time } { Note that HostDisp in HostArea is to be relocated by base of TgtArea } FlushCode(Fragment) Here=ADict+NDict Rec==Record(Here) Rec_Link=FFixups FFixups=Here %IF TgtArea=Code %AND TgtDisp#0 %THEN %START Rec_Tgt=TgtDisp Rec_Type=FixUpType %IF ThruList=0 %THEN ThruList=Here %IF ThruLink#0 %THEN %START Rec2==Record(ThruLink) Rec2_ThruLink=Here %FINISH ThruLink=Here %FINISH %ELSE %START Rec_Tgt=(TgtArea<<24)!TgtDisp %FINISH Rec_Host=(HostArea<<24)!HostDisp FileSize=FileSize+8 NDict=NDict+Sizeof(Rec) %END { of PFix } %EXTERNAL %ROUTINE PBReloc(%INTEGER AreaLoc,BaseLoc) { A satisfied relocation request in a bound file. } { Binding has set word in AreaLoc>>24, displacement = (AreaLoc<<8)>>8, } { the address of area BaseLoc>>24, displacement = (BaseLoc<<8)>>8.} %INTEGER Here %RECORD (FixUpFmt) %NAME Rec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PBReloc(".Itos(AreaLoc>>24)."/".Htos((AreaLoc<<8)>>8,6)."->") Printstring(Itos(BaseLoc>>24)."/".Htos((BaseLoc<<8)>>8,6)." ") %FINISH %FINISH %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) %IF BoundRelocs=0 %THEN FileSize=FileSize+8 { Allow for header first time } { Note that relocation given by AreaLoc:BaseLoc has been satisfied by binding. } Here=ADict+NDict Rec==Record(Here) Rec_Link=BoundRelocs BoundRelocs=Here Rec_Tgt=BaseLoc Rec_Host=AreaLoc FileSize=FileSize+8 NDict=NDict+Sizeof(Rec) %END { of PBReloc } %EXTERNAL %ROUTINE PDXRef(%INTEGER Type,Area,Disp, %STRING (31) %NAME ENm) { Define an external data reference } { Relocate word at Disp in Area by external data ref ENm } { Type holds min size in lowest byte } %INTEGER I,J %RECORD (EDHeadFmt) %NAME Head %RECORD (EDRefFmt) %NAME Rec %IF Tracing=On %THEN %START %IF mon#0 %THEN %START Printstring("PDXRef(".Areas(Area)."/".HtoS(Disp,8)."->".ENm." ") %FINISH %FINISH { Note that Disp in Area is to be relocated by data xref Name } I=Addr(ENm)+1 J=Length(ENm) UCTranslate(I,J) I=XDList %WHILE I#0 %CYCLE Head==Record(I) %IF Head_Name=ENm %THEN ->Found I=Head_Link %REPEAT %IF NDict+Sizeof(Head)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict Head==Record(I) Head_Link=XDList Head_Len=Type Head_Name=ENm XDList=I FileSize=FileSize+((20+Length(ENm))&(\3)) NDict=NDict+Sizeof(Head) Found: %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict Rec==Record(I) Rec_Link=Head_XDLink Head_XDLink=I Rec_ADisp=(Area<<24)!Disp FileSize=FileSize+4 NDict=NDict+Sizeof(Rec) %END { of PDXRef } %EXTERNAL %ROUTINE PDataEntry(%STRING (255) %NAME XName, %INTEGER Area,Maxlen,Disp) %INTEGER I,J %RECORD (EDDefFmt) %NAME Rec %STRING (31) Name %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("P Data Entry ".XName.Areas(Area)."+".Htos(Disp,8)." ") %FINISH %FINISH { Note an ext data EP at Disp in Area } Name<-Xname I=Addr(Name)+1 J=Length(Name) UCTranslate(I,J) %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict Rec==Record(I) Rec_Link=XDEPList Rec_Props=(Area<<24)!MaxLen Rec_Disp=Disp Rec_Name=Name XDEPList=I FileSize=FileSize+((20+Length(Name))&(\3)) NDict=NDict+Sizeof(Rec) %END { of PDataEntry } ! The next five routines deal with PROCEDURES %EXTERNAL %ROUTINE PEntry(%INTEGER Index, %STRING (255) %NAME XIden) { Sideways entry into procedure. Zero Index means overwrite main EP } %INTEGER I,Props,J %RECORD (CodeFragFmt) %NAME CRec %RECORD (ECDefFmt) %NAME Rec1,Rec2 %STRING (31) Iden %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("PEntry ".XIden." ".Itos(Index)." ") %FINISH %FINISH Iden<-XIden I=Addr(Iden)+1 J=LEngth(Iden) UCTranslate(I,J) Flushcode(Fragment) %IF XProcList#0 %AND Index=0 %THEN %START { Redefine main entry point as this one } I=XProcList Rec1==Record(I) %IF Rec1_Ca<0 %THEN %START XProcList=Rec1_link %FINISH %ELSE %START I=Rec1_Link %WHILE I#0 %CYCLE Rec2==Record(I) %IF Rec2_Ca<0 %THEN %START Rec1_Link=Rec2_Link ->Found %FINISH Rec1==Rec2 I=Rec1_link %REPEAT Found: %FINISH %FINISH { Note a sideways entry here } %IF Index=0 %THEN Props=X'80000000' %ELSE Props=0 %IF NDict+Sizeof(Rec1)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict Rec2==Record(I) Rec2_Link=XProcList CRec==Record(ThisBaseCa) Rec2_W0=CRec_Ca Rec2_W1=0 Rec2_Ca=Ca!Props Rec2_ParamW=-1 Rec2_Type=ECDefType %IF Props#0 %THEN Rec2_Name="S#GO" %ELSE Rec2_Name<-Iden NDict=NDict+Sizeof(Rec2) XProcList=I %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_ThruLink=I %FINISH Rec2_ThruLink=0 ThruLink=I %IF ThruList=0 %THEN ThruList=I { First on Ca ordered list } FileSize=FileSize+20+(Length(Iden)+4)&(\3) %END { of PEntry } %EXTERNAL %ROUTINE PProc(%STRING (31) %NAME XName, %INTEGER Props,ParamW, %INTEGER %NAME Id) { Start a new procedure } { PROPS&1 = external } { PROPS>>31 = Main entry } %INTEGER Type,Save,Disp %INTEGER I,J %RECORD (CodeFragFmt) %NAME CRec %RECORD (ECDefFmt) %NAME Rec,Rec1 %STRING (31) Name %IF Tracing=On %THEN %START %IF mon#0 %THEN printstring(" proc: ".XName." CA: ".Htos(CA,8)." ") %FINISH Name<-XName I=Addr(Name)+1 J=Length(Name) UCTranslate(I,J) CurLexLev=CurLexLev+1 %IF Id=-1 %THEN %START { No previous spec, so claim an Id } NextSym=NextSym+1 Id=NextSym %FINISH %IF Props#0 %THEN %START { Note an external entry point at Ca corresponding to Name } FlushCode(Fragment) %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict Rec==Record(I) Rec_Link=XProcList CRec==Record(ThisBaseCa) Rec_W0=CRec_Ca Rec_W1=0 Rec_Ca=Ca!((Props>>31)<<31) Rec_ParamW=ParamW Rec_Type=ECDefType Rec_Name<-Name NDict=NDict+Sizeof(Rec) XProcList=I %IF ThruLink#0 %THEN %START Rec1==Record(ThruLink) Rec1_ThruLink=I %FINISH Rec_ThruLink=0 ThruLink=I %IF ThruList=0 %THEN ThruList=I { First on Ca ordered list } FileSize=FileSize+20+(Length(Name)+4)&(\3) %FINISH %END { of PProc } %EXTERNAL %ROUTINE PProcEntry(%INTEGER CodeOffset,GlaOffset,EPOffset,ParamW, %STRING (31) %NAME XName) { Pass a complete procedure entry } %RECORD (ECDefFmt) %NAME Rec %INTEGER Here %STRING (31) Name Name<-XName %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) Rec_W0=CodeOffset Rec_W1=GlaOffset Rec_Ca=EPOffset Rec_ParamW=ParamW Rec_Name=Name Rec_Link=XProcList XProcList=Here NDict=NDict+Sizeof(Rec) FileSize=FileSize+20+(Length(Rec_Name)+4)&(\3) %END { of PProcEntry } %ROUTINE ProcessCode { Do the jump preprocessing } %RECORD (CodeFragFmt) %NAME JRec,CRec %RECORD (LabFmt) %NAME LRec %RECORD (SwFmt) %NAME Sw %RECORD (SwElFmt) %NAME SwEl %INTEGER CodeOfst %RECORD (UsingFmt) %NAME Used %INTEGER I,J,Reg,Adjustment %INTEGER JAd,Ofst,LCa %RECORD (FixUpFmt) %NAME FRec %RECORD (ECDefFmt) %NAME ECD %SWITCH ThruType(Fragment:FixUpType) %ROUTINE JumpFail(%STRING (255) ErrMess) { Report a jump/label/using mismatch } IBMRecode(Addr(JRec)+Sizeof(JRec),Addr(JRec)+Sizeof(JRec)+JRec_Len,JRec_Ca) Printstring("Jump at ".HtoS(JRec_Ca,8)." line ".ItoS(JRec_Line)." Label at ".HtoS(LRec_Ca,8).", label no ".Itos(LRec_Label)." ******** ".ErrMess." ") %MONITOR %END { of JumpFail } FlushCode(Fragment) { Allow for the possible addition of multiples at head of code } %IF AddMultiples#0 %THEN %START CodeOfst=((Ca//4096)<<2)+4 %IF CodeOfst<(MinMults<<2)+4 %THEN CodeOfst=MinMults<<2+4 %IF CodeOfst>4*Multmax %THEN PError("Insufficient Multiples",1) %IF NDict+Sizeof(JRec)+CodeOfst>TopDict %THEN PError("Table overflow",1) I=ADict+NDict JRec==Record(I) JRec_Type=Fragment JRec_Len=CodeOfst Move(CodeOfst,Addr(Multiples(0)),I+Sizeof(JRec)) NDict=NDict+Sizeof(JRec)+CodeOfst CRec==Record(ThisBAseCa) JRec_Link=CRec_Link CRec_Link=I %FINISH %ELSE CodeOfst=0 Adjustment=CodeOfst I=ThruList %WHILE I#0 %CYCLE J=shortinteger(I) ->ThruType(J) ThruType(Fragment): JRec==Record(I) JRec_Ca=JRec_Ca+Adjustment I=JRec_ThruLink ->Finished ThruType(JumpType): { Process Jump entry } JRec==Record(I) J=I+Sizeof(JRec) LRec==Record(JRec_Label) Lca=lrec_ca %IF lrec_flags&32=0 %THEN lca=lca+adjustment %IF JRec_Used#0 %THEN Used==Record(JRec_Used) {4 Byte jump originally planted} %IF JRec_Reg=0 %THEN %START %IF JRec_Used#0 %THEN %START { Try to use offset from a PUsing } %IF Lrec_Ca=Used_Ca %THEN %START { Can use 2 byte jump} { BCR M,RUsed } Jrec_Reg=-Used_Reg ByteInteger(J+2)=RREqv(ByteInteger(J)) ByteInteger(J+3)=(ByteInteger(J+1)&X'F0')!JRec_Reg JRec_Offset=2 %FINISH %ELSE %IF 0=4096-codeofst %THEN JumpFail("Using too far, label ".ItoS(LRec_Label)) %FINISH %FINISH %ELSE %START; ! no using & no work reg must reach from hd of code %IF LCa>=4096-codeofst %THEN JumpFail("No using, label ".ItoS(LRec_Label)) %FINISH %FINISH %ELSE %START %IF JRec_Reg>0 %THEN %START { 8 byte form was planted } %IF JRec_Used#0 %THEN %START Used==Record(JRec_Used) {%if LCa=Used_Ca %thenstart} { Shorten to 2 Bytes } { BCR M,RUsed } {ByteInteger(J+6) = RREqv(ByteInteger(J+4))} {ByteInteger(J+7) = (ByteInteger(J+5)&X'F0')!Used_Reg} {JRec_Reg = -Used_Reg - 100} { To distinguish from 4 byte form } {JRec_Offset = 6} {%finishelse} %IF 00 %AND 0<(LCa-(JRec_Ca+adjustment)-2)<4096 %THEN %START { Try for 6 byte form } { BASR/BALR followed by BCR } J=J+2 %IF XAFlag=1 %THEN %START ByteInteger(J)=BASR %FINISH %ELSE %START ByteInteger(J)=BALR %FINISH ByteInteger(J+1)=JRec_Reg<<4 JRec_Used=-1 JRec_Reg=-JRec_Reg JRec_Offset=2 %IF ByteInteger(J+3)&15=12 %THEN ByteInteger(J+3)=ByteInteger(J+3)&X'F0' %FINISH %FINISH %FINISH JRec_Ca=JRec_Ca+Adjustment Adjustment=Adjustment-JRec_Offset I=JRec_ThruLink ->Finished ThruType(CNOpType): { Process CNoOp entry } CRec==Record(I) CRec_Ca=CRec_Ca+Adjustment %IF CRec_W=4 %THEN %START %IF CRec_Ca&3#CRec_B %THEN %START CRec_Len=0 Adjustment=Adjustment-2 %FINISH %FINISH %ELSE %START %IF CRec_Ca&7#CRec_B %THEN %START CRec_Len=Adj(CRec_B>>1+(CRec_Ca&7)<<1) Adjustment=Adjustment+CRec_Len-6 %FINISH %FINISH I=CRec_ThruLink ->Finished ThruType(LabelType): { Process Label entry } LRec==Record(I) LRec_Ca=LRec_Ca+Adjustment LRec_Flags=LRec_Flags!32 I=LRec_ThruLink ->Finished ThruType(ECDefType): { Process external code EP entry } ECD==Record(I) ECD_Ca=ECD_Ca+Adjustment+TotCa I=ECD_ThruLink ->Finished ThruType(UsingType): { Process Using entry } Used==Record(I) Used_Ca=Used_Ca+Adjustment I=Used_ThruLink ->Finished ThruType(SwIndType): { Process switch index entry } SwEl==Record(I) SwEl_Ca=SwEl_Ca+Adjustment I=SwEl_ThruLink ->Finished ThruType(FixUpType): { Process a code marker for a fixup } FRec==Record(I) FRec_Tgt=(FRec_Tgt+Adjustment)!(Code<<24) I=FRec_ThruLink ->Finished ThruType(*): { Should not be on list } PError("Wrong type on ThruList, no ".Itos(Integer(I)),0) Finished: %REPEAT { Now plug the missing fields at the jumps } I=CodeList %WHILE I#0 %CYCLE JRec==Record(I) %IF JRec_Type=JumpType %THEN %START %IF JRec_Label=0 %THEN JumpFail("Missing label for jump.") LRec==Record(JRec_Label) Ofst=LRec_Ca %IF Ofst=-1 %THEN JumpFail("Label not set for forward jump") %AND %STOP JAd=I+Sizeof(JRec)+JRec_Offset Reg=JRec_Reg %IF Reg=0 %THEN %START %IF Byteinteger(JAd+1)&15=12 %THEN Byteinteger(JAd+1)=Byteinteger(JAd+1)&X'F0' Byteinteger(JAd+2)=X'C0'!((Ofst>>8)&255) Byteinteger(JAd+3)=Ofst&255 %FINISH %ELSE %START %IF Reg<0 %THEN %START Reg=-Reg %IF JRec_Used>0 %THEN %START %IF Reg#12 %THEN %START Used==Record(JRec_Used) Ofst=Ofst-Used_Ca %FINISH %FINISH %ELSE %START JAd=JAd+2 Ofst=Ofst-JRec_Ca-2 %FINISH %IF Ofst>>12#0 %THEN JumpFail("Offset too large for Using") %AND Ofst=1 %IF Reg>15 %THEN JumpFail("Illegal Reg in using/jump") %AND %STOP Byteinteger(JAd+2)=(Reg<<4)!(Ofst>>8) Byteinteger(JAd+3)=Ofst&255 %FINISH %ELSE %START { 8 byte case } %IF AddMultiples=0 %AND Ofst>>12>Multsize %THEN Perror("Multiples Inadequate",0) %IF Ofst>>12>=64 %THEN Byteinteger(JAd+2)=Byteinteger(JAd+2)!(Ofst>>18) Byteinteger(JAd+3)<-(Ofst>>12)<<2 Byteinteger(JAd+6)=Byteinteger(JAd+6)!((Ofst>>8)&15) Byteinteger(JAd+7)=Ofst&255 %FINISH %FINISH %FINISH %ELSE %IF JRec_Type#Fragment %AND JRec_Type#AStart %AND JRec_Type#CNOpType %THEN %C PError("Wrong type for code",0) I=JRec_Link %REPEAT { Locate switch labels for current code body } I=SwList %WHILE I#CurrSwEnd %CYCLE Sw==Record(I) %IF Sw_Def>0 %THEN %START { Def is a label } %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("Sw_Def = ") write(Sw_Def,1) %FINISH %FINISH I=LocateL(Sw_Def,J) %IF I#0 %THEN PError("Missing default for switch".Itos(Sw_Def),0) LRec==Record(J) Sw_Def=LRec_Ca %FINISH %ELSE Sw_Def=-Sw_Def J=Sw_Labs %WHILE J#0 %CYCLE SwEl==Record(J) %IF SwEl_Type=SwIndType %THEN %EXIT %IF LocateL(SwEl_Lab,I)#0 %THEN %C PError("Label missing for switch ".Itos(Sw_SAd)." element no ".Itos(SwEl_Index)." label no ".Itos %C (SwEl_Lab),0) SwEl_Lab=I J=SwEl_Link %REPEAT I=Sw_Link %REPEAT CurrSwEnd=SwList { set backstop for next body of code } Ca=(Ca+Adjustment+3)&(\3) %IF NDict+Sizeof(JRec)>TopDict %THEN PError("Table overflow",1) I=ADict+NDict JRec==Record(I) NDict=NDict+Sizeof(JRec) CRec==Record(CodeLink) CRec_Link=I CodeLink=I TotCa=TotCa+Ca JRec_Ca=TotCa JRec_Type=AStart Ca=0 LastUsed=0 LFixups=0 ThruList=0 ThruLink=0 ThisBaseCa=I GlobalAdjustment=GlobalAdjustment-Adjustment+CodeOfst Adjustment=0 MinMults=0 %END { of ProcessCode } %EXTERNAL %ROUTINE PMinMultiples(%INTEGER NMults) { Give minimum number of multiples required for non-code addressing } { Called immediately before PProcEnd or PTerminate, according to } { multiple handling option chosen. } MinMults=NMults %END { of PMinMultiples } %EXTERNAL %ROUTINE PProcEnd { End of routine } %INTEGER At,size %INTEGER flag %IF Tracing=On %THEN %START %IF mon#0 %THEN printstring(" Proc END: ") %FINISH Perror("PProcEnd - too many proc ends ",0) %IF curlexlev=0 %IF ProcessbyProcs=1 %THEN ProcessCode CurLexLev=CurLexLev-1 %END { of PProcEnd } {* Put Interface - Miscellaneous *} %EXTERNAL %ROUTINE PNewArea(%STRING (255) %NAME Name, %INTEGER Iin,Props) { Note a new area defined by Props } %INTEGER Here %RECORD (AreaDefFmt) %NAME Rec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("New area ".Name." ".Itos(Iin)." props ".Htos(Props,8)." ") %FINISH %FINISH %IF NDict+Sizeof(Rec)>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) Rec_Name=Name Rec_Props=Props Rec_Iin=Iin Rec_Link=AreaList AreaList=Here FileSize=FileSize+((24+Length(Name))&(\3)) NDict=NDict+Sizeof(Rec) %END { of PNewArea } %EXTERNAL %ROUTINE PEndArea(%INTEGER Id,Len,Props) %INTEGER I %RECORD (AreaDefFmt) %NAME Rec %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("End area ".Itos(Id)."Len= ".Itos(Len)." Props= ".Itos(Props)." ") %FINISH %FINISH I=AreaList %WHILE I#0 %CYCLE Rec==Record(I) %IF Rec_Iin=Id %THEN ->Found I=Rec_Link %REPEAT PError("Undefined area ".Itos(Id),0) Found: Rec_Len=Len Rec_Props=Rec_Props!Props %END { of PEndCommon } %EXTERNAL %ROUTINE PHistory(%INTEGER Type,Ad) { Add a new history record to the object file } %SWITCH Sw(0:10) %INTEGER Here %RECORD (HFormat) %NAME Rec,Rec2 %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("History record type ".Itos(Type).string(ad)." ") %FINISH %FINISH %IF NDict+Sizeof(Rec)+((byteinteger(Ad)+4)&(\3))>TopDict %THEN PError("Table overflow",1) Here=ADict+NDict Rec==Record(Here) %IF HistLink#0 %THEN %START Rec2==Record(HistLink) Rec2_Link=Here %FINISH Rec_Link=0 %IF HistList=0 %THEN HistList=Here HistLink=Here NDict=NDict+Sizeof(Rec)+((byteinteger(Ad)+4)&(\3)) FileSize=FileSize+2+byteinteger(Ad) Rec_Type=Type Rec_S=String(Ad) %END { of PHistory } %EXTERNAL %ROUTINE Pfaulty { Code generator has encountered a user error. Code requests should no } { longer be checked and minimum work done in PUT } Faulty=1 %END { of PFaulty } %EXTERNAL %ROUTINE PLineStart(%INTEGER Line) { Updates latest line number } CurrentLine=Line %IF Tracing=On %THEN %START %IF Line>=ComRegMap(1)#0 %THEN Mon=0 %ELSE %IF Line>=ComRegMap(60)#0 %THEN Mon=3 %IF Mon#0 %THEN Printstring("Line no ".Itos(CurrentLine)." ") %FINISH LastCa=0 LastCaOffset=CodeBuffer_Len %END { of PLineStart } %EXTERNAL %ROUTINE PLineDecode { Decodes from last PLineStart or Decode } %INTEGER I,J %RECORD (CodeFragFmt) %NAME CRec %IF Trace=On %THEN %START %IF Mon#0 %THEN %START Printstring("Decode called ") %FINISH %FINISH %IF LastCa=0 %THEN J=LastCaOffset %ELSE %START J=0 %WHILE LastCa#0 %CYCLE CRec==Record(LastCa) I=LastCa+Sizeof(CRec)+CRec_Offset+LastCaOffset IBMRecode(I,I+CRec_Len-LastCaOffset,CRec_Ca+LastCaOffset) LastCaOffset=0 LastCa=CRec_Link %REPEAT %FINISH %IF CodeBuffer_Len-J#0 %THEN %START IBMRecode(BuffStart+J,BuffStart+CodeBuffer_Len,CodeBuffer_Ca+J) LastCaOffset=CodeBuffer_Len %FINISH %END { of PLineDecode } %EXTERNAL %ROUTINE PInitialise(%INTEGER Language,Properties,Version) { Start code generation } %RECORD (CodeFragFmt) %NAME NewARec %STRING (255) S1,S2 %INTEGER I %IF Language=-1 %THEN LangVers=String(Version) %ELSE LangVers="Unkown" %IF Tracing=On %THEN %START Mon=ComRegMap(26)&3 %IF Mon#0 %THEN %START Printstring(" PInitialise ".PutVersion." Vsn = ".LangVers." ") Write(Language,8); Write(Properties,8); Write(Version,8) NewLine %FINISH %FINISH %IF LangVers->S1.("Imp80").S2 %THEN %START ImpFlag=1 OutFile("T#CODE",UInfI(28),Zero,X'20000000',BuffStart,I) %IF I#0 %THEN %START s1=FailureMessage(I) PError("Create work file fails ".s1,1) %FINISH %FINISH %ELSE %START BuffStart=ComRegMap(14) ImpFlag=0 %FINISH CodeBuffer==Record(BuffStart+32) globaladjustment=0 processbyprocs=0 lastcaoffset=0 curlexlev=0 CodeBuffer_Len=0 LinkorMod=0 MinMults=0 Faulty=0 XAFlag=1 Ca=0 LastCa=0 TotCa=0 AreaBuffer==Array(BuffStart+32+32+4096,AreaBuffArrayFmt) %FOR I=Gla,1,Cnst %CYCLE AreaHead(I)=0 AreaTail(I)=0 IntList(I)=0 BuffAd(I)=Addr(AreaBuffer(I)_Data(1)) %REPEAT NextSym=0 ADict=BuffAd(Cnst)+4096 TopDict=Integer(BuffStart+8)+BuffStart-ADict BuffStart=BuffStart+32+Sizeof(CodeBuffer) LFixups=0 XProcList=0 XRefList=0 BoundRelocs=0 FFixups=0 XDEPList=0 XDList=0 SwList=0 CurrSwEnd=0 ThruList=0 ThruLink=0 CurLabs=ADict CurLabsTop=((ADict+4095)&(\4095))+(4*4096) NewARec==Record(CurLabsTop) NDict=Sizeof(NewARec)+CurLabsTop-ADict CodeList=CurLabsTop CodeLink=CurLabsTop NewARec_Type=AStart ThisBaseCa=CurLabsTop LastUsed=0 AreaList=0 HistLink=0 HistList=0 InitList=0 FileSize=32 {header}+4+10*12 { Object file map}+15*4 { LDATA } Multsize=0 %IF Properties&2#0 %THEN ProcessbyProcs=1 %IF Properties&1=0 %THEN %START AddMultiples=0 SafeCode=4096 %FINISH %ELSE %START AddMultiples=1 SafeCode=4096-4*Multmax %FINISH PHistory(9,Addr(LangVers)) CurrentLine=0 %END { of PInitialise } %EXTERNAL %ROUTINE SetBALR { Must be called by systems not having BASR, immediately after PInitialise } XAFlag=0 %END { of SetBALR } %EXTERNAL %INTEGER %FN PTerminate(%INTEGER AdAreaSizes,MSize) { Code generator closes with this call } { Set Code size etc. } { Object file record formats } %RECORD %FORMAT ProcEntFmt(%INTEGER Link,CodeOffset,GlaOffset,EPOffset,ParamW, %STRING (31) Name) %RECORD %FORMAT ProcRefFmt(%INTEGER Link,RefLoc, %STRING (31) Name) %RECORD %FORMAT FixRecFmt(%INTEGER AreaLoc,BaseLoc) %RECORD %FORMAT RelocFmt(%INTEGER Link,N,startofreqs) %RECORD %FORMAT DataEntFmt(%INTEGER Link,Disp,Len,Area, %STRING (31) Name) %RECORD %FORMAT DataHeadFmt(%INTEGER Link,RefArray,Len, %STRING (31) Name) %RECORD %FORMAT DataListFmt(%INTEGER N, %INTEGER %ARRAY RefLoc(1:4000)) %RECORD %FORMAT AInitFmt(%INTEGER Link,Area,Disp,Len,Rep,Adr) %RECORD %FORMAT ADefFmt(%INTEGER Link,Area,Len,Props) %RECORD %FORMAT CDefFmt(%INTEGER Link,Area,Len,Props, %STRING (31) Name) %RECORD %FORMAT HistFmt(%BYTE %INTEGER Type, %STRING (255) S) { Object file record pointers } %RECORD (ProcEntFmt) %NAME CEP %RECORD (ProcRefFmt) %NAME CREF %RECORD (RelocFmt) %NAME FHead %RECORD (DataEntFmt) %NAME DEP %RECORD (DataHeadFmt) %NAME DHead %RECORD (DataListFmt) %NAME DList %RECORD (AInitFmt) %NAME AInit %RECORD (ADefFmt) %NAME ADef %RECORD (CDefFmt) %NAME CDef %RECORD (HistFmt) %NAME Hist %RECORD (fixrecfmt) %NAME reloc { Internal record pointers } %RECORD (InitFmt) %NAME Init %RECORD (AreaDefFmt) %NAME AreaD %RECORD (HFormat) %NAME Histy %RECORD %FORMAT AFmt(%INTEGER Start,Len,Props) %RECORD %FORMAT ObjMapFmt(%INTEGER N, %RECORD (AFmt) %ARRAY Area(Code:Cnst)) %INTEGER %ARRAY %FORMAT LDataFmt(0:14) %RECORD (ObjMapFmt) OMap %RECORD (ObjMapFmt) %NAME ObjMap %INTEGER %ARRAY %NAME LData %INTEGER SAd,DefAd,OutAd,Flag,CurAd %CONST %STRING (6) tempobj="T#TOBJ"; ! temporary object name for newgen %INTEGER relocreq pointer %STRING (255) Mess,FileName %RECORD (ECRefFmt) %NAME ECR %RECORD (ECDefFmt) %NAME ECD %RECORD (EDHeadFmt) %NAME EDH %RECORD (EDRefFmt) %NAME EDR %RECORD (EDDefFmt) %NAME EDD %INTEGER HostArea,HostOfst %RECORD (SwFmt) %NAME Sw %RECORD (CodeFragFmt) %NAME CRec %RECORD (LabFmt) %NAME LRec %RECORD (SwElFmt) %NAME SwEl %RECORD (AreaFmt) %NAME ARec %RECORD (FixupFmt) %NAME Fix %RECORD (UsingFmt) %NAME Used %INTEGER %ARRAY %FORMAT AreaSizeFm(1:11) %INTEGER %ARRAY %NAME AreaSizes %INTEGER %ARRAY AreaStart(Code:Cnst) %INTEGER I,J,K %INTEGER JAd,Ofst,Adju,FixArea,Newgen reqd %ROUTINE Follow(%INTEGER Link, %INTEGER %NAME Highest) { Follow the index tree for a switch and fill in its table } %INTEGER I %RECORD (SwElFmt) %NAME El El==Record(Link) %IF El_LLink#0 %THEN Follow(El_LLink,Highest) %IF Sw_Size=4 %THEN Integer(SAd+4*(El_Index-Sw_Lower))=El_Ca %ELSE %START Byteinteger(SAd+2*(El_Index-Sw_Lower))=El_Ca>>8 Byteinteger(SAd+2*(El_Index-Sw_Lower)+1)=El_Ca&255 %FINISH Highest=El_Index+1 %IF El_RLink#0 %THEN Follow(El_RLink,Highest) %END { of Follow } %IF Tracing=On %THEN %START %IF Mon#0 %THEN Printstring("P Terminate called, MSize = ".Itos(MSize)." ") %FINISH Multsize=Msize AreaSizes==Array(AdAreaSizes,AreaSizeFm) %IF ProcessbyProcs=0 %THEN ProcessCode %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring(" *** Adjustment = ".Itos(GlobalAdjustment)." ( ") Print(GlobalAdjustment/TotCa*100,2,2) Printstring("% ) ") %FINISH %FINISH Filesize=((Filesize+7)&(\7)) { Calculate total object file size } {%if LinkorMod=0 %then}AreaSizes(Code)=TotCa %FOR I=Code,1,Cnst %CYCLE AreaSizes(I)=(AreaSizes(I)+3)&(\3) FileSize=FileSize+AreaSizes(I) %UNLESS i=zust; ! these not in object file %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring(Areas(I)." ".Itos(AreaSizes(I))." bytes ") %FINISH %FINISH %REPEAT %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START PrintString("Total file size = ".Itos(FileSize)." ") %FINISH %FINISH FileName=String(ComRegMap(52)) %IF Faulty#0 %THEN %RESULT=Faulty %IF FileName=".NULL" %THEN %RESULT=Faulty OutFile(FileName,FileSize,Zero,Zero,OutAd,Flag) Newgen reqd=0 %IF Flag#0 %THEN %START mess=FailureMessage(Flag) outfile(tempobj,filesize,zero,zero,outad,j) %IF j=0 %AND (278<=flag<=279 %OR flag=234) %THEN %START newgen reqd=1; ! press on if conflicting mode or connected in other VM %FINISH %ELSE %START PError("Create object file fails ".Mess,1) %STOP %FINISH %FINISH ! Set filetype to CORRUPT OBJECT pro tem(char by default).This !has been a nuisance following failures within TERMINATE. Integer(Outad+12)=5 {corrupt object} { Write out code list } OMap=0 OMap_Area(Code)_Start=32 OMap_Area(Code)_Len=TotCa OMap_Area(Code)_Props=0 I=CodeList AreaStart(Code)=OutAd+32 J=0 %WHILE I#0 %CYCLE CRec==Record(I) %IF CRec_Type=AStart %THEN J=CRec_Ca %ELSE Move(CRec_Len,I+Sizeof(CRec)+CRec_Offset,OutAd+32+J+CRec_Ca) I=CRec_Link %REPEAT { Write out the other areas } %FOR J=2,1,9 %CYCLE K=NextArea(J) I=NextArea(J-1) FlushData(K) OMap_Area(K)_Start=OMap_Area(I)_Start+OMap_Area(I)_Len OMap_Area(K)_Len=AreaSizes(K) OMap_Area(K)_Props=AProps(K) AreaStart(K)=AreaStart(I)+AreaSizes(I) I=IntList(K) %WHILE I#0 %CYCLE Init==Record(I) %IF Init_Len=1 %THEN %START { Value not pointer } Fill(Init_NCopies,AreaStart(K)+Init_Disp,Integer(I+Sizeof(Init))) %FINISH %ELSE %START %FOR Ofst=1,1,Init_NCopies %CYCLE Move(Init_Len,I+Sizeof(Init),AreaStart(K)+Init_Disp+((Ofst-1)*Init_Len)) %REPEAT %FINISH I=Init_Link %REPEAT I=AreaHead(K) %WHILE I#0 %CYCLE ARec==Record(I) Move(ARec_Len,I+Sizeof(ARec),AreaStart(K)+ARec_Offset) I=ARec_Link %REPEAT %REPEAT I=NextArea(9) CurAd=AreaStart(I) { + AreaSizes(I) these are zust and not in file} Integer(OutAd+28)=CurAd-OutAd ObjMap==Record(CurAd) ObjMap=OMap ObjMap_N=10 CurAd=CurAd+Sizeof(ObjMap) LData==Array(CurAd,LDataFmt) Integer(OutAd+24)=CurAd-OutAd LData(0)=14 CurAd=CurAd+60 { Fill in the switch tables } I=SwList %WHILE I#0 %CYCLE Sw==Record(I) SAd=Sw_SAd+AreaStart(SST) %IF Sw_Def#0 %THEN %START I=Sw_Def %FOR J=0,1,Sw_Upper-Sw_Lower %CYCLE %IF Sw_Size=4 %THEN Integer(SAd+J<<2)=I %ELSE %START Byteinteger(SAd+J<<1)=I>>8 %IF Tracing=On %THEN %START %IF Mon#0 %THEN %START Printstring("Entered Check") Printstring("Def ad = ") Write(I,1) %FINISH %FINISH Byteinteger(SAd+J<<1+1)=I&255 %FINISH %REPEAT %FINISH J=Sw_Lower %IF Sw_Labs#0 %THEN %START SwEl==Record(Sw_Labs) %IF SwEl_Type=SwIndType %THEN %START Follow(Sw_Labs,J) %FINISH %ELSE %START J=Sw_Labs %WHILE J#0 %CYCLE SwEl==Record(J) LRec==Record(SwEl_Lab) %IF Sw_Size=4 %THEN %START Integer(SAd+((SwEl_Index-Sw_Lower)<<2))=LRec_Ca %FINISH %ELSE %START Byteinteger(SAd+((SwEl_Index-Sw_Lower)<<1))=LRec_Ca>>8 ByteInteger(SAd+((SwEl_Index-Sw_Lower)<<1)+1)=LRec_Ca&255 %FINISH J=SwEl_Link %REPEAT %FINISH %FINISH I=Sw_Link %REPEAT { Process outstanding lists of requests } I=XProcList { Process external code EPs } %WHILE I#0 %CYCLE ECD==Record(I) CEP==Record(CurAd) CEP_Link=LData(1) LData(1)=CurAd-OutAd Move(17+Length(ECD_Name),Addr(ECD_W0),Addr(CEP_CodeOffset)) CurAd=CurAd+((24+Length(ECD_Name))&(\3)) I=ECD_Link %REPEAT I=XRefList { Process external code refs } %WHILE I#0 %CYCLE ECR==Record(I) CREF==Record(CurAd) %IF ECR_GlaAd>0 %THEN %START CREF_Link=LData(7) LData(7)=CurAd-OutAd %FINISH %ELSE %START CREF_Link=LData(8) LData(8)=CurAd-OutAd ECR_GlaAd=ECR_GlaAd&X'FFFFFF' %FINISH CREF_RefLoc=(2<<24)!ECR_GlaAd CREF_Name=ECR_Name CurAd=CurAd+((Length(ECR_Name)+12)&(\3)) I=ECR_Link %REPEAT I=FFixups { Process word relocations } %IF I#0 %THEN %START FHead==Record(CurAd) FHead_Link=LData(14) relocreq pointer=addr(fhead_start of reqs) LData(14)=CurAd-OutAd J=0 %WHILE I#0 %CYCLE Fix==Record(I) J=J+1 !! FHead_Reloc(J)_AreaLoc = Fix_Host !! FHead_Reloc(J)_BaseLoc = Fix_Tgt reloc==record(relocreq pointer) reloc_arealoc=fix_host reloc_baseloc=fix_tgt relocreq pointer=relocreq pointer+8 I=Fix_Link %REPEAT FHead_N=J CurAd=CurAd+8+J<<3 %FINISH I=BoundRelocs { Process word relocations } %IF I#0 %THEN %START FHead==Record(CurAd) FHead_Link=LData(3) relocreq pointer=addr(fhead_start of reqs) LData(3)=CurAd-OutAd J=0 %WHILE I#0 %CYCLE Fix==Record(I) J=J+1 !! FHead_Reloc(J)_AreaLoc = Fix_Host !! FHead_Reloc(J)_BaseLoc = Fix_Tgt reloc==record(relocreq pointer) reloc_arealoc=fix_host reloc_baseloc=fix_tgt relocreq pointer=relocreq pointer+8 I=Fix_Link %REPEAT FHead_N=J CurAd=CurAd+8+J<<3 %FINISH I=XDEPList { Process external data EPs } %WHILE I#0 %CYCLE DEP==Record(CurAd) EDD==Record(I) DEP_Link=LData(4) LData(4)=CurAd-OutAd DEP_Disp=EDD_Disp DEP_Len=EDD_Props&X'FFFFFF' DEP_Name=EDD_Name DEP_Area=EDD_Props>>24 CurAd=CurAd+((20+Length(EDD_Name))&(\3)) I=EDD_Link %REPEAT I=XDList { Process external data refs } %WHILE I#0 %CYCLE EDH==Record(I) DHead==Record(CurAd) DHead_Link=LData(9) LData(9)=CurAd-OutAd CurAd=CurAd+((16+Length(EDH_Name))&(\3)) DHead_Name=EDH_Name J=EDH_XDLink DHead_Len=EDH_Len EDR==Record(J) DHead_RefArray=CurAd-OutAd DList==Record(CurAd) DList_N=0 %WHILE J#0 %CYCLE EDR==Record(J) DList_N=DList_N+1 DList_RefLoc(DList_N)=EDR_ADisp J=EDR_Link %REPEAT CurAd=CurAd+(DList_N<<2)+4 I=EDH_Link %REPEAT { Process area definitions } I=AreaList %WHILE I#0 %CYCLE AreaD==Record(I) %IF AreaD_Props&3=0 %AND AreaD_Iin<255 %THEN %START ADef==Record(CurAd) ADef_Link=LData(11) LData(11)=CurAd-OutAd ADef_Area=AreaD_Iin ADef_Props=AreaD_Props ADef_Len=AreaD_Len CurAd=CurAd+16 %FINISH %ELSE %START CDef==Record(CurAd) %IF AreaD_Props<0 %THEN %START CDef_Link=LData(10) LData(10)=Curad-OutAd %FINISH %ELSE %START CDef_Link=LData(2) LData(2)=CurAd-OutAd %FINISH CDef_Area=AreaD_Iin CDef_Name=AreaD_Name CDef_Props=AreaD_Props CDef_Len=AreaD_Len CurAd=CurAD+((20+Length(AreaD_Name))&(\3)) %FINISH I=AreaD_Link %REPEAT { Process initialisations } I=InitList %WHILE I#0 %CYCLE Init==Record(I) AInit==Record(CurAd) AInit_Link=LData(13) LData(13)=CurAd-OutAd AInit_Area=Init_Area AInit_Disp=Init_Disp AInit_Rep=Init_NCopies AInit_Len=Init_Len CurAd=CurAd+24 %IF Init_Len=1 %THEN %START AInit_Adr=byteinteger(I+Sizeof(Init)) %FINISH %ELSE %START AInit_Adr=CurAd-OutAd Move(AInit_Len,I+Sizeof(Init),CurAd) CurAd=CurAd+((Init_Len+3)&(\3)) %FINISH I=Init_Link %REPEAT { Process history records } I=HistList %IF I#0 %THEN %START LData(12)=CurAd-OutAd %WHILE I#0 %CYCLE Histy==Record(I) byteinteger(CurAd)=Histy_Type string(CurAd+1)=Histy_S I=Histy_Link CurAd=CurAd+2+Length(Histy_S) %REPEAT %FINISH CurAd=(CurAd+3)&(\3) Integer(OutAd)=CurAd-OutAd %IF filesize>1-1 %CYCLE PIXRR(BCR,0,0) %REPEAT %END { of PCNOP } %END %OF %FILE