         Edinburgh IMP77 Compiler - Version 8.4

    1  !!! %option  stack=40
    2  !! 17/1/78
    3  {Modified 25-Feb-82 to run on new subsystem}
    4  
    5  !!!!  %CONTROL 1;        ! CHECK SWITCHES ONLY
    6  
    7  ! PASS 3 OF 7/32 IMP COMPILER - VERSION FOR MOUSES AND OS-32MT SUBSYSTEM
    8  
    9  %CONSTINTEGER  MAX PERM = 54
   10  %CONSTINTEGERARRAY PERMS(1: 733) = %C
   11+ X'0037',X'018E',X'019A',X'01A4',X'01B8',X'024B',X'01EE',X'01FB',X'01CF',
   12+ X'0000',X'0084',X'00A3',X'00C6',X'0046',X'00DB',X'0000',X'0000',X'02C4',
   13+ X'02B5',X'02A6',X'029E',X'0298',X'0292',X'0282',X'0210',X'003C',X'005E',
   14+ X'0059',X'0218',X'0141',X'0184',X'0050',X'004B',X'0077',X'0070',X'0069',
   15+ X'0063',X'007F',X'0041',X'0169',X'0220',X'0225',X'022A',X'022F',X'024E',
   16+ X'0055',X'0057',X'0235',X'023A',X'023F',X'0245',X'016E',X'017A',X'026F',
   17+ X'0004',X'2440',X'583D',X'0004',X'0303',X'0004',X'2441',X'583D',X'0004',
   18+ X'0303',X'0004',X'2445',X'583D',X'0004',X'0303',X'0004',X'2442',X'583D',
   19+ X'0004',X'0303',X'0004',X'2443',X'583D',X'0004',X'0303',X'0004',X'2444',
   20+ X'583D',X'0004',X'0303',X'0001',X'0000',X'0001',X'0000',X'0004',X'2449',
   21+ X'583D',X'0004',X'0303',X'0004',X'244A',X'583D',X'0004',X'0303',X'0005',
   22+ X'246A',X'2445',X'583D',X'0004',X'0303',X'0006',X'0856',X'246A',X'2447',
   23+ X'583D',X'0004',X'0303',X'0006',X'C860',X'0020',X'2445',X'583D',X'0004',
   24+ X'0303',X'0007',X'0856',X'C860',X'0020',X'2447',X'583D',X'0004',X'0303',
   25+ X'0004',X'2446',X'583D',X'0004',X'0303',X'001E',X'4801',X'0000',X'C500',
   26+ X'8080',X'2135',X'2401',X'2410',X'8888',X'0001',X'9400',X'9330',X'1001',
   27+ X'2188',X'D301',X'4300',X'0000',X'D202',X'4300',X'0000',X'2308',X'2731',
   28+ X'4801',X'4300',X'0000',X'4002',X'4300',X'0000',X'2732',X'2217',X'0308',
   29+ X'0022',X'4801',X'0000',X'C500',X'8080',X'2135',X'2401',X'2410',X'8888',
   30+ X'0001',X'9400',X'9300',X'D352',X'0000',X'0865',X'0A62',X'0A50',X'C550',
   31+ X'00FF',X'2325',X'2405',X'241C',X'8888',X'0001',X'D252',X'0000',X'2701',
   32+ X'0218',X'2661',X'2611',X'D331',X'0000',X'D236',X'0000',X'2208',X'0014',
   33+ X'0862',X'D301',X'0000',X'D352',X'0000',X'0B50',X'2318',X'0A05',X'2306',
   34+ X'D336',X'0000',X'D431',X'0000',X'0238',X'2611',X'2661',X'2701',X'2218',
   35+ X'0855',X'0308',X'005D',X'D0B7',X'0100',X'08B2',X'48D1',X'0000',X'C5D0',
   36+ X'8080',X'2338',X'94DD',X'93DD',X'4802',X'0000',X'C500',X'8080',X'2135',
   37+ X'2401',X'2410',X'8888',X'0001',X'9400',X'9300',X'0B0D',X'4210',X'8022',
   38+ X'08CB',X'08E1',X'08FD',X'27F1',X'4210',X'801E',X'26C1',X'26E1',X'D33C',
   39+ X'0000',X'D43E',X'0000',X'2239',X'26B1',X'2701',X'4300',X'FFDA',X'D1B7',
   40+ X'0100',X'0801',X'0308',X'0866',X'2135',X'05B2',X'2037',X'4300',X'801C',
   41+ X'083B',X'0B32',X'D236',X'0000',X'08CC',X'05BC',X'2338',X'2661',X'26C1',
   42+ X'D336',X'0000',X'D23C',X'0000',X'2208',X'0855',X'2136',X'0800',X'4230',
   43+ X'FFC6',X'4300',X'8022',X'0ABD',X'D302',X'0000',X'0A02',X'0830',X'0B3B',
   44+ X'D235',X'0000',X'05B0',X'2338',X'26B1',X'2651',X'D335',X'0000',X'D23B',
   45+ X'0000',X'2208',X'D1B7',X'0000',X'05DD',X'0308',X'0007',X'0827',X'C810',
   46+ X'0100',X'9261',X'4012',X'0000',X'0308',X'0027',X'4836',X'0000',X'C530',
   47+ X'8080',X'2135',X'2401',X'2410',X'8888',X'0001',X'9433',X'9333',X'0855',
   48+ X'2328',X'5807',X'002C',X'0503',X'2124',X'0B05',X'2601',X'2315',X'2405',
   49+ X'2419',X'8888',X'0001',X'C837',X'002C',X'0813',X'D203',X'0000',X'0A65',
   50+ X'2701',X'0218',X'2631',X'D326',X'0000',X'D223',X'0000',X'2661',X'2208',
   51+ X'0004',X'2448',X'583D',X'0004',X'0303',X'000B',X'6827',X'002C',X'5867',
   52+ X'0030',X'5857',X'0034',X'C840',X'0016',X'583D',X'0004',X'0303',X'0009',
   53+ X'6827',X'002C',X'5867',X'0030',X'C840',X'0017',X'583D',X'0004',X'0303',
   54+ X'0009',X'5867',X'002C',X'5857',X'0030',X'C840',X'0015',X'583D',X'0004',
   55+ X'0303',X'000B',X'0830',X'0A33',X'2734',X'0218',X'5801',X'4300',X'0000',
   56+ X'5002',X'4300',X'0000',X'2208',X'0009',X'0830',X'0A33',X'2400',X'2734',
   57+ X'0218',X'5002',X'4300',X'0000',X'2205',X'0013',X'0831',X'4932',X'0002',
   58+ X'212B',X'4B32',X'0000',X'2118',X'0A33',X'7333',X'4200',X'0004',X'2333',
   59+ X'0A3E',X'0233',X'0821',X'2405',X'2414',X'8888',X'0001',X'0016',X'5016',
   60+ X'0008',X'5036',X'0004',X'5056',X'0000',X'CB35',X'FFFF',X'2125',X'2405',
   61+ X'2416',X'8888',X'0001',X'1C21',X'1C05',X'2400',X'0B01',X'C813',X'0003',
   62+ X'C410',X'FFFC',X'0308',X'001E',X'5073',X'0000',X'5103',X'0000',X'5063',
   63+ X'0004',X'0827',X'0A71',X'583D',X'0000',X'C973',X'FE00',X'2327',X'0B71',
   64+ X'0821',X'2402',X'2410',X'8888',X'0001',X'585E',X'0010',X'F550',X'8080',
   65+ X'8080',X'0238',X'5051',X'42FF',X'FFFC',X'2714',X'2035',X'000C',X'0833',
   66+ X'2316',X'0823',X'2405',X'241A',X'8888',X'0001',X'2411',X'2731',X'0218',
   67+ X'1C02',X'2203',X'000D',X'2401',X'2F00',X'0801',X'2316',X'2D02',X'2820',
   68+ X'2400',X'CB01',X'0001',X'0338',X'2C02',X'2701',X'2203',X'0002',X'0816',
   69+ X'0308',X'0003',X'0816',X'0A15',X'0308',X'0007',X'C817',X'002C',X'C840',
   70+ X'0011',X'583D',X'0004',X'0303',X'0007',X'C817',X'002C',X'C840',X'0012',
   71+ X'583D',X'0004',X'0303',X'0004',X'244D',X'583D',X'0004',X'0303',X'0004',
   72+ X'244E',X'583D',X'0004',X'0303',X'0004',X'244F',X'583D',X'0004',X'0303',
   73+ X'0005',X'C840',X'0010',X'583D',X'0004',X'0303',X'0004',X'244B',X'583D',
   74+ X'0004',X'0303',X'0004',X'244C',X'583D',X'0004',X'0303',X'0005',X'C840',
   75+ X'0013',X'583D',X'0004',X'0303',X'0005',X'C840',X'0014',X'583D',X'0004',
   76+ X'0303',X'0002',X'2F01',X'0308',X'0008',X'581D',X'0000',X'0B17',X'0318',
   77+ X'2402',X'2410',X'8888',X'0001',X'000B',X'6807',X'002C',X'F810',X'4080',
   78+ X'0000',X'5017',X'002C',X'6A07',X'002C',X'2E10',X'0308',X'0004',X'6807',
   79+ X'002C',X'2E10',X'0308',X'0006',X'6807',X'002C',X'2E10',X'2F21',X'2B02',
   80+ X'0308',X'0012',X'5817',X'002C',X'C460',X'000F',X'1164',X'C660',X'E101',
   81+ X'4067',X'0000',X'2460',X'4067',X'0002',X'C860',X'0308',X'4067',X'0004',
   82+ X'4307',X'0000',X'000F',X'0822',X'233A',X'0B10',X'0801',X'EE00',X'001F',
   83+ X'1D02',X'2611',X'2113',X'0800',X'0338',X'2405',X'2411',X'8888',X'0001',
   84+ X'0005',X'0338',X'2406',X'2411',X'8888',X'0001',X'0005',X'0348',X'2406',
   85+ X'2411',X'8888',X'0001',X'0007',X'D401',X'0000',X'0388',X'2406',X'2411',
   86+ X'8888',X'0001',X'000E',X'5912',X'0000',X'2117',X'5912',X'0004',X'2124',
   87+ X'5C02',X'0008',X'0308',X'0821',X'2406',X'2412',X'8888',X'0001',X'000E',
   88+ X'4A78',X'0000',X'580D',X'0000',X'C507',X'0200',X'4388',X'0002',X'4B78',
   89+ X'0000',X'2402',X'2410',X'8888',X'0001',X'0019',X'0847',X'4A48',X'0000',
   90+ X'4A78',X'0002',X'580D',X'0000',X'C507',X'0200',X'2387',X'4B78',X'0002',
   91+ X'2402',X'2410',X'8888',X'0001',X'580E',X'0010',X'5004',X'0000',X'2644',
   92+ X'0547',X'2224',X'4308',X'0004'
   93  !
   94  !  FAULT MESSAGES
   95  !   1  -  NO CODE REFS LEFT
   96  !   2  -  TOO MANY LABELS
   97  !   3  -  SPURIOUS PERM CALL
   98  !   4  -  TOO MANY PATCHES
   99  !   5  -  CORRUPT JUMP
  100  !   6  -  CORRUPT PERM ROUTINE
  101  !   7  -  PHASE ERROR
  102  !   8  -  CORRUPT PERM ADDRESS
  103  !   9  -  CODE INCOMPLETE
  104  !  10  -  GLAP INCOMPLETE
  105  !
  106  %CONSTINTEGER PSEUDO OBJ = 2, DIRECT = 3;! INPUT STREAMS
  107  %CONSTINTEGER  REPORT = 0, OBJECT = 2;      ! OUTPUT
  108  
  109  %CONSTINTEGERARRAY NOT(0:12) = 1,0,5,4,3,2,7,6,11,10,9,8,12
  110  %CONSTINTEGERARRAY SB(0:12) =
  111+ X'2230', X'2030', X'2010', X'2020', X'2220', X'2210',
  112+ X'2230', X'2030', X'2020', X'2010', X'2210', X'2220', X'2200'
  113  %CONSTINTEGERARRAY SF(0:12) =
  114+ X'2330', X'2130', X'2110', X'2120', X'2320', X'2310',
  115+ X'2330', X'2130', X'2120', X'2110', X'2310', X'2320', X'2300'
  116  %CONSTINTEGERARRAY LJ(0:12) =
  117+ X'433E', X'423E', X'421E', X'422E', X'432E', X'431E',
  118+ X'433E', X'423E', X'422E', X'421E', X'431E', X'432E', X'430E'
  119  %CONSTINTEGER MAX PATCH = 450
  120  %CONSTINTEGER MAX JUMPS = 3000
  121  %CONSTINTEGER MAX LABELS= 2000
  122  %BEGIN
  123  
  124     %RECORDFORMAT PFM(%INTEGER WHAT, WHERE)
  125     %RECORDFORMAT LFM(%INTEGER LAB, CA)
  126                      !  LAB =  MODE(3)+LABEL(12)
  127                      !  MODE= LONG+CONDITIONAL+PERM+RT
  128     %RECORD(LFM)%ARRAY JUMP(1 : MAXJUMPS+1)
  129     %RECORD(PFM)%ARRAY PATCH(1 : MAX PATCH)
  130     %INTEGERARRAY LAB(0 : MAXLABELS)
  131     %INTEGERARRAY LTEMP(0:9)
  132     %INTEGERARRAY PEP, PADDR(1:MAX PERM)
  133     %INTEGER CA, GA, LA, DA
  134     %INTEGER LINE SIZE
  135     %INTEGER CODE SIZE, GLA SIZE, LOAD SIZE, PERM SIZE, DIAG SIZE
  136     %CONSTINTEGER EMARK = X'8888'
  137     %CONSTINTEGER NEVER = X'7FFF'
  138     %CONSTINTEGER LONG = X'800000'
  139     %CONSTINTEGER COND = X'400000'
  140     %CONSTINTEGER PERM = X'200000'
  141     %CONSTINTEGER RT   = X'100000'
  142     %CONSTINTEGER VERY = X'080000'
  143     %CONSTINTEGER LABEL= X'FFFF'
  144     %OWNINTEGER MAX LABEL = 1
  145     %OWNINTEGER INIT GLA = 0
  146     %INTEGER REF EXTRA, IGNORE, FLAG
  147     %INTEGER REFS, CURRENT LINE
  148     %INTEGER J,K,L,z
  149     %INTEGER CP, GP, CODE, TAG, EXTRA
  150     %RECORD(PFM)%NAME PAT
  151     %INTEGER CTAG, CCA, UCA, DEFMOD, LAST
  152     %INTEGER MODE, CADDR, CVAL, GADDR, GVAL
  153     %SWITCH D(1:8), C(2:11)
  154     %RECORD(LFM)%NAME UREF, CREF
  155     %RECORD(LFM)%NAME  R,B
  156     %INTEGERNAME V
  157     %INTEGER PHASE
  158     %INTEGER  RX1,RX2,RX3,SJ;  RX1=0;  RX2=0;  RX3=0;  SJ=0
  159     %INTEGER RTNCALLS, PERMCALLS;  RTNCALLS=0;  PERMCALLS=0
  160  !
  161  !
  162  !
  163  %SHORTINTEGER  CBP, GBP, LBP, DBP, TBP
  164  
  165  !  N.B.   'GLABUFFSIZE' MUST BE A POWER OF 2 -- SEE LINE 562 ISH
  166  %CONSTINTEGER  CODEBUFFSIZE=200, GLABUFFSIZE=256, LD BUFF SIZE=200
  167  %CONSTINTEGER DIAG BUFF SIZE = 256
  168  %SHORTINTEGERARRAY TBUFF,DBUFF(1:DIAG BUFF SIZE)
  169  %SHORTINTEGERARRAY CBUFF(1:CODE BUFFSIZE), GBUFF(1:GLA BUFFSIZE)
  170  %SHORTINTEGERARRAY LBUFF(1:LD BUFFSIZE);   ! ... LD = 'LOADER DATA'
  171  !
  172  !   -------OBJECT BLOCK TYPE CODES-------
  173  %CONSTINTEGER END OF FILE BLOCK = 0
  174  %CONSTINTEGER NONDIAG CODE BLOCK = 1
  175  %CONSTINTEGER DIAG CODE BLOCK = 2
  176  %CONSTINTEGER STATIC DATA BLOCK = 3;  ! ...'GLA' IN IMP CONTEXT
  177  %CONSTINTEGER DIAGS DATA BLOCK = 4
  178  %CONSTINTEGER DIAG TABLE     = 5
  179  %CONSTINTEGER ENTRY POINT BLOCK = 6
  180  %CONSTINTEGER EXTERNAL REF BLOCK = 7
  181  %CONSTINTEGER SEGMENT SIZE BLOCK = 15
  182  !
  183     %ROUTINE  GET(%INTEGERNAME  N)
  184        %INTEGER S
  185        READSYMBOL(N);  READSYMBOL(S)
  186        N = N<<8!S
  187     %END
  188  !
  189  %ROUTINE  PUT HALF(%SHORTINTEGER N)
  190     PRINT SYMBOL((N>>8)&255)
  191     PRINT SYMBOL(N&255)
  192  %END
  193  !
  194  %ROUTINE  PUT BLOCK(%SHORTINTEGER HEADER, %SHORTINTEGERARRAYNAME BLOCK)
  195  %SHORTINTEGER I,J
  196     PUT HALF(HEADER)
  197     %CYCLE I = 1,1,(HEADER>>4)&X'0FFF';   ! ...EXTRACT LENGTH
  198        J = BLOCK(I)
  199        HEADER = HEADER+J;    ! ...ACCUMULATE CHECKSUM
  200        PUT HALF(J)
  201     %REPEAT
  202     PUT HALF(-HEADER-1);   ! ...CHECKSUM
  203  %END
  204  !
  205  %ROUTINE  COPY BLOCK(%SHORTINTEGER  HEADER)
  206  %SHORTINTEGER I;  %INTEGER N
  207     PUT HALF(HEADER)
  208     %CYCLE I = 1,1,(HEADER>>4)&X'0FFF'
  209        GET(N); HEADER = HEADER+N
  210        PUT HALF(N)
  211     %REPEAT
  212     PUT HALF(-HEADER-1)
  213  %END
  214  %ROUTINE  CFLUSH
  215  !   OUTPUT BUFFER IF THERE IS ANYTHING IN IT -- OTHERWISE JUST
  216  !   INITIALISE.   BUFFER IS EMPTY IF CBP=1
  217     PUT BLOCK( (CBP<<4)!DIAG CODE BLOCK, CBUFF ) %IF CBP # 1
  218     CBP = 1;  CBUFF(1) = CURRENT LINE
  219  %END
  220  !
  221  %ROUTINE  GFLUSH
  222     PUT BLOCK( (GBP<<4)!STATIC DATA BLOCK, GBUFF) %UNLESS GBP = 0
  223     GBP = 0
  224  %END
  225  !
  226  %ROUTINE  LFLUSH
  227     PUT BLOCK( (LBP<<4)!EXTERNAL REF BLOCK, LBUFF) %IF LBP # 0
  228     LBP = 0
  229  %END
  230  !
  231  %ROUTINE DFLUSH
  232     %RETURN %IF DBP = 0
  233     PUT BLOCK(DBP<<4+DIAGS DATA BLOCK, DBUFF)
  234     DBP = 0
  235  %END
  236  %ROUTINE T FLUSH
  237     PUT BLOCK((TBP<<4)!DIAG TABLE, T BUFF) %UNLESS TBP = 0
  238     TBP = 0
  239  %END
  240  %ROUTINE  CPUT(%SHORTINTEGER  N)
  241     CBP = CBP+1;  CBUFF(CBP) = N
  242     CA = CA+2
  243  %END
  244  !
  245  %ROUTINE  GPUT(%SHORTINTEGER  N)
  246     GFLUSH %IF GBP = GLA BUFF SIZE
  247     GBP = GBP+1;  GBUFF(GBP) = N
  248     GA = GA+2
  249  %END
  250  !
  251  %ROUTINE  LPUT(%SHORTINTEGER  N)
  252     LFLUSH %IF LBP = LD BUFFSIZE
  253     LBP = LBP+1;  LBUFF(LBP) = N
  254     LA = LA+2
  255  %END
  256  !
  257  %ROUTINE  LSYM(%SHORTINTEGER N)
  258  %OWNINTEGER  FLAG,V
  259     FLAG = \FLAG
  260     %IF FLAG = 0 %START
  261        LPUT(N<<8+V)
  262     %ELSE
  263        V = N
  264     %FINISH
  265  %END
  266  !
  267  %ROUTINE DPUT(%SHORTINTEGER N)
  268     DBP = DBP+1;  DBUFF(DBP) = N
  269     DFLUSH %IF DBP = DIAG BUFF SIZE
  270     DA = DA+2
  271  %END
  272  %ROUTINE  DIAG LINE
  273  %OWNINTEGER  HERE = 0
  274     %RETURN %IF HERE = CURRENT LINE
  275     HERE = CURRENT LINE
  276     DPUT(CURRENT LINE);  DPUT(CA)
  277  %END
  278  %ROUTINE T PUT(%SHORTINTEGER V)
  279     TBP = TBP+1;  TBUFF(TBP) = V
  280     T FLUSH %IF TBP = DIAG BUFF SIZE
  281  %END
  282  %ROUTINE  CLOSE OBJECT FILE
  283     CFLUSH;  GFLUSH;  LFLUSH
  284     DPUT(0);  DPUT(0);  D FLUSH ;  ! ... MARK END OF TABLE THEN FLUSH
  285     TPUT(X'8800');  TPUT(CA+2)
  286     TPUT(0);  TPUT(0)
  287     TPUT(0);  TPUT(0)
  288     TPUT(0);  TPUT(0); T FLUSH;   ! .... DITTO ....
  289     PUT HALF( (0<<4)!END OF FILE BLOCK );  ! ...ZERO DATA CONTENT
  290     PUT HALF(-END OF FILE BLOCK-1);   ! ...CHECK SUM
  291  %END
  292  !
  293  !
  294  !
  295  !
  296  !
  297     %ROUTINE MONITOR(%INTEGER N)
  298        SELECTOUTPUT(REPORT)
  299        PRINTSTRING("FAULT");  WRITE(N, 1)
  300        PRINTSTRING("   PHASE");  WRITE(PHASE, 1);  NEWLINE
  301        WRITE(REFS, 1);  PRINTSTRING(" REFS");  NEWLINE
  302        PRINTSTRING("MAX LABEL");  WRITE(MAX LABEL, 1);  NEWLINE
  303        %SIGNAL 15,15
  304     %END
  305  !
  306     %ROUTINE SORT(%INTEGER FROM, TO)
  307        %INTEGER FLAG, J, T
  308        %RECORD(PFM)%NAME A, B
  309        %WHILE TO > FROM %CYCLE
  310           FLAG = 0
  311           A == PATCH(FROM)
  312           %CYCLE J = FROM+1, 1, TO
  313              B == PATCH(J)
  314              %IF A_WHERE > B_WHERE %START
  315                 T = A_WHERE;  A_WHERE = B_WHERE;  B_WHERE = T
  316                 T = B_WHAT;  B_WHAT = A_WHAT;  A_WHAT = T
  317                 FLAG = 1
  318              %ELSE %IF A_WHERE = B_WHERE
  319                 FLAG = 1
  320                 A_WHERE = -10
  321              %FINISH
  322              A == B
  323           %REPEAT
  324           %EXIT %IF FLAG = 0
  325           TO = TO-1
  326        %REPEAT
  327     %END
  328     %ROUTINE NEXT CODE
  329        %OWNINTEGER P = 1, J = 1
  330        %INTEGER C, BV
  331        %RECORD(PFM)%NAME PP
  332        C = NEVER;  BV = NEVER;  MODE = NEVER
  333        %IF P <= CP %START;! CODE PATCHES LEFT
  334           %CYCLE
  335              PP == PATCH(P)
  336              %EXIT %IF PP_WHERE # -10
  337              P = P+1
  338           %REPEAT
  339           C = PP_WHERE>>1
  340        %FINISH
  341        %IF J < REFS %START;!  JUMPS LEFT
  342           B == JUMP(J)
  343           BV = B_CA>>1
  344        %FINISH
  345        CADDR = NEVER
  346        %RETURN %IF BV = NEVER = C
  347        %IF BV > C %START
  348           P = P+1
  349           CADDR = PP_WHERE;  CVAL = PP_WHAT
  350           %RETURN
  351        %FINISH
  352        %IF C > BV %START
  353           J = J+1
  354           MODE = 0;  CADDR = B_CA
  355           %RETURN
  356        %FINISH
  357        MONITOR(1)
  358     %END
  359     %ROUTINE NEXT GLA
  360        GADDR = NEVER %AND %RETURN %IF GP > MAX PATCH
  361        PAT == PATCH(GP) %AND GP = GP+1 %UNTIL PAT_WHERE >= 0
  362        GADDR = PAT_WHERE;  GVAL = PAT_WHAT
  363     %END
  364     %ROUTINE SET PERM(%INTEGER N)
  365        %INTEGER J,K
  366        %RETURN %UNLESS PEP(N) = 1
  367        PEP(N) = 2
  368        K = PERMS(N)
  369        %IF K = 0 %START
  370           SELECTOUTPUT(REPORT)
  371           PRINTSTRING("NO ENTRY FOR PERM");  WRITE(N, 1);  NEWLINE
  372           PEP(N) = 0
  373           SELECTOUTPUT(OBJECT)
  374           %RETURN
  375        %FINISH
  376        %CYCLE J = 1, 1, PERMS(K)
  377           K = K+1
  378           %IF PERMS(K) = EMARK %START
  379              N = PERMS(K+1)
  380              %IF PEP(N) # 2 %START
  381                 PEP(N) = 1;  SET PERM(N)
  382              %FINISH
  383           %FINISH
  384        %REPEAT
  385     %END
  386  
  387  %ROUTINE  PLANT LONG JUMP
  388     %INTEGER N
  389  !  PLANT A BRANCH OR BAL INSTRUCTION WHICH IS ASSUMED TO BE DESCRIBED
  390  !  BY 'L'(OP CODE + BASE REG), 'TAG'(DESTINATION ADDRESS),
  391  !  'B'(NAME OF RECORD CONTAINING FLAG BITS) AND 'CA'(CURRENT CODE
  392  !  ADDRESS).
  393     %IF B_LAB&VERY = 0 %START;    ! ...CAN USE A 32 BIT FORM
  394        N = TAG-(CA+4)
  395        %IF -16*1024 <= N < 16*1024 %START;      ! USE PC RELATIVE
  396           L = L&X'FFF0';          ! STRIP OFF BASE REGISTER
  397           CPUT(L);  CPUT(N!X'8000' )
  398           RX2 = RX2+1
  399        %ELSE;          !USE BASE+DISP
  400           CPUT(L);  CPUT(TAG)
  401           RX1 = RX1+1
  402        %FINISH
  403     %ELSE;                        ! ...48 BIT ADDRESS REQ'D
  404        CPUT(L)
  405        CPUT((TAG>>16&X'FF')+X'4000')
  406        CPUT(TAG);      ! ...N.B. 'CPUT' ONLY PUTS 16 BITS
  407        RX3 = RX3+1
  408     %FINISH
  409  %END
  410  
  411  
  412  
  413  !
  414  ! PHASE 1 - INPUT PROGRAM & GENERATE JUMP TABLES + PATCH TABLES
  415  !
  416     PHASE = 1
  417     PEP(J) = 0 %AND PADDR(J) = 0 %FOR J = 1, 1, MAX PERM
  418     CP = 0;  GP = MAX PATCH+1
  419     REFS = 0;  DEFMOD = 0;  UCA = 0;  CCA = 0;  CTAG = 0
  420     LAB(J) = 0 %FOR J = 1,1,MAX LABELS
  421     SELECTINPUT(DIRECT)
  422     READ SYMBOL(INIT GLA);  ! MINIMUM POSSIBLE SIZE OF GLA - FROM PASS 2
  423     %CYCLE
  424        READSYMBOL(CODE);  ->D(CODE)
  425  D(1):! TAG DEF <REF>, <CA>
  426        GET(TAG);  GET(CA)
  427        MONITOR(2) %IF TAG > MAX LABELS
  428        MAX LABEL = TAG %IF TAG > MAX LABEL
  429        %IF TAG = CTAG %AND CCA = CA %AND UCA = CA %START
  430           DEFMOD = DEFMOD+2
  431           UREF_LAB = UREF_LAB!PERM!COND
  432           CREF_LAB = CREF_LAB!VERY!RT
  433           CTAG = UREF_LAB&LABEL
  434           CREF == UREF
  435           CCA = CA+2
  436        %ELSE
  437           CTAG = 0
  438        %FINISH
  439        LAB(TAG) = CA
  440        %CONTINUE
  441  D(2):! CREF <REF>, <CA>
  442        FLAG = COND;  ->CURP
  443  D(3):! UREF <REF>, <CA>
  444        FLAG = 0;     ->CURP
  445  D(4):! RREF <REF>, <CA>
  446        FLAG = RT+LONG
  447        RTNCALLS = RTNCALLS+1
  448        -> CURP
  449  
  450  D(5):! PREF <REF>, <CA>
  451        FLAG = PERM+LONG
  452        PERMCALLS = PERMCALLS+1
  453  
  454  CURP: GET(TAG);  GET(CA)
  455        REFS = REFS+1;  R == JUMP(REFS)
  456        MONITOR(1) %IF REFS > MAX JUMPS
  457        R_LAB = TAG+FLAG
  458        R_CA = CA
  459        %IF FLAG = 0 %START;       ! UNCONDITIONAL
  460           UCA = CA+2;  UREF == R
  461        %ELSE %IF FLAG = COND;     ! CONDITIONAL
  462           CCA = CA+4;  CTAG = TAG;  CREF == R
  463        %FINISH
  464        %IF FLAG&PERM # 0 %START
  465           %IF TAG > MAX PERM %OR PERMS(TAG) = 0 %START
  466              SELECTOUTPUT(REPORT)
  467              PRINTSTRING("NO PERM");  WRITE(TAG, 1);  NEWLINE
  468              SELECTOUTPUT(OBJECT)
  469           %ELSE
  470              PEP(TAG) = 1
  471           %FINISH
  472        %FINISH
  473        %CONTINUE
  474  D(6):! GPATCH <WHAT>, <WHERE>
  475        GP = GP-1;  PAT == PATCH(GP);  ->PWW
  476  D(7):! CPATCH <WHAT>, <WHERE>
  477        CP = CP+1;  PAT == PATCH(CP)
  478  PWW:  GET(TAG);  GET(CA)
  479        PAT_WHAT = TAG;  PAT_WHERE = CA
  480        MONITOR(4) %IF CP = GP
  481     %REPEAT
  482  D(8):! END MARKER
  483     GET(CODE SIZE);  GET(GLA SIZE);  GET(LINE SIZE);  GET(DIAG SIZE)
  484     CODE SIZE = CODE SIZE-DEF MOD
  485     REFS = REFS+1;  JUMP(REFS) = 0
  486     %IF DEF MOD # 0 %START
  487        REF EXTRA = 0
  488        %CYCLE L = 1, 1, REFS-1
  489           R == JUMP (L)
  490           R_CA = R_CA-REF EXTRA
  491           %IF R_LAB&COND # 0 %AND R_LAB&RT # 0 %START
  492              REF EXTRA = REF EXTRA+2
  493              %CYCLE K = 1, 1, CP
  494                 PAT == PATCH(K)
  495                 PAT_WHERE = PAT_WHERE-2 %IF PAT_WHERE > R_CA
  496              %REPEAT
  497              %IF GP <= MAX PATCH %START
  498                 %CYCLE K = GP, 1, MAX PATCH
  499                    PAT == PATCH(K)
  500                    PAT_WHAT = PAT_WHAT-2 %IF PAT_WHAT > R_CA
  501                    PAT_WHERE = PAT_WHERE-2 %IF PAT_WHERE&1 # 0 %AND  %C
  502+                                            PAT_WHERE > R_CA
  503                 %REPEAT
  504              %FINISH
  505              %CYCLE K = 1, 1, MAX LABEL
  506                 LAB(K) = LAB(K)-2 %IF LAB(K) > R_CA
  507              %REPEAT
  508              DEFMOD = DEFMOD-2
  509           %FINISH
  510        %REPEAT
  511        MONITOR(5) %IF DEFMOD # 0
  512     %FINISH
  513  
  514  
  515  ! IDENTIFY THOSE PERM ROUTINES WHICH ARE REQUIRED.
  516     PERM SIZE = 0
  517     SET PERM(J) %FOR J = 1,1,MAX PERM
  518     %CYCLE  J = 1,1,MAX PERM
  519        %IF PEP(J) # 0 %START
  520           PADDR(J) = CODE SIZE
  521           L = PERMS(PERMS(J))*2
  522           CODE SIZE = CODE SIZE + L
  523           PERM SIZE = PERM SIZE + L
  524        %FINISH
  525     %REPEAT
  526  
  527  
  528  ! PHASE 2 - IDENTIFY LONG JUMPS
  529  !
  530     PHASE = 2
  531     %IF REFS > 1 %START
  532     %CYCLE
  533        FLAG = 0;  REF EXTRA = 0
  534        %CYCLE L = 1, 1, REFS-1
  535           R == JUMP(L);! JUMP REFERENCE
  536           R_CA = R_CA+REF EXTRA
  537           %CONTINUE %IF R_LAB&VERY # 0;! ALREADY VERY LONG
  538           EXTRA = 0
  539           J = R_LAB&LABEL
  540           %IF R_LAB&PERM = 0 %OR R_LAB&COND # 0 %C
  541+                 %THEN K = LAB(J) %ELSE K = PADDR(J)
  542           %UNLESS -30 <= K-R_CA <= 30 %START;  ! ...CAN'T BE SHORT
  543              %IF R_LAB&LONG=0 %START;          ! ...BUT IT IS...
  544                 %IF K < 16*1024 %OR -16*1024<=K-(R_CA+4)<16*1024 %START
  545                 ! 32 BIT FORM:  BASE+DISPLACEMENT  OR  PC RELATIVE
  546                    EXTRA = 2;  R_LAB = R_LAB!LONG;  ! SHORT -> LONG
  547                 %ELSE
  548                 ! 48 BIT FORM REQ'D:  BASE+DISP
  549                    EXTRA = 4;  R_LAB = R_LAB!VERY;  ! SHORT -> VERY
  550                 %FINISH
  551              %ELSE
  552                 %UNLESS K<16*1024 %OR -16*1024<=K-(R_CA+4)<16*1024 %START
  553                    EXTRA = 2;  R_LAB = R_LAB!!(LONG!VERY); ! LONG -> VERY
  554                 %FINISH
  555              %FINISH
  556              %CONTINUE %IF EXTRA = 0;  ! ...NO CHANGES REQ'D
  557              FLAG = 1
  558              ! ADJUST PATCHES
  559              %IF CP > 0 %START
  560                 %CYCLE K = 1, 1, CP
  561                    PAT == PATCH(K)
  562                    PAT_WHERE = PAT_WHERE+EXTRA %IF PAT_WHERE > R_CA
  563                 %REPEAT
  564              %FINISH
  565              %IF GP <= MAX PATCH %START
  566                 %CYCLE K = GP, 1, MAX PATCH
  567                    PAT == PATCH(K)
  568                    PAT_WHAT = PAT_WHAT+EXTRA %IF PAT_WHAT > R_CA
  569                 %REPEAT
  570              %FINISH
  571              ! ADJUST REMAINING REFS
  572              %CYCLE K = 1, 1, MAX LABEL
  573                 V == LAB(K)
  574                 V = V+EXTRA %IF V > R_CA
  575              %REPEAT
  576              %CYCLE K = 1, 1, MAX PERM
  577                 PADDR(K) = PADDR(K)+EXTRA %IF PADDR(K) # 0
  578              %REPEAT
  579              REF EXTRA = REF EXTRA+EXTRA
  580              CODE SIZE = CODE SIZE+EXTRA
  581           %FINISH
  582        %REPEAT
  583     %REPEAT %until flag = 0
  584     %FINISH
  585  !
  586  ! PHASE 3 - GENERATE OBJECT FILE
  587  !
  588     PHASE = 3
  589     J = MAX PATCH+1;  K = J
  590     %WHILE J > GP %CYCLE
  591        J = J-1
  592        PAT == PATCH(J)
  593        %IF PAT_WHERE&1 # 0 %START
  594           PAT_WHERE = PAT_WHERE&(\1)
  595           CP = CP+1;  PATCH(CP) = PAT
  596        %ELSE
  597           K = K-1;  PATCH(K) = PAT
  598        %FINISH
  599     %REPEAT
  600     GP = K
  601     SORT(1, CP)
  602     SORT(GP, MAX PATCH)
  603  !
  604  !
  605     SELECT OUTPUT(OBJECT);  PUT HALF(X'8282')
  606  !
  607  ! OUTPUT A CONTROL BLOCK GIVING CODE  AND GLA SEGMENT SIZES(IN
  608  ! HALF-WORDS).  OTHER PARAMETERS MAY BE ADDED AS REQ'D.
  609  !  USES 'GBUFF' AS WORKSPACE.
  610     GBUFF(1) = (CODE SIZE + 1)>>1
  611     GBUFF(2) = (GLA SIZE + 1)>>1
  612     GBUFF(3) = (DIAG SIZE+16)>>1;    ! ... +16 FOR EXTRA WORD AS TERMINATOR
  613     GBUFF(4) = (LINE SIZE+16)>>1
  614  ! -------REQUIRES LOADER DATA SIZE-----------
  615     PUT BLOCK((4<<4)!SEGMENT SIZE BLOCK,GBUFF)
  616  !
  617     SELECT INPUT(PSEUDO OBJ)
  618     CA = 0;  GA = INITGLA;  LA = 0;  DA = 0
  619     CURRENT LINE = 0;  CBP = 1;  CFLUSH
  620     GBP = INIT GLA>>1;  LBP = 0;  DBP = 0;  TBP = 0
  621     NEXT CODE;  NEXT GLA
  622  
  623     READSYMBOL(CODE);! = 1
  624     IGNORE = 0;  LAST = 0
  625     %CYCLE
  626        READ SYMBOL(CODE);  -> C(CODE+IGNORE)
  627  C(2):! CODE <VAL>
  628        GET(L)
  629        %IF CA = CADDR %START
  630           %IF MODE # 0 %START;! CODE PATCH
  631              CPUT(CVAL)
  632           %ELSE;!  JUMP+PERM+RT
  633              TAG = LAB(B_LAB&LABEL)
  634              %IF B_LAB&(PERM!RT) = 0 %OR B_LAB&COND # 0 %START;! JUMP
  635                 %IF B_LAB&(PERM!RT) # 0 %START
  636                    %IF B_LAB&RT # 0 %START
  637                       LAST = L %IF LAST = 0
  638                       LAST = NOT(LAST&15)!X'8000'
  639                       NEXT CODE
  640                       %CONTINUE
  641                    %FINISH
  642                    L = LAST;  LAST = 0
  643                 %FINISH
  644                 L = L&15
  645                 %IF B_LAB&(LONG!VERY) = 0 %START;! LEAVE IT SHORT
  646                    J = (TAG-CA)//2
  647                    MONITOR(5) %UNLESS -15 <= J <= 15
  648                    %IF J < 0 %THEN CPUT(SB(L)-J) %C
  649+                             %ELSE CPUT(SF(L)+J)
  650                    SJ = SJ+1
  651                 %ELSE;               ! MAKE IT LONG
  652                    L = LJ(L);  PLANT LONG JUMP
  653                 %FINISH
  654              %ELSE;! PERM OR ROUTINE
  655                 DIAG LINE
  656                 IGNORE = 5
  657                 TAG = PADDR(B_LAB&LABEL) %IF B_LAB&PERM # 0
  658                 PLANT LONG JUMP
  659              %FINISH
  660           %FINISH
  661           NEXT CODE
  662        %FINISH %ELSE CPUT(L)
  663        %CONTINUE
  664  C(11):GET(J)
  665        %IF J = X'FFFF' %START
  666           GET(J)
  667           TPUT(X'4000');  TPUT(CA)
  668           %CONTINUE
  669        %FINISH
  670        TPUT(J)
  671        GET(K)
  672        K = CA %IF J&X'8000' # 0
  673                 TPUT(K)
  674        GET(K);  TPUT(K)
  675        GET(K);  TPUT(K)
  676        GET(K);  TPUT(K)
  677        GET(K);  TPUT(K)
  678        %CONTINUE
  679  C(10): DIAG LINE;  %CONTINUE
  680  C(4):
  681  C(9):CURRENT LINE = CURRENT LINE+1;  CFLUSH
  682       %CONTINUE;! LINE FLAG
  683  C(7):IGNORE = 0;  GET(L);  %CONTINUE
  684  C(6):L = NL
  685       J = 0
  686       %CYCLE K = 1, 1, 9
  687          %IF L # 0 %START
  688             READSYMBOL(L)
  689             J = J+1;  LTEMP(J) = L
  690          %FINISH
  691       %REPEAT
  692       READSYMBOL(L) %WHILE L # 0
  693       J = J-1;  LTEMP(0) = J
  694       LSYM(LTEMP(J)) %FOR J = 0, 1, 8
  695       GET(K);  READSYMBOL(L)
  696       LSYM(L);  LPUT(K)
  697       %CONTINUE
  698  C(8):
  699  C(3):! GLA <VAL>  -- SWITCH VECTOR ELEMENT
  700        GET(L)
  701        %IF GA = GADDR %START
  702           L = GVAL
  703           NEXT GLA
  704        %FINISH
  705        GPUT(L)
  706     %REPEAT
  707  C(5):! END
  708     %CYCLE J = 1, 1, MAX PERM
  709        %IF PEP(J) # 0 %START
  710           K = PERMS(J);  MONITOR(6) %IF K = 0
  711           L = PADDR(J)
  712           MONITOR(7) %IF CA # L
  713           CFLUSH %IF CBP+PERMS(K) > CODE BUFF SIZE
  714  {         %CYCLE L = K+1, 1, K+PERMS(K)      L is corrupted below!! }
  715           l = k;  z = k + perms(k)
  716           %while l # z %cycle
  717              l = l+1
  718              TAG = PERMS(L)
  719              %IF TAG = EMARK %START
  720              !  USE PC RELATIVE UNCONDITIONAL BRANCH FOR INTERNAL
  721              !  LINKING BETWEEN PERM ROUTINES.
  722                 CPUT(X'4300')
  723                 L = L+1;  CPUT((PADDR(PERMS(L))-CA-2)!X'8000')
  724              %ELSE
  725                 CPUT(TAG)
  726              %FINISH
  727           %REPEAT
  728        %FINISH
  729     %REPEAT
  730  !
  731     CLOSE OBJECT FILE
  732  !
  733     MONITOR(9) %UNLESS CADDR = NEVER
  734     MONITOR(10) %UNLESS GADDR = NEVER
  735     SELECTOUTPUT(REPORT)
  736     DA = DA+DIAG SIZE
  737     PRINTSTRING("CODE");  WRITE(CODE SIZE-PERM SIZE, 1)
  738     PRINTSTRING(" + GLA");  WRITE(GLA SIZE, 1)
  739     PRINTSTRING(" + PERM");  WRITE(PERM SIZE, 1)
  740     PRINTSTRING(" + DIAGS");  WRITE(DA, 1)
  741     PRINTSTRING(" =")
  742     WRITE(CODE SIZE+GLA SIZE+DA, 1)
  743     PRINTSTRING(" BYTES")
  744     NEWLINE
  745  
  746  
  747  !%ENDOFPROGRAM;     !**REMOVE FOR EXTRA MONITORING**
  748  
  749  ! ------TEMPORARY EXTRA MONITORING-------
  750     NEWLINE
  751     PRINT STRING("JUMPS:")
  752     WRITE(SJ,1);  PRINT STRING(" SHORT,")
  753     WRITE(RX1,1); PRINT STRING(" RX1,")
  754     WRITE(RX2,1); PRINT STRING(" RX2,")
  755     WRITE(RX3,1); PRINT STRING(" RX3")
  756     NEWLINE
  757     PRINT STRING("...INCLUDING")
  758     WRITE(PERMCALLS,1); PRINT STRING(" PERMCALLS AND")
  759     WRITE(RTNCALLS,1); PRINT STRING(" CALLS ON USER-DEFINED ROUTINES")
  760     NEWLINES(2)
  761  %ENDOFPROGRAM
?COPYBLOCK unused
?ENTRYPOINTBLOCK unused
?NONDIAGCODEBLOCK unused
?LOADSIZE unused

  678 Statements compiled
