!LPUT63 language, version and release written to history records.
!LPUT62 correct data init error with minstack
!LPUT61 guarantee that all loaddata is in upper case
!LPUT60 convergence of MOO annotation and MINSTACK processing - again!
! 14/09/83
!LPUT57 converted to IMP80 and removal of variables CODEBASE and CODEMAX
!which apparently did nothing useful. RRM 13/10/82
!LPUT 55 ALLOW AREAS 8 AND 9
!LPUT 53 LENGTH OF STRING 'FILE CHANGED TO 18
CONSTINTEGER EMAS= 1
CONSTINTEGER YES = 1
CONSTINTEGER NO = 0
CONSTINTEGER VME= 0
CONSTINTEGER VERSION=EMAS
IF VERSION=EMAS START
EXTERNALSTRINGFNSPEC UCSTRING(STRING (255) S)
SYSTEMROUTINESPEC NCODE(INTEGER I, J, K)
SYSTEMROUTINESPEC SETFNAME(STRING (63) S)
SYSTEMSTRINGFNSPEC FAILUREMESSAGE(INTEGER MESS)
EXTERNALROUTINESPEC CHANGECONTEXT
SYSTEMROUTINESPEC DUMP(INTEGER A, B)
SYSTEMROUTINESPEC SSERR(INTEGER N)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
SYSTEMROUTINESPEC OUTFILE(STRING (15) S, INTEGER LENGTH, MAXBYTES, C
PROTECTION, INTEGERNAME CONAD, FLAG)
SYSTEMROUTINESPEC MOVE(INTEGER LEN, FROM, TO)
SYSTEMROUTINESPEC FILL(INTEGER LEN, FROM, PATTERN)
FINISH ELSE START
ROUTINE MOVE(INTEGER LENGTH, FROM, TO)
INTEGER I
RETURN IF LENGTH<=0
I = X'18000000'!LENGTH
*LSS_FROM
*LUH_I
*LDTB_I
*LDA_TO
*MV_ L = DR
END ; !OF MOVE
!*
ROUTINE FILL(INTEGER LENGTH, FROM, FILLER)
INTEGER I
RETURN IF LENGTH<=0
I = X'18000000'!LENGTH
*LDTB_I
*LDA_FROM
*LB_FILLER
*MVL_L =DR
END
FINISH
!*
STRING (2)FN ITOS(INTEGER N)
INTEGER SIGN
STRING (2) S
IF N<0 THENSTART
SIGN = 1
N = -N
FINISHELSE SIGN = 0
S = ""
CYCLE
S = TOSTRING((N-(N//10*10))+'0').S
N = N//10
REPEAT UNTIL N=0
IF SIGN#0 THEN S = "-".S
IF LENGTH(S)<2 THEN S = " ".S
RESULT = S
END
!*
ROUTINE DUMP CONSTS(INTEGER START, LENGTH, CA)
ROUTINESPEC PR(INTEGER J)
!*
CONSTBYTEINTEGERARRAY HEX(0:15)= C
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
!*
INTEGER I, J, L
L = 0
WHILE L<LENGTH CYCLE
CYCLE I = 16, -4, 0
PRINTSYMBOL(HEX((CA>>I)&15))
REPEAT
SPACES(6)
PR(INTEGER(START))
NEWLINE
START = START + 4
L = L + 4
CA = CA + 4
REPEAT
RETURN
!
ROUTINE PR(INTEGER J)
INTEGER I
CYCLE I = 28, -4, 0
PRINTSYMBOL(HEX((J>>I)&15))
REPEAT
END ; ! PR
!
END ; ! DUMP CONSTS
!*
CONSTSTRING (11)ARRAY LANGS(0:16) =
" UNNAMED", " IMP", " FORTRAN", " IOPT",
" NASS", " ALGOL", " OPT CODE", " PASCAL",
" SIMULA", " BCPL", " FORTRAN77", " C",
"IMPORTEDOMF", " LINKER", " MODIFY", " PASCAL E",
" DAP"
!*
CONSTSTRING (9)ARRAY MOO(0:15) = C
"","SQRT","LOG","EXP","SIN/COS","SIN/COS","TAN","ATAN",
"","DSQRT","DLOG","DEXP","DSIN/DCOS","DSIN/DCOS","DTAN","DATAN"
!*
SYSTEMROUTINE LPUT(INTEGER TYPE, P1, P2, P3)
RECORDFORMAT RF0(INTEGER TYPE, LA, DATALEN, FILLER)
RECORDFORMAT RF1(INTEGER TYPE, LINK, LOC, STRING (31) NAME)
RECORDFORMAT RF4(INTEGER TYPE, LINK, DISP, L, AREA, STRING (31) NAME)
RECORDFORMAT RF6(INTEGER TYPE, INTEGERARRAY AREALEN(1:7), C
INTEGER TOTLEN)
RECORDFORMAT RF7(INTEGER TYPE, LINK, AREALOC, BASELOC)
RECORDFORMAT RF8(INTEGER TYPE, LINK, CODEADDR, ADDRFIELD)
RECORDFORMAT RF9(INTEGER TYPE, LINK, L, REFLINK, COUNT, STRING (31) NAME)
RECORDFORMAT RF13(INTEGER LINK, A, DISP, LEN, REP, ADDR)
RECORDFORMAT RF27(INTEGER TYPE, LINK, LINE, INF, STRING (32) NAME)
RECORD (RF0) NAME R0
RECORD (RF1) NAME R1
RECORD (RF4) NAME R4
RECORD (RF6) NAME R6
RECORD (RF7) NAME R7
RECORD (RF8) NAME R8
RECORD (RF9) NAME R9
RECORD (RF13) NAME R13
RECORD (RF27) NAME R27
INTEGER I, J, K, L, FLAG
OWNINTEGER TBASE, TON, TMAX, TYPE6, WORKAD, LMAX, WORKMAX
OWNINTEGER FBASE, RECLEN
OWNINTEGER NULLFLAG
OWNINTEGERARRAY HEAD(11:25)
OWNINTEGERARRAY H(0:14)
OWNINTEGERARRAY BASE(1:9)
OWNINTEGERARRAY AREALENGTH(1:9)
OWNINTEGERARRAY AREASTART(1:9)
OWNINTEGERARRAY AREAPROP(1:9)
OWNINTEGER RCOUNT
OWNINTEGER TYPE19NUM
OWNSTRING (17) LANGVERS
OWNSTRING (18) FILE
OWNINTEGER STACKMODE
OWNINTEGER LANGUAGE
OWNINTEGER COMREG57
OWNINTEGER NAMESET
OWNINTEGER NUMEXT
OWNINTEGER NUMFIXUPS
OWNINTEGER PACK5
OWNINTEGER DECODEHEAD, DECODETAIL, PROLOGUE
OWNINTEGER PSEUDOSTACK
INTEGER OBJLEN
INTEGER LDSTART, LDDISP, LAST13
INTEGER CODE OFFSET, CONST OFFSET
STRING (32) PREFIX, CHANGEDNAME, EPNAME, LEFTID, RIGHTID
CONSTBYTEINTEGERARRAY CHANGE(0:49)= C
0(10),1(6),0,1,0(4),1,0,1,0(25)
SWITCH EP(0:49)
SWITCH LSW(0:49)
IF TYPE=0 THEN START
LANGUAGE = P1
STACKMODE = 0
IF VERSION=EMAS THENSTART
IF P1>16 THEN LANGVERS = " ".ITOS(P1) C
ELSE LANGVERS = LANGS(P1)
LANGVERS = LANGVERS." ".ITOS(P2)." ".ITOS(P3)
FILE <- STRING(COMREG(52))
IF FILE=".NULL" THEN START
NULLFLAG = 1
RETURN
FINISH ELSE NULLFLAG = 0
WORKAD = COMREG(14)
FINISH ELSE START
NULLFLAG = NULLOBJ
FBASE = TMPAREA
WORKAD = WRKAREA
FINISH
TBASE = WORKAD+32
TYPE6 = TBASE
TON = TBASE+40; ! RESERVE SPACE FOR TYPE6 RECORD RELATING TO 1ST RTN
WORKMAX = INTEGER(WORKAD+8); !SIZE OF WORK FILE
TMAX = WORKMAX
IF TMAX>X'40000' THEN TMAX = X'40000'
TMAX = WORKAD+TMAX-64
RCOUNT = 0; ! NO OF RELOCATION VALUES
TYPE19NUM = 0; ! NO OF GENERALISED RELOCATION RECORDS
LMAX = 144; ! SIZE OF LDATA+HEAD(16) RECORD
LMAX = LMAX+2048; !TEMPORARY - FAULT IN CALCULATION OF LMAX
CYCLE I = 11, 1, 25
HEAD(I) = 0
REPEAT
CYCLE I = 1, 1, 9
BASE(I) = 0
AREAPROP(I) = 0
REPEAT
COMREG57 = COMREG(57)
NAMESET = 0
NUMEXT = 0
NUMFIXUPS = 0
PACK5 = COMREG(28)&1; ! NON-ZERO ONLY IN CE MODE
DECODEHEAD = 0
DECODETAIL = 0
PROLOGUE = 0
IF COMREG(28)&X'4000'=0 THEN PSEUDOSTACK=NO C
ELSE PSEUDOSTACK=YES
RETURN
FINISH
RETURNUNLESS NULLFLAG=0
IF CHANGE(TYPE)=1 START
CHANGEDNAME = STRING(P3)
CHANGEDNAME=UCSTRING(CHANGEDNAME)
IF CHANGEDNAME->LEFTID.("$").RIGHTID THEN START
CHANGEDNAME = LEFTID."DOLLAR".RIGHTID
FINISH
IF VERSION=EMAS START
IF CHANGEDNAME->PREFIX.("ICL9CM").EPNAME AND PREFIX="" THEN C
CHANGEDNAME = "M#".EPNAME
FINISH
FINISH
->EP(TYPE)
!
ROUTINE CHECKWORK(INTEGER N)
INTEGER J, F
IF TON+N>TMAX THEN START
IF WORKMAX>X'40000' AND WORKMAX-X'40040'>N THEN START
INTEGER(TON) = (WORKAD+X'40000'-TON)!X'19000000'
! TYPE/SIZE OF FILLER RECORD
!THIS MAKES A PSEUDO RECORD TYPE 25 TO BE SKIPPED
TMAX = WORKAD+WORKMAX-64
TON = WORKAD+X'40000'
WORKMAX = 0
FINISH ELSE START
IF VERSION=EMAS START
SELECTOUTPUT(0)
COMREG(24) = 1; !TO GIVE COMPILATION FAULTY MESSAGE
PRINTSTRING("Work file too small")
MONITOR
STOP
FINISH ELSE START
LPUTERROR = 228
NULLFLAG = -1; ! WILL GENERATE FAILURE LATER
TON = TBASE+40; ! AVOID ERROR MEANTIME
FINISH
FINISH
FINISH
END ; ! CHECKWORK
!
EP(37):
IF PSEUDOSTACK=YES THEN TYPE=33 ELSE STACKMODE = 1
EP(30):
EP(31):
EP(32):
EP(33):
EP(34):
EP(35):
EP(36):
EP(38):
EP(39):
EP(1): ! CODE
EP(2): ! GLA
EP(3): ! PLT
EP(4): ! SST
EP(5): ! UST
CHECKWORK(P1+12)
R0 == RECORD(TON)
R0_LA = P2
IF 0<=P3<256 THEN START
I = 20
R0_DATALEN = -P1
R0_FILLER = P3
FINISH ELSE START
I = (P1+15)&X'FFFFFFFC'
R0_DATALEN = P1
MOVE(P1, P3, TON+12)
FINISH
R0_TYPE = TYPE<<24!I; ! TYPE,RECLEN
TON = TON+I
RETURN
EP(47):
IF PSEUDOSTACK=YES THEN TYPE=43
EP(40):
EP(41):
EP(42):
EP(43):
EP(44):
EP(45):
EP(46):
EP(48):
EP(49):
CHECKWORK(P1>>24+16)
R0 == RECORD(TON)
R0_LA = P2
I = (P1>>24+19)&X'FFFFFFFC'
R0_TYPE = TYPE<<24!I; ! TYPE,RECLEN
R0_DATALEN = P1>>24
R0_FILLER = (P1<<8)>>8; ! NO. OF COPIES
MOVE(P1>>24, P3, TON+16)
TON = TON+I
RETURN
EP(24): ! OLD STYLE ENTRY DEFN USED BY LINK
TYPE = 11
P2 = INTEGER(P2+8)
EP(11): ! ENTRY POINT DEFN
IF CHANGEDNAME="S#GO" THEN EPNAME = "ICL9CEMAIN" ELSE C
EPNAME = CHANGEDNAME
IF VERSION=EMAS START
IF COMREG57#0 THEN START
IF EPNAME="ICL9CEMAIN" OR P1>>31#0 THEN START
COMREG(60) = COMREG(60)!2; ! EXISTENCE OF MAIN EP
STRING(COMREG57) = EPNAME
FINISH ELSE START
IF NAMESET=0 THEN STRING(COMREG57) = EPNAME
FINISH
NAMESET = 1
FINISH
FINISH ELSE START ; !VME VERSION
IF EPNAME="ICL9CEMAIN" OR P1>>31#0 START
MAINEPSET = 1
MAINEPNAME = EPNAME
FINISH ELSE START
IF NAMESET=0 THEN MAINEPNAME = EPNAME
FINISH
NAMESET = 1
FINISH
L3: NUMEXT = NUMEXT+1
CHECKWORK(44)
R1 == RECORD(TON)
IF P1&7=0 THEN P1 = P1!2
IF P1<0 THEN P1 = P1!128; ! MAINEP BIT
R1_LOC = P1<<24!(BASE(P1&7)+P2)
LMAX = LMAX+44
R1_NAME <- CHANGEDNAME
I = (LENGTH(R1_NAME)+16)&X'FC'
R1_TYPE = TYPE<<24!I
R1_LINK = HEAD(TYPE)
HEAD(TYPE) = TON
TON = TON+I
RETURN
EP(12): ! EXTERNAL ROUTINE REF
EP(13): ! DYNAMIC ROUTINE REF
EP(22): ! 'DATA OR PROCEDURE' REFERENCE
->L3
EP(10): ! COMMON AREA REFERENCE
EP(15): ! DATA REF
!* P1 = AREA<<24 ! MIN LENGTH
!* P2 = LOC IN AREA OF REF
!* P3 = ADDR(DATA NAME)
!*
CHECKWORK(60); ! ALLOW FOR NEW HEAD + VALUE RECORD
IF PSEUDOSTACK=YES THENSTART
IF P1>>24=7 THEN P1=(P1<<8)>>8!X'03000000'
FINISH
I = HEAD(15)
WHILE I#0 CYCLE
R9 == RECORD(I)
IF R9_NAME=STRING(P3) THEN START
EP15A: R9_COUNT = R9_COUNT+1
INTEGER(TON) = R9_REFLINK
INTEGER(TON+4) = (P1>>24)<<24!(P2+BASE(P1>>24))
R9_REFLINK = TON-WORKAD
TON = TON+8
J = (P1<<8)>>8
IF R9_L<J THEN R9_L = J
LMAX = LMAX+8
RETURN
FINISH
I = R9_LINK
REPEAT
R9 == RECORD(TON)
R9_L = 0
R9_REFLINK = 0
IF TYPE=10 THEN J = X'80000000' ELSE J = 0
R9_COUNT = J
R9_NAME <- STRING(P3)
I = (LENGTH(R9_NAME)+24)&X'FC'
R9_TYPE = 15<<24!I
R9_LINK = HEAD(15)
HEAD(15) = TON
TON = TON+I
LMAX = LMAX+I-12
NUMEXT = NUMEXT+1
->EP15A
!*
EP(14): ! DATA ENTRY IN GLA
K = P1>>24
P1 = P1&X'00FFFFFF'
->A
EP(17): ! DATA ENTRY IN GLA ST
K = 5
TYPE = 14
A: CHECKWORK(52)
NUMEXT = NUMEXT+1
R4 == RECORD(TON)
LMAX = LMAX+52
R4_L = P1
R4_AREA = K
R4_NAME <- CHANGEDNAME
I = (LENGTH(R4_NAME)+28)&X'FC'
R4_TYPE = TYPE<<24!I
R4_LINK = HEAD(TYPE)
HEAD(TYPE) = TON
R4_DISP = BASE(R4_AREA&255)+P2
TON = TON+I
RETURN
EP(18): ! MODIFY 18 BIT ADDRESS FIELD
! P2 @ IN CODE AREA OF 32 BIT INSTRUCTION
! P3 18 BIT VALUE TO BE ADDED TO ADDRESS FIELD
CHECKWORK(16)
R8 == RECORD(TON)
R8_TYPE = (18<<24)!16
R8_LINK = HEAD(18)
HEAD(18) = TON
IF P1=8 THEN P2 = -P2
R8_CODEADDR = P2
R8_ADDRFIELD = P3&X'3FFFF'
TON = TON+16
RETURN
EP(20):
EP(21):
P1 = 2
P3 = TYPE-19
EP(19): ! RELOCATE WORD AT P2 IN AREA P1 BY BASE OF AREA P3
IF PSEUDOSTACK=YES THENSTART
IF P1=7 THEN P1=3
IF P3=7 THEN P3=3
FINISH
NUMFIXUPS = NUMFIXUPS+1
CHECKWORK(16)
R7 == RECORD(TON)
R7_TYPE = (19<<24)!16
R7_LINK = HEAD(19)
HEAD(19) = TON
R7_AREALOC = P1<<24!P2
R7_BASELOC = P3<<24
TON = TON+16
TYPE19NUM = TYPE19NUM+1
LMAX = LMAX+8
AREAPROP(P1) = 1; !FOR AREA PROPERTIES RECORD
RETURN
EP(25): ! OLD STYLE RELOCATION BLOCK(16 BYTES/ENTRY)
P1 = (P1-4)>>1+4
EP(26): ! GENERALISED RELOCATION BLOCK
! P1 NO OF BYTES IN BLOCK
! P3 @ OF BLOCK
CHECKWORK(P1+8)
LMAX = LMAX+P1
R7 == RECORD(TON)
R7_TYPE = 25<<24!(P1+8)
R7_LINK = HEAD(25)
HEAD(25) = TON
IF TYPE=25 THEN START
I = INTEGER(P3)
P3 = P3+4
INTEGER(TON+8) = I
J = TON+12
WHILE I#0 CYCLE
INTEGER(J) = INTEGER(P3)<<24!INTEGER(P3+4)
INTEGER(J+4) = INTEGER(P3+8)<<24!INTEGER(P3+12)
J = J+8
P3 = P3+16
I = I-1
REPEAT
FINISH ELSE MOVE(P1, P3, TON+8)
I = INTEGER(TON+8)
J = TON+12
WHILE I#0 CYCLE
K = INTEGER(J)
INTEGER(J) = K+BASE(K>>24)
K = INTEGER(J+4)
INTEGER(J+4) = K+BASE(K>>24)
J = J+8
I = I-1
REPEAT
TON = TON+P1+8
RETURN
EP(6): ! SUMMARY DATA FOR PREVIOUS ROUTINE
R6 == RECORD(TYPE6)
R6_TYPE = 6<<24!40
MOVE(32, P3, TYPE6+4)
IF STACKMODE=0 THEN START
R6_TOTLEN = R6_AREALEN(6)
R6_AREALEN(6) = 0
R6_AREALEN(7) = 0
FINISH
RCOUNT = 0
CYCLE I = 1, 1, 7
BASE(I) = (BASE(I)+R6_AREALEN(I)+7)&X'FFFFFFF8'
REPEAT
CHECKWORK(40)
TYPE6 = TON
TON = TON+40; ! RESERVE SPACE FOR NEXT DESCRIPTOR
RETURN
!*
EP(27): ! Note code section for decode
!* P1 = -1 prologue
!* -2 epilogue
!* -3 consts
!* -4 fill in prologue
!* >0 line no
!* 2 = len<<18 ! start
!* P3 = addr(prologue name)
!*
IF P1=-4 THEN START ; ! fill in prologue
IF PROLOGUE#0 THEN START
R27 == RECORD(PROLOGUE)
R27_INF = P2
MOVE(32, P3, PROLOGUE+16)
PROLOGUE = 0
FINISH
RETURN
FINISH
!*
CHECKWORK(48)
R27 == RECORD(TON)
IF DECODEHEAD=0 THEN START
DECODEHEAD = TON
FINISH ELSE START
IF P1=-2 THEN START ; ! epilogue may need to overwrite last statement
IF INTEGER(DECODETAIL+12)<<14=P2<<14 THEN START
! overwrite
R27 == RECORD(DECODETAIL)
R27_LINE = -2
R27_INF = P2
RETURN
FINISH
FINISH
INTEGER(DECODETAIL+4) = TON
FINISH
DECODETAIL = TON
!*
IF P1=-1 THEN START ; ! prologue
I = 48; ! allow full string
IF P3=0 THEN START ; ! to be filled in later
PROLOGUE = TON
FINISH ELSE START
MOVE(32, P3, TON+16)
FINISH
FINISH ELSE I = 16
!*
R27_TYPE = 27<<24!I
R27_LINK = 0
R27_LINE = P1
R27_INF = P2
TON = TON+I
RETURN
!*
EP(28): ! produce code listing
!* P1 = PROLOGUE LENGTH
WHILE DECODEHEAD#0 CYCLE
R27 == RECORD(DECODEHEAD)
I = R27_LINE
J = R27_INF>>18; ! length
IF J#0 THEN START ; ! WILL SKIP DUMMY PROLOGUE ENTRY
K = (R27_INF<<14)>>14; ! address
IF I>0 OR I=-2 THEN K = K+P1
NEWLINE
IF I=-3 THEN START
PRINTSTRING("
CONSTANT AREA
")
DUMP CONSTS(FBASE+32+K, J, K)
FINISH ELSE START
IF I=-1 THEN START
PRINTSTRING("PROLOGUE FOR ENTRY ".STRING(DECODEHEAD+16))
FINISH ELSE START
IF I=-2 THEN START
PRINTSTRING("EPILOGUE")
FINISH ELSE START
IF I<-10 THENSTART
PRINTSTRING("CODE FOR ".MOO(-I-10))
FINISHELSESTART
PRINTSTRING("LINE ")
WRITE(I,1)
FINISH
FINISH
FINISH
NEWLINE
NCODE(FBASE+32+K, FBASE+32+K+J, K)
FINISH
FINISH
DECODEHEAD = R27_LINK
REPEAT
RETURN
!*
EP(7): ! END OF FILE
IF VERSION=EMAS START
IF NULLFLAG<0 THEN SSERR(228); !PROGRAM TOO LARGE
FINISH
IF P1>=32 THEN STACKMODE = 1
IF PSEUDOSTACK=YES AND STACKMODE=1 THENSTART
INTEGER(P3+8)=INTEGER(P3+24);! size(3)=size(7)
INTEGER(P3+24)=0;! size(7)=0
FINISH
IF P1=40 THEN START ; ! F77 with prologue insertion
CODE OFFSET = INTEGER(P3+32)
CONST OFFSET = INTEGER(P3+36)
FINISH ELSE START
CODE OFFSET = 0
CONST OFFSET = 0
FINISH
IF TYPE6=TBASE THEN LPUT(6, 32, 0, P3)
R6 == RECORD(TYPE6)
R6_TYPE = 7<<24; ! TO TERMINATE LAYOUT
OBJLEN = LMAX+16
CYCLE I = 1, 1, 7
OBJLEN = OBJLEN+BASE(I)
REPEAT
IF PACK5#0 THEN OBJLEN = OBJLEN-BASE(5)
IF VERSION=EMAS START
OBJLEN = OBJLEN+20; ! FOR LANGUAGE HISTORY RECORD
OUTFILE(FILE, OBJLEN, 0, 0, FBASE, FLAG)
IF FLAG#0 THEN START
COMREG(24) = FLAG; ! To give 'Compilation faulty'
SELECTOUTPUT(0)
SETFNAME(FILE)
PRINTSTRING("Create object file fails - ".FAILUREMESSAGE(FLAG))
COMREG(47) = 0; ! Overwrite 'no of statements' left by compiler
STOP
FINISH
FINISH ELSE START
IF OBJLEN>INTEGER(FBASE+8) THEN START
LPUTERROR = 228
RETURN
FINISH
FINISH
CYCLE I = 1, 1, 7
AREALENGTH(I) = BASE(I)
REPEAT
AREASTART(1) = 32
AREASTART(4) = AREASTART(1)+AREALENGTH(1); ! CST AFTER CODE
AREASTART(3) = AREASTART(4)+AREALENGTH(4); !GLA AFTER PLT
AREASTART(2) = AREASTART(3)+AREALENGTH(3); ! GLA AFTER PLT
IF PACK5#0 THEN START
AREASTART(5) = 0
AREASTART(6) = AREASTART(2)+AREALENGTH(2)
FINISH ELSE START
AREASTART(5) = AREASTART(2)+AREALENGTH(2); ! GLAST AFTER GLA
AREASTART(6) = AREASTART(5)+AREALENGTH(5)
FINISH
AREASTART(7) = AREASTART(6)+AREALENGTH(6)
LDSTART = AREASTART(7)+AREALENGTH(7)
LDSTART = LDSTART+FBASE
INTEGER(FBASE+4) = AREASTART(1); ! START OF CODE
INTEGER(FBASE+12) = 1; ! OBJECT FILE CODE
INTEGER(FBASE+24) = LDSTART-FBASE; ! START OF LDATA
AREASTART(8) = AREASTART(1); ! prologue
AREASTART(9) = AREASTART(1)+CONST OFFSET; ! const area
AREASTART(1) = AREASTART(1)+CODE OFFSET
H(0) = 14
CYCLE I = 1, 1, 14
H(I) = 0
REPEAT
!H(12) = LDSTART-FBASE+68; ! START OF OBJDATA RECORD
TON = TBASE
CYCLE I = 1, 1, 9
BASE(I) = FBASE+AREASTART(I)
REPEAT
LDDISP = 132
LAST13 = ADDR(H(13))
->LSWITCH
LSW(40):
LSW(41):
LSW(42):
LSW(43):
LSW(44):
LSW(45):
LSW(46):
LSW(47):
LSW(48):
LSW(49):
R0 == RECORD(TON)
J = R0_FILLER; ! NO. OF COPIES
L = R0_DATALEN
IF I=40 THEN START
I = R0_LA>>24
R0_LA = R0_LA&X'FFFFFF'
->PACKCMN1
FINISH
IF I=45 AND PACK5#0 THEN START
I = 5
PACKCMN1:
L = LDSTART+LDDISP
INTEGER(LAST13) = L-FBASE; ! CHAIN FORWARD
LAST13 = L
R13 == RECORD(L)
R13_LINK = 0
R13_A = I
R13_DISP = R0_LA
R13_LEN = R0_DATALEN
R13_REP = J
IF R13_LEN=1 THEN R13_ADDR = BYTEINTEGER(TON+16) ELSESTART
R13_ADDR = L+24-FBASE
MOVE(R13_LEN, TON+16, L+24)
FINISH
LDDISP = (LDDISP+R13_LEN+27)&X'FFFFFC'
->NEXT
FINISH
K = BASE(I-40)+R0_LA
WHILE J>0 CYCLE
MOVE(L, TON+16, K)
K = K+L
J = J-1
REPEAT
->NEXT
LSW(30):
R0 == RECORD(TON)
J = R0_LA>>24; !AREA IDENT
R0_LA = R0_LA&X'FFFFFF'
->PACKCMN2
LSW(31):
LSW(32):
LSW(33):
LSW(34):
LSW(35):
LSW(36):
LSW(37):
LSW(38):
LSW(39):
I = I-30
LSW(1):
LSW(2):
LSW(3):
LSW(4):
LSW(5):
J = I
I = BASE(I)
R0 == RECORD(TON)
IF J=5 AND PACK5#0 THEN START
PACKCMN2:
L = LDSTART+LDDISP
INTEGER(LAST13) = L-FBASE; ! CHAIN FORWARD
LAST13 = L
R13 == RECORD(L)
R13_LINK = 0
R13_A = J
R13_DISP = R0_LA
IF R0_DATALEN<0 THEN START ; ! BYTE
R13_LEN = 1
R13_REP = -R0_DATALEN
R13_ADDR = R0_FILLER
LDDISP = LDDISP+24
FINISH ELSE START
R13_LEN = R0_DATALEN
R13_REP = 1
IF R13_LEN=1 THEN R13_ADDR = BYTEINTEGER(TON+12) ELSESTART
R13_ADDR = L+24-FBASE
MOVE(R13_LEN, TON+12, L+24)
FINISH
LDDISP = (LDDISP+R13_LEN+27)&X'FFFFFC'
FINISH
->NEXT
FINISH
IF R0_DATALEN<0 THEN START ; ! FILL
FILL(-R0_DATALEN, R0_LA+I, R0_FILLER)
FINISH ELSE START
MOVE(R0_DATALEN, ADDR(R0_FILLER), R0_LA+I)
FINISH
LSW(11):
LSW(12):
LSW(13):
LSW(14):
LSW(15):
LSW(16):
LSW(18):
LSW(19):
LSW(22):
LSW(25):
LSW(27):
NEXT:
TON = TON+RECLEN
LSWITCH:
IF VERSION=EMAS START
IF BYTEINTEGER(TON)=X'81' START
MONITOR
DUMP(TON-20000, TON+32)
STOP
FINISH
FINISH
I = INTEGER(TON)
RECLEN = (I<<8)>>8
I = I>>24
->LSW(I)
LSW(0):
TON = TON+8; ! DATA REF LIST ENTRY
->LSWITCH
LSW(6):
LSW(7):
IF VERSION=EMAS THEN CHANGECONTEXT; !FINISHED WITH COMPILER - LOSE FROM WORKING SET
UNLESS TON=TBASE THEN START ; ! NOTFIRST R6 REFERS TO LAST T6
CYCLE I = 1, 1, 7
BASE(I) = (BASE(I)+R6_AREALEN(I)+7)&X'FFFFFFF8'
REPEAT
FINISH
R6 == RECORD(TON)
->NEXT UNLESS R6_TYPE>>24=7
L = LDSTART+LDDISP; ! SPACE FOR LISTHEADS+OBJDATA
J = HEAD(11)
WHILE J#0 CYCLE
R1 == RECORD(J)
INTEGER(L) = H(1)
H(1) = L-FBASE
INTEGER(L+4) = R1_LOC
STRING(L+8) = R1_NAME
L = (L+12+LENGTH(R1_NAME))&X'FFFFFFFC'
J = R1_LINK
REPEAT
J = HEAD(14)
WHILE J#0 CYCLE
R4 == RECORD(J)
INTEGER(L) = H(4)
H(4) = L-FBASE
MOVE(12, ADDR(R4_DISP), L+4)
STRING(L+16) = R4_NAME
L = (L+20+LENGTH(R4_NAME))&X'FFFFFFFC'
J = R4_LINK
REPEAT
CYCLE I = 7, 1, 9; ! EXREF, DYNAMIC XREF
IF I=9 THEN START ; ! 'DATA OR PROCEDURE' REFERENCE
K = 11
J = HEAD(22)
FINISH ELSE START
K = I
J = HEAD(I+5)
FINISH
WHILE J#0 CYCLE
R1 == RECORD(J)
INTEGER(L) = H(K)
H(K) = L-FBASE
IF R1_LOC>>24=9 THEN START ; ! ref from const area
R1_LOC = X'01000000'!((R1_LOC<<8)>>8+CONST OFFSET)
FINISH
INTEGER(L+4) = R1_LOC
STRING(L+8) = R1_NAME
L = (L+12+LENGTH(R1_NAME))&X'FFFFFFFC'
J = R1_LINK
REPEAT
REPEAT
!*
J = HEAD(15); ! DATA REFS
WHILE J#0 CYCLE
R9 == RECORD(J)
INTEGER(L) = H(9)
H(9) = L-FBASE
I = L+4
INTEGER(L+8) = R9_L
STRING(L+12) = R9_NAME
L = (L+16+LENGTH(R9_NAME))&X'FFFFFFFC'
K = R9_COUNT
INTEGER(I) = (L-FBASE)!(K>>31)<<31
K = (K<<1)>>1
INTEGER(L) = K
I = R9_REFLINK
WHILE I#0 CYCLE
I = I+WORKAD
INTEGER(L+K<<2) = INTEGER(I+4); ! STORE FROM END TO GIVE ORDERED ARRAY
I = INTEGER(I)
K = K-1
REPEAT
L = L+INTEGER(L)<<2+4
J = R9_LINK
REPEAT
!*
J = HEAD(18); ! MODIFY ADDRESSES IN CODE
WHILE J#0 CYCLE
R8 == RECORD(J)
K = R8_CODEADDR
IF K>=0 THEN K = K+CODE OFFSET ELSE K = -K
IF K<AREALENGTH(1)+CODE OFFSET THEN START
I = FBASE+AREASTART(8)+K
IF I&2=0 THEN START ; ! 1 WORD ALLIGNED
K = (INTEGER(I)<<14+R8_ADDRFIELD<<14)>>14
INTEGER(I) = (INTEGER(I)&X'FFFC0000')!K
FINISH ELSE START
K = ((INTEGER(I-2)&3)<<30)!(INTEGER(I+2)>>2)
K = (K+R8_ADDRFIELD<<14)>>14
INTEGER(I-2) = (INTEGER(I-2)&X'FFFFFFFC')!(K>>16)
INTEGER(I+2) = (INTEGER(I+2)&X'0000FFFF')!(K<<16)
FINISH
FINISH
J = R8_LINK
REPEAT
!*
J = HEAD(19); ! INDIVIDUAL RELOCATION BLOCKS
IF J#0 THEN START
H(14) = L-FBASE
INTEGER(L) = 0
INTEGER(L+4) = TYPE19NUM
L = L+8
FINISH
WHILE J#0 CYCLE
R7 == RECORD(J)
IF R7_BASELOC>>24=9 THEN R7_BASELOC = (1<<24)!CONST OFFSET
INTEGER(L) = R7_AREALOC
INTEGER(L+4) = R7_BASELOC
IF R7_BASELOC>>24=1 AND CODE OFFSET#0 THEN START
I = FBASE+AREASTART(R7_AREALOC>>24)+(R7_AREALOC<<8)>>8
UNLESS INTEGER(I)=0 AND INTEGER(I-4)=X'E1000000' THEN C
INTEGER(I) = INTEGER(I)+CODE OFFSET
FINISH
L = L+8
J = R7_LINK
REPEAT
J = HEAD(25); ! GENERALISED RELOCATION BLOCKS
WHILE J>0 CYCLE
R7 == RECORD(J)
INTEGER(L) = H(14)
H(14) = L-FBASE
K = INTEGER(J+8)<<3+4
MOVE(K, J+8, L+4)
L = L+K+4
J = R7_LINK
REPEAT
!******* AREA SUMMARY
INTEGER(FBASE+28) = L-FBASE
INTEGER(L) = 7; ! NO. OF AREAS
L = L+4
AREASTART(1) = AREASTART(8)
CYCLE I = 1, 1, 7
INTEGER(L) = AREASTART(I)
INTEGER(L+4) = AREALENGTH(I)
INTEGER(L+8) = AREAPROP(I)
L = L+12
REPEAT
IF VERSION=EMAS THENSTART
L = L + 20; ! LANGUAGE HISTORY RECORD
FINISH
L = (L+11)&X'FFFFFFF8'
INTEGER(FBASE) = L-FBASE
H(2) = NUMEXT
H(3) = NUMFIXUPS
MOVE(60, ADDR(H(0)), LDSTART)
IF VERSION=EMAS THENSTART
H(12) = L-FBASE-20; ! HISTORY RECORD POINTER
BYTEINTEGER(L-20) = 8; ! LANGUAGE HISTORY RECORD
MOVE(18,ADDR(LANGVERS),L-19)
BYTEINTEGER(L-1) = 0; ! END OF HISTORY RECORDS
FINISH
! CHANGES ACCESS MODE
RETURN
END ; ! LPUT
!*
ENDOFFILE