!!******************************************
!! *
!! OMF CONVERTER : ERCC TYPE OBJECT *
!! FILE INTO ICL TYPE OBJECT FILE. *
!! *
!!******************************************
!! *
!! PRODUCES A SQ FILE OF MAX RECORD SIZE 4K.
!! THIS IS HANDLED VIA THE COMPILER ENVIRONMENT
!! INTERFACE. AND THEN ON EMAS VIA WRITEBTAPE
!! INTO MEF B ARCHIVE TAPE FORMAT OR VIA KTAPE
!! INTO 'K' COPY OUT TAPE FORMAT.
!! ( THIS WORK IS BASED ON SID D425)
!!
!! THIS PROGRAM SHOULD RUN ON EMAS 2900, VME/B OR VME/K.
!!
!!
!!*****************************************************
!! *
!! OPTIONS FOR OMFOUT ARE HELD IN CONTROL 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 - OUTPUT TRACE ON EMAS *
!! BIT 9 - 24 FREE *
!! BIT 25 - EXCLUSIVE *
!! BIT 26 - SHARE=YES (PURE) *
!! BIT 27 - 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 OMFOUT( C
INTEGER OP SYS, ATEMP, AWRK, CONTROL, LANG CODE, ADATE, C
ATIME, STRING (7) SUBNAME, STRING (4) VERSION, C
STRING (32) MODULE NAME, STRING (32) MRTPREFIX, CEPREFIX)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! SYSTEM ROUTINES !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
SYSTEMROUTINESPEC ITOE(INTEGER AD, L)
SYSTEMROUTINESPEC MOVE(INTEGER LEN, FROMAD, TOAD)
SYSTEMROUTINESPEC SSMESSA(INTEGER N, STRING (32) MESSS)
SYSTEMROUTINESPEC PHEX(INTEGER N)
SYSTEMINTEGERFNSPEC SET ALIAS(INTEGER DR0, DR1)
SYSTEMINTEGERFNSPEC OMFRECORD(INTEGER DR0, DR1)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! INTERNAL ROUTINES !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
ROUTINESPEC OUTRECORD(INTEGER IIN, FROM, TO, NEXT)
ROUTINESPEC FIXUP(INTEGER AREACODE, TYPE, BASECODE, AREADISP, C
BASEDISP)
INTEGERFNSPEC OUTPUT RELOCATED AREA( C
INTEGER H, B, AREAIIN, AF)
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)
ROUTINESPEC SETNAME(STRINGNAME S INTEGER A,TYPE)
ROUTINESPEC KEY(STRING (32) S)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! 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 FHEADFMT(INTEGER TSIZE, HSIZE, PSIZE, TYPE, C
DATE, TIME, DISPLDATA, DISPATTR)
RECORDNAME FHEAD(FHEADFMT)
INTEGERARRAYNAME LISTHEAD; ! LDATA HEADER BLOCK
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! CONSTANTS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!!
!! ERROR CODES GENERATED BY THIS PROGRAM
!!
CONSTINTEGER CORRUPT OBJECT FILE = 226
CONSTINTEGER CORRUPT FIXUP = 243
CONSTINTEGER TOO MANY CHS = 244
CONSTINTEGER OMF WORKFILE FULL = 248
!!
CONSTINTEGER EMAS = 0
! %CONSTINTEGER VMEB=1,VMEK=2
!!
!! 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
CONSTINTEGER NOCASCADE = 8, SHARE = 32
CONSTSTRING (6) ICLPREFIX = 'ICL9CE'
CONSTSTRING (6) ARRAY TYPS(0 : 3) = C
C
C
'MODULE','AREA ','ENTRY ','XREF '
!!
CONSTINTEGER B64K = X'10000'
CONSTINTEGER B70K = X'11800'
CONSTINTEGER B128K = X'20000'
CONSTINTEGER BYTEDR = X'18000000'
!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! OMF ENTRY RECORD FORMATS !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
RECORDFORMAT FIXED PART FM( C
BYTEINTEGER TYPE, PROPERTIES, HALFINTEGER ENTRY SIZE, C
IIN, BYTEINTEGER NAME USE, STRING (32) NAME)
RECORDNAME FP(FIXED PART FM)
RECORDFORMAT MAP MODULE ENTRY FM( C
BYTEINTEGER TYPE, LANGUAGE, HALFINTEGER ENTRY SIZE, C
INTEGER CHAIN, VERSION, D1, D2, HALFINTEGER D3, T1, C
T2,T3,T4, BYTEINTEGER NAME USE, STRING (32) NAME)
RECORDNAME ME(MAP MODULE ENTRY FM)
RECORDFORMAT AEFM(BYTEINTEGER TYPE, PROPERTIES, HALFINTEGER C
ESIZE, INTEGER AREA CHAIN, DISPLACEMENT, C
BYTEINTEGER SIZE0, SIZE1, SIZE2, IIN0, IIN1, IIN2, C
NAME USE, STRING (32) NAME)
RECORDFORMAT XNEFM(BYTEINTEGER TYPE, REASONS, HALFINTEGER ESIZE, C
INTEGER CHAIN, OFFSET, C
BYTEINTEGER SPARE1, SPARE2, NAME USE, STRING (32) NAME)
RECORDFORMAT ACEFM(BYTEINTEGER TYPE, SPARE1, HALFINTEGER IIN, C
INTEGER AREA CHAIN)
RECORDNAME AE(AEFM)
RECORDNAME XNE(XNEFM)
RECORDNAME ACE(ACEFM)
RECORDFORMAT MCRFM(BYTEINTEGER TYPE, LASTENTRY, C
HALFINTEGER IIN, INTEGER INC, C
LENCOPS, DISP)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! INTERNAL FORMATS AND MAPPINGS !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
INTEGERARRAYNAME PR; ! PROPERTIES RECORD
INTEGERARRAYNAME D; ! DIAGNOSTIC RECORD
INTEGERARRAYNAME IINTAB
RECORDFORMAT PDEFM(BYTEINTEGER RECORD, HALFINTEGER DISP)
RECORDARRAYFORMAT PDEAFM(1 : 10000)(PDEFM)
RECORDARRAYNAME PDE(PDEFM)
INTEGERARRAYFORMAT IFM(0 : 1000000)
RECORDFORMAT FFM(INTEGER TYPE, C
INTEGER BASECODE, AREADISP, BASEDISP)
RECORDARRAYFORMAT FAFM(1 : 12228)(FFM)
RECORDFORMAT BHEADFM(HALFINTEGER TYPEANDFLAG,IIN, C
INTEGER DISP,LEN)
RECORDNAME BHEAD(BHEADFM)
RECORDFORMAT AREAFM(INTEGER START, L, PROP, FP, AF)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! VARIABLES !!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
STRING (40) S
STRING (32) REST, DS
STRING (32) MODULEPREFIX; ! MODULE ENTRY PREFIX
INTEGER LASTAREA, LASTUAREA
INTEGER MAXAREAIIN; ! LARGEST TYPE 1 IIN
INTEGER ENTRY START, GLASIZE
BYTEINTEGERNAME LARGEST TYPE1IIN; ! STORE MAXAREAIIN HERE AT END.
INTEGER K, XREF, LXREF
INTEGER I, J, L, IIN, LINK, LASTLINK
INTEGER DP, PRP; ! PTRS TO DIAG AND PROPS. RECORDS.
INTEGER NDRECS
INTEGER LCL; ! LENGTH OFLARGEST COMMON
BYTEINTEGERNAME SUFFIX
INTEGER CBASE, ADB, NEXT
INTEGER ENTRYSIZE, TYPE, ACES, COFFSET
INTEGER LASTBLOCKLEN
BYTEINTEGERARRAY B(0 : 4096); ! OUTPUT BUFFER
RECORD MCR(MCRFM); ! MULTIPLE COPY RECORD
INTEGER INLIST13
INTEGER MAXF; ! MAXIMUM FIXUPS PER AREA
INTEGER NAREAS; ! NUMBER OF AREAS IN THE ERCC OBJECT
RECORDARRAY AREA(1 : 9)(AREAFM)
INTEGER EXCL; ! SEPERATE AREAS EXCL=1
INTEGER LIST
!!
!!
!################################
!# #
!# BEGIN HERE #
!# #
!################################
! INITIALISATION OF VARIABLES
INLIST13 = 0
DP = 1
PRP = 1
LASTUAREA = 0
LASTAREA = 0
LASTBLOCKLEN = 0
CBASE = 0
NDRECS = 0
ADB = ADDR(B(0))
BHEAD == RECORD(ADB)
EXCL = (CONTROL&32)>>6
!!
!!
!! ASSIGN DEFAULT MAIN ENTRY POINT NAME
IF MODULENAME = '' THEN MODULENAME = 'ICL9CEMAIN'
!!
!#########################################
!!
FHEAD == RECORD(ATEMP); ! MAP ONTO EMAS OBJECT FILE HEADER
RESULT = CORRUPT OBJECT FILE C
IF FHEAD_TSIZE <= 32 OR FHEAD_TYPE # 1
!!
LISTHEAD == ARRAY(FHEAD_DISPLDATA+ATEMP,IFM)
! MAP ONTO LDATA LISTHEADS
J = FHEAD_DISPATTR+ATEMP; ! ADDRESS OF ATTRIBUTES TABLE
NAREAS = INTEGER(J)
RESULT = CORRUPT OBJECT FILE UNLESS 1 < NAREAS < 10
L = 0
CYCLE I = NAREAS,-1,1
AREA(I) = 0
MOVE(12,J+4+((I-1)*12),ADDR(AREA(I)))
! SET START ADDRESSES ABSOLUTE
AREA(I)_START = AREA(I)_START+ATEMP
IF I = 2 THEN AREA(I)_PROP = 1; ! TEMPORARY
IF I = 7 AND AREA(I)_START > ATEMP THEN AREA(7)_PROP = 1
! TEMP
IF 5 # I # 6 AND AREA(I)_L > 0 C
THEN LASTUAREA = LASTAREA AND LASTAREA = I
IF AREA(I)_PROP&1 = 1 THEN L = L+1; ! COUNT UNSHAREABLE AREAS
REPEAT
IF CONTROL&X'800000' # 0 START
PRINTSTRING("
LAST AREA = ")
WRITE(LASTAREA,1)
NEWLINE
FINISH
!!
!!#########################################
!! SS#WRK IS ALLOCATED THUS
!!
!! 0K -> 64K - PROPERTIES RECORD / THEN PDE ARRAY
!! 64K -> 70K - XREF IIN TABLE
!! 70K -> 128K - DIAGNOSTIC RECORD
!! 128K -> 512K - FIXUPS
!!
!!
!!
!! MAP WORK SPACE ONTO SS#WRK
!!
PR == ARRAY(AWRK,IFM)
D == ARRAY(AWRK+B70K,IFM)
PDE == ARRAY(AWRK,PDEAFM)
IINTAB == ARRAY(AWRK+B64K,IFM)
J = AWRK+B128K
L = (384//L)*1024
CYCLE I = 1,1,NAREAS
IF AREA(I)_PROP&1 = 1 START
AREA(I)_AF = J; ! ADDRESS OF FIXUP SPACE FOR THIS AREA
J = J+L
AREA(I)_FP = 1; ! ARRAY INDEX TO START
FINISH
REPEAT
MAXF = L//16
!!
!!
!##########################################
!***DO PROPERTIES RECORD***
!!
! TYPE 0 MAIN MODULE NAME
!!
! IIN TO START AT ZERO, AFTER INCREMENTING
IIN = -1
SETNAME(MODULENAME,0,0)
IF CONTROL&NOCASCADE # 0 THEN FP_PROPERTIES = X'20'
! INHIBIT CASCADE LOAD
! PREPARE SPACE TO RECORD IIN OF LAST AREA
PR(PRP) = 1<<24
LARGEST TYPE 1 IIN == BYTEINTEGER(ADDR(PR(PRP))+3)
! POINTER BACK TO IT
PRP = PRP+1
!!
MODULEPREFIX = "EMPTY"
I = LENGTH(CEPREFIX)
IF I = 0 THEN MODULEPREFIX = MRTPREFIX C
AND I = LENGTH(MRTPREFIX) ELSE MODULEPREFIX = CEPREFIX
IF I # 0 START ; ! SET A MODULE PREFIX
PR(PRP) = X'FF010000'!(I<<8)!((I+3)>>2)
MOVE(I,ADDR(MODULEPREFIX)+1,ADDR(PR(PRP+1)))
ITOE(ADDR(PR(PRP+1)),I)
PRP = PRP+1+((I+3)>>2)
FINISH
!!
FP_ENTRY SIZE = PRP-1
S = MODULENAME.'-C'; ! USE SUFFIX TO DENOTE AREA
L = LENGTH(S)
SUFFIX == BYTEINTEGER(ADDR(S)+L)
!!
!!
!************************************************
! TYPE 1 ENTRY FOR CODE
!!
IF AREA(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.
IF CONTROL&SHARE # 0 THEN FP_PROPERTIES = B'01101000' C
ELSE FP_PROPERTIES = B'00101000'
! PURE?/EPB/READ
FP_NAME USE = X'40'; ! LOCAL/PERM
FP_NAME = S
PRP = PRP+3+(L+3)>>2
PR(PRP-1) = AREA(CODE)_L; ! 0 - AREA SIZE
! SET AREA PROPERTIES 2 IF REQD TO SHOW MODE OF USE AND EXCLUSIVE
IF CONTROL&X'3000020' # 0 C
THEN PR(PRP) = X'3000000'!((CONTROL&X'03000000')>>6)! C
EXCL AND PRP = PRP+1
FP_ENTRY SIZE = PRP-ENTRY START
FINISH
!!
!*************************************************
! TYPE 1 ENTRY FOR GLA - INCORPORATING UNSHARED SYMBOL TABLES.
!!
GLASIZE = AREA(GLA)_L+AREA(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
SUFFIX = 'G'
FP_NAME = S
PRP = PRP+3+((L+3)>>2)
PR(PRP-1) = GLASIZE; ! 0 - AREA SIZE
IF CONTROL&X'C000020' # 0 C
THEN PR(PRP) = X'3000000'!((CONTROL&X'0C000000')>>8)! C
EXCL AND PRP = PRP+1
FP_ENTRY SIZE = PRP-ENTRYSTART
FINISH
!!
!!
!!***********************************************************:
!!
!! TYPE 1 ENTRY FOR CODE SYMBOL TABLES (SHARED TABLES)
!!
IF AREA(SST)_L > 0 START
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
IF CONTROL&SHARE # 0 THEN FP_PROPERTIES = B'01001000' C
ELSE FP_PROPERTIES = B'00001000'
! PURE?/READ
FP_IIN = SST
FP_NAMEUSE = X'40'
SUFFIX = 'T'
FP_NAME = S
PRP = PRP+3+((L+3)>>2)
PR(PRP-1) = AREA(SST)_L; ! 0 - AREA SIZE
IF CONTROL&X'30000020' # 0 C
THEN PR(PRP) = X'3000000'!((CONTROL&X'30000000')>>10)! C
EXCL AND PRP = PRP+1
AREA MAP ENTRY(AREA(SST)_L,SST,S)
FP_ENTRYSIZE = PRP-ENTRYSTART
FINISH
!!
!********************************************************
! TYPE 1 ENTRY FOR STACK AREA
!!
IF AREA(STACK)_L > 0 START
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_TYPE = 1
FP_PROPERTIES = B'10011001'; ! STACK WRITE
!! READ ALIGN=1(2WRD)
FP_IIN = 7
FP_NAME USE = X'40'
SUFFIX = 'S'
FP_NAME = S
PRP = PRP+3+((L+3)>>2)
PR(PRP-1) = AREA(STACK)_L; ! 0 - AREA SIZE
IF CONTROL&X'C0000000' # 0 START
PR(PRP) = X'3000000'!((CONTROL&X'C0000000')>>12)
PRP = PRP+1
FINISH
FP_ENTRY SIZE = PRP-ENTRY START
AREA MAP ENTRY(AREA(STACK)_L,STACK,S)
FINISH
!!
MAXAREAIIN = FP_IIN; ! BIGGEST TYPE 1 IIN SO FAR
IIN = 9
SUFFIX = 'G'
IF AREA(GLA)_L > 0 THEN AREA MAP ENTRY(GLASIZE,GLA,S)
!!
!!
!*************************************************
! COMMON ENTRY POINTS PROCESS LIST 4
LINK = LISTHEAD(4)+ATEMP
WHILE LINK > ATEMP THEN CYCLE
DEP == RECORD(LINK)
IF DEP_A = 6 OR DEP_A >= 10 START ; ! COMMON
IF DEP_A >= 10 THEN IIN = DEP_A-1
S = DEP_IDEN
SETNAME(S,0,1); ! AREA ENTRY
PRP = PRP+1
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
DEP_A = DEP_A!(IIN<<16); ! REMEMBER GIVEN IIN
!! NON - STANDARD USE OF DEP_A FIELD
FP_ENTRY SIZE = PRP-ENTRYSTART
FINISH
LINK = DEP_LINK+ATEMP
REPEAT
IIN = MAXAREAIIN
IIN = 9 IF IIN < 9
!!
!*************************************************
! DATA ENTRY POINTS PROCESS LIST 4
LINK = LISTHEAD(4)+ATEMP
WHILE LINK > ATEMP THEN CYCLE
DEP == RECORD(LINK)
IF DEP_A < 10 AND DEP_A # 6 START ; ! NOT A COMMON
S = DEP_IDEN
SETNAME(S,0,2)
PRP = PRP+1
IF DEP_A = UST THEN J = AREA(GLA)_L ELSE J = 0
FP_NAME USE = X'C0'; ! EXTERNAL/PERM/
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 CONTROL&MAXKEYS # 0 THEN KEY(DEP_IDEN)
EXTRA NAME ENTRY(DEP_DISP+J,FP_NAME,DEP_L)
PRP = PRP+2
DEP_A = DEP_A!IIN<<16; ! REMEMBER GIVEN IIN
!! NON - STANDARD USE OF DEP_A FIELD
FP_ENTRY SIZE = PRP-ENTRYSTART
FINISH
LINK = DEP_LINK+ATEMP
REPEAT
!**************************************************
! EXTERNAL DATA ENTRY POINT REFERENCES LIST 9
!!
LINK = LISTHEAD(9)+ATEMP
WHILE LINK > ATEMP THEN CYCLE
DTREF == RECORD(LINK)
DREF == RECORD((DTREF_REFARRAY&X'7FFFFFFF')+ATEMP)
IF LISTHEAD(4) > 0 START
DEP == RECORD(LISTHEAD(4)+ATEMP)
WHILE DEP_LINK # 0 AND DEP_IDEN # DTREF_IDEN C
THEN DEP == RECORD(DEP_LINK+ATEMP)
DS = DEP_IDEN
FINISH ELSE DS = ""
IF DS # DTREF_IDEN THEN START ; ! REF NOT INTERNALLY SATISFIABLE
DREF == RECORD((DTREF_REFARRAY&X'7FFFFFFF')+ATEMP)
S = DTREF_IDEN
I = FINDDXREF(S)
IF S = 'F#BLCM' THEN S = 'ICL9LFBC'; ! BLANK COMMON
IF I < 0 START ; ! FIRST OCCURRENCE
IIN = IIN+1
DREF_N = DREF_N!(IIN<<16); ! REMEMBER IIN
IF DTREF_REFARRAY>>31 = 1 START ; ! COMMON
SETNAME(S,0,1); ! AREA ENTRY
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 SETNAME(S,0,3)
IF DTREF_REFARRAY>>31 = 1 C
THEN PR(PRP) = LCL AND PRP = PRP+1
FP_ENTRYSIZE = PRP-ENTRY START
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+ATEMP
REPEAT
!!
!*************************************************
! PROCESS EXTERNAL REFERENCES IN LIST'S 7 AND 8.
!!
XREF = 1
CYCLE LIST = 7,1,8
LINK = LISTHEAD(LIST)+ATEMP
WHILE LINK > ATEMP THEN CYCLE
ER == RECORD(LINK)
! SEARCH ENTRY LIST
IF LISTHEAD(1) > 0 START
EP == RECORD(LISTHEAD(1)+ATEMP)
WHILE EP_LINK # 0 AND EP_IDEN # ER_IDEN C
THEN EP == RECORD(EP_LINK+ATEMP)
DS = EP_IDEN
FINISH ELSE DS = ""
IF DS # ER_IDEN THEN START ; ! NO SUCH ENTRY
! EXTERNAL REFERENCE
!! SEE IF IT IS THE FIRST OCCURRENCE
LER == RECORD(LISTHEAD(7)+ATEMP)
LXREF = 1
WHILE LER_LINK # ER_LINK C
AND ER_IDEN # LER_IDEN C
THEN LER == RECORD(LER_LINK+ATEMP) C
AND LXREF = LXREF+1
IF LER_LINK = ER_LINK START ; ! FIRST OCCCURRENCE
!! DUMP TYPE 3 ENTRY
!! CTM REFERENCES SHORT CUT THE LIBRARY
!! SEARCH MECHANISM BY HAVING AN IDENTIFYING
!! BIT ACT AS A PREFIX.
S = ER_IDEN
IF S -> ("M#").REST THEN S = "ICL9CM".REST
IF S -> ('ICLCTM').REST C
OR S -> ('CTM').REST THEN S = REST
SETNAME(S,0,3)
IF S = REST THEN FP_PROPERTIES = X'40'
IF S -> ('ICL9CE').REST C
AND CEPREFIX # "" THEN FP_PROPERTIES = X'80'
J = LENGTH(MRTPREFIX)
IF S -> ("ICL9CM").REST AND J # 0 START
IF MRTPREFIX = MODULEPREFIX C
THEN FP_PROPERTIES = X'80' C
ELSE FP_PROPERTIES = X'C0'
FINISH
IF IIN > 1530 THEN I = 3 AND -> WORKFILE FULL
IINTAB(XREF) = IIN; ! STORE IIN
IF FP_PROPERTIES&X'C0' = X'C0' START
! PREFIX OPTIONAL FIELD
PR(PRP) = X'FF010000'!(J<<8)!((J+3)>>2)
MOVE(J,ADDR(MRTPREFIX)+1,ADDR(PR(PRP+1)))
ITOE(ADDR(PR(PRP+1)),J)
PRP = PRP+1+(BYTEINTEGER(ADDR(PR(PRP))+3))
FINISH
! DELAY FIXUP IF DYNAMIC REFERENCE
IF LIST = 8 THEN FP_PROPERTIES = FP_ C
PROPERTIES!X'10'
FP_ENTRYSIZE = PRP-ENTRYSTART
FINISH
FIXUP(ER_REFLOC>>24,3,IINTAB(LXREF),ER_REFLOC& C
X'FFFFFF',0)
FINISH ELSE START
! INTERNAL REFERENCE
!! TO REDUCE THE NUMBER OF DIFFERENT TYPES 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')+AREA(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+ATEMP
XREF = XREF+1
REPEAT
REPEAT
IF AREA(CODE)_L > 0 THEN AREA MAP ENTRY(AREA(CODE)_L,CODE, C
MODULENAME."-C")
!!
!**************************************************
! TYPE 2 ENTRIES - PROCESS LIST 1
!!
LINK = LISTHEAD(1)+ATEMP
WHILE LINK > ATEMP THEN CYCLE
EP == RECORD(LINK)
COFFSET = INTEGER(AREA((EP_LOC>>24)&X'7F')_START+(EP_LOC& C
X'FFFFFF')+4)
S = EP_IDEN
SETNAME(S,EP_LOC,2)
!! SETNAME SETS I=1 IF IT FINDS AN S# ENTRY
IF LANGCODE=X'C7' AND EP_LOC>>1=0 THEN FP_NAMEUSE=X'80' ELSEC
FP_NAME USE = B'11000000'
IF (OPSYS = EMAS AND I = 1) OR CONTROL&MAXKEYS # 0 C
OR FP_NAME = MODULENAME THEN KEY(FP_NAME)
! 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
EXTRA NAME ENTRY(COFFSET,FP_NAME,2); ! JUST TO GET NAME REMEMBERED
LINK = EP_LINK+ATEMP
REPEAT
!!
!!
!!******************************************
!! FINISHED PROPERTIES - TIDY UP
!!
PR(2) = PR(2)!(IIN<<16); ! LARGEST IIN
LARGESTTYPE1IIN = MAXAREAIIN; ! LAST IN NUMERIC ORDER
! NOT IN OUTPUT ORDER
FP_NAME USE = FP_NAMEUSE!1; ! LAST ENTRY IN PROPERTIES
!!
!!
!**********************************************
! RELOCATION 14
!! JUST RECORD A FIXUP FOR EACH RELOCATION ENTRY IN THE CHD. TABLES
!!
LINK = LISTHEAD(14)+ATEMP
WHILE LINK > ATEMP 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)+ATEMP
REPEAT
!!
CYCLE I = 1,1,NAREAS
IF AREA(I)_FP > MAXF THEN I = 4 AND -> WORKFILEFULL
REPEAT
!!
!!
!!************************************************
!! BLOCK OUT PROPERTIES RECORD
!! EACH BLOCK MUST CONTAIN A WHOLE
!! NUMBER OF ENTRIES - NO SPANNING!
!!
IF ADDR(PR(PRP)) > AWRK+B64K THEN I = 1 AND -> WORKFILEFULL
LINK = 1
LASTLINK = 1
I = 0
IF CONTROL&3 # 0 THEN PRINTSTRING("
KEY IIN TYPE NAME
")
CYCLE ; ! THROUGH PROPERTIES ENTRIES
FP == RECORD(ADDR(PR(LINK)))
IF CONTROL&3 > 0 START ; ! PRINT DETAILS OF PROPERTIES RECORD
IF FP_NAME USE&2 > 0 THEN PRINTSYMBOL('*') ELSE SPACE
WRITE(FP_IIN,5)
SPACE
PRINTSTRING(TYPS(FP_TYPE)." ".FP_NAME)
IF FP_NAME USE&X'10' > 0 THEN PRINTSTRING(' CMN ')
NEWLINE
FINISH
ITOE(ADDR(FP_NAME)+1,LENGTH(FP_NAME))
IF I+(FP_ENTRYSIZE<<2) > 4076 START
I = OMFRECORD(BYTEDR!((LINK-LASTLINK)<<2),ADDR(PR( C
LASTLINK)))
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 I = OMFRECORD(BYTEDR!((LINK-LASTLINK+FP_ C
ENTRYSIZE)<<2),ADDR(PR(LASTLINK)))
!!
!!
!*****************************************************
!! OUTPUT THE COMMON BODY AREAS
!!
IF AREA(COM)_L > 0 START
LINK = LISTHEAD(4)+ATEMP
WHILE LINK > ATEMP CYCLE
DEP == RECORD(LINK)
CBASE = AREA(COM)_START+DEP_DISP
IF DEP_A&15 = 6 THEN BLOCK OUT(DEP_A>>16,CBASE,DEP_ C
L)
IF DEP_A&15 = 6 OR DEP_A&15 > 9 C
THEN AREA MAP ENTRY(DEP_L,DEP_A>>16,DEP_IDEN)
LINK = DEP_LINK+ATEMP
REPEAT
FINISH
!!
!!
!!**************************************************
!! INITIALISATION RECORDS IN LIST 13
!! EITHER AN AREA IS WHOLLY INITIALISED FROM LIST 13 ENTRIES
!! OR WHOLLY INITIALISED BY AREAS, NBUT NO MIXTURE OF THE TEO IS
!! ACCEPTED.
!!
!!
IF LISTHEAD(13) # 0 START
INLIST13 = 1
!!
!! FIND OUT WHICH RECORD CARRIES LAST INITIALISATION FOR EACH AREA.
!!
LINK = LISTHEAD(13)+ATEMP
WHILE LINK > ATEMP CYCLE
INIT == RECORD(LINK)
IF INIT_A = 5 THEN INIT_A = 2 C
AND INIT_DISP = INIT_DISP+AREA(GLA)_L
IINTAB(INIT_A) = LINK
LINK = INTEGER(LINK)+ATEMP
REPEAT
!!
!! PRODUCE INITIALISATION BODY RECORDS FOLLOWED BY MULTIPLE COPY RECORDS.
!!
LINK = LISTHEAD(13)+ATEMP
WHILE LINK > ATEMP CYCLE
INIT == RECORD(LINK)
CBASE = INIT_ADDR+INIT_DISP
IF INIT_LEN = 1 START
IF LINK = IINTAB(INIT_A) AND INIT_REP = 1 C
THEN NEXT = 3 ELSE NEXT = 0
OUTRECORD(INIT_A,ADDR(INIT_ADDR)+3,INIT_LEN,NEXT)
FINISH ELSE BLOCKOUT(INIT_A,ATEMP+INIT_ADDR,INIT_ C
LEN)
!!
IF INIT_REP > 1 START
MCR_TYPE = 10; ! MULTIPLE COPY RECORD
IF IINTAB(INIT_A) = LINK C
THEN MCR_LASTENTRY = 3 ELSE MCR_LASTENTRY = 0
MCR_IIN = INIT_A
MCR_INC = INIT_LEN; ! MAX 4096
MCR_LENCOPS = (INIT_LEN<<20)!(INIT_REP-1)
MCR_DISP = INIT_DISP
I = OMFRECORD(X'18000010',ADDR(MCR_TYPE))
FINISH
!!
LINK = INTEGER(LINK)+ATEMP
REPEAT
INLIST13 = 0
FINISH
!!*************************************
!!
AREA(GLA)_L = GLASIZE; ! INCLUDE UST NOW
CYCLE I = NAREAS,-1,1
-> NXT IF 5 <= I <= 6
IF AREA(I)_FP > 1 THEN J = OUTPUT RELOCATED AREA(AREA( C
I)_FP,AREA(I)_START,I,AREA(I)_AF) C
ELSE BLOCKOUT(I,AREA(I)_START,AREA(I)_L) AND J = 0
RESULT = J IF J # 0
NXT:
REPEAT
!!
!!################################
!!
!! 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
!!
!!
ME == RECORD(ADDR(D(DP)))
ME = 0
ME_TYPE = 16; ! MODULE ENTRY
ME_LANGUAGE = LANG CODE
MOVE(4,ADDR(VERSION)+1,ADDR(ME_VERSION))
MOVE(10,ADATE,ADDR(ME_D1))
MOVE(8,ATIME,ADDR(ME_T1))
ME_NAME = MODULE NAME
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
I = (LENGTH(SUBNAME)+3)//4
D(J+4) = X'FF020000'!I; !OPTIONAL ENTRY - SUBNAME
MOVE(LENGTH(SUBNAME),ADDR(SUBNAME)+1,ADDR(D(J+5)))
ME_ENTRYSIZE = J+5-DP+I
ME_CHAIN = -1; ! ONLY ONE MODULE
DP = ME_ENTRYSIZE+DP
!!
!! DO AREA CHAIN ENTRIES
!! - ONE FOR EACH AREA ENTRY
!!
PRP = 1
ACES = X'20000000'
CYCLE ; ! THROUGH THE PROPERTIES RECORD
FP == RECORD(ADDR(PR(PRP)))
IF FP_TYPE = 1 START
ACE == RECORD(ADDR(D(DP)))
ACE = 0
ACES = ACES+1
ACE_TYPE = 19
ACE_IIN = FP_IIN
DP = DP+2
FINISH
EXIT IF FP_NAME USE&1 = 1
PRP = PRP+FP_ENTRYSIZE
REPEAT
!!
!! TERMINATOR ENTRY
!!
D(DP) = ACES; ! TYPE : COUNT OF CHAIN ENTRIES
DP = DP+2
!!
!! OUTPUT THE DIAGNOSTICS
!!
!!
IF ADDR(D(DP)) > AWRK+B128K THEN I = 2 AND -> WORKFILEFULL
LINK = 1
LASTLINK = 1
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
I = OMFRECORD(BYTEDR!((LINK-LASTLINK)<<2),ADDR(D( C
LASTLINK)))
NDRECS = NDRECS+1
LASTLINK = LINK
I = 0
FINISH ELSE I = I+(ENTRYSIZE<<2)
IF TYPE = 17 THEN START
AE == RECORD(ADDR(D(LINK))); ! AREA ENTRY
IIN = ((AE_IIN1&15)<<8)!AE_IIN2
PDE(IIN)_RECORD = NDRECS
J = (LINK<<2)-4
PDE(IIN)_DISP = J
FINISH
IF TYPE = 19 START
ACE == RECORD(ADDR(D(LINK)))
ACE_AREA CHAIN = ((NDRECS-PDE(ACE_IIN)_RECORD)<<12)! C
PDE(ACE_IIN)_DISP
FINISH
IF TYPE = 32 THEN D(LINK+1) = NDRECS+1 AND EXIT
LINK = LINK+ENTRYSIZE
REPEAT
IF I # 0 THEN I = OMFRECORD(BYTEDR!((LINK-LASTLINK+ C
ENTRYSIZE)<<2),ADDR(D(LASTLINK)))
!!
!!
!!
!**********************************************************
!********* SUBROUTINES *******************************
!***********************************************************
!!
!**************************************************
! THIS ROUTINE TEMPORARILY STORES RELOCATION IMFORMATION IN
! RECORD ARRAYS -
! THE IMFORMATION IS DERIVED FROM THE LOAD DATA LISTS
! AND WILL BE SORTED AND THEN FIXED UP ,
! BY THE INTEGERFN OUTPUT RELOCATED AREA.
!!
ROUTINE FIXUP(INTEGER AREACODE, TYPE, BASECODE, AREADISP, C
BASEDISP)
RECORDARRAYNAME F(FFM)
F == ARRAY(AREA(AREACODE)_AF,FAFM)
IF AREACODE = UST THEN AREACODE = GLA C
AND AREADISP = AREADISP+AREA(GLA)_L
IF BASECODE = UST THEN BASECODE = GLA C
AND BASEDISP = AREA(GLA)_L+BASEDISP
MOVE(16,ADDR(TYPE),ADDR(F(AREA(AREACODE)_FP)_TYPE))
AREA(AREACODE)_FP = AREA(AREACODE)_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
!! THEMSELVES 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.
!!
!!
INTEGERFN OUTPUT RELOCATED AREA( C
INTEGER HFP, BASE, AREAIIN, AF)
INTEGERARRAY LASTEA(0 : 16)
INTEGER A, MOD, B, LASTFRP, NEXT, L, MODPREFIX, I, FRP, C
LASTCDA, LASTEAREA, INA, LF
INTEGER TYPE, BASECODE, AREADISP, BASEDISP
INTEGERARRAY FR(1 : 4096)
ROUTINESPEC QKSORT(INTEGER A, B)
OWNINTEGER GRECSIZE = 4076
RECORDARRAYNAME 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
!!
!!
F == ARRAY(AF,FAFM)
LF = (CONTROL>>1)&1; ! OUTPUT CONTROL
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')
WRITE(AREAIIN,1)
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(-AREAIIN,ADDR(FR(1)), C
(FRP-1)<<2,(FR(1)&X'FF0000')>>16)
CLEAR
B = B+GRECSIZE
GRECSIZE = 4076
REPEAT
LASTFRP = FRP
A = AREADISP+BASE; ! GET ADDRESS OF TARGET WORD
INA = INTEGER(A); ! ORIGINAL CONTENTS 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 LASTEAREA = LASTEA(MODPREFIX) C
AND LASTEA(MODPREFIX) = A ELSE LASTEAREA = -1
IF IMOD(A-LASTEAREA)//2 > 31 OR LASTEAREA = -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(LASTEAREA) = INTEGER(LASTEAREA)!((IMOD C
(A-LASTEAREA)>>2)<<26)
IF LF = 1 THEN SPHEX(INTEGER(LASTEAREA))
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)=0
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))
RESULT = CORRUPT FIXUP IF I = -1
FINISH
REPEAT
! BLOCKOUT REMAINDER OF AREA
L = (BASE+AREA(AREAIIN)_L)-B
IF FRP > 2 THEN NEXT = 4 ELSE NEXT = 0
IF L <= 4076 START
!! MARK LAST INITIALISATION RECORD FOR THIS AREA
UNLESS AREAIIN = 2 AND AREA(5)_START = ATEMP START
IF FRP > 2 THEN FR(1) = FR(1)!(3<<16) ELSE NEXT = 3
FINISH
I = L
FINISH ELSE I = 4076
OUTRECORD(AREAIIN,B,I,NEXT); ! UP TO AND INCLUDEING LAST FIX
!! LAST FIXUP RECORD IF ANY
OUTRECORD(-AREAIIN,ADDR(FR(1)),(FRP-1)<<2,(FR(1)& C
X'FF0000')>>16) 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
RESULT = 0
!!
!!
!*********************************************************
! 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 OUTPUT RELOCATED AREA
!!
!!**************************************************
!! WRITE OUT SINGLE RECORD
!!
ROUTINE OUTRECORD(INTEGER IIN, FROM, L, NEXT)
INTEGER I, J, LIIN
!!
!! BODY RECORD (DATA) X'FF0' + 4 BYTE RCW + 3 WORD HEADER
!!
! CHECK FOR VERY LAST RECORD
LIIN = IMOD(IIN)
IF NEXT = 3 AND LIIN = LASTAREA THEN NEXT = 1
IF INLIST13 = 1 START ; ! REP INITS. ENDED BY MULT REC?
IF IINTAB(LIIN) # LINK OR INIT_REP > 1 THEN NEXT = 0
FINISH ELSE START
IF NEXT = 3 AND LIIN = LASTUAREA C
AND LASTAREA = CODE THEN NEXT = 2
FINISH
UNLESS IIN < 0 START
I = 12
BHEAD_TYPEANDFLAG = X'800'!NEXT
BHEAD_IIN = IIN
IF IIN > 7 THEN BHEAD_DISP = FROM-CBASE C
ELSE BHEAD_DISP = FROM-AREA(IIN)_START
IF INLIST13 = 1 THEN BHEAD_DISP = INIT_DISP
BHEAD_LEN = L
FINISH ELSE START
I = 0
INTEGER(FROM) = (INTEGER(FROM)&X'FF00FFFF')!(NEXT<<16)
FINISH
MOVE(L,FROM,ADB+I)
I = OMFRECORD(X'18000000'!(L+I),ADB)
END
!!
!!
!!******************************************************
!! BLOCK THE AREAS OUT TO THE SQFILE IN K CHUNKS
!!
ROUTINE BLOCK OUT(INTEGER IIN, FROM, L)
INTEGER TO
!!
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)+ATEMP
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+ATEMP
IF XLINK = ATEMP 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 I
!!
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
I = LENGTH(S)
ITOE(ADDR(XNE_NAME)+1,I)
XNE_ESIZE = (23+I)>>2; ! ENTRYSIZE IN WORDS
XNE_CHAIN = -1; ! SCAN FORWARD FOR MODULE MAP ENTRY
DP = DP+XNE_ESIZE
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, I
!!
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 AREA(STACK)_L > 0 C
THEN AE_PROPERTIES = X'88'
IF CONTROL&LIBRARY # 0 THEN AE_PROPERTIES = AE_ C
PROPERTIES!X'20'
IINS = IIN<<12+IIN
MOVE(3,ADDR(LEN)+1,ADDR(AE_SIZE0))
MOVE(3,ADDR(IINS)+1,ADDR(AE_IIN0))
IF IIN > 9 THEN AE_NAMEUSE = 16;! COMMON
AE_NAME = S
I = LENGTH(S)
ITOE(ADDR(AE_NAME)+1,I)
AE_ESIZE = (23+I)>>2
DP = DP+AE_ESIZE
AE_AREA CHAIN = -1; ! ONLY AREA IN THIS AREA
END ; ! OF AREA MAP ENTRY
!!
!!
!!**************************************************************
!! ROUTINE TO PROCESS NAMES
!!
ROUTINE SETNAME(STRINGNAME S, INTEGER A, TYPE)
STRING (32) REST
INTEGER L, MAXCHS
!!
IF S -> ("S#").REST THEN S = ICLPREFIX."Z".REST
IF S -> ("ICL9CE").REST THEN I = 1 ELSE I = 0
IF A>>31 = 1 AND OPSYS # EMAS THEN S = MODULENAME
L = LENGTH(S)
IF S = MODULENAME THEN MAXCHS = 28 ELSE MAXCHS = 30
IF L > MAXCHS THEN SSMESSA(TOO MANY CHS,S) C
AND LENGTH(S) = MAXCHS
ENTRYSTART = PRP
FP == RECORD(ADDR(PR(PRP)))
FP = 0
FP_NAME = S
PRP = PRP+2+((L+3)>>2)
IIN = IIN+1
FP_IIN = IIN
FP_TYPE = TYPE
IF TYPE = 1 AND IIN > MAXAREAIIN THEN MAXAREAIIN = IIN
END
!!
!!*******************************************************************
!! - KEYS ARE STORED TWICE
!! - ONCE EXTERNALLY IN LIBRARY FILE DIRECTORY
!! - ONCE INTERNALLY AS BIT IN NAME USE IN PROPERTIES REC.
!!
ROUTINE KEY(STRING (32) S)
FP_NAME USE = FP_NAME USE!2
RETURN IF S = MODULENAME; ! MODULENAME = MAJOR SYNONYM
I = SET ALIAS(X'18000000'!LENGTH(S),ADDR(S)+1)
END
!!
!!
RESULT = 0
CONSTSTRING (1) ARRAY FA(1 : 4) = C
C
"P","D","I","F"
WORKFILEFULL:
SSMESSA(OMF WORKFILE FULL,FA(I))
RESULT = 1
END ; ! OF OMF
ENDOFFILE