!!! %option stack=40
!! 17/1/78
{Modified 25-Feb-82 to run on new subsystem}
!!!! %CONTROL 1; ! CHECK SWITCHES ONLY
! PASS 3 OF 7/32 IMP COMPILER - VERSION FOR MOUSES AND OS-32MT SUBSYSTEM
CONSTINTEGER MAX PERM = 54
CONSTINTEGERARRAY PERMS(1: 733) = C
X'0037',X'018E',X'019A',X'01A4',X'01B8',X'024B',X'01EE',X'01FB',X'01CF',
X'0000',X'0084',X'00A3',X'00C6',X'0046',X'00DB',X'0000',X'0000',X'02C4',
X'02B5',X'02A6',X'029E',X'0298',X'0292',X'0282',X'0210',X'003C',X'005E',
X'0059',X'0218',X'0141',X'0184',X'0050',X'004B',X'0077',X'0070',X'0069',
X'0063',X'007F',X'0041',X'0169',X'0220',X'0225',X'022A',X'022F',X'024E',
X'0055',X'0057',X'0235',X'023A',X'023F',X'0245',X'016E',X'017A',X'026F',
X'0004',X'2440',X'583D',X'0004',X'0303',X'0004',X'2441',X'583D',X'0004',
X'0303',X'0004',X'2445',X'583D',X'0004',X'0303',X'0004',X'2442',X'583D',
X'0004',X'0303',X'0004',X'2443',X'583D',X'0004',X'0303',X'0004',X'2444',
X'583D',X'0004',X'0303',X'0001',X'0000',X'0001',X'0000',X'0004',X'2449',
X'583D',X'0004',X'0303',X'0004',X'244A',X'583D',X'0004',X'0303',X'0005',
X'246A',X'2445',X'583D',X'0004',X'0303',X'0006',X'0856',X'246A',X'2447',
X'583D',X'0004',X'0303',X'0006',X'C860',X'0020',X'2445',X'583D',X'0004',
X'0303',X'0007',X'0856',X'C860',X'0020',X'2447',X'583D',X'0004',X'0303',
X'0004',X'2446',X'583D',X'0004',X'0303',X'001E',X'4801',X'0000',X'C500',
X'8080',X'2135',X'2401',X'2410',X'8888',X'0001',X'9400',X'9330',X'1001',
X'2188',X'D301',X'4300',X'0000',X'D202',X'4300',X'0000',X'2308',X'2731',
X'4801',X'4300',X'0000',X'4002',X'4300',X'0000',X'2732',X'2217',X'0308',
X'0022',X'4801',X'0000',X'C500',X'8080',X'2135',X'2401',X'2410',X'8888',
X'0001',X'9400',X'9300',X'D352',X'0000',X'0865',X'0A62',X'0A50',X'C550',
X'00FF',X'2325',X'2405',X'241C',X'8888',X'0001',X'D252',X'0000',X'2701',
X'0218',X'2661',X'2611',X'D331',X'0000',X'D236',X'0000',X'2208',X'0014',
X'0862',X'D301',X'0000',X'D352',X'0000',X'0B50',X'2318',X'0A05',X'2306',
X'D336',X'0000',X'D431',X'0000',X'0238',X'2611',X'2661',X'2701',X'2218',
X'0855',X'0308',X'005D',X'D0B7',X'0100',X'08B2',X'48D1',X'0000',X'C5D0',
X'8080',X'2338',X'94DD',X'93DD',X'4802',X'0000',X'C500',X'8080',X'2135',
X'2401',X'2410',X'8888',X'0001',X'9400',X'9300',X'0B0D',X'4210',X'8022',
X'08CB',X'08E1',X'08FD',X'27F1',X'4210',X'801E',X'26C1',X'26E1',X'D33C',
X'0000',X'D43E',X'0000',X'2239',X'26B1',X'2701',X'4300',X'FFDA',X'D1B7',
X'0100',X'0801',X'0308',X'0866',X'2135',X'05B2',X'2037',X'4300',X'801C',
X'083B',X'0B32',X'D236',X'0000',X'08CC',X'05BC',X'2338',X'2661',X'26C1',
X'D336',X'0000',X'D23C',X'0000',X'2208',X'0855',X'2136',X'0800',X'4230',
X'FFC6',X'4300',X'8022',X'0ABD',X'D302',X'0000',X'0A02',X'0830',X'0B3B',
X'D235',X'0000',X'05B0',X'2338',X'26B1',X'2651',X'D335',X'0000',X'D23B',
X'0000',X'2208',X'D1B7',X'0000',X'05DD',X'0308',X'0007',X'0827',X'C810',
X'0100',X'9261',X'4012',X'0000',X'0308',X'0027',X'4836',X'0000',X'C530',
X'8080',X'2135',X'2401',X'2410',X'8888',X'0001',X'9433',X'9333',X'0855',
X'2328',X'5807',X'002C',X'0503',X'2124',X'0B05',X'2601',X'2315',X'2405',
X'2419',X'8888',X'0001',X'C837',X'002C',X'0813',X'D203',X'0000',X'0A65',
X'2701',X'0218',X'2631',X'D326',X'0000',X'D223',X'0000',X'2661',X'2208',
X'0004',X'2448',X'583D',X'0004',X'0303',X'000B',X'6827',X'002C',X'5867',
X'0030',X'5857',X'0034',X'C840',X'0016',X'583D',X'0004',X'0303',X'0009',
X'6827',X'002C',X'5867',X'0030',X'C840',X'0017',X'583D',X'0004',X'0303',
X'0009',X'5867',X'002C',X'5857',X'0030',X'C840',X'0015',X'583D',X'0004',
X'0303',X'000B',X'0830',X'0A33',X'2734',X'0218',X'5801',X'4300',X'0000',
X'5002',X'4300',X'0000',X'2208',X'0009',X'0830',X'0A33',X'2400',X'2734',
X'0218',X'5002',X'4300',X'0000',X'2205',X'0013',X'0831',X'4932',X'0002',
X'212B',X'4B32',X'0000',X'2118',X'0A33',X'7333',X'4200',X'0004',X'2333',
X'0A3E',X'0233',X'0821',X'2405',X'2414',X'8888',X'0001',X'0016',X'5016',
X'0008',X'5036',X'0004',X'5056',X'0000',X'CB35',X'FFFF',X'2125',X'2405',
X'2416',X'8888',X'0001',X'1C21',X'1C05',X'2400',X'0B01',X'C813',X'0003',
X'C410',X'FFFC',X'0308',X'001E',X'5073',X'0000',X'5103',X'0000',X'5063',
X'0004',X'0827',X'0A71',X'583D',X'0000',X'C973',X'FE00',X'2327',X'0B71',
X'0821',X'2402',X'2410',X'8888',X'0001',X'585E',X'0010',X'F550',X'8080',
X'8080',X'0238',X'5051',X'42FF',X'FFFC',X'2714',X'2035',X'000C',X'0833',
X'2316',X'0823',X'2405',X'241A',X'8888',X'0001',X'2411',X'2731',X'0218',
X'1C02',X'2203',X'000D',X'2401',X'2F00',X'0801',X'2316',X'2D02',X'2820',
X'2400',X'CB01',X'0001',X'0338',X'2C02',X'2701',X'2203',X'0002',X'0816',
X'0308',X'0003',X'0816',X'0A15',X'0308',X'0007',X'C817',X'002C',X'C840',
X'0011',X'583D',X'0004',X'0303',X'0007',X'C817',X'002C',X'C840',X'0012',
X'583D',X'0004',X'0303',X'0004',X'244D',X'583D',X'0004',X'0303',X'0004',
X'244E',X'583D',X'0004',X'0303',X'0004',X'244F',X'583D',X'0004',X'0303',
X'0005',X'C840',X'0010',X'583D',X'0004',X'0303',X'0004',X'244B',X'583D',
X'0004',X'0303',X'0004',X'244C',X'583D',X'0004',X'0303',X'0005',X'C840',
X'0013',X'583D',X'0004',X'0303',X'0005',X'C840',X'0014',X'583D',X'0004',
X'0303',X'0002',X'2F01',X'0308',X'0008',X'581D',X'0000',X'0B17',X'0318',
X'2402',X'2410',X'8888',X'0001',X'000B',X'6807',X'002C',X'F810',X'4080',
X'0000',X'5017',X'002C',X'6A07',X'002C',X'2E10',X'0308',X'0004',X'6807',
X'002C',X'2E10',X'0308',X'0006',X'6807',X'002C',X'2E10',X'2F21',X'2B02',
X'0308',X'0012',X'5817',X'002C',X'C460',X'000F',X'1164',X'C660',X'E101',
X'4067',X'0000',X'2460',X'4067',X'0002',X'C860',X'0308',X'4067',X'0004',
X'4307',X'0000',X'000F',X'0822',X'233A',X'0B10',X'0801',X'EE00',X'001F',
X'1D02',X'2611',X'2113',X'0800',X'0338',X'2405',X'2411',X'8888',X'0001',
X'0005',X'0338',X'2406',X'2411',X'8888',X'0001',X'0005',X'0348',X'2406',
X'2411',X'8888',X'0001',X'0007',X'D401',X'0000',X'0388',X'2406',X'2411',
X'8888',X'0001',X'000E',X'5912',X'0000',X'2117',X'5912',X'0004',X'2124',
X'5C02',X'0008',X'0308',X'0821',X'2406',X'2412',X'8888',X'0001',X'000E',
X'4A78',X'0000',X'580D',X'0000',X'C507',X'0200',X'4388',X'0002',X'4B78',
X'0000',X'2402',X'2410',X'8888',X'0001',X'0019',X'0847',X'4A48',X'0000',
X'4A78',X'0002',X'580D',X'0000',X'C507',X'0200',X'2387',X'4B78',X'0002',
X'2402',X'2410',X'8888',X'0001',X'580E',X'0010',X'5004',X'0000',X'2644',
X'0547',X'2224',X'4308',X'0004'
!
! FAULT MESSAGES
! 1 - NO CODE REFS LEFT
! 2 - TOO MANY LABELS
! 3 - SPURIOUS PERM CALL
! 4 - TOO MANY PATCHES
! 5 - CORRUPT JUMP
! 6 - CORRUPT PERM ROUTINE
! 7 - PHASE ERROR
! 8 - CORRUPT PERM ADDRESS
! 9 - CODE INCOMPLETE
! 10 - GLAP INCOMPLETE
!
CONSTINTEGER PSEUDO OBJ = 2, DIRECT = 3; ! INPUT STREAMS
CONSTINTEGER REPORT = 0, OBJECT = 2; ! OUTPUT
CONSTINTEGERARRAY NOT(0:12) = 1,0,5,4,3,2,7,6,11,10,9,8,12
CONSTINTEGERARRAY SB(0:12) =
X'2230', X'2030', X'2010', X'2020', X'2220', X'2210',
X'2230', X'2030', X'2020', X'2010', X'2210', X'2220', X'2200'
CONSTINTEGERARRAY SF(0:12) =
X'2330', X'2130', X'2110', X'2120', X'2320', X'2310',
X'2330', X'2130', X'2120', X'2110', X'2310', X'2320', X'2300'
CONSTINTEGERARRAY LJ(0:12) =
X'433E', X'423E', X'421E', X'422E', X'432E', X'431E',
X'433E', X'423E', X'422E', X'421E', X'431E', X'432E', X'430E'
CONSTINTEGER MAX PATCH = 450
CONSTINTEGER MAX JUMPS = 3000
CONSTINTEGER MAX LABELS= 2000
BEGIN
RECORDFORMAT PFM(INTEGER WHAT, WHERE)
RECORDFORMAT LFM(INTEGER LAB, CA)
! LAB = MODE(3)+LABEL(12)
! MODE= LONG+CONDITIONAL+PERM+RT
RECORD(LFM)ARRAY JUMP(1 : MAXJUMPS+1)
RECORD(PFM)ARRAY PATCH(1 : MAX PATCH)
INTEGERARRAY LAB(0 : MAXLABELS)
INTEGERARRAY LTEMP(0:9)
INTEGERARRAY PEP, PADDR(1:MAX PERM)
INTEGER CA, GA, LA, DA
INTEGER LINE SIZE
INTEGER CODE SIZE, GLA SIZE, LOAD SIZE, PERM SIZE, DIAG SIZE
CONSTINTEGER EMARK = X'8888'
CONSTINTEGER NEVER = X'7FFF'
CONSTINTEGER LONG = X'800000'
CONSTINTEGER COND = X'400000'
CONSTINTEGER PERM = X'200000'
CONSTINTEGER RT = X'100000'
CONSTINTEGER VERY = X'080000'
CONSTINTEGER LABEL= X'FFFF'
OWNINTEGER MAX LABEL = 1
OWNINTEGER INIT GLA = 0
INTEGER REF EXTRA, IGNORE, FLAG
INTEGER REFS, CURRENT LINE
INTEGER J,K,L,z
INTEGER CP, GP, CODE, TAG, EXTRA
RECORD(PFM)NAME PAT
INTEGER CTAG, CCA, UCA, DEFMOD, LAST
INTEGER MODE, CADDR, CVAL, GADDR, GVAL
SWITCH D(1:8), C(2:11)
RECORD(LFM)NAME UREF, CREF
RECORD(LFM)NAME R,B
INTEGERNAME V
INTEGER PHASE
INTEGER RX1,RX2,RX3,SJ; RX1=0; RX2=0; RX3=0; SJ=0
INTEGER RTNCALLS, PERMCALLS; RTNCALLS=0; PERMCALLS=0
!
!
!
SHORTINTEGER CBP, GBP, LBP, DBP, TBP
! N.B. 'GLABUFFSIZE' MUST BE A POWER OF 2 -- SEE LINE 562 ISH
CONSTINTEGER CODEBUFFSIZE=200, GLABUFFSIZE=256, LD BUFF SIZE=200
CONSTINTEGER DIAG BUFF SIZE = 256
SHORTINTEGERARRAY TBUFF,DBUFF(1:DIAG BUFF SIZE)
SHORTINTEGERARRAY CBUFF(1:CODE BUFFSIZE), GBUFF(1:GLA BUFFSIZE)
SHORTINTEGERARRAY LBUFF(1:LD BUFFSIZE); ! ... LD = 'LOADER DATA'
!
! -------OBJECT BLOCK TYPE CODES-------
CONSTINTEGER END OF FILE BLOCK = 0
CONSTINTEGER NONDIAG CODE BLOCK = 1
CONSTINTEGER DIAG CODE BLOCK = 2
CONSTINTEGER STATIC DATA BLOCK = 3; ! ...'GLA' IN IMP CONTEXT
CONSTINTEGER DIAGS DATA BLOCK = 4
CONSTINTEGER DIAG TABLE = 5
CONSTINTEGER ENTRY POINT BLOCK = 6
CONSTINTEGER EXTERNAL REF BLOCK = 7
CONSTINTEGER SEGMENT SIZE BLOCK = 15
!
ROUTINE GET(INTEGERNAME N)
INTEGER S
READSYMBOL(N); READSYMBOL(S)
N = N<<8!S
END
!
ROUTINE PUT HALF(SHORTINTEGER N)
PRINT SYMBOL((N>>8)&255)
PRINT SYMBOL(N&255)
END
!
ROUTINE PUT BLOCK(SHORTINTEGER HEADER, SHORTINTEGERARRAYNAME BLOCK)
SHORTINTEGER I,J
PUT HALF(HEADER)
CYCLE I = 1,1,(HEADER>>4)&X'0FFF'; ! ...EXTRACT LENGTH
J = BLOCK(I)
HEADER = HEADER+J; ! ...ACCUMULATE CHECKSUM
PUT HALF(J)
REPEAT
PUT HALF(-HEADER-1); ! ...CHECKSUM
END
!
ROUTINE COPY BLOCK(SHORTINTEGER HEADER)
SHORTINTEGER I; INTEGER N
PUT HALF(HEADER)
CYCLE I = 1,1,(HEADER>>4)&X'0FFF'
GET(N); HEADER = HEADER+N
PUT HALF(N)
REPEAT
PUT HALF(-HEADER-1)
END
ROUTINE CFLUSH
! OUTPUT BUFFER IF THERE IS ANYTHING IN IT -- OTHERWISE JUST
! INITIALISE. BUFFER IS EMPTY IF CBP=1
PUT BLOCK( (CBP<<4)!DIAG CODE BLOCK, CBUFF ) IF CBP # 1
CBP = 1; CBUFF(1) = CURRENT LINE
END
!
ROUTINE GFLUSH
PUT BLOCK( (GBP<<4)!STATIC DATA BLOCK, GBUFF) UNLESS GBP = 0
GBP = 0
END
!
ROUTINE LFLUSH
PUT BLOCK( (LBP<<4)!EXTERNAL REF BLOCK, LBUFF) IF LBP # 0
LBP = 0
END
!
ROUTINE DFLUSH
RETURN IF DBP = 0
PUT BLOCK(DBP<<4+DIAGS DATA BLOCK, DBUFF)
DBP = 0
END
ROUTINE T FLUSH
PUT BLOCK((TBP<<4)!DIAG TABLE, T BUFF) UNLESS TBP = 0
TBP = 0
END
ROUTINE CPUT(SHORTINTEGER N)
CBP = CBP+1; CBUFF(CBP) = N
CA = CA+2
END
!
ROUTINE GPUT(SHORTINTEGER N)
GFLUSH IF GBP = GLA BUFF SIZE
GBP = GBP+1; GBUFF(GBP) = N
GA = GA+2
END
!
ROUTINE LPUT(SHORTINTEGER N)
LFLUSH IF LBP = LD BUFFSIZE
LBP = LBP+1; LBUFF(LBP) = N
LA = LA+2
END
!
ROUTINE LSYM(SHORTINTEGER N)
OWNINTEGER FLAG,V
FLAG = ¬FLAG
IF FLAG = 0 START
LPUT(N<<8+V)
ELSE
V = N
FINISH
END
!
ROUTINE DPUT(SHORTINTEGER N)
DBP = DBP+1; DBUFF(DBP) = N
DFLUSH IF DBP = DIAG BUFF SIZE
DA = DA+2
END
ROUTINE DIAG LINE
OWNINTEGER HERE = 0
RETURN IF HERE = CURRENT LINE
HERE = CURRENT LINE
DPUT(CURRENT LINE); DPUT(CA)
END
ROUTINE T PUT(SHORTINTEGER V)
TBP = TBP+1; TBUFF(TBP) = V
T FLUSH IF TBP = DIAG BUFF SIZE
END
ROUTINE CLOSE OBJECT FILE
CFLUSH; GFLUSH; LFLUSH
DPUT(0); DPUT(0); D FLUSH ; ! ... MARK END OF TABLE THEN FLUSH
TPUT(X'8800'); TPUT(CA+2)
TPUT(0); TPUT(0)
TPUT(0); TPUT(0)
TPUT(0); TPUT(0); T FLUSH; ! .... DITTO ....
PUT HALF( (0<<4)!END OF FILE BLOCK ); ! ...ZERO DATA CONTENT
PUT HALF(-END OF FILE BLOCK-1); ! ...CHECK SUM
END
!
!
!
!
!
ROUTINE MONITOR(INTEGER N)
SELECTOUTPUT(REPORT)
PRINTSTRING("FAULT"); WRITE(N, 1)
PRINTSTRING(" PHASE"); WRITE(PHASE, 1); NEWLINE
WRITE(REFS, 1); PRINTSTRING(" REFS"); NEWLINE
PRINTSTRING("MAX LABEL"); WRITE(MAX LABEL, 1); NEWLINE
SIGNAL 15,15
END
!
ROUTINE SORT(INTEGER FROM, TO)
INTEGER FLAG, J, T
RECORD(PFM)NAME A, B
WHILE TO > FROM CYCLE
FLAG = 0
A == PATCH(FROM)
CYCLE J = FROM+1, 1, TO
B == PATCH(J)
IF A_WHERE > B_WHERE START
T = A_WHERE; A_WHERE = B_WHERE; B_WHERE = T
T = B_WHAT; B_WHAT = A_WHAT; A_WHAT = T
FLAG = 1
ELSE IF A_WHERE = B_WHERE
FLAG = 1
A_WHERE = -10
FINISH
A == B
REPEAT
EXIT IF FLAG = 0
TO = TO-1
REPEAT
END
ROUTINE NEXT CODE
OWNINTEGER P = 1, J = 1
INTEGER C, BV
RECORD(PFM)NAME PP
C = NEVER; BV = NEVER; MODE = NEVER
IF P <= CP START; ! CODE PATCHES LEFT
CYCLE
PP == PATCH(P)
EXIT IF PP_WHERE # -10
P = P+1
REPEAT
C = PP_WHERE>>1
FINISH
IF J < REFS START; ! JUMPS LEFT
B == JUMP(J)
BV = B_CA>>1
FINISH
CADDR = NEVER
RETURN IF BV = NEVER = C
IF BV > C START
P = P+1
CADDR = PP_WHERE; CVAL = PP_WHAT
RETURN
FINISH
IF C > BV START
J = J+1
MODE = 0; CADDR = B_CA
RETURN
FINISH
MONITOR(1)
END
ROUTINE NEXT GLA
GADDR = NEVER AND RETURN IF GP > MAX PATCH
PAT == PATCH(GP) AND GP = GP+1 UNTIL PAT_WHERE >= 0
GADDR = PAT_WHERE; GVAL = PAT_WHAT
END
ROUTINE SET PERM(INTEGER N)
INTEGER J,K
RETURN UNLESS PEP(N) = 1
PEP(N) = 2
K = PERMS(N)
IF K = 0 START
SELECTOUTPUT(REPORT)
PRINTSTRING("NO ENTRY FOR PERM"); WRITE(N, 1); NEWLINE
PEP(N) = 0
SELECTOUTPUT(OBJECT)
RETURN
FINISH
CYCLE J = 1, 1, PERMS(K)
K = K+1
IF PERMS(K) = EMARK START
N = PERMS(K+1)
IF PEP(N) # 2 START
PEP(N) = 1; SET PERM(N)
FINISH
FINISH
REPEAT
END
ROUTINE PLANT LONG JUMP
INTEGER N
! PLANT A BRANCH OR BAL INSTRUCTION WHICH IS ASSUMED TO BE DESCRIBED
! BY 'L'(OP CODE + BASE REG), 'TAG'(DESTINATION ADDRESS),
! 'B'(NAME OF RECORD CONTAINING FLAG BITS) AND 'CA'(CURRENT CODE
! ADDRESS).
IF B_LAB&VERY = 0 START; ! ...CAN USE A 32 BIT FORM
N = TAG-(CA+4)
IF -16*1024 <= N < 16*1024 START; ! USE PC RELATIVE
L = L&X'FFF0'; ! STRIP OFF BASE REGISTER
CPUT(L); CPUT(N!X'8000' )
RX2 = RX2+1
ELSE; !USE BASE+DISP
CPUT(L); CPUT(TAG)
RX1 = RX1+1
FINISH
ELSE; ! ...48 BIT ADDRESS REQ'D
CPUT(L)
CPUT((TAG>>16&X'FF')+X'4000')
CPUT(TAG); ! ...N.B. 'CPUT' ONLY PUTS 16 BITS
RX3 = RX3+1
FINISH
END
!
! PHASE 1 - INPUT PROGRAM & GENERATE JUMP TABLES + PATCH TABLES
!
PHASE = 1
PEP(J) = 0 AND PADDR(J) = 0 FOR J = 1, 1, MAX PERM
CP = 0; GP = MAX PATCH+1
REFS = 0; DEFMOD = 0; UCA = 0; CCA = 0; CTAG = 0
LAB(J) = 0 FOR J = 1,1,MAX LABELS
SELECTINPUT(DIRECT)
READ SYMBOL(INIT GLA); ! MINIMUM POSSIBLE SIZE OF GLA - FROM PASS 2
CYCLE
READSYMBOL(CODE); ->D(CODE)
D(1):! TAG DEF <REF>, <CA>
GET(TAG); GET(CA)
MONITOR(2) IF TAG > MAX LABELS
MAX LABEL = TAG IF TAG > MAX LABEL
IF TAG = CTAG AND CCA = CA AND UCA = CA START
DEFMOD = DEFMOD+2
UREF_LAB = UREF_LAB!PERM!COND
CREF_LAB = CREF_LAB!VERY!RT
CTAG = UREF_LAB&LABEL
CREF == UREF
CCA = CA+2
ELSE
CTAG = 0
FINISH
LAB(TAG) = CA
CONTINUE
D(2):! CREF <REF>, <CA>
FLAG = COND; ->CURP
D(3):! UREF <REF>, <CA>
FLAG = 0; ->CURP
D(4):! RREF <REF>, <CA>
FLAG = RT+LONG
RTNCALLS = RTNCALLS+1
-> CURP
D(5):! PREF <REF>, <CA>
FLAG = PERM+LONG
PERMCALLS = PERMCALLS+1
CURP: GET(TAG); GET(CA)
REFS = REFS+1; R == JUMP(REFS)
MONITOR(1) IF REFS > MAX JUMPS
R_LAB = TAG+FLAG
R_CA = CA
IF FLAG = 0 START; ! UNCONDITIONAL
UCA = CA+2; UREF == R
ELSE IF FLAG = COND; ! CONDITIONAL
CCA = CA+4; CTAG = TAG; CREF == R
FINISH
IF FLAG&PERM # 0 START
IF TAG > MAX PERM OR PERMS(TAG) = 0 START
SELECTOUTPUT(REPORT)
PRINTSTRING("NO PERM"); WRITE(TAG, 1); NEWLINE
SELECTOUTPUT(OBJECT)
ELSE
PEP(TAG) = 1
FINISH
FINISH
CONTINUE
D(6):! GPATCH <WHAT>, <WHERE>
GP = GP-1; PAT == PATCH(GP); ->PWW
D(7):! CPATCH <WHAT>, <WHERE>
CP = CP+1; PAT == PATCH(CP)
PWW: GET(TAG); GET(CA)
PAT_WHAT = TAG; PAT_WHERE = CA
MONITOR(4) IF CP = GP
REPEAT
D(8):! END MARKER
GET(CODE SIZE); GET(GLA SIZE); GET(LINE SIZE); GET(DIAG SIZE)
CODE SIZE = CODE SIZE-DEF MOD
REFS = REFS+1; JUMP(REFS) = 0
IF DEF MOD # 0 START
REF EXTRA = 0
CYCLE L = 1, 1, REFS-1
R == JUMP (L)
R_CA = R_CA-REF EXTRA
IF R_LAB&COND # 0 AND R_LAB&RT # 0 START
REF EXTRA = REF EXTRA+2
CYCLE K = 1, 1, CP
PAT == PATCH(K)
PAT_WHERE = PAT_WHERE-2 IF PAT_WHERE > R_CA
REPEAT
IF GP <= MAX PATCH START
CYCLE K = GP, 1, MAX PATCH
PAT == PATCH(K)
PAT_WHAT = PAT_WHAT-2 IF PAT_WHAT > R_CA
PAT_WHERE = PAT_WHERE-2 IF PAT_WHERE&1 # 0 AND C
PAT_WHERE > R_CA
REPEAT
FINISH
CYCLE K = 1, 1, MAX LABEL
LAB(K) = LAB(K)-2 IF LAB(K) > R_CA
REPEAT
DEFMOD = DEFMOD-2
FINISH
REPEAT
MONITOR(5) IF DEFMOD # 0
FINISH
! IDENTIFY THOSE PERM ROUTINES WHICH ARE REQUIRED.
PERM SIZE = 0
SET PERM(J) FOR J = 1,1,MAX PERM
CYCLE J = 1,1,MAX PERM
IF PEP(J) # 0 START
PADDR(J) = CODE SIZE
L = PERMS(PERMS(J))*2
CODE SIZE = CODE SIZE + L
PERM SIZE = PERM SIZE + L
FINISH
REPEAT
! PHASE 2 - IDENTIFY LONG JUMPS
!
PHASE = 2
IF REFS > 1 START
CYCLE
FLAG = 0; REF EXTRA = 0
CYCLE L = 1, 1, REFS-1
R == JUMP(L);! JUMP REFERENCE
R_CA = R_CA+REF EXTRA
CONTINUE IF R_LAB&VERY # 0; ! ALREADY VERY LONG
EXTRA = 0
J = R_LAB&LABEL
IF R_LAB&PERM = 0 OR R_LAB&COND # 0 C
THEN K = LAB(J) ELSE K = PADDR(J)
UNLESS -30 <= K-R_CA <= 30 START; ! ...CAN'T BE SHORT
IF R_LAB&LONG=0 START; ! ...BUT IT IS...
IF K < 16*1024 OR -16*1024<=K-(R_CA+4)<16*1024 START
! 32 BIT FORM: BASE+DISPLACEMENT OR PC RELATIVE
EXTRA = 2; R_LAB = R_LAB!LONG; ! SHORT -> LONG
ELSE
! 48 BIT FORM REQ'D: BASE+DISP
EXTRA = 4; R_LAB = R_LAB!VERY; ! SHORT -> VERY
FINISH
ELSE
UNLESS K<16*1024 OR -16*1024<=K-(R_CA+4)<16*1024 START
EXTRA = 2; R_LAB = R_LAB!!(LONG!VERY); ! LONG -> VERY
FINISH
FINISH
CONTINUE IF EXTRA = 0; ! ...NO CHANGES REQ'D
FLAG = 1
! ADJUST PATCHES
IF CP > 0 START
CYCLE K = 1, 1, CP
PAT == PATCH(K)
PAT_WHERE = PAT_WHERE+EXTRA IF PAT_WHERE > R_CA
REPEAT
FINISH
IF GP <= MAX PATCH START
CYCLE K = GP, 1, MAX PATCH
PAT == PATCH(K)
PAT_WHAT = PAT_WHAT+EXTRA IF PAT_WHAT > R_CA
REPEAT
FINISH
! ADJUST REMAINING REFS
CYCLE K = 1, 1, MAX LABEL
V == LAB(K)
V = V+EXTRA IF V > R_CA
REPEAT
CYCLE K = 1, 1, MAX PERM
PADDR(K) = PADDR(K)+EXTRA IF PADDR(K) # 0
REPEAT
REF EXTRA = REF EXTRA+EXTRA
CODE SIZE = CODE SIZE+EXTRA
FINISH
REPEAT
REPEAT until flag = 0
FINISH
!
! PHASE 3 - GENERATE OBJECT FILE
!
PHASE = 3
J = MAX PATCH+1; K = J
WHILE J > GP CYCLE
J = J-1
PAT == PATCH(J)
IF PAT_WHERE&1 # 0 START
PAT_WHERE = PAT_WHERE&(¬1)
CP = CP+1; PATCH(CP) = PAT
ELSE
K = K-1; PATCH(K) = PAT
FINISH
REPEAT
GP = K
SORT(1, CP)
SORT(GP, MAX PATCH)
!
!
SELECT OUTPUT(OBJECT); PUT HALF(X'8282')
!
! OUTPUT A CONTROL BLOCK GIVING CODE AND GLA SEGMENT SIZES(IN
! HALF-WORDS). OTHER PARAMETERS MAY BE ADDED AS REQ'D.
! USES 'GBUFF' AS WORKSPACE.
GBUFF(1) = (CODE SIZE + 1)>>1
GBUFF(2) = (GLA SIZE + 1)>>1
GBUFF(3) = (DIAG SIZE+16)>>1; ! ... +16 FOR EXTRA WORD AS TERMINATOR
GBUFF(4) = (LINE SIZE+16)>>1
! -------REQUIRES LOADER DATA SIZE-----------
PUT BLOCK((4<<4)!SEGMENT SIZE BLOCK,GBUFF)
!
SELECT INPUT(PSEUDO OBJ)
CA = 0; GA = INITGLA; LA = 0; DA = 0
CURRENT LINE = 0; CBP = 1; CFLUSH
GBP = INIT GLA>>1; LBP = 0; DBP = 0; TBP = 0
NEXT CODE; NEXT GLA
READSYMBOL(CODE);! = 1
IGNORE = 0; LAST = 0
CYCLE
READ SYMBOL(CODE); -> C(CODE+IGNORE)
C(2):! CODE <VAL>
GET(L)
IF CA = CADDR START
IF MODE # 0 START; ! CODE PATCH
CPUT(CVAL)
ELSE; ! JUMP+PERM+RT
TAG = LAB(B_LAB&LABEL)
IF B_LAB&(PERM!RT) = 0 OR B_LAB&COND # 0 START; ! JUMP
IF B_LAB&(PERM!RT) # 0 START
IF B_LAB&RT # 0 START
LAST = L IF LAST = 0
LAST = NOT(LAST&15)!X'8000'
NEXT CODE
CONTINUE
FINISH
L = LAST; LAST = 0
FINISH
L = L&15
IF B_LAB&(LONG!VERY) = 0 START; ! LEAVE IT SHORT
J = (TAG-CA)//2
MONITOR(5) UNLESS -15 <= J <= 15
IF J < 0 THEN CPUT(SB(L)-J) C
ELSE CPUT(SF(L)+J)
SJ = SJ+1
ELSE; ! MAKE IT LONG
L = LJ(L); PLANT LONG JUMP
FINISH
ELSE; ! PERM OR ROUTINE
DIAG LINE
IGNORE = 5
TAG = PADDR(B_LAB&LABEL) IF B_LAB&PERM # 0
PLANT LONG JUMP
FINISH
FINISH
NEXT CODE
FINISH ELSE CPUT(L)
CONTINUE
C(11):GET(J)
IF J = X'FFFF' START
GET(J)
TPUT(X'4000'); TPUT(CA)
CONTINUE
FINISH
TPUT(J)
GET(K)
K = CA IF J&X'8000' # 0
TPUT(K)
GET(K); TPUT(K)
GET(K); TPUT(K)
GET(K); TPUT(K)
GET(K); TPUT(K)
CONTINUE
C(10): DIAG LINE; CONTINUE
C(4):
C(9):CURRENT LINE = CURRENT LINE+1; CFLUSH
CONTINUE; ! LINE FLAG
C(7):IGNORE = 0; GET(L); CONTINUE
C(6):L = NL
J = 0
CYCLE K = 1, 1, 9
IF L # 0 START
READSYMBOL(L)
J = J+1; LTEMP(J) = L
FINISH
REPEAT
READSYMBOL(L) WHILE L # 0
J = J-1; LTEMP(0) = J
LSYM(LTEMP(J)) FOR J = 0, 1, 8
GET(K); READSYMBOL(L)
LSYM(L); LPUT(K)
CONTINUE
C(8):
C(3):! GLA <VAL> -- SWITCH VECTOR ELEMENT
GET(L)
IF GA = GADDR START
L = GVAL
NEXT GLA
FINISH
GPUT(L)
REPEAT
C(5):! END
CYCLE J = 1, 1, MAX PERM
IF PEP(J) # 0 START
K = PERMS(J); MONITOR(6) IF K = 0
L = PADDR(J)
MONITOR(7) IF CA # L
CFLUSH IF CBP+PERMS(K) > CODE BUFF SIZE
{ %CYCLE L = K+1, 1, K+PERMS(K) L is corrupted below!! }
l = k; z = k + perms(k)
while l # z cycle
l = l+1
TAG = PERMS(L)
IF TAG = EMARK START
! USE PC RELATIVE UNCONDITIONAL BRANCH FOR INTERNAL
! LINKING BETWEEN PERM ROUTINES.
CPUT(X'4300')
L = L+1; CPUT((PADDR(PERMS(L))-CA-2)!X'8000')
ELSE
CPUT(TAG)
FINISH
REPEAT
FINISH
REPEAT
!
CLOSE OBJECT FILE
!
MONITOR(9) UNLESS CADDR = NEVER
MONITOR(10) UNLESS GADDR = NEVER
SELECTOUTPUT(REPORT)
DA = DA+DIAG SIZE
PRINTSTRING("CODE"); WRITE(CODE SIZE-PERM SIZE, 1)
PRINTSTRING(" + GLA"); WRITE(GLA SIZE, 1)
PRINTSTRING(" + PERM"); WRITE(PERM SIZE, 1)
PRINTSTRING(" + DIAGS"); WRITE(DA, 1)
PRINTSTRING(" =")
WRITE(CODE SIZE+GLA SIZE+DA, 1)
PRINTSTRING(" BYTES")
NEWLINE
!%ENDOFPROGRAM; !**REMOVE FOR EXTRA MONITORING**
! ------TEMPORARY EXTRA MONITORING-------
NEWLINE
PRINT STRING("JUMPS:")
WRITE(SJ,1); PRINT STRING(" SHORT,")
WRITE(RX1,1); PRINT STRING(" RX1,")
WRITE(RX2,1); PRINT STRING(" RX2,")
WRITE(RX3,1); PRINT STRING(" RX3")
NEWLINE
PRINT STRING("...INCLUDING")
WRITE(PERMCALLS,1); PRINT STRING(" PERMCALLS AND")
WRITE(RTNCALLS,1); PRINT STRING(" CALLS ON USER-DEFINED ROUTINES")
NEWLINES(2)
ENDOFPROGRAM