!************************************************************ !*** YOU MUST SET 'SYSTEM' and 'FORMAT' VARIABLE BELOW ****** !************************************************************ ! 23/june/87 Fix Relafm initial bound gput8 ! ! 15/june/87 Tidy up for release. MPX version no gput7 ! ! 3 /june/87 Corrections mainly for sect numbers in symbols. gput6 ! ! 21/may/87 Correction for FAR. Lose extra byte in dict. gput4u ! ! 6/5/87 Move section symbols to end and get rid of gput4 ! empty sections. ! 30/4/87 Check out BSD. gput3 ! ! 13/4/87 Fix bad order of .text and .nbtext . gput2 ! And make relocs relative to section. ! ! Amalgamate NP, MPX, C and UTX versions into new root gput1 ! With COFF changes added. ! 2/mar/87 ! ! 2/mar/86 Align Common on 16 bytes for NP gput20 ! 8/dec/86 If its NP avoid resolution and set asvers gput19 ! 4/nov/86 Add syntaxonly param to Msetfiles - avoid object destruction ! RE-organise relocations to be in area order. ! 3 nov/86 Handle very large dictionaries correctly. gput17b ! 15/oct/86 Only dump base reg info if main program ! 14/oct/86 Put gla and iotables into far data optionally gput17a ! 30/9/86 Better message for Cannot create object gput17 ! 12/Sep/86 Base register markers in mterminate gput16 ! 5/sep/86 DBX changes for array dims. gput15 ! ! Tracing control ! Trace all significant calls on interface if: ! comreg(26) & 1 # 0 or ! as directed by calls on procs. Pmonon/Pmonoff ! Seldom required info controlled by bits of comreg(26) as follows: ! 4 - switch on sdb ! 16 - File use monitoring ! 128 - Requests for more space by Malloc, Expand Area etc. ! %include "ftn_ht" !**************************************** !%constinteger UTX = 0 %constinteger NPL = 3 %constinteger MPXL = 2 %constinteger SYSTEM = NPL %constinteger BSD = 0 %constinteger COFF = 1 %constinteger OBJECT FORMAT = COFF %constinteger ECC=0 { =1 for main program entry of "main" } !**************************************** ! %externalinteger initdataad %IF HOST = ICL2900 %or host=Gould %START %SYSTEMROUTINESPEC PHEX (%INTEGER VALUE) %SYSTEMROUTINESPEC MOVE (%INTEGER LEN, FROM, TO) %SYSTEMROUTINESPEC FILL (%INTEGER LEN, ADR, FILLER) %SYSTEMSTRINGFNSPEC ITOS (%INTEGER VALUE) %SYSTEMSTRINGFNSPEC HTOS (%INTEGER VALUE, PLACES) %SYSTEMINTEGERMAPSPEC COMREG (%INTEGER INDEX) %FINISH %IF HOST = IBM %THEN %START %EXTERNALROUTINESPEC PHEX %ALIAS "S#PHEX" (%INTEGER VALUE) %EXTERNALROUTINESPEC MOVE %ALIAS "S#MOVE" (%INTEGER LEN, FROM, TO) %EXTERNALROUTINESPEC FILL %ALIAS "S#FILL" (%INTEGER LEN, ADR, FILLER) %EXTERNALSTRINGFNSPEC ITOS %ALIAS "S#ITOS" (%INTEGER VALUE) %EXTERNALSTRINGFNSPEC HTOS %ALIAS "S#HTOS" (%INTEGER VALUE, PLACES) %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP" (%INTEGER VALUE) %FINISH %EXTERNALROUTINESPEC FREE (%INTEGER ADR) %EXTERNALROUTINESPEC CSTRING (%STRINGNAME IMPSTRING, %INTEGER AD CSTRING) %EXTERNALROUTINESPEC PHEXBYTE (%INTEGER VALUE) %if host = ICL2900 %or host = IBM %start %EXTERNALROUTINESPEC EMASclose %finish %if host = gould %start %externalroutinespec filewrite %alias "write" (%integer objid,adr,len) %externalroutinespec EXIT(%integer i) %finishelsestart %EXTERNALROUTINESPEC FILEWRITE (%INTEGER OBJID, ADR, LEN) %finish %EXTERNALROUTINESPEC FREE SOURCE AREAS %if SYSTEM=MPXL %start %EXTERNALINTEGERFNSPEC CREAT (%INTEGER AD, MODE, CAD) %finishelsestart %EXTERNALINTEGERFNSPEC CREAT (%INTEGER AD, MODE) %finish %EXTERNALINTEGERFNSPEC LSEEK (%INTEGER OBJID, OFFSET, WHENCE) %EXTERNALINTEGERFNSPEC MALLOC (%INTEGER SIZE) %EXTERNALINTEGERFNSPEC REALLOC (%INTEGER OLDPTR, SIZE) ! %CONSTINTEGER EXT = 1 ! ************* STAB.H TYPE DEFINITIONS FOR SYMBOL TABLE ENTRIES ************** %constinteger undf = x'00', { Undefined } abs = x'02', { Absolute Reference } text = x'04', { Near Text } data = x'06', { Near Data } bss = x'08', { Near BSS } fartext = x'0A', { Far Text } fardata = x'0C' { Far Data } ! farbss = x'0E', { Far BSS } ! comm = x'12', { Common } ! farcomm = x'14', { Far Common } ! fn = x'1f' { File Name } !************** SPECIAL SYMBOL TABLE ENTRIES FOR DBX ************ %constinteger gsym = x'20', { Global Symbol } fname = x'22', { Procedure Name } stsym = x'26', { Static Symbol } lcsym = x'28', { .lcomm Symbol } fun = x'2a', { procedure } farsts = x'2c', { Far Static Symbol } farlcs = x'2e', { Far .lcomm Symbol } rsym = x'40', { Register Symbol } sline = x'4a', { Source Line } ssym = x'60', { Struct Element } so = x'6a', { Source Filename } lsym = x'80', { Local Symbol } sol = x'8a', { Include Filename } psym = x'A0', { Parameter } entry = x'AA', { Alternate Entry } lbrac = x'CA', { Left Bracket } bcomm = x'E2', { Begin Common } ecomm = x'E4', { End Common } ecoml = x'e8', { End COmmon (local) } rbrac = x'EA' %ownINTEGER SDB = 0 %CONSTINTEGER TRUSTED = 0 %CONSTINTEGER DEFAULT AREA SIZE = (4 * 1024) - 8 ;! 8 for malloc control words %CONSTINTEGER ENDOFLIST = 0 %CONSTINTEGER SYMSIZE = 32 ;! Max bytes in a name ( Possibly more would be ok) %if OBJECT FORMAT = COFF %start %RECORDFORMAT SYMFM (%INTEGER STRX, %BYTEINTEGER TYPE, other, DESC1, desc2, %INTEGER VALUE, %integer sect) %constinteger intsymsize = 16 %finishelsestart %RECORDFORMAT SYMFM (%INTEGER STRX, %BYTEINTEGER TYPE, other,DESC1,desc2, %INTEGER VALUE) ;! Symbol table format %CONSTINTEGER INTSYMSIZE = 12 %finish %CONSTINTEGER INITIALSYMBOLTABLESIZE = DEFAULTAREASIZE %CONSTINTEGER INFINITY = X'FFFFFE' %if SYSTEM=MPXL %start %constinteger MODE = 0 %finishelsestart %CONSTINTEGER MODE = X'1B4' ;! Mode of object create, read/write for all %finish %CONSTINTEGER CODE = 1 %CONSTINTEGER GLA = 2 %constinteger plt = 3 %CONSTINTEGER SST = 4 %CONSTINTEGER GST = 5 %CONSTINTEGER DIAGS = 6 %CONSTINTEGER SCALAR = 7 %CONSTINTEGER IOTAB = 8 %CONSTINTEGER ZGST = 9 %CONSTINTEGER CNST = 10 %constinteger SDBsymtab = 17 %CONSTINTEGER DICTTAB = 18 %CONSTINTEGER SYMTAB = 19 %CONSTINTEGER SETAREAS = 20 %CONSTINTEGER RSIZE = 8 ;! sizeof(rfm) when sizeof working %CONSTINTEGER MAXRELS = DEFAULTAREASIZE // RSIZE ;! 511 %CONSTINTEGER MAXLEXLEV = 20 %CONSTINTEGER SIZEOFAREAENTRY = 24 %CONSTSTRING (1) SNL = " " ! %OWNINTEGER CREL = 0 %OWNINTEGER NDRELS = 0 %OWNINTEGER NTRELS = 0 %OWNINTEGER STARTLINEAD %OWNINTEGER LINEAD %OWNINTEGER RDSIZE = 12 %OWNINTEGER DICTSTART %OWNINTEGER STARTVARAD %OWNINTEGER VARAD %owninteger objid { File descriptor ID of object file } %owninteger langimp = 0 %owninteger Faulty = 0 %owninteger curlexlev = 0 %owninteger mon = 0 { Put call monitoring control } %owninteger NextSym = -1 { Index to symbol table. +1 for each entry } %owninteger NextSdbSym = -1 %owninteger incommon=0 %owninteger MainEntryPoint = 0 %owninteger MainProgram = 0 %owninteger Line = 0 { Current Line number as set by start} %OWNINTEGER MAXSYMS,maxsdbsyms %OWNINTEGER MALMON = 0 %OWNINTEGER MAXDATA = 0 %OWNINTEGER LINESTART = 0 %OWNINTEGER MAXAREA = 0 %OWNINTEGER TOPAREA = 21 %OWNINTEGER FILEMON %OWNINTEGER DICTAD = 0,dictlen %OWNINTEGER MAXDICTAD = 0 %owninteger Codebase %OWNSTRING (32) SRCFILE = "Source Unknown" %ownintegerarray includeindex(1:100) %owninteger nextinclude=-2 %owninteger trctr,drctr ! %if OBJECT FORMAT = COFF %start %recordformat coffrelfm(%integer vaddr,symndx,lentype) %ownintegerarray xtype(1:10) %finishelsestart %RECORDFORMAT RELFM (%INTEGER ADDRESS, DATA) %CONSTBYTEINTEGERARRAY XTYPE (1:10) = 10, 6, 4, 10, 12, 10, 0, 6, 14, 10 %finish %RECORDFORMAT RDFM (%INTEGER DISP, LEN, COPIES) %ownintegerarray rpct (1:10) { reloc list current block counts } %ownintegerarray trct (1:10) { Total reloc list count per area. } %ownintegerarray rpad (1:10) { reloc list current block address } %ownintegerarray rpstart(1:10) { reloc list tart points } %RECORDFORMAT BLOCKFM (%INTEGER AD, CA, SYM, PSIZE) %RECORDFORMAT AREAFM (%INTEGER BASE, MAX, LENGTH, SYM, TYPE, LINKDISP) { Guess at section number field values } %constinteger Ndebug = -2, { special symbolic debugging symbol } Nabs = -1, { absolute symbol } Nundef = 0, { undefines external symbol } NearTextsect= 1, FarTextSect = 2 %owninteger FarDATAsect= 103, BSSsect = 104, NearDATAsect = 105 %if OBJECT FORMAT = COFF %start %recordformat HDRFM( %integer magic, nscns, { number of sections } timdat, { Time and Date stamp } symptr, { Start address of symbol pointer } nsyms, { Number of entries in the sym table } opthdr, { bytes in the optional header } flags, pad) { Pad to quad boundary } %recordformat OPTHDRFM( %integer magic, text, { size of text segment } data, { size of data segment } bss, { size of BSS } syms, { size of symbol table } stsize, { string table size } entry, { entry point } txbase, { load address of text } dtbase, { load address of data } Mstamp, { Target machine stamp } Sstamp, { target op sys stamp } Cstamp) { compatibility stamp } %recordformat SECTHDRFM( %c %byteintegerarray name(0:7), { 8 char null padded sect name} %integer paddr, { Physical address of section} vaddr, { Virtual addres of section} size, { Section size in bytes } scnptr, { Pointer to raw data } relptr, { Pointer to reloc entries} lnnoptr, { Pointer to line num entries} nreloc, { number of reloc entries} nlnno, { number of line num entries} flags, align) { Section alignment needed } %finishelsestart { GOULD BSD } %RECORDFORMAT HDRFM (%INTEGER MAGIC, TEXT, DATA, BSS, SYMS, ENTRY, TRSIZE, DRSIZE, %C STSIZE, TXBASE, NBTEXT, NBDATA, NBBSS, TSTAMP, MSTAMP, SSTAMP, CCVERS, ASVERS, LDVERS) ;! Object file header format %finish %ownrecord (Symfm) %arrayformat Symafm(0:100000) %ownrecord (Symfm) %arrayname Syms,SdbSyms %IF HOST = ICL2900 %THEN %START %RECORDFORMAT RFM (%HALFINTEGER HOSTAREA, TGT, %INTEGER HOSTDISP) %RECORDFORMAT VARFM (%INTEGER TYPE, DISP, SIZE, %HALFINTEGER VTYPE, AID) %FINISH %IF HOST = IBM %or host = Gould %START %RECORDFORMAT RFM (%SHORTINTEGER HOSTAREA, TGT, %INTEGER HOSTDISP) %RECORDFORMAT VARFM (%INTEGER TYPE, DISP, SIZE, %SHORTINTEGER VTYPE, AID) %FINISH %OWNRECORD (RFM) %ARRAYFORMAT RAFM (1:100000) %OWNRECORD (RFM) %ARRAYNAME RELS, STARTRELS %ownbyteintegerarrayformat codefm (0:infinity) %ownbyteintegerarrayname codearea %ownrecord (blockfm) %array blocks (-1:maxlexlev) %ownrecord (blockfm) %name parentblock, { descriptor of surrounding procedure } curblock { descriptor of current procedure } %ownrecord (Areafm) %arrayformat AreaAfm (0:10000) %ownrecord (areaAfm) %arrayname Areas ! %routinespec fix (%integer type, area, disp, tgt) %routinespec SDBsym(%string(255) s,%integer type,desc,val) %routinespec PSymbol (%string (255) s, %integer type, val,sect,other) %ROUTINESPEC MSDBVAR (%INTEGER SWAD, TYPE, AREA, DISP, BYTESIZE, NELS,ndims,lower,upper) ! %routine PERROR (%string (255) s) PRINTSTRING(SNL."*** Put Interface Error/ ".S.SNL) ! %return %if faulty # 0 {try and keep going to allow report of multiple faults } %monitor %stop %end ! ! %EXTERNALINTEGERFN GETSPACE (%INTEGER SIZE) ;! M GETSPACE %integer flag %if malmon # 0 %then %start printstring(" malloc "); write(size,1) flag = malloc(size) printstring(" flag = "); phex(flag); newline; %if flag + size > maxdata %then maxdata = flag + size %finish %else flag = malloc(size) %if flag = 0 %then perror(" Malloc out of space ") %result = flag %end ! %ROUTINE FWRITE (%INTEGER AREA, OBJID, BYTEAD, LEN) %IF MON # 0 %THEN PRINTSTRING("File Write - AREA ".ITOS(AREA)." ".HTOS(BYTEAD,8)." ".ITOS(LEN).SNL) Filewrite(objid,bytead,len) %end ! %routine File Position (%integer objid, byteoffset, whence) %integer newptr %IF MON # 0 %THEN PRINTSTRING(" CALL LSEEK - ".ITOS(OBJID)." ".HTOS(BYTEOFFSET,8)." ".ITOS(WHENCE).SNL) newptr = LSEEK(objid,byteoffset,whence) %IF MON # 0 %THEN PRINTSTRING(" New Ptr = ".HTOS(NEWPTR,8).SNL) %end ! %routine expand area (%integer id) %integer from, ad, newsize, oldsize, filler, type { This is crude way of implementing segmentation} { by getting a new hole twice the old size and} { copying the data into the front half of it. } from = areas(id)_base oldsize = areas(id)_max type = areas(id)_type %if id = 5 %or id >= 20 %then filler = 0 %else filler = type >> 24 %if malmon # 0 %then printstring("EXPAND AREA ".itos(id)." from, oldsize ".htos(from,8)." ".htos(oldsize,8).SNL) %if oldsize = 0 %then %start { First use of this area } newsize = default area size AD = GETSPACE(NEWSIZE) Perror("GETSPACE fails") %if ad = 0 %unless type = code %then Fill(newsize,ad,filler) %finish %else %start { Expansion of existing area } newsize = (oldsize*2) + 8 { double + hdrsize } AD = REALLOC(FROM,NEWSIZE) { zero additional area on back } FILL(OLDSIZE,AD + (OLDSIZE),FILLER) %UNLESS TYPE = CODE %if malmon # 0 %then %start printstring("Realloc from to newsize ") phex(from) space phex(ad) space phex(newsize) newline %finish %finish %if id = 0 %then areas == array(ad,areaAfm) { have moved the area table } areas(id)_base = ad %if Id=CODE %then Codebase=Ad %IF MON # 0 %THEN PRINTSTRING("EXPAND AREA ".ITOS(ID).SNL) areas(id)_max = newsize %end ! ! PUT interface Code passing routines ! %ROUTINE CHECKCODESIZE (%INTEGER CA) %if CA >= areas(CODE)_max - 1024 %then %start expand area(CODE) codearea == array(areas(CODE)_base,codefm) %finish %end ! %ROUTINE PH (%INTEGER CA, N) ;! 16 bits into code stream %return %if faulty # 0 CheckCodeSize(CA) CODEAREA(CA + 1) = N & 255 CODEAREA(CA) = (N >> 8) & 255 %end ! %ROUTINE PB (%INTEGER CA, N) ;! Basic opcode planting routine %return %if faulty # 0 CheckCodeSize(CA) byteinteger(Codebase+Ca)<-N ! codearea(CA) <- n %end ! %ROUTINE PW (%INTEGER CA, N) ;! 32 bits into code stream %return %if faulty # 0 CheckCodeSize(CA) codearea(CA) = (n >> 24) & 255 codearea(CA + 1) = (N >> 16) & 255 codearea(CA + 2) = (N >> 8) & 255 codearea(CA + 3) = N & 255 %end ! %EXTERNALROUTINE M CBYTES (%INTEGER OFFSET, LEN, AD) ;! M CODEBYTES %INTEGER I %IF MON # 0 %THEN %START PRINTSTRING("M CBYTES - Len: ".ITOS(LEN)."Offset: ".HTOS(OFFSET,8)." Value: ") %IF LEN = 1 %THEN PHEXBYTE(BYTEINTEGER(AD)) %ELSE %START %CYCLE I = AD, 1, AD + LEN - 1 PHEXBYTE(BYTEINTEGER(I)) %REPEAT %FINISH NEWLINE %FINISH %IF LEN = 1 %THEN PB(OFFSET,BYTEINTEGER(AD)) %ELSE %START %CYCLE I = AD, 1, AD + LEN - 1 PB(OFFSET,BYTEINTEGER(I)) OFFSET = OFFSET + 1 %REPEAT %FINISH %END ! !%owninteger prev = 0 !! !%EXTERNALROUTINE M DUMPINSTR (%STRINGNAME S) ;! M DUMPINSTR ! %integer i ! printstring(" ("); phex(prev); printstring(") ") ! Phexbyte(codearea(i)) %for i=prev,1,CA-1 ! %IF CA - PREV < 16 %THEN SPACES(16 - (CA - PREV)) ! PRINTSTRING(" ".S.SNL) !%end !! !%EXTERNALROUTINE M DISP (%INTEGER DISP) ;! M DISP ! %if -64 <= disp <= 63 %then codearea(CA) = disp & X'7F' %and CA = CA + 1 %else %c ! %if -8192 <= disp <= 8191 %then %start ! disp = ((disp & X'3FFF') ! X'8000') ! codearea(CA + 1) = disp & 255 ! codearea(CA) = (disp >> 8) & 255 ! CA = CA + 2 ! %finish %else %c ! %if -16777215 <= disp <= 16777215 %then PW((disp & X'3FFFFFFF') ! X'C0000000') %else %c ! Perror("M DISP - Disp too large ") !%end !! !%EXTERNALROUTINE M FIXDISP (%INTEGER TYPE, TGT, TDISP) ;! M FIXDISP ! %if mon # 0 %then %start ! printstring(" M FIXDISP type = ") ! write(type,1) ! printstring(" to ") ! write(tgt,1) ! printstring(" + ") ! write(tdisp,1) ! printstring(" CA = ") ! phex(ca) ! space ! phex(addr(codearea(CA))) ! newline ! %finish ! FIX( 0,CODE,CA,tgt) ! tdisp = tdisp + (CA-prev) ! PW(X'C0000000'!tdisp) !%end ! ! %EXTERNALROUTINE M LINESTART (%INTEGER LINENO, CODEAD) ;! M LINESTART %owninteger lastline = -1 %return %if faulty # 0 %IF MON # 0 %THEN PRINTSTRING("M LINESTART - LINENO: ".ITOS(LINENO)." at ".itos(codead).SNL) LINESTART = CODEAD Line = Lineno %if sdb # 0 %then %start { save data for line map } %return %if lineno=0 %if line = 1 %start { Include file ? } nextinclude = nextinclude+1 %if nextinclude >0 %thenc SDBsym("",SOL,includeindex(nextinclude),linestart) %finish %IF LINENO # LASTLINE %THEN SDBsym("",SLINE,lineno,codead) %ELSE LASTLINE = LINENO %finish %end ! ! Put Interface Passing of Data ! %EXTERNALROUTINE M DBYTES (%INTEGER CURAREA, DISP, LEN, AD) ;! M DBYTES %record (Areafm) %name A %integer i, bad, to, encoded, from %record (rdfm) %name r %return %if faulty # 0 %if mon # 0 %then %start PRINTSTRING("M DBYTES(".ITOS(CURAREA)." LEN: ".ITOS(LEN)." DISP: ".ITOS(DISP)." VALUE: ") BAD = AD %if len = 1 %then phexbyte(byteinteger(bad)) %else %start %cycle i = bad, 1, bad + len - 1 PHEXBYTE(BYTEINTEGER(I)) %repeat %finish newline %finish %if curarea = 5 %or curarea >= 20 %then encoded = 1 %else encoded = 0 %if curarea >= 20 %then curarea = syms(curarea - 20)_value { common } A == areas(CurArea) %if trusted = 0 %then %start Perror("bad displacement ") %if disp < 0 %or disp > 4000000 %finish FROM = AD ;! copy to byte boundaries %if encoded # 0 %then %start { encoded area } %if A_max = 0 %then expand area(curarea) %and A_linkdisp = 0 {first use } R == RECORD(A_base + A_linkdisp) %WHILE (A_LINKDISP) + (2*RDSIZE) + R_LEN + LEN + 3 > A_MAX %CYCLE expand area(curarea) R == RECORD(A_base + A_linkdisp) %repeat %if (disp = R_disp + R_len) %and R_copies <= 1 %then %start {adjacent areas } TO = (A_BASE + A_LINKDISP) + RDSIZE + R_LEN R_len = R_len + len %finish %else %start { new start required } TO = (A_BASE + A_LINKDISP + RDSIZE + R_LEN +3 ) & (-4) R == RECORD(to) A_linkdisp = to - A_base R_disp = disp R_len = len R_copies = 1 TO = TO + RDSIZE %finish %finish %else %start { normal mapped area } expand area(Curarea) %while disp + len > A_max TO = A_BASE + DISP %finish MOVE(LEN,FROM,TO) Initdataad = to %end ! %EXTERNALROUTINE M D (%INTEGER AREA, DISP, DATABYTE) ;! M D %integer i %return %if faulty # 0 %return %if databyte = 0 i = databyte << 24 M DBYTES(AREA,DISP,1,ADDR(I)) %end ! %EXTERNALROUTINE M D2 (%INTEGER AREA, DISP, DATADOUBLEBYTE) ;! M D2 %return %if faulty # 0 %return %if datadoublebyte = 0 M DBYTES(AREA,DISP,2,ADDR(DATADOUBLEBYTE) + 2) %end ! %EXTERNALROUTINE M D4 (%INTEGER AREA, DISP, DATAQUADBYTE) ;! M D4 %return %if faulty # 0 %return %if dataquadbyte = 0 M DBYTES(AREA,DISP,4,ADDR(DATAQUADBYTE)) %end ! %EXTERNALROUTINE M DPATTERN (%INTEGER AREA, DISP, NCOPIES, LEN, AD) ;! M DPATTERN %integer i, bad %record (Areafm) %name A %integer to, encoded, from %record (rdfm) %name r %return %if faulty # 0 %if mon # 0 %then %start printstring(" M DPATTERN( area = "); write(area,1) printstring(", disp = "); write(disp,1) printstring(", ncopies = "); write(ncopies,1) printstring(" filler = ") BAD = AD %cycle i = bad, 1, bad + len - 1 PHEXBYTE(BYTEINTEGER(I)) %repeat newline %finish %return %if len = 4 %and integer(ad) = 0 %and areas(area)_type >> 4 = 0 ncopies = 1 %if ncopies = 0 %if area = 5 %or area >= 20 %then encoded = 1 %else encoded = 0 %if area >= 20 %then area = syms(area - 20)_value { common } A == areas(Area) %if trusted = 0 %then %start Perror("bad displacement ") %if disp < 0 %or disp > 4000000 %finish FROM = AD ;! copy to byte boundaries %if encoded # 0 %then %start { encoded area } %if A_max = 0 %then expand area(area) %and A_linkdisp = 0 {first use } R == RECORD(A_base + A_linkdisp) EXPAND AREA(AREA) %WHILE (A_LINKDISP) + (RDSIZE*2) + R_LEN + LEN + 3 > A_MAX TO = (A_BASE + A_LINKDISP + RDSIZE + R_LEN + 3) & (-4) R == RECORD(to) A_linkdisp = to - A_base R_disp = disp R_len = len R_copies = ncopies TO = TO + RDSIZE MOVE(LEN,FROM,TO) %finish %else %start { normal mapped area } %cycle i = 1, 1, ncopies expand area(area) %while disp + len > A_max TO = A_BASE + DISP MOVE(LEN,FROM,TO) %repeat %finish %end ! %routine place in dict (%stringname name, %integername set) %integer wl,oldsize WL = (LENGTH(NAME) + 1) ;! Put the name into the dictionary %if dictad + wl > maxdictad %then %start oldsize = dictad-dictstart expandarea(dicttab) dictstart = areas(dicttab)_base dictad= dictstart +oldsize MAXDICTAD = DICTstart+ areas(dicttab)_max %finish string(dictad) = name set = dictad - dictstart dictad = dictad + wl %IF MON # 0 %THEN PRINTSTRING("PLACE IN DICT - ".NAME." DICTAD: ".HTOS(DICTAD,8).SNL) %end ! ! Put Interface RELOCATION and REFERENCES ! %routine Psymbol (%string (255) name, %integer type, Value,sect,other) { remember a name and its properties for inclusion in the } { object file symbol tables } { names are piled end to end in the dictionary } %record (Symfm) %name Sym %integer i %IF MON # 0 %THEN PRINTSTRING("P SYMBOL- ".NAME) NextSym = NextSym + 1 %if nextsym >= maxsyms %then %start expand area(symtab) syms == array(areas(symtab)_base,symafm) maxsyms = areas(symtab)_max // intSymSize %finish length(NAME) = SYMSIZE %if length(NAME) > SYMSIZE Sym == Syms(NextSym) perror("PSYMBOL - OVERWRITING A SYMBOL TABLE ENTRY, ID= ".ITOS(NEXTSYM)) %IF trusted = 0 %and SYM_strx # 0 Sym = 0 place in dict(name,sym_strx) ;! Remember name in dictionary and set sym_ad to its word address Sym_type = type Sym_value = Value %if OBJECT FORMAT = COFF %start Sym_sect = sect Sym_other=other %finish %end ! %EXTERNALINTEGERFN M XNAME (%INTEGER TYPE, %STRINGNAME S) ;! M XNAME ! Xrefs are used many times so establish mapping to integer ID early ! and save on holding/passing of strings %string (32) name, rest %integer i %record (symfm) %name sym %IF MON # 0 %THEN PRINTSTRING("M XNAME NAME: ".S. " type = ".itos(type).SNL) %result = 0 %if faulty # 0 name <- S %if type&1=0 %start { put _ on front ) %if name -> ("s#").rest %then name = "_s_".rest %ELSE name = "_".name %finish ! Look to see if this is a repeated reference ! %cycle i = 0, 1, nextsym ! sym == syms(i) ! %if sym_type = Ext %then %start { found a reference } ! %if name = string(dictstart + sym_strx) %then %start { name already in place } ! %IF MON # 0 %THEN PRINTSTRING(" M XNAME:(REP) ".S." SYMID = ".ITOS(I + 20).SNL) ! %result = i + 20 ! %finish ! %finish ! %repeat Psymbol(name,EXT,0,0,0) { first occurrence of name } %if mon # 0 %then printstring(" M XNAME: ".s." symID = ".itos(nextsym + 20).SNL) %result = NextSYm + 20 %end ! %routine FIX (%integer type, area, disp, tgt) ;! Remember a reloc. request %record (rfm) %name R %integer ad %IF MON # 0 %THEN %START PRINTSTRING("FIX(".ITOS(TYPE).",".ITOS(AREA).",".ITOS(DISP).",".ITOS(TGT).")".SNL) %FINISH %if trusted = 0 %then %start Perror("Fix - Bad relocation request") %ifc area < 1 %or area > nextsym + 20 %or tgt < 1 %or tgt > nextsym + 20 %finish rels == array(rpad(area),rafm) %cycle rpct(area) = rpct(area) + 1 R == rels(rpct(area)) %if rpct(area) + 1 > Maxrels %then %start { start next block of relocations } %if malmon # 0 %then printstring(SNL." Space for relocation tables ") AD = GETSPACE(DEFAULTAREASIZE) {R_type=255} { marker in type field that this is not a reloc} { , but contains addr of next block } r_hostdisp = (X'F0' << 24) ! ad rpct(area) = 0 %if rpstart(area)=0 %then rpstart(area)=ad rpad(area) = ad rels == array(ad,rafm) %finish %else %exit %repeat %if type < 200 %then %start { if it is a genuine reloc request , count it } trct(area) = trct(area) + 1 %if area = Gla %or area = Iotab %then ndrels = ndrels + 1 %else ntrels = ntrels + 1 %finish {R_type=type} R_tgt = Tgt { Note reloc usually means remember 4 values, but } R_hostarea = area { in this m/c have got tgt disp written in } R_hostdisp = (type << 24) ! disp { host word already } %end ! ! M FIX - REQUEST A 32bit RELOCATION ! %EXTERNALROUTINE M FIX (%INTEGER HOSTAREA, DISP, TGTAREA, TGTDISP) ;! M FIX { A relocation request: set word in area, displacement = 'disp' bytes, { the address of area 'targetareaid', displacent = targetdisp.} %record (Areafm) %name A %integername tgt %return %if faulty # 0 A == areas(HostArea) %if trusted = 0 %then %Start Perror("M FIX - bad displacement ") %if disp < 0 %or disp > 4000000 %finish expand area(Hostarea) %while disp + 4 > A_max ! %if tgtarea = code %then tgtarea = tgtdisp %and tgtdisp = 0 TGT == INTEGER(AREAS(HOSTAREA)_BASE + (DISP)) tgt = tgt + tgtdisp FIX(4,Hostarea,disp,tgtarea) %if mon # 0 %then printstring("M FIX( ".itos(Hostarea)."/".htos(disp,6)." -> ".itos(tgtarea)."/".htos(tgtdisp,6).SNL) %end ! %EXTERNALROUTINE M DXREF (%INTEGER AREA, DISP, id) %return %if faulty#0 fix(4,area,disp,id) { I expect a M XNAME to have been done earlier } %if mon # 0 %then printstring(" M DXREF( ".itos(area)."/".htos(disp,8)." -> ".itos(id)) %END ! %EXTERNALROUTINE M DATAENTRY (%STRINGNAME NAME, %INTEGER AREA, MAXLEN, DISP) ;! M DATAENTRY %string (255) s %return %if faulty # 0 %if mon # 0 %then printstring(" M DATAENTRY( ".itos(area)."/".htos(disp,8)." len ".itos(maxlen).name.SNL) s = "_".name %if area=5 %then psymbol(s,FarDAta ! EXT,disp,FarDatasect,1) %elsec Psymbol(s,DATA ! EXT,disp,NearDatasect,0) %end ! %EXTERNALINTEGERFN M NEXTSYMBOL ;! M NEXTSYMBOL ! Reserve a space in the symbol table %result = 0 %if faulty # 0 nextsym = Nextsym + 1 %if nextsym >= maxsyms %then %start expand area(symtab) syms == array(areas(symtab)_base,symafm) maxsyms = areas(symtab)_max //Intsymsize %finish %if mon # 0 %then printstring("Symbol reserved: ".itos(nextsym + 20).SNL) syms(nextsym)_value = -1 ;! Mark as Forward ref %result = Nextsym + 20 %end ! ! M ENTRY - SIDE CODE ENTRY ! %EXTERNALINTEGERFN M ENTRY (%INTEGER INDEX, CODEDISP, %STRINGNAME NAME) ;! M ENTRY %string (255) S,rest %result = 0 %if faulty # 0 S = "_".name length(S) = 32 %if length(S) > 32 Psymbol(S,EXT ! FARTEXT,CODEDISP,FarTextsect,1) { make symbol table entry } %if mon # 0 %then printstring("M ENTRY: ".itos(nextsym + 20).SNL) %if sdb#0 %start s = name %if s->rest.("_") %then s=rest SDBsym(s.":F11",FUN,0,Codedisp+12) %finish %result = Nextsym + 20 %end ! ! M PROC - START A NEW PROCEDURE ! %EXTERNALROUTINE M PROC (%STRINGNAME NAME, %INTEGER PROPS, CODEAD, %c %INTEGERNAME ID, %integer lineno) ;! M PROC { PROPS & 1 = External } { PROPS&2 = No ASFW } { PROPS>>31 = Main entry } %integer type, save, areaid, i, CGRT, at %owninteger firstproc=0 %string (255) rest, S %record (symfm) %name sym ID = 1 %and %return %if faulty # 0 %if mon # 0 %then %start printstring("M PROC: ".name." ID = ".itos(id)) space; phex(props); NEWLINE %finish Parentblock == Curblock { COPE WITH NESTED PROCEDURES } curlexlev = curlexlev + 1 Curblock == blocks(curlexlev) %if props & 1 # 0 %then type = EXT ! FARTEXT %else type = TEXT %if SYSTEM#NPL %start %if name -> ("s#").rest %then S = "_s_".rest %else S = "_".name %finishelsestart s="_".name %finish length(S) = 32 %if length(S) > 32 ! If this procedure has been declared as a spec previously then a M NEXTSYMBOL ! will have reserved the symbol table entry 'ID' for it ! If there was no spec then ID will <=0 %if langimp = 0 %and id = -1 %then %start ! Fortran may well have placed a reference to this entry earlier ! Search backwards and overwrite (first case only) %cycle i = nextsym, -1, 1 sym == syms(i) %IF SYM_TYPE = EXT %AND S = STRING(DICTSTART + SYM_STRX) %THEN %START ID = I + 20 SYM_STRX = 0 ;! Reset for unused check %FINISH %repeat %finish save = 0 %if ID # -1 %then save = nextsym %and nextsym = id - 1 - 20 %if props >> 31 = 1 %or s = "_s_go" %then %start Main Program = 1 Main Entry Point = CODEAD %if langimp=0 %then s = "_MAIN__" %elsec s = "_main" %if ECC=1 %then s="_main" TYPE = EXT ! FARTEXT ! %if line = 0 %then M LINESTART(1) { temp } %finish Psymbol(S,type,CODEAD,FarTextsect,1) { make symbol table entry } %if ID # -1 %then nextsym = save %else ID = Nextsym + 20 %if mon # 0 %then printstring(" symID = ".itos(ID).SNL) %if sdb#0 %start SDBsym("",SLINE,lineno,codead) %if firstproc=0 %then SDBSYM("void:t11=r11;0;0;",Lsym,0,0) %and firstproc=1 s ->("_").s %if props>>31=1 %and langimp=1 %then s="main" %elsestart %if props>>31=1 %then s="MAIN_" %elsec %if s->rest.("_") %then s=rest %finish SDBsym(s.":F11",FUN,0{resultsize!},Codead+12) { + 12 to allow prologue to take effect } %finish %end ! %EXTERNALROUTINE M PROCEND(%integer codead) ;! M PROCEND %if mon # 0 %then %start PRINTSTRING("M PROC END".SNL) %finish %IF TRUSTED = 0 %AND CURLEXLEV = 0 %THEN PERROR("M PROCEND - too many proc ends".SNL) Curblock == Parentblock curlexlev = curlexlev - 1 Parentblock == blocks(curlexlev - 1) %end ! ! Put Interface - Miscellaneous ! %EXTERNALROUTINE M REVERSEBYTES (%INTEGER AREA, DISP, LEN) ;! M REVERSEBYTES %END ! %EXTERNALINTEGERFN M COMMON (%STRINGNAME NAME) ;! M COMMON %string(63) s %result = 0 %if faulty # 0 %IF MON # 0 %start PRINTSTRING("P COMMON - ".NAME.SNL) write(toparea+1,1) %finish Toparea = Toparea + 1 !%if toparea > maxarea %then %start !expand area(0) !maxarea = areas(0)_max // sizeof(areas(0)) !%finish %if name="F#BLCM" %then s="_BLNK__" %else s="_".name."_" Psymbol(s,EXT,Toparea,0,1) { put area table index in _value temporarily } areas(toparea)_sym = nextsym + 20 %result = nextsym + 20 %end ! %EXTERNALROUTINE M ENDCOMMON (%INTEGER ID, LENGTH) ;! M ENDCOMMON %return %if faulty # 0 %if mon # 0 %then %start PRINTSTRING("P END COMMON ".ITOS(ID)." LENGTH = ") phex(length) newline %finish %if SYSTEM=NPL %then length = (length + 15) &(-16) areas(syms(id - 20)_value)_length = length syms(id - 20)_value = length %end ! %routine SdbSym (%string (255) name, %integer type, desc, Value) { remember a name and its properties for inclusion in the } { object file symbol tables SDB section } { names are piled end to end in the dictionary } %record (Symfm) %name Sym %integer i NextSdbSym = NextSdbSym + 1 %if nextSDBsym >= maxSDBsyms %then %start expand area(SDBsymtab) SDBsyms == array(areas(SDBsymtab)_base,symafm) maxSDBsyms = areas(SDBsymtab)_max // intSymSize %finish Sym == SDBSyms(NextSDBSym) Sym = 0 %if name="" %then sym_strx=0 %elsec place in dict(name,sym_strx) ;! Remember name in dictionary and set sym_ad to its word address %if type = SOL %then sym_strx=desc %and desc=0 Sym_type <- type Sym_desc2 <- desc sym_desc1 = desc>>8 Sym_value = Value %end ! %EXTERNALROUTINE MSDBVAR (%INTEGER SWAD, VTYPE, AREA, DISP, BYTESIZE, NELS,ndims,lower1,upper1) ;! M VAR { Take details of variables and encode for SDB } %owninteger maxvarad %string(63) sinfo %record (varfm) %name v %integer type,desc,value,defno %stringname s %ownstring(12) fnresult="Fn result" %integer dicad,ad,i %conststring(40) %array defs(1:10) = %c "integer*1:t1=r1;0;255;", "integer*2:t2=r2;-32768;32767;", "integer:t3=r3;-2147483648;2147483647;", "real:t4=r4;4;0;", "double precision:t5=r5;8;0;", "complex:t6=r6;8;0;", "double complex:t7=r7;16;0;", "logical*2:t8=r8;0;32767;", "logical:t9=r9;0;2147483647;", "char:t10=r10;0;127;" %ownintegerarray trigger(1:10) = 0(10) %constinteger integer = 1, { Fortran dictionary types } real = 2, complex = 3, logical = 4, character=5 %return %if faulty # 0 %if swad = 0 %then s == Fn result %else s == string(swad) %if mon # 0 %and bytesize # 0 %then %start printstring("MSDBVAR: ".s." type = ") phex(vtype) printstring(" area/disp/len/nels/ndims,lower1,upper1 = ") write(area,1) space; phex(disp) write(bytesize,1) write(nels,1) write(ndims,1) write(lower1,1) write(upper1,1) newline %finish ! { Upper case L is ignored by SDB so translate variable names to lower case!} ! %cycle i= (addr(s)*2) + 1,1,(addr(s)*2) + length(s) ! %if 'A'<=byteinteger(i)<='Z' %then byteinteger(i)=byteinteger(i) + 32 ! %repeat %if swad=0 %start { fn result } SDBsyms(nextSDBsym)_desc2 = bytesize %return %finish type = vtype vtype = vtype&127 %if vtype=integer %start %if bytesize=4 %then defno=3 %elsec %if bytesize=2 %then defno=2 %elsec defno=1 %finishelsec %if vtype=real %start %if bytesize=4 %then defno=4 %else defno=5 %finishelsec %if vtype=complex %start %if bytesize=4 %then defno=6 %else defno=7 %finishelsec %if vtype = logical %start %if bytesize=4 %then defno=9 %else defno=8 %finishelsec %if vtype=character %then defno=10 %if vtype=character %Start { Describe character as a byte array for DBX} nels=bytesize bytesize=0 %finish %if trigger(defno)=0 %start { First use of a type } SDBsym(defs(defno),Lsym,0,0) trigger(defno)=1 %finish desc = bytesize %if type&128#0 %then type = PSYM %else type = stsym %if incommon#0 %then type = GSYM %and area=incommon{ Common } value = disp %if type=stsym %or type=gsym %then value = (area<<24)!disp { adjust at end when area lengths known } %if type=PSYM %then sinfo = string(swad).":v" %elsec sinfo = string(swad).":V" nels = nels - 1 { nels =1 is a variable not a single element array } %if nels>0 %then sinfo=sinfo."ar".itos(defno).";".itos(lower1).";".itos(upper1).";" sinfo = sinfo.itos(defno) SDBsym(sinfo,type,desc,value) %end %externalroutine MSDBcmnstart(%stringname s,%integer id) %string(63) ss %if mon#0 %then printstring(" Msdbcmnstart ".s) %and write(id,1) %and newline %if s="F#BLCM" %then ss="_BLNK__" %else ss=s SDBsym(ss,BCOMM,0,0) incommon=id %end %externalroutine MSDBcmnend(%stringname s,%integer id) %string(63) ss %if mon#0 %then printstring(" Msdbcmnend ".s) %and newline %if s = "F#BLCM" %then ss="_BLNK__" %else ss=s SDBsym(ss,ECOMM,0,0) incommon=0 %end ! %EXTERNALROUTINE M FAULTY ;! M FAULTY { Code generator has encountered a user error. Code requests should no } { longer be checked and minimum work done in PUT } %if mon # 0 %then printstring("M FAULTY".SNL) Faulty = 1 %end ! %EXTERNALROUTINE M SETFILES (%STRINGNAME SRCNAME, OBJFILENAME,%integer syntaxonly) %string(63) name %integer i %ownrecord(areafm) Zeroarea %integer at %owninteger Numincludes = 0 %string (255) S %integerarray Cname(0:64) %integerarray mpxcreat(0:4) %ownstring(8) mpxcstr = "repl=t" %IF MON # 0 %THEN PRINTSTRING("M SETFILES : ".SRCNAME." : ".OBJFILENAME.SNL) S = SRCname %if objfilename = "include" %start ! remember the files name for DBX Placeindict(srcname,at) NumIncludes = Numincludes+1 Includeindex(Numincludes) = at %finishelsestart %if syntaxonly=0 %start %if length(s) > 32 %then length(s) = 32 Srcfile = S CSTRING(objfilename,addr(Cname(0))) %if SYSTEM=MPXL %start Cstring(mpxcstr,addr(mpxcreat(0))) Objid = CREAT(addr(cname(0)),mode,addr(mpxcreat(0))) %finishelsestart Objid = CREAT(addr(cname(0)),mode) %finish %if objid < 0 %start selectoutput(2) printstring(" Cannot create ".objfilename) newline exit(1) %finish %finish ! Unfortunately a few calls on put are made even if syntax only option ! is in force, so start up tables to avoid failure. Areas == array(addr(ZeroArea),Areaafm) { Start of area table } expand area(0) MaxArea = areas(0)_max // sizeofareaentry name = "123" { Put a dummy 4 byte entry into the symbol table } place in dict(name,i) { to leave space for its length to be filled in } %finish %end ! ! M INITIALISE - CODE GENERATION BEGINS WITH THIS CALL ! %EXTERNALROUTINE M INITIALISE (%INTEGER LANGUAGE, PROPS, SOURCEAD) ;! M INITIALISE %integer i %string (32) lang %IF MON # 0 %THEN PRINTSTRING("M Initialise".SNL) %return %if faulty # 0 %if language = 1 %then lang = "IMP80" %and langimp = 1 %else lang = "FORTRAN77" %if comreg(26) & 128 # 0 %then malmon = 1 %if comreg(26) & 16 # 0 %then filemon = 1 %if comreg(26) & 4 # 0 %then sdb=1 %if language = 1 %then M LINESTART(0,0) { give p_rts a valid line number } Free Source Areas { release consource claimed space } curblock == blocks(0) { Set pointer to dummy outer level } rpstart(code)=getspace(defaultareasize) rpad(code)=rpstart(code) rpstart(plt)=getspace(defaultareasize) rpad(plt)=rpstart(plt) rpstart(gla)=getspace(defaultareasize) rpad(gla)=rpstart(gla) %if language#1 %start rpstart(iotab)=getspace(defaultareasize) rpad(iotab)=rpstart(iotab) %finish %if sdb#0 %then SDBsym(srcfile,SO,0,0) { start with source file record } %end ! ! M TERMINATE - CODE GENERATOR CLOSES WITH THIS CALL TO ESTABLISH AREA LENGTHS ! %EXTERNALROUTINE M TERMINATE (%INTEGER ADAREASIZES) %ownstring(7) base6="__base6",base5="__base5",base4="__base4" %ownstring(7) ubase7="_base7",ubase6="_base6" %INTEGER I, AD, L %return %if faulty # 0 %if mon # 0 %then %start PRINTSTRING("M TERMINATE".SNL) PRINTSTRING(" Arealengths from Mterminate are:".SNL) %cycle i = 0, 1, 9 WRITE(INTEGER(ADAREASIZES + (I * 4)),1) %REPEAT NEWLINE %finish { Put down Base register markers for LD } %if SYSTEM=NPL %Start Psymbol(base4,ext!abs,-1,Nabs,0) Psymbol(base5,ext!abs,-1,Nabs,0) Psymbol(base6,ext!abs,-1,Nabs,0) %finish ad = adareasizes %cycle i = 1, 1, 10 L = INTEGER(AD) AD = AD + 4 %if l<0 %then l=l-4 %if SYSTEM#NPL %start l = (l+7) & (-8) %finishelsestart l = (l + 15) & (-16) { Keep areas tidy on 16 byte boundaries } %finish ! Perror("Mterminate - Area ".itos(i)." has incorrect length".SNL) %if trusted = 0 %and i # 1 %and l = 0 %and areas(i)_max # 0 areas(i)_length = l %repeat %end ! ! M GENERATE - FINAL PHASE OF COMPILATION IS CREATE OBJECT FILE ! %EXTERNALROUTINE M GENERATEOBJECT (%STRINGNAME OBJFILENAME ) %if OBJECT FORMAT = COFF %start %ownbyteintegerarray buff(0:500) %ownrecord(hdrfm) %name hdr %record(opthdrfm) %name oh %record(secthdrfm) %name sh %string(8) name %integer at,ntextlns,FarDataSym %constinteger STYPtext = x'20' { executeable code } %constinteger STYPdata = x'40' { initialised data } %constinteger STYPbss = x'80' { unintialised data } %constinteger STYPFar = x'1000' %finishelsestart %record (hdrfm) hdr %finish %INTEGER TEXTLEN, DATALEN, SYMLEN, AD, J, FILLER, I, BSSLEN, L, %C LINKDISP, AREABASE, KAD, Dataoffset %integer NearDataLen,fardatalen,fartextlen,neartextlen %integer fargla, fariotab, commondisp %integerarray areastart(1:toparea) %record (rdfm) %name rd %string (255) s %integer NearDataPtr,FarDataPtr,NearTextPtr,FarTextPtr %integer SymPtr,NearTextRelptr,NearDataRelptr,TextLnnoptr %integer Fartextrelptr,Fardatarelptr %integer ntrct,ftrct,ndrct,fdrct %constbyteintegerarray order (2:10) = 2, 8, 10, 7, 4, 5, 6, 3, 9 ! ! Object file area allocations: ! ! Near Text: 3 ! Far Text: 1, 10, 4, 6 ! Near Data: 2, 8 ! Far Data: 5 ! Far BSS: 9 ! %routine PATTERN (%integer fileid, ncopies, l, bad) %byteintegerarray b(0:511) %integer i, left, ad, to, blen, bufsize AD = ADDR(B(0)) { if l > 512 ? } { First fill the buffer with the pattern } %if l = 1 %then %Start { single byte pattern } FILL(512,AD,BAD) ;! bad contains filler byte if l=1 bufsize = 512 %finish %else %start { multiple byte pattern } bufsize = 0 %cycle i = 1, 1, ncopies to = ad + bufsize MOVE(l,BAD,TO) bufsize = bufsize + l %if bufsize + l > 511 %then %exit %repeat %finish left = ncopies * l { And then write it out } %cycle %if left > bufsize %then blen = bufsize %else blen = left left = left - blen Fwrite(15,fileid,ad,blen) %repeat %until left <= 0 %end ! %ROUTINE RELOCATIONS ! Output UTX header, code area, data areas and relocations to object file %if host=Gould %start %if OBJECT FORMAT = COFF %start %record(coffrelfm) %arrayformat relafm(0:10000) %record(coffrelfm) %arrayname ntr %record(coffrelfm) %arrayname ftr %record(coffrelfm) %arrayname ndr %record(coffrelfm) %arrayname fdr %finishelsestart %record(relfm) %arrayformat relafm(0:10000) %record(relfm) %arrayname TR,DR %finish %finishelsestart %record (Relfm) %array TR(0:nTrels + 1) ;! Build code reloc table here %record (Relfm) %array DR(0:nDrels + 1) ;! Build data reloc table here %finish %integer i %integer ntrctr,ftrctr,ndrctr,fdrctr %integerarray sizes(0:15) %integer ii,x,size3 %routine relocsforarea(%integer area) %record (rfm) %name R %integer i, j, vad, type, TgtSym, A, hostdisp, format, Tgtsymtype %integer tgtdisp, rdisp, Extern, Gtgtsym %if OBJECT FORMAT = COFF %start %record(coffrelfm) %name coffrel %finishelsestart %record (relfm) %name rel %finish %record(rfm) %arrayname rels %CONSTINTEGER MEMREF = 2 ;! Memory Reference Instruction type relocation %CONSTINTEGER ABSCONST = 0 ;! Absolute Constant type relocation %CONSTINTEGER ADDRCONST = 1 ;! Address Constant type relocation %return %if rpstart(area) = 0 rels == array(rpstart(area),rafm) i = 1 %cycle { Through list of Relocation requests } R == Rels(i) Type = R_hostdisp >> 24 hostdisp = R_hostdisp & X'FFFFFF' %if type = X'E0' %then %exit ;! End of relocs %if type & X'F0' = X'F0' %then %c rels == array(R_hostdisp&X'FFFFFFF',rafm)%and i = 1 %and %continue { next block } TgtSym = R_tgt ! tgtdisp = r_tgtdisp tgtdisp = 0 Extern = 0 %if Tgtsym >= Setareas %then %start { symbol id not an area } { Could be common,data xref or proc. } tgtsym = tgtsym - Setareas TgtSymType = syms(Tgtsym)_type { If its an initialised common point at FarDAta } %if tgtsymtype=Ext!Fardata %start %if OBJECT FORMAT = COFF %Start gtgtsym = xtype(5) %finishelsestart gtgtsym=FarDAta %finish a = areas(r_hostarea)_base+hostdisp integer(a)=integer(a)+areastart(5)+syms(tgtsym)_value %finishelsestart %if tgtsymtype=EXT %then extern=1 %else tgtsym=text Gtgtsym=Tgtsym %finish %finish %else %start { area id to be used } tgtdisp = areastart(tgtsym) A = AREAS(R_HOSTAREA)_BASE + HOSTDISP { Access to near data via MEM REF is contained in 16 bits of offset } { plus 3 bits for the base register. The Loader can cope with losing } { the higher bits because the Gtgtsym tells it NEAR DATA } %if r_hostarea=code %and (tgtsym=gla %or tgtsym=iotab) %thenc integer(a)=integer(A) + (areastart(tgtsym)&x'7ffff') %elsec INTEGER(A) = INTEGER(A) + AREASTART(TGTSYM) GTGTSYM = XTYPE(TGTSYM) %if OBJECT FORMAT=BSD %start %if tgtsym=gla %and fargla#0 %then gtgtsym=12 %if tgtsym=iotab %and fariotab#0 %then gtgtsym=12 %finish ! %if R_hostarea = CODE %then tgtdisp = tgtdisp + (Textlen - hostdisp) %finish ! Work out where the relocation entry is and where it points %IF R_HOSTAREA = CODE %OR R_HOSTAREA = 3 %THEN %START ;! Text Relocation %if OBJECT FORMAT = COFF %start %if R_hostarea = code %start coffrel == FTR(ftrctr-1) ftrctr = ftrctr + 1 %finishelsestart coffrel == NTR(ntrctr-1) ntrctr = ntrctr + 1 %finish %finishelsestart rel == TR(trctr - 1) trctr = trctr + 1 %finish %IF R_HOSTAREA = CODE %THEN %START %IF TGTSYM = GLA %OR TGTSYM = 3 %OR TGTSYM = IOTAB %THEN FORMAT = MEMREF %ELSE FORMAT = ADDRCONST %FINISH %ELSE FORMAT = ADDRCONST Vad=Hostdisp +Areastart(R_Hostarea) %FINISH %ELSE %START ;! Data Relocation %if OBJECT FORMAT = COFF %start %if (R_hostarea = gla %and fargla#0) %orc (R_hostarea=iotab %and fariotab#0) %start coffrel == FDR(fdrctr-1) fdrctr = fdrctr + 1 %finishelsestart coffrel == NDR(ndrctr-1) ndrctr = ndrctr + 1 %finish %finishelsestart rel == DR(drctr - 1) drctr = drctr + 1 %finish FORMAT = ADDRCONST VAD = HOSTDISP + AREASTART(R_HOSTAREA) - Dataoffset %finish ! Fill in relocation entry %if OBJECT FORMAT = COFF %start coffrel_vaddr = hostdisp + areastart(R_hostarea) coffrel_symndx = Gtgtsym coffrel_lentype = (2<<24)!(FORMAT<<16) %finishelsestart REL_ADDRESS = VAD ! Format of data word is SYMBOL:24 ; PCREL:1 (Not used on UTX) ; LENGTH:2 ; EXTERN:1 ; FORMAT:4 { if extern=0 then symbol is target type } REL_DATA = (GTGTSYM << 8) ! (0 << 7) ! (2 << 5) ! (EXTERN << 4) ! (FORMAT) %finish i = i + 1 %repeat %end { Put end markers on the relocation lists } %cycle i = 1,1,10 %if rpstart(i)#0 %then fix(x'e0',i,2,20) %repeat %if host=Gould %start %if OBJECT FORMAT = COFF %start NTR==array(getspace((ntrct+2)*12),relafm) FTR==array(getspace((Ftrct+2)*12),relafm) NDR==array(getspace((ndrct+2)*12),relafm) FDR==array(getspace((fdrct+2)*12),relafm) ftrctr=1 ntrctr=1 fdrctr=1 ndrctr=1 %finishelsestart TR==array(getspace((ntrels+2)*8),relafm) DR==array(getspace((ndrels+2)*8),relafm) %finish %finish drctr = 1 trctr = 1 RelocsForArea(PLT) { Produce relocations area by area } RelocsForArea(Code) { in vm order. ie. near text , text } %if fargla=0 %and fariotab#0 %start RelocsForArea(IOtab) RelocsForArea(GLA) %finishelsestart RelocsForArea(GLA) RelocsForArea(IOtab) %finish ! Write out private header information (area sizes etc) %if SYSTEM=NPL %start size3=16 %finishelsestart size3=8 %finish SIZES(0) = X'4550434C' !%CYCLE X = 1, 1, 15 !%IF X < 11 %THEN SIZES(X) = AREAS(X)_LENGTH %ELSE SIZES(X) = 0 !%REPEAT FWRITE(11,OBJID,ADDR(SIZES(0)),size3) ! ! Write out Text Areas %IF AREAS(3)_BASE # 0 %THEN %START ;! Area 3 L = AREAS(3)_LENGTH - size3 FWRITE(3,OBJID,AREAS(3)_BASE + size3,L) FREE(AREAS(3)_BASE) %FINISH FWRITE(1,OBJID,Codebase,AREAS(1)_LENGTH) ;! Area 1 %IF AREAS(10)_BASE # 0 %THEN %START ;! Area 10 L = AREAS(10)_LENGTH FWRITE(10,OBJID,AREAS(10)_BASE,L) FREE(AREAS(10)_BASE) %FINISH %IF AREAS(4)_BASE # 0 %THEN %START ;! Area 4 L = AREAS(4)_LENGTH FWRITE(4,OBJID,AREAS(4)_BASE,L) FREE(AREAS(4)_BASE) %FINISH %IF AREAS(6)_BASE # 0 %THEN %START ;! Area 6 L = AREAS(6)_LENGTH FWRITE(6,OBJID,AREAS(6)_BASE,L) FREE(AREAS(6)_BASE) %FINISH ! ! Move Data areas into position { Move out the FAR DATA - areas 5 and init. commons } %cycle ii=setareas+1,1,toparea %if ii=setareas+1 %then i=5 %else i=ii { Get gst out in front: realcommon start +2} l = areas(i)_length %continue %if l = 0 { These are all ENCODED areas } areabase = LSEEK(Objid,0,1) {where am I?} filler = areas(i)_type >> 24 %if filler # 0 %then %start { to be pre-patterned } pattern(objid,l,1,filler) FilePosition(Objid,areabase,0) { put file back to start of area } %finish %if areas(i)_base = 0 %then %start %if i >= setareas %then %continue %else -> empty %finish linkdisp = 0 %cycle { Through area frags.} RD == RECORD(areas(i)_base + linkdisp) FilePosition(Objid,RD_disp + areabase,0) KAD = (AREAS(I)_BASE + LINKDISP) + RDSIZE %if RD_copies > 1 %then %start %if RD_len = 1 %then kad = byteinteger(kad) pattern(objid,RD_copies,RD_len,kad) %finish %else FWRITE(I,Objid,kad,RD_len) LINKDISP = (LINKDISP + RD_LEN + RDSIZE + 3) & (-4) %repeat %until Addr(RD) - areas(i)_base = areas(i)_linkdisp empty: FilePosition(Objid,areabase + l,0) %repeat ! { Now put out the NEAR DATA or FAR DATA - areas 2 and 8 } ! %if fargla=0 %and fariotab#0 %start %cycle i=8,-6,2 l=areas(i)_length %continue %if l=0 %if areas(i)_base#0 %start FWRITE(I,OBJID,AREAS(I)_BASE,L) FREE(AREAS(I)_BASE) %finishelse FILE POSITION(OBJID,L,1) %repeat %finishelsestart { usual order } %cycle i=2,6,8 l = areas(i)_length %continue %if l = 0 { These are all mapped areas } %if areas(i)_base # 0 %then %start { has any initialisation been recvd? } FWRITE(I,OBJID,AREAS(I)_BASE,L) FREE(AREAS(I)_BASE) %finish %else FILE POSITION(Objid,l,1) %repeat %finish !thenc Write out relocation tables %if OBJECT FORMAT = COFF %start %IF NTRct > 0 %THEN FWRITE(12,OBJID,ADDR(NTR(0)),12 * (NTRCTR - 1)) %IF FTRct > 0 %THEN FWRITE(12,OBJID,ADDR(FTR(0)),12 * (FTRCTR - 1)) %IF FDrct > 0 %THEN FWRITE(12,OBJID,ADDR(FDR(0)),12 * (FDRCTR - 1)) %IF nDrct > 0 %THEN FWRITE(12,OBJID,ADDR(NDR(0)),12 * (NDRCTR - 1)) %finishelsestart %IF NTRELS > 0 %THEN FWRITE(12,OBJID,ADDR(TR(0)),8 * (TRCTR - 1)) %IF NDRELS > 0 %THEN FWRITE(12,OBJID,ADDR(DR(0)),8 * (DRCTR - 1)) %finish %END ! %ROUTINE SYMBOL TABLES ! Output symbol tables to object file %record (symfm) %name s %constinteger size=intsymsize//2 %integer area,l %IF HOST = ICL2900 %THEN %START %HALFINTEGERARRAY BUF (0:size * (NEXTSYM + 1)) %FINISHELSESTART %if host=Gould %start %shortintegerarrayformat bufafm(0:size*(nextsym+1)) %shortintegerarrayname buf %finishelsestart %SHORTINTEGERARRAY BUF (0:size * (NEXTSYM + 1)) %finish %FINISH %integer i, j, strx %if host=gould %start buf==array(getspace((nextsym+2)*intsymsize),bufafm) %finish %CYCLE I = 0, 1, NEXTSYM s == syms(i) j = i *size STRX = S_STRX BUF(J) <- STRX >> 16 ;! cannnot use a record array because of 4 byte BUF(J + 1) <- STRX & X'FFFF' ;! alignment { If its unintialised common do Ext type and x'01' 'other' } { to mean can be placed in Far } !%if s_type=Ext %and s_value#0 %then buf(j+2)<-x'0101' %elsestart BUF(J + 2) <- S_TYPE << 8 ! s_other !%if S_Type&X'1E' = Fardata %then Buf(J+2)=Buf(J+2)!1 !%finish BUF(J + 3) <- (S_DESC1<<8) ! s_desc2 %if OBJECT FORMAT = BSD %start %if s_type = EXT ! FArDATA %then s_value = s_value+ textlen %if s_type = EXT ! DATA %then s_value = s_value + textlen +commondisp %IF S_TYPE = X'A1' %OR S_TYPE = X'B' %THEN S_VALUE = S_VALUE + NearTextlen %finish { COFF section values are filled in as if all areas are present } { Now they are adjusted to miss out unused areas } %if OBJECTFORMAT = COFF %start %if s_sect=103 %then s_sect=fardatasect %if s_sect=104 %then s_sect=bsssect %if s_sect=105 %then s_sect=neardatasect %finish BUF(J + 4) <- S_VALUE >> 16 BUF(J + 5) <- S_VALUE & X'FFFF' %if OBJECT FORMAT = COFF %start BUF(J + 6) <- S_sect >>16 BUF(J + 7) <- S_sect & x'ffff' %finish %repeat j = j + size FWRITE(13,OBJID,ADDR(BUF(0)),J * 2) %if sdb#0 %start { add sdb symbols on the end } %cycle i = 0,1,nextsdbsym s == sdbsyms(i) %if s_type = FUN %or s_type = SLINE %or s_type = SO %then s_value=s_value+NearTextlen %if s_type = stsym %or s_type=gsym %start area = s_value>>24 %if OBJECTFORMAT=BSD %start %if area < 20 %then l = textlen %if (area = 2 %and fargla=0) %orc ( area = 8 %and fariotab=0) %then l = l + fardatalen %if area = 9 %then l = l + datalen %finishelsestart { COFF } l=0 %finish s_value=s_value&x'ffffff' %if area<20 %then s_value=s_value+l %if area>=20 %start { common } %if syms(area-setareas)_type = EXT!Fardata %start { initialised common } s_value = syms(area-setareas)_value + s_value s_type = FarSTS s_sect=FarDataSect { sect = 0 for uninit. FarData for init.} %finish %finish %if area=5 %then s_type = FarSTS %if area=gla %and fargla#0 %then s_type = FarSTS %if area=iotab %and fariotab#0 %then s_type=FarSTS %if area=9 %then s_type = LCsym %finish %repeat Fwrite(13,objid,addr(sdbsyms(0)),(nextsdbsym+1)*intsymsize) %finish %END ! %ROUTINE DICTIONARY ! Output dictionary (string table) to object file %integer i, j %byteintegerarrayformat bfm(0:255) %byteintegerarrayname b %IF MON # 0 %THEN %START PRINTSTRING("OUTPUT DICTIONARY - DICTAD: ".HTOS(DICTAD,8)." DICTSTART: ".HTOS(DICTSTART,8).SNL) %FINISH J = DICTAD - DICTSTART INTEGER(DICTSTART) = J ;! Fill in string table length I = DICTSTART + 4 %cycle S = STRING(I) L = BYTEINTEGER(I) ;! L = LENGTH(S) b == array(i,bfm) b(j - 1) = b(j) %for j = 1,1,l b(l) = 0 I = I + L + 1 %repeat %until i = Dictad FWRITE(14,OBJID,DICTSTART,DICTlen) %END ! !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Main routine start ! %return %unless faulty = 0 %IF MON # 0 %THEN PRINTSTRING("M GENERATE".SNL) ! PRINTSTRING(SNL."Max data before object generation = ".HTOS(MAXDATA,4)) areastart(i) = 0 %for i = 1,1,toparea ! Work out size of major parts of object file FarTextlen = AREAS(1)_LENGTH + AREAS(10)_LENGTH + AREAS(4)_LENGTH + AREAS(6)_LENGTH NearTextlen = AREAS(3)_LENGTH TEXTLEN = farTextLen + NearTextlen bsslen=0 { Only the Zero-Gst area goes directly } { into BSS. The linker will look after } { the uninit. commons which also } { belong in BSS. } {** See if any data has been switched into FAR ***} { Indicated by a negative length } %if areas(gla)_length<0 %start fargla = 1 areas(gla)_length = -areas(gla)_length %finishelsec fargla = 0 %if areas(iotab)_length<0 %start fariotab = 1 areas(iotab)_length = -areas(iotab)_length %finishelsec fariotab = 0 DATALEN = AREAS(2)_LENGTH + AREAS(8)_LENGTH + AREAS(5)_LENGTH ! Now check for initialised commons and tack them onto FAR data fardatalen = areas(5)_length commondisp = fardatalen %cycle i = setareas+2,1,toparea %if mon#0 %start printstring(" COMMON length ") write(areas(i)_max,1) write(areas(i)_length,1) newline %finish %if areas(i)_max#0 %start { Initialised common } j=areas(i)_sym-setareas syms(j)_value=fardatalen syms(j)_type = EXT!FARDATA syms(j)_sect = Fardatasect datalen = datalen+areas(i)_length fardatalen = fardatalen + areas(i)_length %finish %repeat ntrct = trct(3) { number of relocs in near text = those for area 3 } ftrct = trct(1) { number of relocs in far text = those for area 1 } ndrct = 0 fdrct = 0 %if fargla =0 %then ndrct = ndrct + trct(2) %c %else fdrct = fdrct + trct(2) %if fariotab=0 %then ndrct = ndrct + trct(8) %c %else fdrct = fdrct + trct(8) AREASTART(3) = 0 %if OBJECT FORMAT=BSD %start AREASTART(1) = AREAS(3)_LENGTH AREASTART(10) = AREAS(1)_LENGTH + AREASTART(1) AREASTART(4) = AREAS(10)_LENGTH + AREASTART(10) AREASTART(6) = AREAS(4)_LENGTH + AREASTART(4) AREASTART(5) = Areas(6)_Length + Areastart(6) %if fargla=0 %and fariotab#0 %start AREASTART(8) = Fardatalen + Areastart(5) AREASTART(2) = AREAS(8)_LENGTH + AREASTART(8) areastart(9) = areas(2)_length + areastart(2) %finishelsestart AREASTART(2) = Fardatalen + Areastart(5) AREASTART(8) = AREAS(2)_LENGTH + AREASTART(2) areastart(9) = areas(8)_length + areastart(8) %finish %finishelsestart { COFF } AREASTART(1) = 0 { start of .nbtext } AREASTART(10) = AREAS(1)_LENGTH AREASTART(4) = AREAS(10)_LENGTH + AREASTART(10) AREASTART(6) = AREAS(4)_LENGTH + AREASTART(4) AREASTART(5) = 0 { start of .nbdata } %if fargla=0 %and fariotab#0 %start AREASTART(8) = Areastart(5) AREASTART(2) = 0 { start of .data } areastart(9) = areas(2)_length %finishelsestart %if fargla#0 %then AREASTART(2) = Areastart(5)+Fardatalen %c %else AREASTART(2)=0 AREASTART(8) = AREAS(2)_LENGTH + AREASTART(2) %finish areastart(Zgst)=0 { start of .nbbss } %finish %if fargla#0 %then fardatalen = fardatalen + areas(gla)_length %if fariotab#0 %then fardatalen=fardatalen+areas(iotab)_length Dataoffset = Areastart(5) %if OBJECT FORMAT = COFF %Start { Variables ending in 'ptr' are 'File Pointers' } { and measure bytes from start of file } NearDatalen = Datalen - FarDataLen NearTextPtr = 32+48+(2*48) { One file hdr,one opt hdr and 1-6 section hdrs } %if areas(zgst)_length > 0 %then bsslen = areas(zgst)_length %if bsslen>0 %then NearTextPtr = nearTextPtr + 48 %if NearDatalen>0 %then NearTextPtr = nearTextPtr + 48 %if Fardatalen>0 %then NearTextPtr = nearTextPtr + 48 FarTextPtr = NearTextPtr + NearTextLen FarDataPtr = FarTextptr + FarTextlen NearDataPtr = FarDataPtr + FarDataLen NearTextrelptr = NearDataptr + Neardatalen !NearDataPtr = FarTextptr + FarTextlen !FarDataPtr = NearDataPtr + NearDataLen !NearTextrelptr = FarDataptr + Fardatalen FarTextrelptr = NearTextrelptr + (12*ntrct) FarDatarelptr = FarTextrelptr + (12*ftrct) NearDatarelptr = FarDatarelptr + (12*fdrct) Textlnnoptr = NearDatarelptr + (12*ndrct) Ntextlns = 0 { Just for Beta } Symptr = Textlnnoptr + (Ntextlns*8) { lengthof lnno entry guessed!} { Empty sections have a zero pointer } %if NearTextLen = 0 %then NearTextPtr = 0 %if NearDataLen = 0 %then NearDataPtr = 0 %if FarDataLen = 0 %then FarDataPtr = 0 %if Ntextlns = 0 %then Textlnnoptr = 0 %if fdrct=0 %then FarDatarelptr=0 %finish { COFF requires symbol table entries for the major sections } %if OBJECT FORMAT = COFF %start Psymbol(".text",text,0,NearTextSect,0) xtype(3)=nextsym Psymbol(".nbtext",fartext,0,FarTextSect,1) xtype(1)=nextsym xtype(10)=nextsym xtype(4)=nextsym xtype(6)=nextsym fardatasect=3 %if FarDataLen>0 %start Psymbol(".nbdata",FarData,0,FarDataSect,1) xtype(5)=nextsym FarDataSym = Nextsym Bsssect=4 Neardatasect=5 %finishelsestart { Far Data is missing } BSSsect = 3 NearDatasect = 4 xtype(5)=Nextsym %finish %if bsslen>0 %start Psymbol(".nbbss",14,0,BSSsect,1) xtype(zgst)=nextsym %finish %else %start %if fardatalen<=0 %then neardatasect=3 %else neardatasect=4 %finish %if NearDataLen>0 %start Psymbol(".data",6,0,NearDataSect,0) %finish %if FarIOtab=1 %then xtype(8)=FarDataSym %else xtype(8)=nextsym %if FarGla=1 %then xtype(2)=FarDataSym %else xtype(2)=nextsym %finish Symlen = ((NextSym + 1) * intsymsize) + ((NextSDBsym+1)*intsymsize) dictlen=((dictad-dictstart)+3)&(-4) ! Output generated fragments to object file in final order ! ! Fill in the object file header (all sizes in the UTX header are in bytes) %if OBJECT FORMAT=COFF %start HDR == record(addr(buff(0))) HDR = 0 HDR_MAGIC = x'014D' { o'0515' } HDR_NSCNS = 2 { always near and far text } %if FarDataLen > 0 %then HDR_Nscns=HDR_Nscns+1 %if NearDataLen > 0 %then HDR_Nscns=HDR_Nscns+1 %if BSSLen > 0 %then HDR_Nscns=HDR_Nscns+1 HDR_SYMPTR=SYMPTR HDR_NSYMS = nextsym+1 HDR_OPTHDR = 48 { size of opt hdr entry } { Flags: x'200' = Gould byte order } { x'800' = BSD symbols } { x'004' = No Line numbers } %if sdb = 0 %then HDR_FLAGS = x'A04' %c %else HDR_FLAGS = x'A00' {-------- Fill in Optional Header --------------} OH == record(addr(buff(32))) OH = 0 OH_MAGIC = X'00000107' OH_TEXT = TEXTLEN OH_DATA = DATALEN OH_BSS = BSSLEN OH_SYMS = SYMLEN OH_STSIZE = DICTlen OH_ENTRY = MAINENTRYPOINT OH_TXBASE = 0 !OH_DTBASE = 0 OH_MSTAMP = x'4E503100' { NP1 } OH_SSTAMP = x'55545800' { UTX } %if system=MPXL %start OH_CSTAMP = x'56330000' { V3 } %finishelsestart OH_CSTAMP = x'6e703100' { np1 } %finish {-------- Fill in Section Headers --------------} at = 32 + 48 sh == record(addr(buff(at))) sh = 0 name = ".text" Cstring(name,addr(sh)) !sh_paddr = 0 !sh_vaddr = 0 sh_size = NearTextlen sh_scnptr = NeartextPtr sh_relptr = NearTextRelPtr !sh_lnnoptr = 0 sh_nreloc = ntrct !sh_nlnno = 0 sh_flags = STYPtext sh_align = 16 at = at + 48 sh == record(addr(buff(at))) sh = 0 name = ".nbtext" Cstring(name,addr(sh)) !sh_paddr = 0 !sh_vaddr = 0 sh_size = farTextlen sh_scnptr = FartextPtr sh_relptr = FarTextRelPtr !sh_lnnoptr = 0 sh_nreloc = ftrct !sh_nlnno = 0 sh_flags = STYPtext ! STYPFAR sh_align = 16 at = at +48 %if FarDataLen > 0 %start sh == record(addr(buff(at))) sh = 0 name = ".nbdata" Cstring(name,addr(sh)) !sh_paddr = 0 !sh_vaddr = 0 sh_size = FarDatalen sh_scnptr = FardataPtr sh_relptr = FarDataRelptr !sh_lnnoptr = 0 sh_nreloc = fdrct !sh_nlnno = 0 sh_flags = STYPdata ! STYPFAR sh_align = 16 at = at +48 %finish %if BSSlen >0 %start sh == record(addr(buff(at))) sh = 0 name = ".nbbss" Cstring(name,addr(sh)) !sh_paddr = 0 !sh_vaddr = 0 sh_size = BSSlen !sh_scnptr = 0 !sh_relptr = !sh_lnnoptr = 0 !sh_nreloc = !sh_nlnno = 0 sh_flags = STYPbss ! StypFar sh_align = 16 at = at +48 %finish %if NearDatalen > 0 %start sh == record(addr(buff(at))) sh = 0 name = ".data" Cstring(name,addr(sh)) !sh_paddr = 0 !sh_vaddr = 0 sh_size = NearDatalen sh_scnptr = NeardataPtr sh_relptr = NearDataRelPtr !sh_lnnoptr = 0 sh_nreloc = ndrct !sh_nlnno = 0 sh_flags = STYPdata sh_align = 16 at = at +48 %finish FWRITE(0,OBJID,ADDR(buff(0)),at) %finishelsestart { Gould BSD } HDR = 0 HDR_MAGIC = X'00000107' HDR_TEXT = TEXTLEN ;! Total size of Text Area HDR_DATA = DATALEN HDR_BSS = BSSLEN HDR_SYMS = SYMLEN HDR_ENTRY = MAINENTRYPOINT HDR_TRSIZE = 8 * Ntrels HDR_DRSIZE = 8 * Ndrels HDR_STSIZE = DICTAD - DICTSTART HDR_NBTEXT = FarTextlen HDR_NBDATA = Fardatalen HDR_NBBSS = BSSLEN ;! Size of Far BSS %if SYSTEM#NPL %start HDR_ASVERS=x'56330000' %finishelsestart HDR_ASVERS = x'6e703100' %finish FWRITE(0,OBJID,ADDR(HDR),76) %finish ! RELOCATIONS SYMBOL TABLES FREE(ADDR(SYMS(0))) DICTIONARY %if host = ICL2900 %or host = IBM %start EMASclose ;! Tidy up file header (EMAS only) %Finish %END ! %EXTERNALROUTINE M MONON MON = 1 %END ! %EXTERNALROUTINE M MONOFF MON = 0 %END ! %EXTERNALROUTINE M TRACEON %END ! %EXTERNALROUTINE M TRACEOFF %END ! %externalroutine Mcodesize(%integer bytes) %integer ad ad = get space(bytes+1028) areas(code)_base = ad areas(code)_max = bytes+1028 codebase = ad areas(code)_type = code %end %ENDOFFILE