!!******************************************
!! *
!! OMF CONVERTER : ERCC TYPE OBJECT *
!! FILE INTO ICL TYPE OBJECT FILE. *
!! *
!!******************************************
!! *
!! PRODUCES A SQ FILE OF MAX RECORD SIZE 4K.
!! THIS IS HANDLED VIA RECMAN ON B OR VIA BATAPE
!! INTO MEF B ARCHIVE TAPE FORMAT OR VIA KTAPE
!! INTO 'K' COPY OUT TAPE FORMAT.
!! ( THIS WORK IS BASED ON SID 425)
!!
! COMPILE PARM (NOCHECK) OR (OPT)
!!
!! THIS PROGRAM SHOULD RUN ON EMAS 2900, VME/B OR VME/K.
!! THERE ARE STATEMENTS CONDITIONAL ON OPERATING SYSTEM
!! AND SECTIONS OF CODE WHICH COULD BE OMITTED IN
!! SPECIFIC VERSIONS IF SPACE BECOMES CRITICAL.
!!
!! ON EMAS THIS PROGRAM IS LINKED WITH AN INTERFACE
!! 'OMFINTY' WHICH SETS UP FILES AND PARAMETERS.
!! THE LINKED FILE IS CALLED OPUTY AND THE ENTRY IS
!! OPUT
!!
!!
!!
!!
!!*****************************************************
!! *
!! OPTIONS FOR NROBJ ARE HELD IN C26 AS BITS. *
!! THEY ARE SET BY CALLING THE ROUTINE OMF PARM, *
!! OR BY THE SUBSYSTEM. *
!! *
!! BIT 0 - STACK AREA MODE *
!! BIT 1 - " " *
!! BIT 2 - CODE SYMBOL TABLES AREA MODE *
!! BIT 3 - " " *
!! BIT 4 - GLA AREA MODE *
!! BIT 5 - " " *
!! BIT 6 - CODE AREA MODE *
!! BIT 7 - " " *
!! BIT 8 - AREA MODES SET(OTHERWISE IGNORE 0-7) *
!! BIT 9 - 26 FREE *
!! BIT 27 - DUMP TEMPORARY MODULE/LIBRARY *
!! BIT 28 - INHIBIT CASCADE LOADING *
!! BIT 29 - MAXKEYS *
!! BIT 30 - FIXUPS (GIVE LIST OF RELOCATIONS *
!! BIT 31 - MAP (GIVE NAME MAP OF OBJECT) *
!! *
!!*****************************************************
!!
SYSTEMINTEGERFN NROBJ(INTEGER OP SYS, FILE CURRENCY, C
STRING (63) FILE NAME, C
INTEGERNAME EPDRDR0, EPDRDR1, OMFDRDR0, OMFDRDR1)
!!
!! OP SYS = 0 - EMAS
!! OP SYS = 1 - SYSTEM B
!! OP SYS = 2 - SYSTEM K
!!
!!
!! EPDRDR0 USED TO SPECIFY FATE OF OBJECT FILE
!!
!! EPDRDR0 = 0 - SEND OBJECT TO FILE STORE (COMPILE ONLY)
!! EPDRDR0 = 1 - STORE OBJECT IN VIRTUAL MEMORY (COMPILE AND RUN)
!! EPDRDR0 = 2 - STORE OBJECT IN BOTH FILE AND VM.
!!
!! EPDRDR1 USED TO SPECIFY TREATMENT OF NAMES
!!
!! EPDRDR1 = -1 - SUPPRESS NAMES NOT IN FILE NLIST.
!! EPDRDR1 = -2 - SET NLIST NAMES TO BUILD STRENGTH
!! EPDRDR1 = -3 - SUPPRESS NLIST NAMES.
!! EPDRDR1 = -4 - SET NO KEYS
!! EPDRDR1 = -5 - FIND KEYS IN NLIST.
!! EPDRDR1 = -6 - ALL NAMES TO BE KEYED.
!!
!! IF A TEMPORARY MODULE IS TO BE GENERATED IN VIRTUAL STORE
!! THEN TWO DESCRIPTORS ARE RETURNED TO SPECIFY WHERE THE PARTS
!! OF THE MODULE ARE. THESE WILL BE PASSED TO RECORD TEMPORARY MODULE.
!! EPDRDR0 AND EPDRDR1 CONTAIN A DESCRIPTOR DESCRIPTOR TO THE KEYS OF THE
!! MODULE AND OMFDRDR0 AND OMFDRDR1 CONAINS A DESCRIPTOR DESCRIPTOR
!! TO THE DATA AREAS OF THE MODULE.
!!
!!
!! THE FOLLOWING FIVE WORK FILES/AREAS MAY BE REQUIRED
!! IN ADDITION TO SS#WRK.
!!
!! SS#NWRK1 - TEMPORARY DR'S
!! SS#NWRK2 - TEMPORARY OMF MODULE
!! SS#NWRK3 - CONTINUATION OF TEMPORARY MODULE
!! SS#NWRK4 - LIST OF ENTRIES(NLIST) FOR SPECIAL TREATMENT
!! SS#NWRK5 - LAYOUT OF INITIALISED COMMON AREAS
!!
!! ON VME/K 512K FILES ARE NOT ALLOWED SO SS#WRK IS SPLIT
!! INTO TWO 256K FILES - SS#WRK AND SS#WRK2.
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! SYSTEM ROUTINES !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
SYSTEMROUTINESPEC ETOI(INTEGER AD, L)
SYSTEMROUTINESPEC REMOVE AREA(STRING (17) S)
SYSTEMROUTINESPEC ITOE(INTEGER AD, L)
SYSTEMROUTINESPEC MOVE(INTEGER LEN, FROMAD, TOAD)
SYSTEMROUTINESPEC SSMESSA(INTEGER N, STRING (32) MESSS)
SYSTEMROUTINESPEC SSMESS(INTEGER N)
SYSTEMROUTINESPEC SSERR(INTEGER N)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER N)
SYSTEMROUTINESPEC PHEX(INTEGER N)
SYSTEMROUTINESPEC DATIME(STRINGNAME DATE, TIME)
SYSTEMINTEGERFNSPEC ADDSYNONYM(INTEGER A, B, C)
SYSTEMINTEGERFNSPEC READJSVAR(STRING (32) NAME, C
INTEGER OPTION, RADDR)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! OUTPUT IO ROUTINES !!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
SYSTEMINTEGERFNSPEC OPEN FILE( C
INTEGER FILE CURR, ACCESS TYPE, BUFFAD, BUFFLEN, C
RECSIZE AD, ACCESS DR AD)
SYSTEMINTEGERFNSPEC CLOSE FILE(INTEGER ROUTECCY, ADRECCCY)
SYSTEMINTEGERFNSPEC FILEOP( C
INTEGER ACCESS DR AD, ACCESS TYPE, OPTYPE, BUFFAD, C
BUFFLEN, DISP)
! K ONLY
SYSTEMINTEGERFNSPEC FAST FILE OP(INTEGER ACCESS DR AD)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! SUBSYSTEM FILE HANDLING AND FILE DESCRIPTOR RECORD !!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
SYSTEMROUTINESPEC OUTFILE(STRING (15) S, C
INTEGER LENGTH, MAXBYTES, PROTECTION, C
INTEGERNAME CONAD, J)
SYSTEMINTEGERFNSPEC SET CONTENT LIMIT(STRING (32) S, C
INTEGER SIZE)
SYSTEMROUTINESPEC CONNECT(STRING (15) S, C
INTEGER ACCESS, MAXBYTES, PROTECTION, C
RECORDNAME R, INTEGERNAME J)
RECORDFORMAT INRFM(INTEGER CONAD, FILESIZE, C
BYTEINTEGER DUM1, DUM2, DUM3, DUM4, C
STRING (6) DUM5, INTEGER TYPEDUM6, C
INTEGER DATASTART, DATAEND, DUM7)
RECORD IN(INRFM)
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! INTERNAL ROUTINES !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
ROUTINESPEC OUTRECORD(INTEGER IIN, FROM, TO, NEXT)
ROUTINESPEC FIXUP(INTEGER AREACODE, TYPE, BASECODE, AREADISP, C
BASEDISP)
ROUTINESPEC PLACE RELOCATION IMFORMATION( C
INTEGER H, B, AREAIIN, RECORDARRAYNAME F, C
STRING (5) AREA)
ROUTINESPEC BLOCKOUT(INTEGER IIN, FROM, TO)
INTEGERFNSPEC FINDDXREF(STRING (31) IDEN)
ROUTINESPEC EXTRA NAME ENTRY(INTEGER OFFSET, C
STRING (32) S, INTEGER L)
ROUTINESPEC AREA MAP ENTRY(INTEGER LENGTH, IIN, C
STRING (32) S)
INTEGERFNSPEC CLAIM(STRING (32) S, C
INTEGER ID, STARTSIZE, MAXSIZE, INC, INTEGERNAME CONAD)
INTEGERFNSPEC CHECKSUPPRESS(STRINGNAME S)
ROUTINESPEC CHECKBUILD(STRINGNAME S)
INTEGERFNSPEC CHSIZE(INTEGER ID, EXTRA)
ROUTINESPEC READLINE(STRING (17) NAME S)
ROUTINESPEC CHKENTRY(STRING (40) S INTEGER CHS,A)
ROUTINESPEC SET SYNONYM(STRING (32) S)
ROUTINESPEC DUMP(INTEGER START, LEN)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! ERCC LOADER DATA RECORD FORMATS !!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
RECORDFORMAT RFM(INTEGER AREALOC, BASELOC)
RECORDFORMAT DEPFM(INTEGER LINK, DISP, L, A, C
STRING (31) IDEN)
RECORDFORMAT EPFM(INTEGER LINK, LOC, STRING (31) IDEN)
RECORDFORMAT EXTRFFM(INTEGER LINK, REFLOC, STRING (31) IDEN)
RECORDFORMAT DEXTRFM(INTEGER LINK, REFARRAY, L, C
STRING (31) IDEN)
RECORDFORMAT DREFFM(INTEGER N, INTEGERARRAY REFLOC(1 : 1000))
RECORDFORMAT INITFM(INTEGER LINK, A, DISP, LEN, REP, ADDR)
RECORDNAME DREF(DREFFM)
RECORDNAME INIT(INITFM)
RECORDNAME EP(EPFM); ! LIST1 ENTRY POINTS
RECORDNAME DEP(DEPFM); ! LIST4 DATA ENTRY POINT
RECORDNAME LER, ER(EXTRFFM); ! LIST7 EXT REF LIST
RECORDNAME DTREF(DEXTRFM); ! LIST9 DATA REF LIST
RECORDNAME RRB(RFM); ! LIST 14 RELOCATION REQUEST BLOCK
RECORDFORMAT ATTR(INTEGER START, L, PROP)
RECORDARRAYFORMAT AAFM(1 : 7)(ATTR)
RECORDARRAYNAME AA(ATTR)
INTEGERARRAYNAME LISTHEAD; ! LDATA HEADER BLOCK
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! CONSTANTS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!!
!! ERROR CODES GENERATED BY THIS PROGRAM
!!
CONSTINTEGER CORRUPT OBJECT FILE = 226
CONSTINTEGER OMF FILE NOT AVAILABLE = 246
CONSTINTEGER OMF WORKFILE FAILS = 241
CONSTINTEGER CORRUPT FIXUP = 243
CONSTINTEGER TOO MANY CHS = 244
CONSTINTEGER OMF WORKFILE FULL = 248
!!
!!
CONSTINTEGER EMAS = 0, VMEB = 1, VMEK = 2
!!
!! VALUES FOR STRENGTH PARAMETER
!!
CONSTINTEGER NOKEYS=-4
CONSTINTEGER BUILD=-2
CONSTINTEGER KEY=-5
!!
!! EMAS AREA NUMBERS
!!
CONSTINTEGER CODE = 1, GLA = 2, UST = 5, SST = 4, COM = 6, C
STACK = 7
CONSTINTEGER MAXKEYS = 4, LIBRARY = 16;! MASKS TO COMREG 26
CONSTSTRING (6) ICLPREFIX = 'ICL9CE'
CONSTSTRING (6) ARRAY TYPS(0 : 3) = C
'MODULE','AREA ','ENTRY ','XREF '
!!
! SUBNAMES - IMP,FORG,IMP,IMP,ALGE,IMP,PASC
!!
CONSTINTEGERARRAY LSUB(1 : 7) = C
X'C9D4D740',X'C6D6D9C7',X'C9D4D740',X'C9D4D740',
X'C1D3C7C5',X'C9D4D740',X'D7C1E2C3'
CONSTBYTEINTEGERARRAY C(0 : 15) = C
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
CONSTINTEGER B2K = X'800'
CONSTINTEGER B4K = X'1000'
CONSTINTEGER B8K = X'2000'
CONSTINTEGER B16K = X'4000'
CONSTINTEGER B32K = X'8000'
CONSTINTEGER B64K = X'10000'
CONSTINTEGER B128K = X'20000'
CONSTINTEGER B192K = X'30000'
CONSTINTEGER B256K = X'40000'
CONSTINTEGER B512K = X'80000'
CONSTINTEGER EXCL = 1
! EBCIDIC TRANSLATION - LANGUAGE CODES FOR ICL
!! ALL UNDEFINED LANGUAGES FORCED TO FORTE
CONSTBYTEINTEGERARRAY EMASLF(1 : 7) = C
C
X'D3',X'C7',X'D3',X'C7',X'D3',X'D3',X'D7'
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! OMF ENTRY RECORD FORMATS !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
RECORDFORMAT FIXED PART FM( C
BYTEINTEGER TYPE, PROPERTIES, DUM1, ENTRY SIZE, DUM2, C
IIN, NAME USE, STRING (32) NAME)
RECORDNAME FP(FIXED PART FM)
RECORDFORMAT MAP MODULE ENTRY FM( C
BYTEINTEGER TYPE, LANGUAGE, DUM1, ENTRY SIZE, C
INTEGER CHAIN, VERSION, THE, DATE, AND, D2, C
BYTEINTEGER DUM3, TIME, NAME USE, STRING (32) NAME)
RECORDNAME ME(MAP MODULE ENTRY FM)
RECORDFORMAT AEFM(BYTEINTEGER TYPE, PROPERTIES, ESIZE0, C
ESIZE1, INTEGER AREA CHAIN, DISPLACEMENT, C
BYTEINTEGER SIZE0, SIZE1, SIZE2, IIN0, IIN1, IIN2, C
NAME USE, STRING (32) NAME)
RECORDFORMAT XNEFM(BYTEINTEGER TYPE, REASONS, ESIZE0, ESIZE1, C
INTEGER CHAIN, OFFSET, C
BYTEINTEGER SPARE1, SPARE2, NAME USE, STRING (32) NAME)
RECORDFORMAT ACEFM(BYTEINTEGER TYPE, SPARE1, IIN0, IIN1, C
INTEGER AREA CHAIN)
RECORDNAME AE(AEFM)
RECORDNAME XNE(XNEFM)
RECORDNAME ACE(ACEFM)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! INTERNAL FORMATS AND MAPPINGS !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
STRING (32) ARRAYFORMAT EFM(-1 : 10000)
STRINGARRAYNAME ENTRIES; ! SCREENING LIST OF CODE ENTRIES
INTEGERARRAYNAME PR; ! PROPERTIES RECORD
INTEGERARRAYNAME D; ! DIAGNOSTIC RECORD
INTEGERARRAYNAME XREFIIN
INTEGERARRAYFORMAT IFM(0 : 1000000)
RECORDFORMAT FFM(BYTEINTEGER TYPE, C
INTEGER BASECODE, AREADISP, BASEDISP)
RECORDARRAYFORMAT FAFM(1 : X'4000'+2)(FFM)
RECORDFORMAT PDEFM(BYTEINTEGER RECORD, DISP0, DISP1)
RECORDARRAYFORMAT PDEAFM(1 : 10000)(PDEFM)
RECORDARRAYNAME PDE(PDEFM)
RECORDARRAYNAME GLF, STF(FFM); ! FOR STORING RELOCATION INFORMATION
BYTEINTEGERARRAYFORMAT BFM(0 : 4095)
BYTEINTEGERARRAYNAME B
INTEGERARRAYNAME EPDR, OMFDR, OMFAREAS
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! VARIABLES !!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
STRING (40) S
STRING (32) REST, SM, SC
STRING (32) CELIBPREFIX; ! PREFIX TO ECS LIBRARY
STRING (32) ICLMRTLPREFIX; ! PREFIX TO ICL MATHS. ROUTINE LIBRARY
INTEGER CELIBFLAG, ICLMRTFLAG; ! FLAGS TO SAY IF LIB PREFIXES NEEDED
INTEGER LASTUIIN; ! LAST UNSHARED AREA IIN
INTEGER NENTRIES, LASTIIN, ENTRY START, CONAD, GLASIZE
INTEGER ATMPOB; ! START ADDRESS OF 'SS#TMPOB' THE EMAS TYPE OBJECT FILE
INTEGER ASSWRK; ! START ADDRESS OF 'SS#WRK' WORK FILE
INTEGER K, XREF, LXREF
INTEGER I, J, L, IIN, LINK, LASTLINK, LASTTYPE1IIN
INTEGER GLFP, STFP; ! POINTERS INTO FIXUP ARRAY
INTEGER C26; ! TAKE COMREG(26) HERE
INTEGER DP, PRP; ! INCREMENTING POINTERS TO DIAGNOSTIC AND PROPERTIES RECORDS
INTEGER OMFID
INTEGER NDRECS
INTEGER LCL; ! LENGTH OFLARGEST COMMON
BYTEINTEGERNAME LARGEST TYPE 1 IIN
INTEGER ACCESS DR, DR2, DR3, DR4; ! INDIRECT ACCESS DR FOR OUTPUT
INTEGER FOURK; ! INDIRECT RECSIZE FOR OUTPUT
INTEGER SYNDRDR, SYNDRADDR, SYNDR, SYNADDR; ! SYNONYM REF/REF BYTE
BYTEINTEGERARRAY BUFF(0 : 4095); ! OUTPUT BUFFER
INTEGER CBASE
STRING (8) DATE, TIME
BYTEINTEGER LF, B1, B2, B3, ELF
INTEGER ENTRYSIZE, TYPE, ACES, COFFSET
INTEGER STRENGTH; ! HOLDS EPDRDR1 TO SPECIFY TREATMENT OF NAMES
INTEGER RTMON; ! FLAG CONTROLLING GENERATION OF VM MODULE
INTEGER OMFDRPTR
INTEGER LASTBLOCKLEN
INTEGER OMFAREA, FIRSTTIME
INTEGER EPPTR, OMFPTR
INTEGERARRAY INCS(0 : 12); ! SIZES TO INCREMENT AREAS BY
INTEGERARRAY MAXS(0 : 12); ! MAXIMUM PERMITTED AREA SIZES
INTEGERARRAY CSIZE(0 : 12); ! CURRENT SIZE OF AREAS
INTEGERARRAY ACTSIZE(0 : 12); ! SPACE USED IN AREAS
STRING (8) ARRAY AREAS(0 : 12); ! NAMES GIVEN TO WORK AREAS
STRING (8) OMFS
INTEGER MAXPRSPACE, MAXFIXSPACE, MAXDSPACE, SEG, MAXPDESPACE
INTEGER TEMPOBSPACE, TEMPOMFSPACE, TEMPEPDRSPACE, TEMPOMFDRSPACE
INTEGER ATMPMOD
!!
!!
!!
!################################
!# #
!# BEGIN HERE #
!# #
!################################
! INITIALISATION OF VARIABLES
B == ARRAY(ADDR(BUFF(0)),BFM)
RTMON = EPDRDR0
STRENGTH = EPDRDR1
EPPTR = 0
FIRSTTIME = 0
OMFAREA = 2
OMFPTR = 0
GLFP = 1
STFP = 1
DP = 1
PRP = 1
SYNDRDR = X'30000001'; ! SET UP LONG WORD DRDR FOR SYNONYM
SYNDRADDR = ADDR(SYNDR)
LASTBLOCKLEN = 0
FOURK = 4096
CBASE = 0
OMFS = 'SS#NWRK2'
OMFID = 7
NDRECS = 0
!!
!!
!! ASSIGN DEFAULT MAIN ENTRY POINT NAME
IF FILENAME = '' THEN FILENAME = 'ICL9CEMAIN'
C26 = COMREG(26); ! OPTIONS BIT MAP IN THIS COMREG
!!
!#########################################
! CONNECT INPUT FILE - EMAS TYPE OBJECT FILE
!!
CONNECT('SS#TMPOB',3,0,0,IN,J)
OUT1:
IF J # 0 THEN SSMESSA(J," SS#TMPOB") AND RESULT = 1
TEMPOBSPACE = INTEGER(IN_CONAD)
IF TEMPOBSPACE <= 32 OR INTEGER(IN_CONAD+12) # 1 C
THEN J = CORRUPT OBJECT FILE AND -> OUT1
!!
ATMPOB = IN_CONAD
LISTHEAD == ARRAY(INTEGER(ATMPOB+24)+ATMPOB,IFM)
! MAP ONTO LDATA LISTHEADS
LISTHEAD(0) = 0
!!
J = INTEGER(ATMPOB+28)+ATMPOB; ! ADDRESS OF ATRIBUTES TABLE
AA == ARRAY(J+4,AAFM)
IF LISTHEAD(13) # 0 START ; ! INITIALISATION OF DATA
OUTFILE("SS#NWRK5",AA(COM)_L,0,0,IN_CONAD,J)
IF J # 0 THEN SSMESS(J) C
AND SSMESSA(OMF WORKFILE FAILS," SS#NWRK5") C
AND RESULT = 1
I = TEMPOBSPACE-AA(COM)_START
IF AA(COM)_L < I THEN I = AA(COM)_L
MOVE(I,AA(COM)_START+ATMPOB,IN_CONAD)
AA(COM)_START = IN_CONAD-ATMPOB
FINISH
NENTRIES = INTEGER(J); ! NUMBER OF AREAS IN ATTRIBUTES MAP
!! SET START ADDRESSES ABSOLUTE - NON STANDARD USE
UNTIL NENTRIES = 0 THEN AA(NENTRIES)_START = AA(NENTRIES)_ C
START+ATMPOB AND NENTRIES = NENTRIES-1
!!
!!#########################################
!! SORT OUT WORK SPACE
!!
!! CONNECT MAIN WORK FILE
!!
IF OPSYS = VMEK THEN I = B256K ELSE I = B512K
OUTFILE('SS#WRK',I,0,0,ASSWRK,J)
IF J = 218 THEN ASSWRK = COMREG(14) AND J = 0
! FUDGE FOR NR EMAS
IF J # 0 THEN SSMESS(J) C
AND SSMESSA(OMF WORKFILE FAILS," SS#WRK") AND RESULT = 1
!!
J = LISTHEAD(2)
IF J = 0 THEN J = 400
!!
! NUMBER OF ENTRIES AND XREFS + MODULE ENTRY + AREA ENTRIES(4)
! COMMON AREA ENTRIES COUNTED AS DATA ENTRIES
!! ALIGNED TO PAGE BOUNDARIES
MAXPRSPACE = ((J*84)+80+160+1023)>>10<<10
! EXTRA NAME ENTRIES + MODULE ENTRY + 4 AREA ENTRIES + AREA CHAINS
MAXDSPACE = ((J*52)+88+244+(J*8)+40+1023)>>10<<10
MAXFIXSPACE = ((J*16)+(LISTHEAD(3)*16)+1023)>>10<<10
MAXPDESPACE = ((J*4)+1023)>>10<<10
I = LISTHEAD(2)*4+32
XREFIIN == ARRAY(ASSWRK+32,IFM)
!!
!!
PR == ARRAY(ASSWRK+I,IFM)
CONAD = ASSWRK+MAXPRSPACE
IF MAXPRSPACE+MAXDSPACE > B256K THEN -> FIXALLOC
D == ARRAY(CONAD,IFM)
CONAD = CONAD+MAXDSPACE
PDE == ARRAY(CONAD,PDEAFM)
CONAD = CONAD+MAXPDESPACE
!!
!!
CYCLE I = GLA,5,STACK
IF AA(I)_L > 0 START
SEG = CONAD>>14
IF (CONAD+MAXFIXSPACE)>>14 # SEG START
IF OPSYS = VMEK OR ASSWRK>>14 # SEG C
THEN -> FIXALLOC ELSE CONAD = ASSWRK+B256K
FINISH
IF I = 2 THEN GLF == ARRAY(CONAD,FAFM) C
ELSE STF == ARRAY(CONAD,FAFM)
CONAD = CONAD+MAXFIXSPACE
FINISH
REPEAT
!!
!!
I = CONAD-ASSWRK
IF I < B512K AND OPSYS # VMEK START
J = SET CONTENT LIMIT('SS#WRK',I)
IF J # 0 THEN SSMESSA(J,'SS#WRK FOR OMF')
FINISH
!!
!!
-> RNDFIX
FIXALLOC:
D == ARRAY(ASSWRK+B128K,IFM)
MAXPRSPACE = B128K
PDE == ARRAY(ASSWRK+B192K,PDEAFM)
MAXPDESPACE = B64K
IF OPSYS = VMEK START ; ! CLAIM SECOND 256K WORKFILE
OUTFILE("SS#WRK2",B256K,B256K,0,J,J)
IF J # 0 THEN SSMESS(J) C
AND SSMESSA(OMF WORKFILE FAILS,"SS#WRK2") C
AND RESULT = 1
FINISH ELSE J = ASSWRK+B256K
GLF == ARRAY(J,FAFM)
MAXFIXSPACE = B128K
STF == ARRAY(J+B128K,FAFM)
RNDFIX:
!!
!!
IF RTMON > 0 START
TEMPOMFSPACE = MAXPRSPACE+MAXDSPACE+TEMPOBSPACE
! CLAIM MAX THEN RESET DOWNWARDS, SO MAX AVAILABLE IN NEXT INCARNATION
IF OPSYS = VMEK THEN I = B256K ELSE I = B512K
J = CLAIM('SS#NWRK2',2,B32K,I,B32K,ATMPMOD)
OMFAREAS == ARRAY(ATMPMOD,IFM)
IF TEMPOMFSPACE > B512K THEN TEMPOMFSPACE = B512K C
ELSE START
J = SET CONTENT LIMIT('SS#NWRK2',TEMPOMFSPACE)
IF J # 0 THEN SSMESSA(J,'SS#NWRK2')
FINISH
TEMPEPDRSPACE = ((LISTHEAD(2)*8)+1023)>>10<<10
IF LISTHEAD(2) <= 0 THEN TEMPEPDRSPACE = B8K
TEMPOMFDRSPACE = ((((TEMPOBSPACE//4096)*2)+B2K)+1023)>>10<<10
I = TEMPEPDRSPACE+TEMPOMFDRSPACE
J = CLAIM('SS#NWRK1',1,B16K,B256K,B8K,EPDRDR1)
EPDR == ARRAY(EPDRDR1,IFM)
OMFDRDR1 = EPDRDR1+TEMPEPDRSPACE
OMFDR == ARRAY(OMFDRDR1,IFM)
OMFDRPTR = 0
J = SET CONTENT LIMIT('SS#NWRK1',I)
IF J # 0 THEN SSMESSA(J,'SS#NWRK1')
FINISH
!!
IF STRENGTH # 0 AND STRENGTH # -4 AND STRENGTH # -6 START
! READ IN NLIST IF ANY
I = CLAIM('SS#NWRK4',4,B4K,B256K,B4K,CONAD)
RESULT = 1 IF I # 0
ENTRIES == ARRAY(CONAD,EFM); ! MAP ARRAY ONTO WORK FILE
S = ''
WHILE S # '***END***' THEN READLINE(S) C
AND ENTRIES(NENTRIES) = S AND NENTRIES = NENTRIES+1
FINISH
!!
!!
!!
INTEGER(ASSWRK) = 0
! SEE IF LIBRARY NAMES FOR PREFIXING ARE AVAILABLE
!! USE START OF WORK FILE AS BUFFER TO READ THEM IN FROM JOB SPACE VARS.
CELIBFLAG = READJSVAR('ICL9CEPREFIX',2,ASSWRK)
CELIBPREFIX = STRING(ASSWRK)
ICLMRTFLAG = READJSVAR('ICL9CEMRTPREFIX',2,ASSWRK)
ICLMRTLPREFIX = STRING(ASSWRK)
!!
!##########################################
!***DO PROPERTIES RECORD***
! TYPE 0 MAIN MODULE NAME
!!
IF OPSYS = EMAS THEN SM = ICLPREFIX.FILENAME C
ELSE SM = FILENAME
IIN = -1; ! IIN TO START AT ZERO, AFTER INCREMENTING.
IF C26&16 # 0 THEN FP_PROPERTIES = X'20'; ! INHIBIT CASCADE LOAD
CHKENTRY(SM,30,0)
S = S.'-C'; ! USE SUFFIX TO DENOTE AREAS - C FOR CODE
SM = FP_NAME; ! IN CASE ALTERED BY CHKENTRY
L = L+2; ! NEW LENGTH OF S
PR(PRP) = 1<<24; ! PREPARE SPACE TO RECORD IIN OF LAST AREA
LARGEST TYPE 1 IIN == BYTEINTEGER(ADDR(PR(PRP))+3)
! POINTER BACK TO IT
PRP = PRP+1
!!
IF CELIBFLAG = 0 START ; ! THERE IS A MODULE PREFIX
I = LENGTH(CELIBPREFIX)
PR(PRP) = X'FF000000'!(1<<16)!(I<<8)!((I+3)>>2)
MOVE(I,ADDR(CELIBPREFIX)+1,ADDR(PR(PRP+1)))
ITOE(ADDR(PR(PRP+1)),I)
PRP = PRP+1+((I+3)>>2)
FINISH
! SET DEFAULT AREA MODES TO SPARSE
IF C26&X'800000' = 0 THEN C26 = C26!X'AA000000'
!!
FP_ENTRY SIZE = PRP-1
!!
!!
!************************************************
! TYPE 1 ENTRY FOR CODE
!!
IF AA(CODE)_L > 0 START
ENTRY START = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
FP_IIN = 1
!! THE PROPERTY PURE ALLOWS PUBLIC LOADING WHEN REQD.
FP_PROPERTIES = B'01101000'; ! PURE/EPB/READ
FP_NAME USE = X'40'; ! LOCAL/PERM
FP_NAME = S
SC = S
PRP = PRP+4+(L+3)>>2
PR(PRP-2) = AA(CODE)_L; ! 0 - AREA SIZE
PR(PRP-1) = X'3000000'!((C26&X'03000000')>>6)
IF OPSYS = EMAS THEN PR(PRP-1) = PR(PRP-1)!EXCL
! AREA PROPERTIES
FP_ENTRY SIZE = PRP-ENTRY START
FINISH
!!
!*************************************************
! TYPE 1 ENTRY FOR GLA - INCORPORATING UNSHARED SYMBOL TABLES.
!!
GLASIZE = AA(GLA)_L+AA(UST)_L
IF GLASIZE > 0 START
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
FP_PROPERTIES = B'00011100'; ! WRITE/READ/PLT
FP_IIN = 2
FP_NAME USE = X'40'; ! LOCAL/PERM/NOT SYS/NOT KEY
BYTEINTEGER(ADDR(S)+L) = 'G'; ! G FOR GLA
FP_NAME = S
PRP = PRP+4+((L+3)>>2)
PR(PRP-2) = GLASIZE; ! 0 - AREA SIZE
PR(PRP-1) = X'3000000'!((C26&X'0C000000')>>8)
IF OPSYS = EMAS THEN PR(PRP-1) = PR(PRP-1)!EXCL
! AREA PROPERTIES
FP_ENTRY SIZE = PRP-ENTRYSTART
FINISH
!!
!!
!!***********************************************************:
!!
!! TYPE 1 ENTRY FOR CODE SYMBOL TABLES (SHARED TABLES)
!!
IF AA(SST)_L > 0 START
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
FP_PROPERTIES = B'01001000'; ! PURE:READ
FP_IIN = SST
FP_NAMEUSE = X'40'
BYTEINTEGER(ADDR(S)+L) = 'T'; ! T FOR SHARED TABLES
FP_NAME = S
PRP = PRP+4+((L+3)>>2)
PR(PRP-2) = AA(SST)_L; ! 0 - AREA SIZE
PR(PRP-1) = X'3000000'!((C26&X'30000000')>>10)
IF OPSYS = EMAS THEN PR(PRP-1) = PR(PRP-1)!EXCL
! AREA PROPERTIES
AREA MAP ENTRY(AA(SST)_L,SST,S)
FP_ENTRYSIZE = PRP-ENTRYSTART
FINISH
!!
!********************************************************
! TYPE 1 ENTRY FOR STACK AREA
!!
IF AA(STACK)_L > 0 START
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
FP_PROPERTIES = B'10011011'; ! STACK WRITE READ ALIGN. FOLLWS
FP_IIN = 7
FP_NAME USE = X'40'
BYTEINTEGER(ADDR(S)+L) = 'S'; ! S FOR STACK
FP_NAME = S
PRP = PRP+4+((L+3)>>2)
PR(PRP-2) = AA(STACK)_L; ! 0 - AREA SIZE
PR(PRP-1) = X'3003000'!((C26&X'C0000000')>>12)
! 3 AREA PROPERTIES 2
! SPARSE / ALIGN ON 2**3 WORD
FP_ENTRY SIZE = PRP-ENTRY START
AREA MAP ENTRY(AA(STACK)_L,STACK,S)
FINISH
!!
LASTIIN = FP_IIN; ! KEEP RECORD OF LAST AREA IIN
IIN = 7
BYTEINTEGER(ADDR(S)+L) = 'G'
IF AA(GLA)_L > 0 THEN AREA MAP ENTRY(AA(GLA)_L,GLA,S)
!!
!!
! ACTSIZE(PRAREA) = PRP<<2
!*************************************************
! DATA ENTRY POINTS PROCESS LIST 4
LINK = LISTHEAD(4)+ATMPOB
WHILE LINK > ATMPOB THEN CYCLE
DEP == RECORD(LINK)
IF DEP_A # 6 AND (STRENGTH = -1 OR STRENGTH = -3) START
I = CHECKSUPPRESS(DEP_IDEN)
-> NEXTDENTRY IF I < 0
FINISH
! I = CHSIZE(PRAREA,52)
CHKENTRY(DEP_IDEN,32,0)
PRP = PRP+1
IF DEP_A = 6 START ; ! IF A COMMON
FP_TYPE = 1; ! AREA ENTRY
FP_PROPERTIES = B'00011010'; ! WRITE/READ
! ALIGNED FOUR WORD BOUNDARY
FP_NAME USE = B'11011100'; ! SCOPE/PERM/COMMON/EVERY INIT/UNIQUE COMMON
PR(PRP-1) = DEP_L; ! AREASIZE
LASTIIN = IIN
FINISH ELSE START ; ! DATA ENTRY
FP_TYPE = 2
IF DEP_A = UST THEN J = AA(GLA)_L ELSE J = 0
FP_NAME USE = X'C0'; ! EXTERNAL/PERM/
IF STRENGTH = BUILD THEN CHECKBUILD(DEP_IDEN)
PR(PRP-1) = 128<<24+DEP_DISP+DEP_L+J; ! LAST BYTE OF AREA
PR(PRP) = 129<<24+DEP_DISP+J; ! FIRST BYTE
PR(PRP+1) = X'85000002'; ! 133 - TYPE 1 IIN
IF (OPSYS = 0 OR C26&MAXKEYS # 0) C
AND STRENGTH # NOKEYS THEN SET SYNONYM(DEP_IDEN)
EXTRA NAME ENTRY(DEP_DISP+J,FP_NAME,DEP_L)
PRP = PRP+2
FINISH
DEP_A = DEP_A!IIN<<16; ! REMEMBER GIVEN IIN
!! NON - STANDARD USE OF DEP_A FIELD
FP_ENTRY SIZE = PRP-ENTRYSTART
! ACTSIZE(PRAREA) = ACTSIZE(PRAREA)+(FP_ENTRY SIZE<<2)
NEXTDENTRY:
LINK = DEP_LINK+ATMPOB
REPEAT
!**************************************************
! EXTERNAL DATA ENTRY POINT REFERENCES LIST 9
!!
LINK = LISTHEAD(9)+ATMPOB
WHILE LINK > ATMPOB THEN CYCLE
! I = CHSIZE(PRAREA,44)
DTREF == RECORD(LINK)
DREF == RECORD((DTREF_REFARRAY&X'7FFFFFFF')+ATMPOB)
DEP == RECORD(LISTHEAD(4)+ATMPOB)
WHILE DEP_LINK # 0 AND DEP_IDEN # DTREF_IDEN C
THEN DEP == RECORD(DEP_LINK+ATMPOB)
IF DEP_IDEN # DTREF_IDEN THEN START ;! REF NOT INTERNALLY SATISFIABLE
DREF == RECORD((DTREF_REFARRAY&X'7FFFFFFF')+ATMPOB)
S = DTREF_IDEN
I = FINDDXREF(S)
IF S = 'F#BLCM' THEN S = 'ICL9LFBC'; ! BLANK COMMON
IF I < 0 START ; ! FIRST OCCURRENCE OF THIS EXTERNAL OBJECT
IIN = IIN+1
DREF_N = DREF_N!(IIN<<16); ! REMEMBER IIN
! I = CHSIZE(PRAREA,44)
CHKENTRY(S,32,0)
IF DTREF_REFARRAY>>31 = 1 START ; ! COMMON
FP_TYPE = 1
LASTIIN = IIN
FP_PROPERTIES = B'00011010'
! READ WRITE,ALIGN 4 WORD BOUND
FP_NAME USE = B'11011100'; ! SCOPE/PERM/COMMON/EVERY INIT/UNIQUE COMMON
!! ALIGNMENT ON 4 WORD BOUNDARY
AREA MAP ENTRY(LCL,IIN,S)
FINISH ELSE FP_TYPE = 3
IF DTREF_REFARRAY>>31 = 1 C
THEN PR(PRP) = LCL AND PRP = PRP+1
FP_ENTRYSIZE = PRP-ENTRY START
! ACTSIZE(PRAREA) = ACTSIZE(PRAREA)+(FP_ENTRYSIZE<<2)
I = IIN
FINISH
J = 0; ! BASEDISP
FINISH ELSE START
! INTERNAL REFERENCE
IF DTREF_REFARRAY>>31 = 1 C
THEN I = DEP_A>>16 AND J = 0 C
ELSE I = DEP_A&X'FFFF' AND J = DEP_DISP
FINISH
K = DREF_N&X'FFFF'
WHILE K > 0 THEN CYCLE
FIXUP(DREF_REFLOC(K)>>24,0,I,DREF_REFLOC(K)&X'FFFFFF', C
J)
K = K-1
REPEAT
LINK = DTREF_LINK+ATMPOB
REPEAT
!!
!*************************************************
! PROCESS EXTERNAL REFERENCES IN LIST 7
!!
XREF = 1
LINK = LISTHEAD(7)+ATMPOB
WHILE LINK > ATMPOB THEN CYCLE
ER == RECORD(LINK)
! SEARCH ENTRY LIST
EP == RECORD(LISTHEAD(1)+ATMPOB)
WHILE EP_LINK # 0 AND EP_IDEN # ER_IDEN C
THEN EP == RECORD(EP_LINK+ATMPOB)
IF EP_IDEN # ER_IDEN THEN START ; ! NO SUCH ENTRY
! EXTERNAL REFERENCE
!! SEE IF IT IS THE FIRST OCCURRENCE
LER == RECORD(LISTHEAD(7)+ATMPOB)
LXREF = 1
WHILE LER_LINK # ER_LINK C
AND ER_IDEN # LER_IDEN C
THEN LER == RECORD(LER_LINK+ATMPOB) C
AND LXREF = LXREF+1
IF LER_LINK = ER_LINK START ; ! FIRST OCCCURRENCE
!! DUMP TYPE 3 ENTRY
! I = CHSIZE(PRAREA,76)
!! CTM REFERENCES SHORT CUT THE LIBRARY
!! SEARCH MECHANISM BY HAVING AN IDENTIFYING
!! BIT ACT AS A PREFIX.
S = ER_IDEN
IF S -> ('ICLCTM').REST C
OR S -> ('CTM').REST C
THEN FP_PROPERTIES = X'40' AND S = REST
IF S -> ('ICL9CE').REST AND CELIBFLAG = 0 C
THEN FP_PROPERTIES = X'80'
IF S -> ('ICL9CM').REST AND ICLMRTFLAG = 0 C
THEN FP_PROPERTIES = X'C0' AND S = REST
CHKENTRY(S,32,0)
FP_TYPE = 3
XREFIIN(XREF) = IIN; ! STORE IIN
IF FP_PROPERTIES&X'C0' = X'C0' START
! PREFIX OPTIONAL FIELD
I = LENGTH(ICLMRTLPREFIX)
PR(PRP) = X'FF010000'!(I<<8)!((I+3)>>2)
MOVE(I,ADDR(ICLMRTLPREFIX)+1,ADDR(PR(PRP+1)))
ITOE(ADDR(PR(PRP+1)),I)
PRP = PRP+1+(BYTEINTEGER(ADDR(PR(PRP))+3))
FINISH
FP_ENTRYSIZE = PRP-ENTRYSTART
! ACTSIZE(PRAREA) = ACTSIZE(PRAREA)+(FP_ENTRYSIZE<<2)
FINISH
FIXUP(ER_REFLOC>>24,3,XREFIIN(LXREF),ER_REFLOC& C
X'FFFFFF',0)
FINISH ELSE START
! INTERNAL REFERENCE
!! TO REDUCE THE NUMBER OF DIFFERENT TYPE OF FIXUPS
!! RATHER THAN USE A PARTIAL DESCRIPTOR HERE THE
!! DR HEAD IS FILLED IN EXPLICITLY AS A DESCRIPTOR-
!! DESCRIPTOR AND A SINGLE WORD RELOCATION PREPARED
!! FOR THE DR ADDRESS.
!!
INTEGER((ER_REFLOC&X'FFFFFF')+AA(GLA)_START) = C
X'B1000000'
FIXUP(ER_REFLOC>>24,0,2,(ER_REFLOC&X'FFFFFF')+4,EP_ C
LOC&X'FFFFFF')
FINISH
LINK = ER_LINK+ATMPOB
XREF = XREF+1
REPEAT
IF AA(CODE)_L > 0 THEN AREA MAP ENTRY(AA(CODE)_L,CODE,SC)
!!
!**************************************************
! TYPE 2 ENTRIES - PROCESS LIST 1
!!
LINK = LISTHEAD(1)+ATMPOB
WHILE LINK > ATMPOB THEN CYCLE
EP == RECORD(LINK)
COFFSET = INTEGER(AA((EP_LOC>>24)&X'7F')_START+(EP_LOC& C
X'FFFFFF')+4)
! USED TO ADD EP_CODE TOABOVE EXPRESSION - WHY?
IF (STRENGTH = -1 OR STRENGTH = -3) START
I = CHECKSUPPRESS(EP_IDEN)
-> NEXTENTRY IF I < 0
FINISH
! I = CHSIZE(PRAREA,56)
CHKENTRY(EP_IDEN,32,EP_LOC)
FP_TYPE = 2
!! CHKENTRY SETS I=1 IF IT FINDS ANS# ENTRY
FP_NAME USE = B'11000000'
IF (STRENGTH = -6 OR (OPSYS = EMAS AND I = 1) C
OR C26&MAXKEYS # 0 OR COMREG(27)&X'12000000' # 0 C
OR FP_NAME = FILENAME) AND STRENGTH # NOKEYS C
THEN SET SYNONYM(FP_NAME)
IF STRENGTH = BUILD THEN CHECKBUILD(EP_IDEN)
!! NAME USE = EXTERNAL / PERM / KEYED?
PR(PRP) = 129<<24+COFFSET
! 129 - CODE ENTRY POINT
PR(PRP+1) = X'82000002'; ! 130 - PLT IIN
PR(PRP+2) = 131<<24+(EP_LOC&X'FFFFFF');! PLT DISPLACEMENT
PR(PRP+3) = X'85000001'; ! 133 - TYPE 1 IIN
PRP = PRP+4
FP_ENTRY SIZE = PRP-ENTRYSTART
! ACTSIZE(PRAREA) = ACTSIZE(PRAREA)+(FP_ENTRYSIZE<<2)
NEXTENTRY:
EXTRA NAME ENTRY(COFFSET,FP_NAME,2); ! JUST TO GET NAME REMEMBERED
LINK = EP_LINK+ATMPOB
REPEAT
!!
!!
!!******************************************
!! FINISHED PROPERTIES - TIDY UP
!!
PR(2) = PR(2)!(IIN<<16); ! LARGEST IIN
IF LASTIIN = 4 THEN LASTUIIN = 2 ELSE LASTUIIN = LASTIIN
LARGESTTYPE1IIN = LASTIIN; ! LAST IN NUMERIC ORDER NOT IN OUTPUT ORDER
LASTTYPE1IIN = LASTIIN; ! FIND LAST AREA IN OUTPUT ORDER
IF AA(CODE)_L > 0 THEN LASTTYPE1IIN = 1
IF AA(SST)_L > 0 THEN LASTTYPE1IIN = SST
FP_NAME USE = FP_NAMEUSE!1; ! MARK AS LAST ENTRY IN PROPERTIES RECORD
!!
!!
!**********************************************
! RELOCATION 14
!! JUST RECORD A FIXUP FOR EACH RELOCATION ENTRY IN THE CHD. TABLES
!!
LINK = LISTHEAD(14)+ATMPOB
WHILE LINK > ATMPOB CYCLE ; ! CHN THRU TABLES
J = (INTEGER(LINK+4)-1)<<3
CYCLE I = 0,8,J; ! PROCESS INDIVIDUAL TABLE
RRB == RECORD(LINK+I+8)
FIXUP(RRB_AREALOC>>24,0,RRB_BASELOC>>24,RRB_AREALOC& C
X'FFFFFF',RRB_BASELOC&X'FFFFFF')
REPEAT
LINK = INTEGER(LINK)+ATMPOB
REPEAT
!!
!!
!!###############################################
!! PROCESS INITIALISATION DATA IN LIST 13
!!
LINK = LISTHEAD(13)+ATMPOB
WHILE LINK > ATMPOB THEN CYCLE
INIT == RECORD(LINK)
IF INIT_A = COM START
IF INIT_LEN < 5 START
MOVE(INIT_LEN,ADDR(INIT_ADDR)+(4-INIT_LEN),ADDR(J))
INIT_ADDR = ADDR(J)
FINISH
I = INIT_REP
WHILE I > 0 THEN CYCLE
MOVE(INIT_LEN,INIT_ADDR,AA(INIT_A)_START+INIT_DISP)
I = I-1
REPEAT
FINISH ELSE SSMESSA(1000,"OMF/ NON-COMMON REP INIT")
LINK = INTEGER(LINK)+ATMPOB
REPEAT
!!
!!############################################
!! BEGIN OUTPUTTING OBJECT
UNLESS RTMON = 1 START
IF OPSYS = VMEK THEN I = 11 ELSE I = 6
J = OPEN FILE(FILE CURRENCY,I,ADDR(BUFF(0)),4096,ADDR( C
FOURK),ADDR(ACCESS DR))
IF J # 0 START
SSMESS(J)
SSMESS(OMF FILE NOT AVAILABLE)
RESULT = 1
FINISH
FINISH
!!
!!************************************************
!! BLOCK OUT PROPERTIES RECORD
!! EACH BLOCK MUST CONTAIN A WHOLE
!! NUMBER OF ENTRIES - NO SPANNING!
!!
IF ADDR(PR(PRP)) > ADDR(D(1)) C
THEN PHEX(('P'<<24)!MAXPRSPACE) AND SSMESS(248) C
AND RESULT = 1
LINK = 1
LASTLINK = 1
I = 0
CYCLE ; ! THROUGH PROPERTIES ENTRIES
FP == RECORD(ADDR(PR(LINK)))
IF C26&3 > 0 START ; ! PRINT DETAILS OF PROPERTIES RECORD
WRITE((FP_DUM2<<8)!FP_IIN,1)
SPACE
PRINTSTRING(TYPS(FP_TYPE)." ".FP_NAME)
IF FP_NAME USE&X'10' > 0 THEN PRINTSTRING(' CMN ')
IF FP_NAME USE&2 > 0 THEN PRINTSTRING(' KEY')
NEWLINE
FINISH
ITOE(ADDR(FP_NAME)+1,LENGTH(FP_NAME))
IF I+(FP_ENTRYSIZE<<2) > 4076 START
OUTRECORD(0,ADDR(PR(LASTLINK)),(LINK-LASTLINK)<<2,0)
LASTLINK = LINK
I = 0
FINISH ELSE I = I+(FP_ENTRYSIZE<<2)
EXIT IF FP_NAME USE&1=1
LINK = LINK+FP_ENTRYSIZE
REPEAT
!! PUT OUT LAST INCOMPLETE PROPERTIES RECORD
IF I # 0 THEN OUTRECORD(0,ADDR(PR(LASTLINK)),(((LINK- C
LASTLINK)+FP_ENTRYSIZE)<<2),0)
!!
!!
!*****************************************************
! FIXUPS - AND OUTPUT RELOCATED AREAS
PLACE RELOCATION IMFORMATION(GLFP,AA(GLA)_START,GLA,GLF, C
'GLA')
PLACE RELOCATION IMFORMATION(STFP,AA(STACK)_START,STACK,STF, C
'STACK')
!!***************************
!! OUTPUT THE COMMON BODY AREAS
!!
LINK = LISTHEAD(4)+ATMPOB
WHILE LINK > ATMPOB CYCLE
DEP == RECORD(LINK)
IF DEP_A&15 = 6 THEN BLOCK OUT(DEP_A>>16,AA(COM)_START+ C
DEP_DISP,DEP_L) AND AREA MAP ENTRY(DEP_L,DEP_A>>16, C
DEP_IDEN)
LINK = DEP_LINK+ATMPOB
REPEAT
!!
!! FURTHER BODIES SHARED/PURE
BLOCKOUT(1,AA(CODE)_START,AA(CODE)_L)
BLOCKOUT(4,AA(SST)_START,AA(SST)_L)
!!
!!################################
!!
!! DIAGNOSTIC MAP RECORD - MODULE ENTRY
!!
!!
!! ICL LANGUAGE CODES ARE -
!! COBOL(RCO) = 'D' / FORTRAN(RCO) = 'G'
!! ALGOL(RCO) = 'L' / UNDEFINED = 'X'
!! PASCAL = 'P'
!!
!! EMAS LANGUAGE CODES
!! 1 - IMP
!! 2 - FORTE
!! 3 - IMPS
!! 4 - NASS
!! 5 - ALGOL
!! 6 - OPTIMISED IMP
!! 7 - PASCAL
!!
!! EMAS FILE GLA FIFTH WORD FORMAT IS-
!! BYTE 0 LANGUAGE FLAG
!! BYTE 1 COMPILER VERSION
!! BYTE 2 COMPILER OPTIONS
!! BYTE 3 LANGUAGE DEPENDANT
!!
!!
ME == RECORD(ADDR(D(DP)))
ME = 0
ME_TYPE = 16; ! MODULE ENTRY
LF = BYTEINTEGER(AA(GLA)_START+16); ! LANG BYTE IN EMAS FILE GLA
IF 1 <= LF <= 5 THEN ELF = EMASLF(LF) ELSE ELF = X'C7'
! TRANS OR 'G'
ME_LANGUAGE = ELF
B1 = BYTEINTEGER(AA(GLA)_START+17)
B2 = B1//100
ME_VERSION = X'F0F0F0F0'!(B2<<16)
B1 = B1-(B1//100)
B2 = B1//10
ME_VERSION = ME_VERSION!(B2<<8)
B1 = B1-(B1//10)
ME_VERSION = ME_VERSION!B1
DATIME(DATE,TIME)
S = '19'.DATE.TIME; ! HAVE TO RE-ARRANGE DATE AND TIME TO ICL FORMAT
J = ADDR(S); ! DD/MM/YY -> 19YY/MM/DD
MOVE(2,J+3,ADDR(I))
MOVE(2,J+9,J+3)
MOVE(2,ADDR(I),J+9)
ITOE(J+1,18)
MOVE(18,J+1,ADDR(ME_THE))
BYTEINTEGER(ADDR(ME_D2)) = X'7A'; ! NEED TO PUT IN ':'S EXPLICITLY
BYTEINTEGER(ADDR(ME_D2)+3) = X'7A'
ME_NAME = SM
ITOE(ADDR(ME_NAME)+1,LENGTH(ME_NAME))
J = DP+(32+LENGTH(ME_NAME)+3)>>2
D(J) = X'FF010003'; ! OPTIONAL ENTRY ERROR PROCEDURE NAME
D(J+1) = X'C9C3D3F9'; ! ICL9
D(J+2) = X'C3C5D9D9'; ! CERR
D(J+3) = X'D7D9D6C3'; ! PROC
D(J+4) = X'FF020001'; ! OPTIONAL ENTRY - SUBNAME
UNLESS 1 <= LF <= 7 THEN LF = 4
IF OPSYS = EMAS THEN D(J+5) = X'C5D5E540' C
ELSE D(J+5) = LSUB(LF)
ME_ENTRYSIZE = J+6-DP
ME_CHAIN = -1; ! ONLY ONE MODULE
DP = ME_ENTRYSIZE+DP
!!
!! DO AREA CHAIN ENTRIES
!! - ONE FOR EACH AREA ENTRY
!!
!! ACTSIZE(DIAGAREA) = DP<<2
PRP = 1
ACES = 0
CYCLE ; ! THROUGH THE PROPERTIES RECORD
FP == RECORD(ADDR(PR(PRP)))
IF FP_TYPE = 1 START
! I = CHSIZE(DIAGAREA,8)
ACE == RECORD(ADDR(D(DP)))
ACE = 0
ACES = ACES+1
ACE_TYPE = 19
ACE_IIN0 = FP_DUM2
ACE_IIN1 = FP_IIN
DP = DP+2
FINISH
EXIT IF FP_NAME USE&1 = 1
PRP = PRP+FP_ENTRYSIZE
REPEAT
!!
!! TERMINATOR ENTRY
!!
! I = CHSIZE(DIAGAREA,8)
D(DP) = (32<<24)!ACES; ! TYPE : COUNT OF CHAIN ENTRIES
DP = DP+2
!!
!! OUTPUT THE DIAGNOSTICS
!!
!!
IF ADDR(D(DP)) > ADDR(PDE(1)) C
THEN SSMESSA(OMF WORKFILE FULL,"DIAGNOSTIC AREA") C
AND RESULT = 1
LINK = 1
LASTLINK = 1
NDRECS = 0
I = 0
CYCLE
TYPE = BYTEINTEGER(ADDR(D(LINK)))
IF 16 <= TYPE <= 18 THEN ENTRYSIZE = (D(LINK)&X'FFFF') C
ELSE ENTRYSIZE = 2
IF (I+ENTRYSIZE<<2) > 4076 START
OUTRECORD(0,ADDR(D(LASTLINK)),(LINK-LASTLINK)<<2,0)
NDRECS = NDRECS+1
LASTLINK = LINK
I = 0
FINISH ELSE I = I+(ENTRYSIZE<<2)
IF TYPE = 17 THEN START
AE == RECORD(ADDR(D(LINK)))
IIN = ((AE_IIN1&15)<<8)!AE_IIN2
IF ADDR(PDE(IIN)) > ADDR(PDE(1))+MAXPDESPACE C
THEN SSMESSA(OMF WORKFILE FULL,"DATA ENTRIES") C
AND RESULT = 1
PDE(IIN)_RECORD = NDRECS
J = (LINK<<2)-4
PDE(IIN)_DISP0 = (J>>8)&255
PDE(IIN)_DISP1 = J&255
FINISH
IF TYPE = 19 START
ACE == RECORD(ADDR(D(LINK)))
IIN = (ACE_IIN0<<8)!ACE_IIN1
ACE_AREA CHAIN = ((NDRECS-PDE(IIN)_RECORD)<<12)!(PDE C
(IIN)_DISP0<<8)!PDE(IIN)_DISP1
FINISH
IF TYPE = 32 THEN D(LINK+1) = NDRECS+1 AND EXIT
LINK = LINK+ENTRYSIZE
REPEAT
IF I # 0 THEN OUTRECORD(0,ADDR(D(LASTLINK)),(LINK- C
LASTLINK+ENTRYSIZE)<<2,0)
! REMOVE AREA('SS#TMPOB')
!!
!!
!! SET UP RECORD TEMPORARY MODULE DESCRIPTORS
!!
STRENGTH = EPDRDR1
IF RTMON > 0 START
I = CHSIZE(OMFAREA,4)
! OMFAREAS(OMFPTR-1) = LASTBLOCKLEN
IF EPPTR = 0 THEN EPDRDR0 = -1 AND EPDRDR1 = -1 C
ELSE EPDRDR0 = X'30000000'!(EPPTR>>1)
OMFDRDR0 = X'30000000'!(OMFDRPTR>>1)
IF C26&3 > 0 START
PRINTSTRING('
ENTRY DR ')
PHEX(EPDRDR0)
SPACE
PHEX(EPDRDR1)
IF C26&16 # 0 THEN DUMP(EPDRDR1,EPDRDR0&X'FFFFFF')
PRINTSTRING('
OMF AREAS DR ')
PHEX(OMFDRDR0)
SPACE
PHEX(OMFDRDR1)
NEWLINE
IF C26&16 # 0 THEN DUMP(OMFDRDR1,OMFDRDR0&X'FFFFFF')
FINISH
FINISH
!!
!!
UNLESS RTMON = 1 THEN I = CLOSE FILE(0,ADDR(ACCESS DR))
!!
!**********************************************************
!********* SUBROUTINES *******************************
!***********************************************************
!!
!**************************************************
! THIS ROUTINE TEMPORARILY STORES RELOCATION IMFORMATION IN TWO
! RECORD ARRAYS - ONE FOR THE GLA AND ONE FOR THE STACK.
! THE IMFORMATION IS DERIVED FROM THE LOAD DATA LISTS
! AND WILL BE SORTED AND THEN FIXED UP ,
! BY THE ROUTINE PLACE RELOCATION DATA.
!!
ROUTINE FIXUP(INTEGER AREACODE, TYPE, BASECODE, AREADISP, C
BASEDISP)
RECORDARRAYNAME F(FFM)
INTEGERNAME FP
INTEGER I, J
IF AREACODE=2 THEN F==GLF AND FP==GLFP ELSEC
F==STF AND FP==STFP
! %IF AREACODE=7 %THEN J=6 %ELSE J=2
! I = CHSIZE(J,16)
IF ADDR(F(FP)) > ADDR(F(1))+MAXFIXSPACE C
THEN PHEX(('F'<<24)!MAXFIXSPACE) AND NEWLINES(2) C
AND SSERR(OMF WORKFILE FULL)
IF BASECODE = 5 THEN BASECODE = 2 C
AND BASEDISP = AA(GLA)_L+BASEDISP
MOVE(16,ADDR(TYPE),ADDR(F(FP)_TYPE))
FP = FP+1
END
!!
!**************************************************************
!! RELOCATION INFORMATION IS STORED MAINLY IN CHAINS LINKING
!! THE TARGET WORDS. CHAIN HEADERS AND VALUES TOO LARGE TO
!! BE ACCOMODATED WITHIN THE TARGET WORDS HAVE A RECORD TO
!! THENSELVES FOLLOWING THE BODY RECORD.
!! RELOCATION HAS BEEN REDUCED TO ONLY TWO TYPES TO SIMPLIFY
!! THE PROGRAMMING.
!! COMPLETE DESCRIPTOR REQUESTS - USED FOR CODE XREFS.
!! EXTENDED ADDRESS - SINGLE WORD RELOCATION ON
!! EVERYTHING ELSE.
!!
!! SINCE THE COMPLETE DESCRIPTOR FIXUPS HAVE TWO WORDS IN WHICH TO
!! CODE INFORMATION, THE FIELDS ARE LARGER AND THE CHAIN POINTER IS
!! SUFFICIENTLY LARGE THAT THERE NEED ONLY EVER BE A SINGLE SUCH
!! CHAIN IN ANY BODY RECORD.
!!
!! IN CONTRAST A NUMBER OF EXTENDED ADDRESS CHAINS MAY BE ACTIVE AT ANY
!! TIME. - BEING INTERWOVEN. EACH IS CHARACTERISED BY A
!! PARTICULAR MODIFIER PREFIX - (MODIFIER>>14)
!!
!! THE FIXUPS ARE SORTED IN ORDER OF TARGET WORDS WITHIN THE AREA BODY.
!! THIS ENABLES A MINIMUM OF CHAINS TO BE USED, ALL OF WHICH ARE
!! FORWARD.
!!
!!
ROUTINE PLACE RELOCATION IMFORMATION( C
INTEGER HFP, BASE, AREAIIN, RECORDARRAYNAME F, C
STRING (5) AREA)
INTEGERARRAY LASTEA(0 : 16)
INTEGER A, MOD, B, LASTFRP, NEXT, L, MODPREFIX, I, FRP, C
LASTCDA, LASTEAA, INA, LF
INTEGER TYPE, BASECODE, AREADISP, BASEDISP
INTEGERARRAY FR(1 : 4096)
ROUTINESPEC QKSORT(INTEGER A, B)
OWNINTEGER GRECSIZE = 4076
RECORDSPEC F(FFM)
!!
ROUTINE SPHEX(INTEGER N)
SPACE
PHEX(N)
END
!!
ROUTINE CLEAR
INTEGER I
CYCLE I = 0,1,16
LASTEA(I) = -1
REPEAT
LASTCDA = -1
FRP = 2
END
!!
!!
LF = (C26>>1)&1; ! OUTPUT CONTROL
RETURN IF HFP = 1; ! NO FIXUPS REQUIRED
B = BASE
QKSORT(1,HFP-1)
CLEAR
IF LF = 1 THEN START ; ! PRINT OUT HEADER
NEWLINES(3)
WRITE(HFP-1,1)
PRINTSTRING(' RELOCATIONS TO THE '.AREA)
PRINTSTRING('
BASE BDISP ADISP TFP MOD TARGET WORDS CHD
')
FINISH
FR(1) = X'09000000'!AREAIIN
!!
CYCLE I = 1,1,HFP-1; ! PROCESS RELOCATIONS
MOVE(16,ADDR(F(I)),ADDR(TYPE))
!! PROCESS DATA INTO 4K CHUNKS UNTIL A FIXUP IS ENCOUNTERED
!! - IE. NOT ALL BODY RECORDS WILL BE FOLLOWED BY FIXUP RECORDS.
WHILE BASE+AREADISP >= B+4076 THEN CYCLE
IF FRP > 2 THEN NEXT = 4 ELSE NEXT = 0
! MARK NEXT RECORD FIXUPS
OUTRECORD(AREAIIN,B,GRECSIZE,NEXT)
IF LF = 1 THEN PRINTSTRING('
* ') ELSE SPACE
IF FRP > 2 THEN OUTRECORD(0,ADDR(FR(1)),(FRP-1)<< C
2,0)
CLEAR
B = B+GRECSIZE
GRECSIZE = 4076
REPEAT
LASTFRP = FRP
A = AREADISP+BASE; ! GET ADDRESS OF TARGET WORD
INA = INTEGER(A); ! ORIGINAL CONTENTS OF WORD TO BE RELOCATED
MOD = BASEDISP+INA
!!
IF TYPE = 0 START ; ! EXTENDED ADDRESS
!! - INCLUDES ADDRESS FXS , EXT=0
IF IMOD(INA)>>24 # 0 THEN I = -1 AND LF = 1
! BAD CONTENTS
MODPREFIX = MOD>>14
IF 0 <= MODPREFIX <= 16 C
THEN LASTEAA = LASTEA(MODPREFIX) C
AND LASTEA(MODPREFIX) = A ELSE LASTEAA = -1
IF IMOD(A-LASTEAA)//2 > 31 OR LASTEAA = -1 START
!! NEED NEW CHAIN
FR(FRP) = AREADISP>>2<<12+MODPREFIX<<24>>21
FRP = FRP+1
FINISH ELSE START
!! LINK ON END OF OLD CHAIN
INTEGER(LASTEAA) = INTEGER(LASTEAA)!((IMOD(A- C
LASTEAA)>>2)<<26)
IF LF = 1 THEN SPHEX(INTEGER(LASTEAA))
FINISH
INTEGER(A) = MOD<<18>>6+BASECODE
FINISH
IF TYPE = 3 START ; ! COMPLETE DESCRIPTOR
IF LASTCDA = -1 START ; ! FIRST SUCH - BEGIN CHAIN
FR(FRP) = (AREADISP)>>2<<12+3
FRP = FRP+1
FINISH ELSE START ; ! ADD TO CHAIN
INTEGER(LASTCDA) = (A-LASTCDA)>>2
IF LF = 1 THEN SPHEX(INTEGER(LASTCDA))
FINISH
LASTCDA = A
INTEGER(A+4) = BASECODE
IF A = B+4072 THEN GRECSIZE = 4080; !ALLOW FOR DR ON BOUNDARY
FINISH
IF LF = 1 THEN START
NEWLINE
WRITE(BASECODE,3)
SPHEX(BASEDISP)
SPHEX(AREADISP)
IF LASTFRP = FRP THEN SPACES(9) C
ELSE SPHEX(FR(LASTFRP))
IF TYPE < 2 THEN SPHEX(MOD) ELSE SPACES(9)
SPHEX(INTEGER(A))
IF TYPE < 2 THEN SPACES(10) C
ELSE SPACE AND SPHEX(INTEGER(A+4))
NEWLINES(2) AND SSERR(CORRUPT FIXUP) IF I = -1
FINISH
REPEAT
! BLOCKOUT REMAINDER OF AREA
L = (BASE+AA(AREAIIN)_L)-B
IF AREAIIN = GLA THEN L = L+AA(UST)_L
IF FRP > 2 THEN NEXT = 4 ELSE NEXT = 0
IF L <= 4076 START
!! MARK LAST INITIALISATION RECORD FOR THIS AREA
IF FRP > 2 THEN FR(1) = FR(1)!(3<<16) ELSE NEXT = 3
I = L
FINISH ELSE I = 4076
OUTRECORD(AREAIIN,B,I,NEXT); ! UP TO AND INCLUDEING LAST FIX
!! LAST FIXUP RECORD IF ANY
OUTRECORD(0,ADDR(FR(1)),(FRP-1)<<2,0) IF FRP > 2
IF L > 4076 THEN BLOCKOUT(AREAIIN,B+4076,L-4076)
! BLOCK OUT REMAINING AREA - FREE OF FIXUPS
IF LF = 1 THEN NEWLINE
!!
!!
!*********************************************************
! ROUTINE TO SORT FIXUP TABLE
ROUTINE QKSORT(INTEGER A, B)
INTEGER L, U, E
RECORD EKEEP(FFM)
RETURN IF A >= B
L = A
U = B
E = F(U)_AREADISP
EKEEP = F(U)
-> FIND
UP: L = L+1
-> FOUND IF L = U
FIND: -> UP UNLESS F(L)_AREADISP > E
F(U) = F(L)
DOWN: U = U-1
-> FOUND IF L = U
-> DOWN UNLESS F(U)_AREADISP < E
F(L) = F(U)
-> UP
FOUND: F(U) = EKEEP
QKSORT(A,L-1)
QKSORT(U+1,B)
END
END ; ! OF PLACE RELOCATION IMFORMATION
!!
!!**************************************************
!! WRITE OUT SINGLE RECORD
!!
ROUTINE OUTRECORD(INTEGER IIN, FROM, L, NEXT)
INTEGER I, J, K
!!
!! BODY RECORD (DATA) X'FF0' + 4 BYTE RCW + 3 WORD HEADER
!!
IF (FROM # 0 AND IIN # 0) THEN I = 12 ELSE I = 0
IF RTMON > 0 START
IF FIRSTTIME = 0 THEN FIRSTTIME = 1 ELSE START
K = CHSIZE(OMFAREA,4)
!OMFAREAS(OMFPTR-1)=LASTBLOCKLEN
LASTBLOCKLEN = 0
FINISH
B == ARRAY(ADDR(OMFAREAS(OMFPTR+1)),BFM)
K = CHSIZE(OMFAREA,L+I+4)
FINISH
UNLESS FROM = 0 START
UNLESS IIN = 0 START
! CHECK FOR END OF LAST UNSHAREABLE AREA
IF NEXT = 3 AND IIN = LASTUIIN THEN NEXT = 2
! CHECK FOR VERY LAST INITIALISATION BODY RECORD
IF (NEXT = 3 OR NEXT = 2) C
AND IIN = LASTTYPE1IIN THEN NEXT = 1
B(0) = 8; ! TYPE = BODY RECORD
B(1) = NEXT
B(2) = IIN>>8
B(3) = IIN&255
IF IIN > 7 THEN J = CBASE ELSE J = AA(IIN)_START
INTEGER(ADDR(B(4))) = FROM-J
! DISPLACEMENT
INTEGER(ADDR(B(8))) = L
FINISH
MOVE(L,FROM,ADDR(B(I)))
IF RTMON = 2 THEN MOVE(L+I,ADDR(B(0)),ADDR(BUFF(0)))
FINISH
FOURK = L+I; ! PUT LENGTH IN INDIRECT POSN TOO
IF RTMON > 0 START
OMFAREAS(OMFPTR) = ((FOURK+4)<<16)!LASTBLOCKLEN
LASTBLOCKLEN = FOURK+8
OMFDR(OMFDRPTR) = X'18000000'!(LASTBLOCKLEN)
OMFDR(OMFDRPTR+1) = ADDR(OMFAREAS(OMFPTR))
OMFDRPTR = OMFDRPTR+2
OMFPTR = OMFPTR+((LASTBLOCKLEN+3)>>2)
OMFAREAS(OMFPTR-1) = LASTBLOCKLEN-4
IF C26&16 # 0 OR C26&2 # 0 START
!DUMP RECORD
NEWLINES(2)
PHEX(OMFDR(OMFDRPTR-2))
SPACE
PHEX(OMFDR(OMFDRPTR-1))
NEWLINES(2)
DUMP(OMFDR(OMFDRPTR-1),LASTBLOCKLEN)
FINISH
FINISH
UNLESS RTMON = 1 START
IF OPSYS = VMEK THEN I = FILEOP(ADDR(ACCESSDR),11,2, C
ADDR(BUFF(0)),L+I,0) ELSE I = FASTFILEOP(ADDR( C
ACCESS DR))
IF I # 0 THEN SSMESSA(I,"IN OMF GENERATION") C
AND SSERR(1000)
FINISH
END
!!
!!
!!******************************************************
!! BLOCK THE AREAS OUT TO THE SQFILE IN K CHUNKS
!!
ROUTINE BLOCK OUT(INTEGER IIN, FROM, L)
INTEGER TO
!!
NEWLINE
IF IIN > 7 THEN CBASE = FROM
TO = FROM+L
WHILE TO-FROM > 4080 CYCLE
OUTRECORD(IIN,FROM,4080,0); ! LEAVE 3 WRDS FOR HEADER + 1 ALIGN
FROM = FROM+4080
REPEAT
IF TO-FROM > 0 THEN OUTRECORD(IIN,FROM,TO-FROM,3)
END ; ! OF BLOCK OUT
!!
!!*****************************************************
!! THE LIST OF
!! EXTERNAL DATA REFERENCES IS SEARCHED . IF AN INSTANCE OF
!! THE GIVEN NAME IS FOUND PRIOR IN THE LIST THEN A POSITIVE
!! INDEX IS RETURNED TO IT AND THE DXREF WILL BE MAPPED ONTO THIS FIRST
!! INSTANCE. IF THE NAME IS FOUND TO BE THE FIRST INSTANCE
!! THEN A NEGATIVE RESULT IS RETURNED.
!! MAPPING TOGETHER COMMON DXREFS LIKE THIS REQUIRES YOU TO KNOW THE
!! MAXIMUM LENGTH CLAIMED BY ANY OF THE MULTIPLE DXREFS TO A
!! GIVEN AREA. SO HAVING FOUND THE FIRST INSTANCE OF
!! A COMMON THE REST OF THE LIST IS STILL SEARCHED AND THE MAX.
!! LENGTH RECORDED IN LCL.(LARGEST COMMON LENGTH)
!!
INTEGERFN FINDDXREF(STRING (31) IDEN)
INTEGER XLINK, KEEPI
RECORDNAME DTREF(DEXTRFM)
XLINK = LISTHEAD(9)+ATMPOB
LCL = 0
CYCLE
DTREF == RECORD(XLINK)
IF XLINK = LINK THEN LCL = DTREF_L AND KEEPI = -1
IF DTREF_IDEN = IDEN START
IF LCL = 0 THEN RESULT = INTEGER(DTREF_REFARRAY)>>16
IF DTREF_L > LCL THEN LCL = DTREF_L
FINISH
XLINK = DTREF_LINK+ATMPOB
IF XLINK = ATMPOB THEN RESULT = KEEPI
REPEAT
END
!!
!!
!!************************************************************
!!
!! SUBROUTINES GENERATING DIAGNOSTIC RECORDS
!!
!!
!!********************************
!! EXTRA NAME ENTRIES
!!
ROUTINE EXTRA NAME ENTRY(INTEGER OFFSET, C
STRING (32) S, INTEGER L)
INTEGER ESIZE
!!
ESIZE = 23+LENGTH(S)
! I = CHSIZE(DIAGAREA,ESIZE)
XNE == RECORD(ADDR(D(DP)))
XNE = 0
XNE_TYPE = 18
XNE_REASONS = B'10000000'; ! COMPILED NAME
XNE_OFFSET = OFFSET
! NAME USE = 0 IE. CORRESPONDING TYPE 2 PROPERTIES ENTRY
XNE_NAME = S
ITOE(ADDR(XNE_NAME)+1,LENGTH(S))
XNE_ESIZE1 = ESIZE>>2; ! ENTRYSIZE IN WORDS
XNE_CHAIN = -1; ! SCAN FORWARD FOR MODULE MAP ENTRY
DP = DP+XNE_ESIZE1
D(DP-1) = (1<<24)!L; ! SIZE OF OBJECT
END ; ! OF EXTRA NAME ENTRY
!!
!************************************
!! AREA MAP ENTRY
!!
ROUTINE AREA MAP ENTRY(INTEGER LEN, IIN, STRING (32) S)
!!
INTEGER IINS, COMMON, ESIZE
!!
ESIZE = 23+LENGTH(S)
! I = CHSIZE(DIAGAREA,ESIZE)
AE == RECORD(ADDR(D(DP)))
AE = 0
AE_TYPE = 17
IF IIN = 1 THEN AE_PROPERTIES = 1<<7
! IF THIS CODE AREA ACCESSES STATIC STACK SET BIT
IF IIN = 1 AND AA(STACK)_L > 0 C
THEN AE_PROPERTIES = X'88'
IF OPSYS = EMAS OR C26&LIBRARY # 0 C
THEN AE_PROPERTIES = AE_PROPERTIES!X'20'
! DISP=0
IINS = IIN<<12+IIN
AE_IIN0 = (IINS>>16)&255
AE_IIN1 = (IINS>>8)&255
AE_IIN2 = IINS&255
AE_SIZE0 = (LEN>>16)&X'FF'
AE_SIZE1 = (LEN>>8)&255
AE_SIZE2 = LEN&255
IF IIN > 7 THEN COMMON = 1 ELSE COMMON = 0
AE_NAMEUSE = COMMON<<4
AE_NAME = S
ITOE(ADDR(AE_NAME)+1,LENGTH(S))
AE_ESIZE1 = ESIZE>>2
DP = DP+AE_ESIZE1
AE_AREA CHAIN = -1; ! ONLY AREA IN THIS AREA
END ; ! OF AREA MAP ENTRY
!!
!!
!!****************************************
!! THIS ROUTINE CLAIMS A CORE AREA AS WORK SPACE
!!
INTEGERFN CLAIM(STRING (32) S, C
INTEGER ID, STARTSIZE,MAXSIZE, INC, INTEGERNAME CONAD)
!!
INTEGER FLAG
!!
OUTFILE(S,MAXSIZE,MAXSIZE,0,CONAD,FLAG); ! CLAIM MAX FOR NOW
IF FLAG # 0 THEN SSMESSA(OMF WORKFILE FAILS,S) C
AND SSERR(FLAG)
MAXS(ID) = MAXSIZE
INCS(ID) = INC
CSIZE(ID) = MAXSIZE; ! JUST FOR NOW
ACTSIZE(ID) = 0
AREAS(ID) = S
RESULT = 0
END ; ! OF CLAIM
!!
!!
!!********************************************
!! THIS ROUTINE CHECKS THERE IS SUFFICIENT SPACE
!! REMAINING IN THE CORE WORK AREA , AND OBTAINS MORE
!! UNTIL A MAXIMUM IS REACHED.
!!
INTEGERFN CHSIZE(INTEGER ID, EXTRA)
INTEGER I
!!
RESULT = 0 UNLESS 2 <= ID <= 3; ! JUST FOR NOW
I = ACTSIZE(ID)+EXTRA
! %IF I > CSIZE(ID) %START
! %IF I > MAXS(ID) %START
!%IF 2<=ID<=3 %START
! TEMP OMF AREA - GET ANOTHER
IF ACTSIZE(ID)>>14 # I>>14 START
IF (I>>14)-(ACTSIZE(ID)>>14) > 1 C
THEN PHEX(('T'<<24)!I) AND NEWLINES(2) C
AND SSERR(248) ELSE START
OMFAREAS == ARRAY(ATMPMOD+B256K,IFM)
ACTSIZE(ID) = B256K
RESULT = 0
FINISH
FINISH
! SSERR(248)
! %FINISH %ELSE %START
! %FINISH
! %FINISH
! %UNLESS ID = PRAREA %THENC
ACTSIZE(ID) = ACTSIZE(ID)+EXTRA
RESULT = 0
END ; ! OF CHSIZE
!!
!!***************************************
!! READ STRING FROM NEXT LINE
!!
ROUTINE READLINE(STRING (32) NAME S)
!!
S = ''
WHILE NEXTSYMBOL = NL THEN SKIPSYMBOL
CYCLE
IF NEXTSYMBOL = '''' THEN SKIPSYMBOL
IF NEXTSYMBOL = NL THEN EXIT
! S = S.NEXTITEM
LENGTH(S) = LENGTH(S)+1
BYTEINTEGER(ADDR(S)+LENGTH(S)) = NEXTSYMBOL
SKIPSYMBOL
REPEAT
SKIPSYMBOL
END ; ! OF READLINE
!!
!!
!!
!!*******************************************************************
!! ROUTINE TO PROCESS MODULE, CODE ENTRY AND CODE XREF NAMES INTO PR
!!
ROUTINE CHKENTRY(STRING (40) SS, INTEGER MAXCHS, A)
INTEGER J
IF SS -> ('S#').REST THEN S = ICLPREFIX."Z".REST C
ELSE S = SS
IF STRENGTH = KEY START
I = 1
IF NENTRIES > 0 START
I = 0
CYCLE J = 0,1,NENTRIES
IF S = ENTRIES(J) THEN I = 1 AND EXIT
REPEAT
FINISH
FINISH ELSE START
IF S -> ('ICL9CE').REST THEN I = 1 ELSE I = 0
FINISH
IF A>>31 = 1 AND OPSYS#EMAS THEN S = FILENAME
L = LENGTH(S)
IF L > MAXCHS THEN SSMESSA(TOO MANY CHS,S)
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_NAME = S
PRP = PRP+2+((L+3)>>2)
IIN = IIN+1
FP_DUM2 = IIN>>8
FP_IIN = IIN&255
END
!!
!!
!!*******************************************************************
!! ROUTINE TO CALL ADD LIBRARY FILE SYNONYM OR
!! TOSTORE DESCRIPTOR FOR RECORD TEMPORARY MODULE.
!! - REMEMBER KEYS ARE STORED TWICE
!! - ONCE EXTERNALLY IN LIBRARY FILE DIRECTORY
!! - ONCE INTERNALLY AS BIT IN NAME USE IN PROPERTIES REC.
!!
ROUTINE SET SYNONYM(STRING (32) S)
STRING (32) ISOS
INTEGER I
FP_NAME USE = FP_NAME USE!2
RETURN IF S = FILENAME; ! FILENAME = MAJOR SYNONYM
ISOS = S
SYNDR = X'18000000'!LENGTH(S)
UNLESS RTMON = 1 START ; ! CREATING OMF IN FILESTORE
SYNADDR = ADDR(S)+1
ITOE(SYNADDR,LENGTH(S))
I = ADDSYNONYM(FILE CURRENCY,SYNDRDR,SYNDRADDR)
IF I # 0 THEN NEWLINE AND PRINTSTRING( C
" ADD SYNONYM FAILS FOR - ".ISOS." RC = ") C
AND WRITE(I,1)
FINISH
IF RTMON > 0 START ; ! CREATING TEMPORARY MODULE
EPDR(EPPTR) = SYNDR; ! REMEMBER ADDITIONAL KEYS FOR RTM
EPDR(EPPTR+1) = ADDR(FP_NAME)+1
EPPTR = EPPTR+2
FINISH
END
!*
ROUTINE DUMP(INTEGER START, LEN)
INTEGER I, J, CNT, FINISH, LASTLINE, STAR
CONSTBYTEINTEGERARRAY BPATT(0 : 132) = C
C
10,'*',' '(32),'*',' '(2),'(',' '(8),')',' '(86)
OWNBYTEINTEGERARRAY B(-1 : 132)
INTEGER BP
ROUTINESPEC P(INTEGER AD, K)
NEWLINE
CNT = 32
RETURN IF LEN <= 0
FINISH = START+LEN
START = START&X'FFFFFFFC'
NEWLINE
LASTLINE = 0
STAR = 0
WHILE START < FINISH CYCLE
IF LASTLINE # 0 THEN START
CYCLE I = 0,4,CNT-4
UNLESS INTEGER(START+I) = INTEGER(LASTLINE+I) C
THEN -> NO MATCH
REPEAT
STAR = 1
-> NEXT
FINISH
NO MATCH:
BP = 2
MOVE(132,ADDR(BPATT(0)),ADDR(B(0)))
CYCLE I = 0,1,CNT-1
J = BYTEINTEGER(START+I)
ETOI(ADDR(J)+3,1)
UNLESS 32 <= J <= 95 THEN J = ' '
B(BP) = J
BP = BP+1
REPEAT
P(ADDR(START),38)
IF STAR # 0 THEN B(48) = '*' ELSE B(48) = ' '
STAR = 0
LASTLINE = START
BP = 49
CYCLE I = 0,4,CNT-4
P(START+I,BP)
BP = BP+9
REPEAT
B(-1) = 120
PRINTSTRING(STRING(ADDR(B(-1))))
NEXT: START = START+CNT
REPEAT
RETURN
ROUTINE P(INTEGER AD, K)
INTEGER I, J
CYCLE I = 0,1,3
J = BYTEINTEGER(I+AD)
B(K) = C(J>>4)
B(K+1) = C(J&15)
K = K+2
REPEAT
END ; ! P
END ; ! DUMP
!!
!!
INTEGERFN CHECK SUPPRESS(STRINGNAME IDEN)
INTEGER I
!!
IF NENTRIES > 0 START
! CHECK LIST AGAINST NLIST IF ANY
CYCLE I = 0,1,NENTRIES
I = -1 AND EXIT IF IDEN = ENTRIES(I)
REPEAT
RESULT = -1 IF (I > -1 AND STRENGTH = -1) C
OR (I = -1 AND STRENGTH = -3)
FINISH
RESULT = 0
END ; ! OF CHECK SUPPRESS
!!
ROUTINE CHECK BUILD(STRINGNAME IDEN)
INTEGER J
!!
IF NENTRIES > 0 START
! CHECK LIST AGAINST ENTRIES
CYCLE J = 0,1,NENTRIES
IF IDEN = ENTRIES(J) THEN FP_NAME USE = FP_ C
NAME USE&X'10000000' AND EXIT
! LEAVE ONLY EXTERNAL PROPERTY - IE. AVAILABLE TO
! SATISFY REFERENCES, BUT DISAPPEARING AFTER FIRST COLLECTION.
REPEAT
FINISH
END ; ! OF CHECK BUILD
!!
UNLESS OPSYS = EMAS THEN REMOVEAREA('SS#WRK')
RESULT = 0
END ; ! OF OMF
ENDOFFILE