ÿ!!! %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'Dÿ0B7',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 CTÿAG, 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;  CBUFÿF(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 %CYCÿLE
         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
!  PLAÿNT 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 SIZÿE = 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
%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
ING-------
   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')