*DECK             CODGJ1
USETEXT   TSOURCE 
USETEXT   TTARGET 
USETEXT   TCEXECQ 
USETEXT   TSYMCNS 
USETEXT   TREGNOS 
USETEXT   TCOMTF
USETEXT   TCOM39Q 
USETEXT   TCOM78Q 
USETEXT   TCEXEC
USETEXT   TCOM88
USETEXT   TCOM88J 
    PROC CODGJ1;
                                        #CODGJ1 IS THE CODE GENERATOR  #
                                        # PASS 2 (CG2) MAIN CONTROL    #
                                        # PROGRAM. IT IS CALLED BY THE #
                                        # CRADLE EXECUTIVE PROGRAM     #
                                        # AFTER CG2 IS LOADED.         #
                                        # LINKAGE:   CODGJ1            #
    BEGIN 
        XREF PROC KZ00;  # CODE FILE BUFFER WRITER                     #
        XREF PROC CFW00;
        XREF PROC DCW00;
        XREF
        BEGIN 
                 PROC PTLSTV; 
            PROC CODGK1;
        END 
  
  
  
  
#     DEFS                                                             #
  
      DEF J849 #849#;              # SYMABT DIAGNOSTIC 849             # CODGJ1 
      DEF J850 #850#;              # SYMABT DIAGNOSTIC 850             # CODGJ1 
      DEF J851 #851#;              # SYMABT DIAGNOSTIC 851             # CODGJ1 
  
  
  
  
*CALL COMEX 
  
  
  
        XDEF PROC PRIORITY; 
        XDEF PROC JNSM; 
        XDEF PROC CANNED; 
        XDEF FUNC FTEMP;
        XDEF PROC IINST;
        XDEF PROC VACATE; 
        XDEF PROC LSTPRD; 
        XDEF PROC LSTADD; 
        XDEF FUNC PTAS; 
        XDEF PROC CPBRT;
        XDEF PROC LOOPCN; 
        XDEF PROC CGINVS; 
        XDEF PROC BADIV;
        XDEF PROC ENTRAU; 
        XDEF PROC CG2ABT; 
        XDEF PROC CG2STI; 
      XDEF PROC ICOVRFL;                                                 CODGJ1 
        XDEF FUNC ACSTYPE;
        XREF PROC BDT;
      XREF PROC SYMABTL;                                                 CODGJ1 
        XREF PROC INTERRUPT;
  XREF PROC NODUPL;                                                      SOPT 
        XREF PROC DB; 
        XREF
            BEGIN 
#                                                                      #
                 PROC GTICF;
                 PROC PTLST;
                 PROC BINDEC; 
                 PROC FIND; 
                 PROC BINOCT; 
                 PROC POST; 
                 PROC CHRCHR; 
#                                                                      #
            END 
   ITEM JK;                                                              SOPT 
          XREF ITEM LENICF;  #TOTAL LENGTH OF ICF FILE# 
         ITEM LENREAD =0 ;
         ITEM BEGSEQ =0;
         XREF PROC LINKOB;
         XREF PROC LINKOBS; 
  
#**********************************************************************#
  
  
      CFPS[0]=0;
        CALL CG2STI;     # INITIALIZE SYMBOL TABLE                     #
        CLC[0] = ADCNL*4;  # START LOCATION COUNTER AFTER LAST ADCON   #
        RPFN = F; # INIT. REPL INTO A PFUN FLAG                        #
        IF INTOPS LT 0 THEN CALL SDUMP(O"777"); 
$BEGIN
DB("(4X, 16HUNBEHAVED/TRACE= O1)", B<0,3>OPTION, "." ); 
$END
CG2A:   IF PTRM THEN GOTO CG2W; 
        CALL  BDT;  # READ ICF AND BUILD DEPENDENCY TREE               #
  
            REMOVENULLS;
  
          I = ICFTW1;   #CLAN MOP FROM BOTTOM#                           STOPT
CLEARMOP: I = BOL[I];                                                    STOPT
          MOP[I] =0;                                                     STOPT
           IF LOADOP[OPCD[I]] 
           AND REFCT[I] EQ 0 THEN 
             BEGIN
             OPCD[I] = QICFOP"NULL";
             OPN1[I] = 0; 
             OPN2[I] = 0; 
  
             # IF ENTRY IS ON A BASE(AND BASE+SUBS) CHAIN THEN DELINK  #
             IF BCHN[I] NQ I THEN 
             BEGIN
                 LINKOB(I); # LINKOUT BASE CHAIN                       #
                 BCHN[I] = I; 
                 LINKOBS(I); # LINK OUT BASEPLUS SUBS CHAIN            #
                 BSCHN[I] = I;
             END
             END
          IF I GE 0 THEN GOTO CLEARMOP;                                  STOPT
         I = -1;
        $BEGIN
        IF ICFTDBG1 THEN ICFTDUMP;
        $END
        KERRY = TRUE;                  #INDICATE CODGK1 IS IN OPERATION#
        CALL CODGK1; # REGISTER SELECTION, SCHEDULING AND CODE FILE WRT#
        $BEGIN
        IF ICFTDBG2 THEN CALL ICFTDUMP; 
        $END
        JAM = FALSE;
        ICFTPAD = ICFTPADINT; 
CG2J: 
        KERRY = FALSE;
CG2C: 
    # MOVE DEAD TEMPS FROM BUSY TO AVAILABLE LIST                     # 
        I = BTEMP;
        J = 0;
        IF LOOPL NE 0 THEN J = LICF[LOOPL]; 
CG2G:   IF I NE 0 THEN
            BEGIN 
                X = NTLE[I];
                IF TLUS[I] AND J GE TPCI[I] THEN
                    BEGIN 
                        IF I EQ BTEMP THEN BTEMP = X; 
                        ELSE NTLE[K] = X; 
                        NTLE[I] = ATEMP;
                        ATEMP = I;
                        I = X;
                        GOTO CG2G;
                    END 
                K = I;
                I = X;
                GOTO CG2G;
            END 
        GOTO CG2A;
  
CG2JAMRECOVR: 
        # DO THINGS NECESSARY ON JAM AND ICFT OVERFLOW RECOVERY        #
        # MOSTLY THE SAME AS CG2J EXCEPT WE ARE NOT READY YET          #
        # TO MOVE THE TEMPS TO THE AVAILABLE LIST                      #
  
        KERRY = FALSE;
        GOTO CG2A;
  
        CONTROL EJECT;
          XDEF PROC JAMM; 
        PROC JAMM;           # REBUILD CURRENT ICFT AND SET SCHEDULER 
                               TO JAM MODE     #
        BEGIN 
      DEADCODE = FALSE;      #REINITIALIZE DEAD CODE FLAG#
          RESTOREIC;    # REBUILD ICFT  # 
        JAM = TRUE; 
        GOTO CG2JAMRECOVR;
           END
  
  
  
  
          PROC RESTOREIC ;
           BEGIN
  
           # REBUILD ICFT FOR PREVIOUS SEQUENCE IT JAMMED OR OVERFLOWED#
  
        XREF PROC BKSPIC; 
        ITEM I; 
        NBI = BI; 
        I = 1-BI; 
  
        OPTERM = LASTOPTERM;
                   PTRM = FALSE;              #IN CASE THIS IS LAST SEQ# LARRY-Y
        CLC[0] = SAVECLC; 
      LENREAD = I - 1;
        BKSPIC (I); 
$BEGIN                                                                   LARRY-R
                   DB ( "(2X,15H JAM WA,BBI=            ,O6,O6)",I,NBI, 
                        "."  ); 
$END                                                                     LARRY-R
        ICFBI = NICFB +1;     # DESTROY ICF BUFFER  # 
  
        #  RESTORE LABLS IN SYMBOL TABLE TO STATE BEFORE THIS SEQ   # 
  
        FOR I = 0 STEP 1 UNTIL ICFTI-1 DO 
  
          BEGIN 
          IF OPCD[I] EQ QICFOP"LABL" THEN 
            BEGIN 
            LICF[OPN1[I]] =0; 
            LBNL[OPN1[I]] =0; 
            LBSN[OPN1[I]] = FALSE;
            FRGT[OPN1[I]] = TRUE; 
            END 
  
          IF CONDITJMP[OPCD[I]] 
          OR OPCD[I] EQ QICFOP"JP"    THEN
            BEGIN        # REFERENCE TO A LABL   #
            IF OPN1[I] GR 0 
            AND CLAS[OPN1[I]] EQ QCLAS"LABL" THEN 
              BEGIN 
              LRC[OPN1[I]] = LRC[OPN1[I]] + 1 ; 
                IF LFSR[OPN1[I]] GQ BEGSEQ
                AND LFSR[OPN1[I]] LQ SEQ THEN 
                  # LABL FIRST SEEN IN THIS SEQ  #
                LFSR[OPN1[I]] = 0;
              END 
            END 
  
          END 
  
        LOOPL =0; 
        END 
           CONTROL EJECT; 
     XDEF FUNC LOOPTEMP;
#**********************************************************************#
      FUNC LOOPTEMP((I)); 
# IF I IS NOT A LOAD OF A VARIABLE INVARIANT OVER THE LOOP THE , MAKE 
   IT USE AN UNALLOCATED TEMP TO AVOID :--
     FOR I =1 STEP 1 UNTIL J DO 
      BEGIN 
         .. 
         .. 
        J = J+ 20 
         .. 
         END
                   UGH .......
      WHERE LIMIT IS INVARIANT BUT J IS NOT.
# 
  
     BEGIN
     ITEM I;
     ITEM ST , LOT ,JSAVE  ;
     ITEM REPLI;
  
     IF OPCD[I] NQ QICFOP"LOAD" THEN
       BEGIN
NULLL:  
       JSAVE = J; 
       J =I ; 
       IINST ( QICFOP"NULL" , BI-I ,0); 
       J = JSAVE; 
       LOOPTEMP = K;
       RETURN;
       END
  
     ELSE 
  
         IF OPN1[I] GR 0 THEN 
            # SCALAR LOAD#
           LOOPTEMP = I;
         ELSE 
           GOTO NULLL;
         RETURN;
  
         END
CONTROL EJECT;
PROC REMOVENULLS; 
BEGIN  #REMOVENULLS#
  
#     THIS PROC IS CALLED RIGHT AFTER BDT TO REMOVE MULTIPLE-LINK      #
#     NULL CHAINS AND TO POINT ANY OPERANDS WHICH ARE POINTING TO      #
#     NULLS TO THE PROPER INSTRUCTION                                  #
#                                                                      #
#     NOTE THAT WE NEED DO THE TIME CONSUMING OPERATION OF CHECKING    #
#     EVERY OPERAND TO SEE IF IT IS POINTING TO A NULL ONLY            #
#     IF WE HAVE FOUND A NULL WITH A REFERENCE COUNT ON IT             #
#                                                                      #
#     WE ALSO HAVE TO HANDLE THE CASE OF A SUBS POINTING TO A NULL     #
#     (WHEN WE HAVE JUST FINISHED PROCESSING THE SUBS IN NORMAL MODE)  #
  
      ITEM I,J,K, USEDNULL; 
  
      I = 0;
      USEDNULL = 0; 
  
      ASLONGAS I GE 0 DO
         BEGIN  #FORWARD CHAIN# 
  
         # REDUCE NULL ONE LOGICAL NULL LINK                           #
         # ALSO CHECK TO SEE IF ANY OF THE NULLS ARE USED (REFCT NE 0) #
         IF OPCD[I] EQ QICFOP"NULL" THEN
            BEGIN  #NULL# 
            IF  USEDNULL EQ 0 
            AND REFCT[I] NE 0 THEN
               BEGIN  #USED NULL# 
               USEDNULL = 1;                        #NULL WITH REFCT   #
               I = 0;                               #BACK UP (FOR SUBS)#
               END  #USED NULL# 
            IF OPN1[I] LT 0 THEN
               BEGIN  #LINK NULLS#
               J = BI - OPN1[I];
               IF OPCD[J] EQ QICFOP"NULL" THEN
                  OPN1[I] = OPN1[J];                #REMOVE EXCESS LINK#
               END  #LINK NULLS#
            END  #NULL# 
  
         ELSE 
         IF USEDNULL EQ 1 THEN
            BEGIN  #CHECK OPERANDS# 
  
            # IF ANY NULLS HAVE SOMEONE RELYING ON THEM FOR A LINK,    #
            # THEN WE MUST FIND THE USES AND POINT THEM CORRECTLY      #
            J = BI - OPN1[I]; 
            IF  OPN1ST[OPCD[I]] 
            AND OPN1[I] LT 0
            AND OPCD[J] EQ QICFOP"NULL" THEN
               BEGIN  #REMOVE NULL LINK#
               K = BI - OPN1[J];
               OPN1[I] = OPN1[J]; 
               REFCT[K] = REFCT[K] + REFCT[J];
               REFCT[J] = 0;
               END  #REMOVE NULL LINK#
  
            J = BI - OPN2[I]; 
            IF  OPN2ST[OPCD[I]] 
            AND OPN2[I] LT 0
            AND OPCD[J] EQ QICFOP"NULL" THEN
               BEGIN  #REMOVE NULL LINK#
               K = BI - OPN1[J];
               OPN2[I] = OPN1[J]; 
               REFCT[K] = REFCT[K] + REFCT[J];
               REFCT[J] = 0;
               END  #REMOVE NULL LINK#
            END  #CHECK OPERANDS# 
  
         I = FOL[I];
         END  #FORWARD CHAIN# 
END  #REMOVENULLS#
    CONTROL EJECT;
    PROC PRIORITY;
                                        #PRIORITY IS CALLED AFTER THE  #
                                        # DEPENDENCY TREE IS BUILT AND #
                                        # BEFORE SCHEDULING TO DETER-  #
                                        # MINE THE PRIORITY OF EACH    #
                                        # INSTRUCTION IN THE ICFT. THE #
                                        # PRIORITY OF AN INSTRUCTION   #
                                        # IS AN ESTIMATE OF THE TIME   #
                                        # REQUIRED TO EXECUTE ALL IN-  #
                                        # STRUCTIONS THAT DEPEND UPON  #
                                        # IT  IN THE SEQUENCE, ASSUMING#
                                        # UNLIMITED FUNCTIONAL UNITS.  #
                                        # LINKAGE:   PRIORITY          #
    BEGIN 
        I = ICFTW1;  # START WITH LAST ENTRY (OPCD = "EOS")            #
      CURSEQF = 0;
        K = 0;
        IF NOSKED                # NO SCHEDULING   #
        OR JAM      THEN         # OR JAM   # 
        BEGIN # ASSIGN PRIORITIES IN DESCENDING ORDER                  #
PR5:  
            PFF1[I] = K;
            K = K+1;
            I = BOL[I]; 
            IF I GE 0 THEN GOTO PR5;
            GOTO PR90;
        END 
     # SCHEDULING ON, COMPUTE REAL PRIORITIES                          #
PR10:   I = BOL[I];  # PROCEED BACKWARDS USING BOL.                    #
        IF I GE 0 THEN
            BEGIN 
                J = STI[I]; 
                L = 0;  # REPRESENTS MAX SUCCESSOR PRIORITY # 
PR20:           IF J NE 0 THEN
                    BEGIN 
                        M = PFF1[ISUC[J]];
                        IF L LT M THEN
                            BEGIN 
                                L = M;
                                K = J;
                            END 
                        J = LSUC[J];
                        GOTO PR20;
                    END 
          IF L EQ 0 AND NOT SEQTOP[OPCD[I]] THEN OPCD[I] =               STOPT
                                              QICFOP"NULL"    ;          STOPT
                  #THAT WAS A HANGING INSTRUCTION#                       STOPT
                PFF1[I] = L+DURATE[OPCD[I]];
                # IF INSTRUCTION IS A LOAD, LOC, OR REPL WITH ACCESS   #
                # TYPE OF INDIRECT OR DOUBLE INDIRECT THEN THE         #
                # EXECUTION TIME IS DOUBLED AS A REASONABLE APPROX.    #
                IF (OPCD[I] EQ QICFOP"LOAD" OR
                    OPCD[I] EQ QICFOP"LOC" OR 
                    OPCD[I] EQ QICFOP"REPL") AND
                    AT[I] GT QAT"LCM" THEN
                    PFF1[I] = PFF1[I]+DURATE[OPCD[I]];
              IF K NQ 0 THEN      #NO PREDECESSORS MEANS NO PRIORITY   # LARRY-Y
                PFF2[I] = ISUC[K]; # ICFT INDX OF SUCCSR WITH MAX PFF1 #
      IF CURSEQF LS PFF1[I] 
      THEN
          CURSEQF = PFF1[I]; #HIGHEST PRIORITY IN SEQUENCE# 
                GOTO PR10;
            END # OF PRIORITY COMPUTATION   # 
PR90: 
    END  # PRIORITY # 
    CONTROL EJECT;
    XDEF PROC GICFB;
    PROC GICFB;      # GET ICF BUFFER                                  #
        BEGIN 
            LENREAD = LENREAD+L$ICF + 1 ; 
            NICFB = L$ICF + 1 ; 
            IF LENREAD GR LENICF THEN 
            NICFB  = LENICF-LENREAD+L$ICF+1;
            GTICF ( ICFBUF,NICFB,GICFB5 );
            ICFBI = 0;
            RETURN; 
GICFB5: # END OF FILE RETURN, THERE IS NO PTRM                         #
            CG2ABT(J849,"UNEXPECTED END-OF-FILE, NO PTRM(GICFB IN CODGJ1
) LINE XXXXX", 59); 
            GOTO CG2W;
        END # GICFB # 
    CONTROL EJECT;
#   GETEMP --  GET S.T. INDEX OF TEMP ENTRY EITHER BY USING A TEMP IN  #
#              THE AVAILABLE LIST, OR, IF THAT IS EMPTY, BY POSTING A  #
#              NEW TEMP ENTRY.                                         #
      FUNC GETEMP((X)); 
        BEGIN 
           ITEM X;       # ICF INDEX OF STORE INTO TEMP               # 
           ITEM GT1;     # TEMP REQUIRED BECAUSE I CANT USE GETEMP VALU#
           IF ATEMP NE 0 THEN # AVAILABLE TEMP LIST CONTAINS AN ENTRY  #
               BEGIN # USE ATEMP ENTRY                                 #
                   GT1 = ATEMP; 
                   ATEMP = NTLE[GT1]; 
                   TLUS[GT1] = FALSE; 
                   GOTO GTP10;
               END
           CALL POST(NONAM,TEMP$W,GT1); 
           CLAS[GT1] = S"TEMP"; 
            ASEQ[LENT[DSLC]] = GT1; 
            LENT[DSLC] = GT1; 
           LOCN[GT1] = SSIZ[DSLC];
           SSIZ[DSLC] = SSIZ[DSLC]+1; 
GTP10:     NTLE[GT1] = BTEMP; 
            TPCI[GT1] = X;
           BTEMP = GT1; 
$BEGIN
DB("( 9X12HGETEMP  STI=O6,15H  ICF STR INDX=O6)",GT1,X,".");
$END
           GETEMP = GT1;
        END # GETEMP #
    XDEF FUNC GETEMP; 
      CONTROL EJECT;
#**********************************************************************#
  
    # JNSM                                                            # 
    #     MAKES J A SUCCESSOR OF NSM, SETS LSM = BI-J, ENTERS NEW NSM  #
    #     ENTRY, AND MAKES J A PREDECESSOR OF NEW NSM.                 #
    #     NOTE -- FOR VALID COMPARISONS OF SEQUENCE NUMBERS WITH LSM,  #
    #             ONLY ORIGINAL ICF INSTRUCTIONS SHOULD BE MADE THE    #
    #             LAST SEQUENCE MARK VIA JNSM                          #
    #                                                                 # 
    PROC JNSM;
    BEGIN 
        ITEM T1,T2,T3,T4; 
        T1 = FOL[J];
        T2 = BOL[J];
        T3 = FOL[NSM];
        T4 = BOL[NSM];
    # EXCHANGE FORWARD AND BACKWARD ORDER LINKS OF J AND NSM          # 
        IF T1 EQ NSM THEN T1 == T4; 
        FOL[J] = T3;
        BOL[J] = T4;
        FOL[NSM] = T1;
        BOL[NSM] = T2;
        BOL[T1] = NSM;
        FOL[T2] = NSM;
        BOL[T3] = J;
        FOL[T4] = J;
        CALL MPRED(NSM,J); # MAKE NSM A PREDECESSOR OF J.             # 
        LSM = BI-J;  # MAKE J THE NEXT SEQUENCE MARK #
        J = T3; 
        CALL IINST(QICFOP"NULL",0,0); 
        NSM = K;
        J = BI-LSM; 
        CALL MPRED(J,NSM); # MAKE J A PREDECESSOR OF NEW NSM           #
$BEGIN
DB("( 9X10HJNSM  LSM=O6,8H  NSM=J=O6)",LSM,J,".");
$END
    END # JNSM #
CONTROL EJECT;
    PROC CANNED(CCA); 
                                        #CANNED IS USED TO COPY        #
                                        # SEQUENCES OF INSTRUCTIONS    #
                                        # FROM THE CANNED CODE ARRAYS  #
                                        # TO THE ICFT AND THEN TO CAUSE#
                                        # THOSE INSTRUCTIONS TO BE     #
                                        # WRITTEN TO THE CODE FILE.    #
                                        # EACH CANNED CODE ARRAY IS A  #
                                        # CONSTANT SEQUENCE OF         #
                                        # INSTRUCTIONS. CANNED MAY BE  #
                                        # CALLED WITH ANY OF THE CANNED#
                                        # CODE ARRAYS AS ITS PARAMETER #
                                        # AND WILL CAUSE ALL THE       #
                                        # INSTRUCTIONS IN THE PARAMETER#
                                        # ARRAY TO BE WRITTEN TO THE   #
                                        # CODE FILE.                   #
                                        # LINKAGE:   CANNED(CCA)       #
    BEGIN 
        ARRAY CCA[0:1] S(1);
            ITEM  CCOP I (0,9,9), 
                  CCIDES U (0,18,3),
                  CCJDES U (0,21,3),
                  CCKDES I (0,24,18), 
                  CCST   I (0,42,18), 
                  CCLAST B (0,8,1); 
        ITEM CCI,CCJ; 
        IF JAM THEN RETURN  ;  # DONT OUTPUT IF JAM  WE DID IT BEFORE  #
        CCI = 0;
        CCJ = ICFTI+2;
CAN1:   FOL[CCJ-1] = CCJ; 
        ICFW0[CCJ] = 0;                        #JUST TO BE SAFE....    # LCMISC 
        ICFW1[CCJ] = 0;                                                  LCMISC 
        ICFW2[CCJ] = 0;                                                  LCMISC 
        ICFW3[CCJ] = 0;                                                  LCMISC 
        ICFW4[CCJ] = 0;                                                  LCMISC 
        ICFW5[CCJ] = 0; 
        BCHN[CCJ] = CCJ;
        BSCHN[CCJ] = CCJ; 
        FOL[CCJ] = -1;
        MOP[CCJ] = CCOP[CCI]; 
        IDES[CCJ] = CCIDES[CCI];
        JDES[CCJ] = CCJDES[CCI];
        KDES[CCJ] = CCKDES[CCI];
        OPN1[CCJ] = CCST[CCI];
$BEGIN
DB("( 9X19HCANNED  MOP,K,OPN1=O3,3XO6,3XO6)",MOP[CCJ],KDES[CCJ],OPN1[CCJ
    ],"."); 
$END
        CCJ = CCJ+1;
        CCI = CCI+1;
        IF NOT CCLAST[CCI-1] THEN GOTO CAN1;
        CALL CFW00(ICFTI+2); # COPY STUFF TO CODE FILE #
    END  # CANNED  #
CONTROL EJECT;
    # FTEMP --- FIND TEMP COMPUTED AT ICF INDEX X.                     #
    #                                                                  #
          FUNC FTEMP ( (X) ) ;
        BEGIN 
            ITEM X,Y; 
            Y = BTEMP;
FT10:       IF Y EQ 0 THEN
                BEGIN 
            CG2ABT(J850,"CANT FIND TEMP(FTEMP IN CODGJ1) LINE XXXXX", 
                   42); 
                   Y = GETEMP(0); #GET A TEMP, JUST TO BE NICE         #
                   GOTO FT20; 
                END 
            IF X NE TPCI[Y] THEN
                BEGIN 
                    Y = NTLE[Y];
                    GOTO FT10;
                END 
FT20: 
            FTEMP = Y;
$BEGIN
DB("( 9X12HFTEMP  ICFX=O6, 9H  S.T.I.=O6)",X,Y,".");
$END
        END # FTEMP # 
CONTROL EJECT;
#  MPRED -- MAKE PREDECESSOR LINK INSERTION                           # 
#     MPRED IS THE ONLY ROUTINE IN CG2 THAT USES THE ICFT IN A         #
#     REACTIVE WAY, THEREFORE WE CAN MAKE ICFT/CG2 WELLBEHAVED         #
#     IF WE CAN STOP THE SCHEDULER FROM DOING ALL THE REACTIVE         #
#     STUFF IN MPRED                                                   #
#                                                                      #
#     WE DO THIS BY INSERTING CALLS TO A DO-NOTHING PROC               #
#                                                                      #
#     WE GET SOME DEGRADATION OF MPRED, BUT SHOULD IMPROVE CG2         #
#     IN THE WHOLE                                                     #
         XDEF PROC MPRED; 
          PROC MPRED ( (P) , (S) ) ;
             BEGIN # MPRED #
                 ITEM P;     # PREDECESSOR INSTRUCTION ICFT INDEX     # 
                 ITEM S;     # SUCCESSOR INSTRUCTION ICFT INDEX       # 
                 IF P EQ S THEN GOTO MP10; # DONT MAKE LOOP IN D.T.   # 
   $BEGIN 
   IF P LT -1                                  #SPECIAL IRON CLAD MPRED#
   OR P GT ICFTW1                              #(IMPOSSIBLE TO MAKE BAD#
   OR S LT -1                                  #MPRED CALL NOW )       #
   OR S GT ICFTW1 
   OR P EQ S THEN 
      BEGIN 
      DB("(/, 44H **BANG YOU*RE DEAD - BAD MPRED CALL IGNORED / )",".");
      GOTO MP10;
      END 
   $END 
         IF STI[P] NQ 0 AND ISUC[STI[P]] EQ S THEN GOTO  MP10;           SOPT 
           #DONT KEEP ADDING THE SAME OLD THING -- ITS USELESSS#         SOPT 
                 NPRED[S] = NPRED[S]+1; 
                 INTERRUPT;                    #BREAK SCHEDULING       #
                 SUCTI = SUCTI+1; 
                 ISUC[SUCTI] = S; 
                 INTERRUPT;                    #BREAK SCHEDULING       #
                 LSUC[SUCTI] = STI[P];
                 INTERRUPT;                    #BREAK SCHEDULING       #
                 STI[P] = SUCTI;
MP10: 
$BEGIN
DB("(9X9HMPRED  P=O6,5H   S=O6,10H   CALLER=O16)",P,S,MPRED,"."); 
$END
             END # OF MPRED # 
CONTROL EJECT;
#  IINST -- INSERT INSTRUCTION -- LINKS A NEW INSTRUCTION INTO ICFT    #
#                                                                      #
#      INPUT - J      - LOGICAL SUCCESSOR OF NEW INSTRUCTION           #
#      OUTPUT- K      - ICFT INDEX OF NEW INSTRUCTION                  #
#                                                                      #
#      IF THE ICFT SHOULD OVERFLOW DURING BDT, THERE IS NO HOPE OF     #
#      RECOVERY SINCE THERE IS NO EXISTING MECHANISM TO REBUILD THE    #
#      ICFT IN BDT AND MAKE IT SMALLER NEXT TIME.  SAY GOOD BYE....    #
  
      PROC IINST((OP),(OP1),(OP2)); 
         BEGIN # IINST #
             ITEM  OP    ;         # INSTRUCTION OPCODE # 
             ITEM  OP1   ;         # OPERAND 1 POINTER  # 
             ITEM  OP2   ;         # OPERAND 2 POINTER  # 
             ICFTJ = ICFTJ-1; 
             K = ICFTJ; 
             ICFW0[K] = 0;
             ICFW1[K] = 0;
             ICFW2[K] = 0;
             ICFW3[K] = 0;
             ICFW4[K] = 0;
             ICFW5[K] = 0;
             BCHN[K] = K;  # SET BASE CHAIN LINK                       #
             BSCHN[K] = K;  # SET BASE+SUBS CHAIN LINK                 #
             OPCD[K] = OP;  OPN1[K] = OP1;  OPN2[K] = OP2;
            CNO[K] = K; # MAKE INSTRUCTION POINT TO ITSELF            # 
          #  INSERT NEW LOGICAL ORDER LINKS                           # 
             BOL[K] = BOL[J]; 
             FOL[K] = J;
             BOL[J] = K;
             FOL[BOL[K]] = K; 
   MRKS[K] = MRKS[J];                                                    SOPT 
   JK = J ;  #SAVE J#                                                    SOPT 
          IF DUPOPC [OPCD[J] ] THEN NODUPL;                              SOPT 
                    #CHECK FOR DUPLICATE INTRUCTION IN CURRENTLY AVAIL.  SOPT 
                        SEQUENCE#                                        SOPT 
  J= JK;                                                                 SOPT 
             IF ICFTJ LQ ICFTI
             THEN 
               BEGIN
               CG2ABT(-J851, "ICFT OVERFLOW (IINST) LINE XXXXX", 32); 
               END
  
$BEGIN
DB("(9X21HIINST  J,K,OP,OP1,2= O6,2XO6,2XO3,2XO6,2XO6,4H CA=O16)",J,K,
    OP,OP1,OP2,IINST,".");
$END
         END # IINST #
CONTROL EJECT;
    PROC VACATE(LN);
                                        #VACATE IS USED TO ADD A LIST  #
                                        # TO THE FREE LIST. THE ARGU-  #
                                        # MENT TO VACATE IS THE LIST   #
                                        # HEAD LINK, I.E. THE INDEX OF #
                                        # THE FIRST ENTRY IN THE LIST. #
        BEGIN  # VACATE  #
            ITEM LN;  # LIST NAME    #
            ITEM VT1,VT2; # TEMPS  #
            VT1 = LN; 
VC10:       IF VT1 NE 0 THEN # ADD LIST ELEMENT TO FREE LIST          # 
                BEGIN 
                    VT2 = FREEL;
                    FREEL = VT1;
                    VT1 = LISTL[VT1]; 
                    LISTL[FREEL] = VT2; 
                    GOTO VC10;
                END 
$BEGIN
DB("(9X13HVACATE  LIST=O6,12H  CALL ADDR=O16)",LN,VACATE ,"."); 
$END
        LN = 0; 
        END # VACATE  # 
CONTROL EJECT;
          PROC LSTPRD ( (T1) , (S) ) ;
                                        #LSTPRD IS USED TO MAKE EACH   #
                                        # INSTRUCTION IN A LIST OF     #
                                        # INSTRUCTIONS A PREDECESSOR   #
                                        # OF A GIVEN INSTRUCTION. THE  #
                                        # FIRST ARGUMENT IS THE INDEX  #
                                        # OF THE FIRST ENTRY IN THE    #
                                        # LIST. THE SECOND ARGUMENT IS #
                                        # THE ICFT INDEX OF THE        #
                                        # INSTRUCTION WHICH IS TO BE A #
                                        # SUCCESSOR OF ALL LIST ENTRIES#
                                        # LINKAGE:  LSTPRD(LIST,       #
                                        # SUCCESSOR)                   #
        BEGIN # LSTPRD #
          ITEM T1;   # LIST HEAD LINK#
            ITEM S;   # ICFT INDEX OF SUCCESSOR INSTRUCTION           # 
            $BEGIN
            ITEM L;                            #FOR DEBUG PRINT MSG    #
            L = T1; 
            $END
LSP10:      IF T1 NE 0 THEN 
                BEGIN 
                    CALL MPRED(BI-LISTI[T1],S); 
                    T1 = LISTL[T1]; 
                    GOTO LSP10; 
                END 
$BEGIN
DB("(9X13HLSTPRD  LIST=O6,8H   SUCC=O6,13H   CALL ADDR=O16)",L,S, 
    LSTPRD,".");
$END
        END # LSTPRD #
CONTROL EJECT;
# LSTADD ADDS A LIST ELEMENT TO A LIST. THE LIST IS IDENTIFIED BY     # 
# PARAMETER "LIST", THE ELEMENT BY PARAMETER "MEMBER". THE SPACE FOR  # 
# THE NEW LIST ELEMENT IS OBTAINED FROM THE FREE LIST.                # 
# "MEMBER" IS CONVERTED FROM  AN ICFT TO A NEGATIVE ICF INDEX.        # 
      PROC LSTADD(LIST,(MEMBER)); 
        BEGIN # LSTADD #
            ITEM LIST;    # HEAD LINK IN LIST # 
            ITEM MEMBER;  # ICFT INDEX OF INSTRUCTION TO ADD TO LIST  # 
            ITEM LATP;
            ITEM OLDLIST; 
            OLDLIST = LIST; 
            IF FREEL EQ 0 THEN
                BEGIN # FREE LIST IS EMPTY, ADD 5 ELEMENTS TO IT #
                    ICFTJ = ICFTJ - 1;
                    FREEL = ICFTJ;
                    LISTL[ICFTJ] = ICFTJ+ICFTNE;
                    LISTL[ICFTJ+ICFTNE] = ICFTJ+ICFT2NE;
                    LISTL[ICFTJ+ICFT2NE] = ICFTJ+ICFT3NE; 
                    LISTL[ICFTJ+ICFT3NE] = ICFTJ+ICFT4NE; 
                    LISTL[ICFTJ+ICFT4NE] = ICFTJ+ICFT5NE; 
                    LISTL[ICFTJ+ICFT5NE] = 0; 
                END # OF ADDITIONS TO FREE LIST # 
            LISTI[FREEL] = BI-MEMBER; 
            LATP = LIST;                # SAVE LIST POINTER # 
            LIST = FREEL;               # ADD NEW MEMBER TO LIST #
            FREEL = LISTL[FREEL];       # DELETE FREE LIST MEMBER # 
            LISTL[LIST] = LATP; 
$BEGIN
DB("(9X, 13HLSTADD  LIST= O6, 10H  OLDLIST= O6, 7H  MEMB= O6, 
     12H  CALL ADDR= O16)", LIST, OLDLIST, MEMBER, LSTADD, ".");
$END
        END # LSTADD  # 
CONTROL EJECT;
    # PTAS -- COMPUTE TYPE AND SIZE OF PARAMETER OR FUNCTION VALUE    # 
    #         IF PARAMETER IS "CALL BY NAME", RESULT IS 0.            # 
    #         OTHERWISE RESULT IS NUMBER OF WORDS IN VALUE            # 
   #                                                                  # 
          FUNC PTAS ( (X) ) ; 
       BEGIN
          ITEM X; # SYMBOL TABLE INDEX OF PARAMETER OR FUNC ENTRY     # 
          PTAS = 0; # INITIALLY, ASSUME ITS CALL BY NAME              # 
          IF CLAS[X] NE S"FUNC" AND FPRI[X] NE S"VALU" THEN GOTO PTAS20;
          PTAS = 1; # NOW ASSUME VALUE IS ONE WORD LONG               # 
          IF TYPE[X] EQ S"HLTH" OR TYPE[X] EQ S"TRAN" OR
              TYPE[X] EQ S"EBCD" THEN PTAS = (NBYT[X]+9)/10;
PTAS20: 
$BEGIN
DB("( 9X 8HPTAS  X=O6,10H  CLAS[X]=O2,10H  TYPE[X]=O2)",X,CLAS[X],
    TYPE[X],"."); 
$END
        END # PTAS #
CONTROL EJECT;
#  ACSTYPE  --  CALCULATE ACSTYPE FOR A GIVEN VARIABLE                 #
#               INPUT IS THE SYMBOL TABLE INDEX FOR THE VARIABLE       # LARRY-R
#               CALCULATES ACSTYPE FOR THE DIFFERENT CORE ACCESS LEVELS# LARRY-R
#                                                                      # LARRY-R
#               FORMAL BASED ARRAYS MUST BE SCM/SCM/SCM (AT THIS TIME) # LARRY-R
#               PARMS HAVE AN IMPLICIT FIRST FETCH IN SCM(SCM/WHATEVER)# LARRY-R
#               LOCAL BASED ARRAYS CAN BE "ANYWHERE"                   # LARRY-R
#                                                                      #
#               SINCE THIS ROUTINE KNOWS NOTHING ABOUT THE OFFS/SUBS   #
#               STRUCTURE IT IS NOT CORRECT FOR PFUNCS                 #
  
FUNC ACSTYPE((STI));
BEGIN  #ACSTYPE#
  
      ITEM  STI,MOM,BASD B;                                              LARRY-R
      ITEM  CAT S:QAT,CLASS S:QCLAS;                                     LARRY-R
                                                                         LARRY-R
      CLASS = CLAS[STI];                       #SET CONVENIENCE TEMPS  # LARRY-R
      CAT = S"NULL";                                                     LARRY-R
                                                                         LCMISC 
    IF CKUSES[CLASS] THEN                      #FORGIVE THIS INDENTING # LCMISC 
      BEGIN  #NORMAL VARIABLE#                                           LCMISC 
      IF CLASS EQ S"TABL" THEN                                           LARRY-R
         BEGIN  #TRANSFORM#                                              LARRY-R
         MOM = STI;                            #MAKE TABL A TITM       # LARRY-R
         STI = BABY[STI];                                                LARRY-R
         END  #TRANSFORM#                                                LARRY-R
                                                                         LARRY-R
       ELSE                                                              LARRY-R
      IF CLASS EQ S"TITM"                                                LARRY-R
         THEN MOM = MAMA[STI];                                           LARRY-R
         ELSE MOM = STI;                                                 LARRY-R
      BASD = TORT[CLASS]                       #BASED SHOWS BA HERE    # LARRY-R
             AND TTYP[MOM] EQ S"BASED";                                  LARRY-R
                                                                         LARRY-R
      IF  CKPARM[CLASS]                        #CHECK IF PARM          # LARRY-R
      AND FPRI[MOM] EQ S"NAMC" THEN                                      LARRY-R
         BEGIN  #PARM#                                                   LARRY-R
         IF BASD THEN                          #FORMAL BASED ARRAY     # LARRY-R
            CAT = S"SSSCM";                                              LARRY-R
         ELSE                                                            LARRY-R
            BEGIN  #NOT BASED#                                           LARRY-R
            IF LEVL[STI] EQ S"LEV1"                                      LARRY-R
               THEN CAT = S"SSCM";                                       LARRY-R
               ELSE CAT = S"SLCM";                                       LARRY-R
            END  #NOT BASED#                                             LARRY-R
         BASD = F;                             #RESET FOR FORMAL BA    # LARRY-R
         END  #PARM#                                                     LARRY-R
                                                                         LARRY-R
      IF BASD THEN                             #LOCAL BASED ARRAY      # LARRY-R
         BEGIN  #LOCAL BA#                                               LARRY-R
         IF LEVL[STI] EQ S"LEV1" THEN                                    LARRY-R
            BEGIN  #SCM TITM#                                            LARRY-R
            IF LEVL[MOM] EQ S"LEV1"                                      LARRY-R
               THEN CAT = S"SSCM";                                       LARRY-R
               ELSE CAT = S"LSCM";                                       LARRY-R
            END  #SCM TITM#                                              LARRY-R
         ELSE                                                            LARRY-R
            BEGIN  #LCM TITM#                                            LARRY-R
            IF LEVL[MOM] EQ S"LEV1"                                      LARRY-R
               THEN CAT = S"SLCM";                                       LARRY-R
               ELSE CAT = S"LLCM";                                       LARRY-R
            END  #LCM TITM#                                              LARRY-R
         END  #LOCAL BA#                                                 LARRY-R
                                                                         LARRY-R
      IF CAT EQ S"NULL" THEN                   #SCALAR                 # LARRY-R
         BEGIN  #SCALAR#                                                 LARRY-R
         IF LEVL[STI] EQ S"LEV1"                                         LARRY-R
            THEN CAT = S"SCM";                                           LARRY-R
            ELSE CAT = S"LCM";                                           LARRY-R
         END  #SCALAR#                                                   LARRY-R
      END  #NORMAL VARIABLE#                                             LCMISC 
                                                                         LCMISC 
      ELSE                                                               LCMISC 
      IF CKPARM[CLASS] THEN                    #CHECK FOR FORMAL PROC  # LCMISC 
         BEGIN  #PARM#                                                   LCMISC 
         IF FPRI[STI] EQ S"NAMC"                                         LCMISC 
            THEN CAT = S"SSCM";                #ARG IS FORMAL PARM     # LCMISC 
            ELSE CAT = S"SCM";                                           LCMISC 
         END  #PARM#                                                     LCMISC 
                                                                         LCMISC 
ACS90:                                                                   LCMISC 
      ACSTYPE = CAT;                                                     LARRY-R
  
END  #ACSTYPE#
CONTROL EJECT;
#   CPBRT --  CONVERT PARAMETER AND BASED ITEM REFERENCES TO USE TABLE #
#             ENTRY.                                                   #
#                                                                      #
      PROC CPBRT(OS,(SS),ST); 
        BEGIN 
            ITEM OS ;  # ICFT INDEX OF "OFFS" ENTRY, NEGATIVE IF NONE # 
            ITEM SS ;  # ICFT INDEX OF "SUBS" ENTRY IF THERE IS ONE   # 
            ITEM ST ;  # S.T. INDEX OF ITEM                           # 
$BEGIN
DB("( 9X10HCPBRT  OS=O6,5H  SS=O6,5H  ST=O6)",OS,SS,ST,".");
$END
            IF CLAS[ST] EQ S"TITM" OR CLAS[ST] EQ S"STRG" THEN
                BEGIN 
                    IF OS GE 0 THEN 
                        BEGIN 
                            OPN2[OS] = OPN2[OS]+LOCN[ST]; 
                        END 
                    ELSE
                        BEGIN 
                            CALL IINST(QICFOP"OFFS",ST,LOCN[ST]); 
                            OPN1[SS] = BI-K;
                            OS = K; 
                        END 
                    ST = MAMA[ST];
                    OPN1[OS] = ST;
                END 
        END # CPBRT # 
CONTROL EJECT;
    # LOOPCN -- CHECK TO SEE IF OPERAND POINTER I IS A LOOP CONSTANT  # 
    #     K =  S.T. INDEX IF LOOP CONSTANT, OTHERWISE, K IS NEGATIVE  # 
    #                                                                 # 
    PROC LOOPCN;
        ITEM T1;
        BEGIN 
            K = -1; 
            IF I LT 0 THEN
                BEGIN # I REPRESENTS A COMPUTATION  # 
                    T1 = BI-I;
                    IF T1 GT LOPLAB THEN GOTO LC50; 
                    IF T1 GE 0 AND OPN1[T1] EQ 0 THEN 
                    BEGIN # OPERAND IS A SAVE THAT NEEDS A TEMP        #
                        OPN1[T1] = GETEMP(I); 
                    END 
                    K = FTEMP(I); # FIND TEMP THAT CONTAINS I"S VALUE  #
                END 
            ELSE
                IF NOT RICS[I] OR LSEQ[I] NE SEQ THEN   K = I;
LC50: 
$BEGIN
DB("( 9X10HLOOPCN  I=O6,5H   K=O6)",I,K,"."); 
$END
        END 
CONTROL EJECT;
    # CGINVS -- CHECK IF "I", (THE S.T. INDEX OF AN INDUCTION VARIABLE)#
    #           IS IN THE GOOD INVS LIST. IF IT IS, K = THE ICFT INDEX #
    #           OF THE INVS. IF NOT, K = -1.                           #
    #                                                                  #
    PROC CGINVS;
        BEGIN 
            ITEM T1;
            K = -1; 
            T1 = GINVS; 
C10:        IF T1 GE 0 THEN 
                BEGIN 
                   IF I EQ OPN1[BI-OPN1[T1]] THEN 
                       BEGIN
                           K = T1;
                           GOTO C20;
                       END
                   T1 = KDES[T1]; 
                   GOTO C10;
                END 
C20:  
$BEGIN
  DB("( 9X10HCGINVS  I=O6,4H  K=O6)",I,K,".");                           PSRSIA 
$END
        END 
CONTROL EJECT;
    # BADIV -- MOVES FROM GOOD INVS LIST TO BAD INVS LIST, THE INVS AT #
    #          ICFT INDEX I                                            #
    #                                                                  #
    PROC BADIV; 
        BEGIN 
            ITEM T1;
            T1 = GINVS; 
            IF GINVS EQ I THEN
                BEGIN 
                    GINVS = KDES[I];
                    GOTO B20; 
                END 
B10:        IF KDES[T1] EQ I THEN 
                BEGIN 
                    KDES[T1] = KDES[I]; 
                    GOTO  B20;
                END 
            T1 = KDES[T1];
            GOTO  B10;
B20:        KDES[I] = BINVS;
            BINVS = I;
$BEGIN
DB("( 9X9HBADIV  I=O6)",I,"."); 
$END
        END 
CONTROL EJECT;
#  ENTRAU ---  ENTER AU TABLE WITH PARCEL SAVINGS COUNT               # 
PROC ENTRAU((I),(J),(ATP));                                              LARRY-R
        BEGIN  # ENTRAU # 
                        # I - SYMBOL TABLE INDEX OF ENTITY             # LARRY-R
                        # J - OFFSET FROM THE BASE ADDRESS             # LARRY-R
            ITEM ATP;   # ACCESS TYPE, 0-DIRECT, 1-INDIRECT, 2-DBL.IND.#
            ITEM  I,J,K;
            ITEM  TPARS; # TEMPORARY PARCEL SAVINGS # 
            K = CLAS[I];
                IF K EQ QCLAS"TITM" OR K EQ QCLAS"STRG" THEN
                BEGIN # CONVERT TO TABLE ADDRESS AND OFFSET # 
                    J = J+LOCN[I]-LOCN[MAMA[I]];
                    I = MAMA[I];
                END 
            TPARS = AUSAVNG[ATP];              #GET PARCEL SAVINGS     # LARRY-R
            IF  OPCD[ICFTI] EQ QICFOP"PFUN"    #CAN"T GET CORRECT J    #
            AND K EQ QCLAS"TABL" THEN          #LOOKING FOR A PFUN     #
               TPARS = -TPARS;                 #WELB PFUN HAS NEG SAVNG#
            IF NICLOP THEN TPARS = TPARS*8; #INCREASE SAVING IF IN LOOP#
            FOR K = LASTAU STEP -1 UNTIL 0  DO
                BEGIN 
                    IF AUADD[K] EQ I THEN 
                        BEGIN 
#     TURN ON RPFN IF 1ST USE OF ARRAY IN THIS SEQ IS A REPL INTO PFUN #
                        RPFN = IDRV[K]; 
                        IF AUOFF[K] EQ J AND ATP EQ ACTP[K] THEN
                            BEGIN 
                                PSAVE[K] = PSAVE[K]+TPARS;
                                AUIL[K] = NICLOP; 
                                QSAVE[K] = QSAVE[K] + 1;                 LARRY-R
                                GOTO ENT90; 
                            END 
                        END  #AUADD[K] EQ I#
                END 
            IF LASTAU LT AUSIZE THEN
                BEGIN 
                    LASTAU = LASTAU+1;
                    # IF ITS A REPL INTO A PFUN, SET IDRV T, ELSE F    #
                    IF RPFN THEN IDRV[LASTAU] = TRUE; 
                            ELSE IDRV[LASTAU] = FALSE;
                    AUADD[LASTAU] = I;
                    AUOFF[LASTAU] = J;
                    PSAVE[LASTAU] = -1; 
                    AUIL[LASTAU] = NICLOP;
                    IF NICLOP THEN PSAVE[LASTAU] = TPARS; 
                    ACTP[LASTAU] = ATP; 
                    QSAVE[LASTAU] = 0;                                   LARRY-R
                    AUISSU[LASTAU] = FALSE;                              LARRY-R
                    K = LASTAU;                  #SET FOR DEBUG PRINT  # LARRY-R
                END 
ENT90:  
            RPFN = FALSE; # ALWAYS SET IT FALSE                        #
$BEGIN
DB("( 9X, 11HENTRAU  ST= O6, 6H  OFF= O6, 6H  ATP= O2, 8H  PSAVE= O3,    LARRY-R
      8H  QSAVE= O2, 4H  K= O2)", I, J, ATP, PSAVE[K], QSAVE[K], K,"."); LARRY-R
$END
        END  # ENTRAU # 
   CONTROL  EJECT;                                                       SOPT 
    XDEF PROC ADDARRY;                                                   SOPT 
      #ADD THE S.T. INDEX OF TABLE TO ARRAY LIST -----                   SOPT 
                IF IT ISNT ALREADY THERE#                                SOPT 
          PROC ADDARRY ( (MUM) ) ;
    BEGIN                                                                SOPT 
      ITEM MUM;   #ADDRESS OF TABLE BEING REFERENCED:#                   SOPT 
      ITEM I;                                                            SOPT 
$BEGIN
DB("(9X, 12HADDARRY MUM= O6, 9H  CALLER= O16)", MUM, ADDARRY, "." );
$END
      I = ARLIST;                                                        SOPT 
NEXTARRY:                                                                SOPT 
      IF I EQ 0 THEN                                                     SOPT 
        BEGIN                                                            SOPT 
        LSTADD ( ARLIST , BI-MUM);  #N.B. ITS AN S.T. INDEX#             SOPT 
        RETURN;                                                          SOPT 
        END                                                              SOPT 
      IF MUM EQ LISTI [I] THEN RETURN;   #ITS THERE ALREADY#             SOPT 
      I = LISTL [I];                                                     SOPT 
      GOTO NEXTARRY;                                                     SOPT 
    END  #ADDARRY#                                                       SOPT 
                                                                         SOPT 
                                                                         SOPT 
                                                                         SOPT 
      #EMPTY THE USES LISTS OF ALL TABLES AND THEIR TITMS IN ARLIST#     SOPT 
    XDEF PROC CLEANARRY;                                                 SOPT 
    PROC CLEANARRY;                                                      SOPT 
      BEGIN                                                              SOPT 
      ITEM I,J,K ;                                                       SOPT 
      I = ARLIST;                                                        SOPT 
NEXTMAMA:                                                                SOPT 
      IF I EQ 0 THEN                                                     SOPT 
        BEGIN                                                            SOPT 
        VACATE(ARLIST);                                                  SOPT 
        RETURN;                                                          SOPT 
        END                                                              SOPT 
      J =LISTI [I] ;             #TABLE NAME#                            SOPT 
      K = BABY [ J] ;    # FIRST TITM#                                   SOPT 
NEXTBABY:                                                                SOPT 
      IF USES [J] NQ 0 THEN                                              SOPT 
        BEGIN                                                            SOPT 
         # EMPTY THAT LIST#                                              SOPT 
IF LSEQ[J] EQ SEQ THEN
        VACATE (USES [J] ) ;                                             SOPT 
        USES [J] = 0 ;                                                   SOPT 
        END                                                              SOPT 
      LDST[J] = 0;
      IF K NQ 0 THEN                                                     SOPT 
        BEGIN                                                            SOPT 
        J = K ;                                                          SOPT 
        K = ASEQ [K] ;          # NEXT BABY#                             SOPT 
        GOTO NEXTBABY;                                                   SOPT 
        END                                                              SOPT 
      I = LISTL [I] ;                                                    SOPT 
      GOTO NEXTMAMA;                                                     SOPT 
    END                                                                  SOPT 
CONTROL EJECT;
PROC ICOVRFL; 
          BEGIN 
  
  
        #    ICFT HAS OVERFLOWED DURING SCHEDULING (K1) 
             REBUILD THE TREE SELECTING A SHORT SEQUENCE             #
  
  
#        IF ICFTPAD IS LARGER THAN THE ICFT SIZE, WE ARE IN DEEP       #
#        TROUBLE AND HAVE NO HOPE OF RECOVERY.  SAY GOOD NIGHT....     #
  
         IF ICFTPAD GR ICFTNE-100 THEN
           BEGIN
           CG2ABT(-J851,"ICFT OVERFLOW(CODGJ1-ICOVRFL) LINE XXXXX",40); 
           END
  
           RESTOREIC ;     # BACK SPACE ICF AND RESET FLAG,SYMBOL TAB  #
  
           ICFTPAD = ICFTPAD + ICFTPADINC;
                       # SELECT SHORT SEQ  #
           GOTO CG2JAMRECOVR; 
  
           END
  
CONTROL EJECT;
PROC CG2ABT((ABTNUM), STRING, (STRLENGTH)); 
BEGIN  #CG2ABT# 
  
#     THIS ROUTINE HANDLES ALL ABORTS COMING OUT OF CG2.               #
#                                                                      #
#     THE FUNCTION OF THIS ROUTINE IS TO ISSUE AN ICFT DUMP IF THIS    #
#     IS A DEBUG COMPILER, AND TO CALL SYMABTL.                        #
#                                                                      #
#     THE CALL TO SYMABTL ADDS THE LINE NUMBER AND NEGATES THE ABORT   #
#     NUMBER.  (ALL ABORTS FROM CG2 CAN RETURN TO THE CALLER.)         #
  
      ITEM ABTNUM;                 # ABORT NUMBER                      #
      ITEM STRING C(10);           # TEXT OF ABORT MESSAGE             #
      ITEM STRLENGTH;              # ACTUAL LENGTH OF MESSAGE          #
  
      $BEGIN
      ICFTDUMP;                    # GET ICFT DUMP IF DEBUG COMPILER   #
      $END
  
      SYMABTL(-ABTNUM, STRING, STRLENGTH, LINE);
  
END  #CG2ABT# 
CONTROL EJECT;
    PROC CG2STI;
                                        #CG2STI INITIALIZES THE SYMBOL #
                                        # TABLE FOR CG2.               #
                                        # LINKAGE:   CG2STI            #
    BEGIN 
        I = SYMSTART; 
SI1:  
        SWITCH SISW:QCLAS 
          SI900:NULL, 
      $ADCN:ADCN, $BPAR:BPAR, $COMM:COMM, $CONS:CONS, 
      $DATA:DATA, $DEF:DEF, $DUMY:DUMY, 
      $DTXT:DTXT, $EMPT:EMPT, 
      $FPAR:FPAR, $FUNC:FUNC, $INSC:INSC, $LABL:LABL, 
      $NAME:NAME, $PROC:PROC, $PROG:PROG, 
      $SCON:SCON, $SLC:SLC,   $STSL:STSL, $SWCH:SWCH, 
      $TABL:TABL, $TEMP:TEMP, $TEXT:TEXT, $TITM:TITM; 
        GOTO SISW[CLAS[I]]; 
$ADCN:  
        WELB[I] = TRUE;                             #ADCN IS WELLBEHAVD#
        I = I+ADCN$W; 
        GOTO SI1; 
$BPAR:  
        I = I+BPAR$W; 
        GOTO SI1; 
$COMM:  
        I = I+COMM$W; 
        GOTO SI1; 
$CONS:  
         LDST[I]=0;                                                      J1/B 
        BREG[I] = 0;
        LSEQ[I] = 0;
        USES[I] = 0;
        WELB[I] = TRUE;                             #CONS IS WELLBEHAVD#
        I = I+CONS$W; 
        GOTO SI1; 
$DATA:  
        LSEQ[I] = 0;
        USES[I] = 0;
        BREG[I] = 0;
        I = I+DATA$W; 
        GOTO SI1; 
$DEF: 
        I = I+DEF$W;
        GOTO SI1; 
$DTXT:  
          I = I + (NCHR[I] + (BYTNDEFWD*2 -1) ) / BYTNDEFWD;
          GOTO SI1; 
$DUMY:  
        I = I+DUMY$W; 
        GOTO SI1; 
$EMPT:  
        I = I + EMPT$W; 
        GOTO SI1; 
$FPAR:  
        I = I+FPAR$W; 
        GOTO SI1; 
$FUNC:  
        I = I+FUNC$W; 
        GOTO SI1; 
$INSC:  
        I = I+INSC$W; 
        GOTO SI1; 
$LABL:  
        LBSN[I] = FALSE;
        LFSR[I] = 0;
        FRGT[I] = TRUE; 
        I = I+LABL$W; 
        GOTO SI1; 
$NAME:  
        I = I+(NCHR[I]+19)/10;
        GOTO SI1; 
$OVER:  
        I = I+OVER$W; 
        GOTO SI1; 
$PROC:  
        I = I+PROC$W; 
        GOTO SI1; 
$PROG:  
        I = I+PROG$W; 
        GOTO SI1; 
$SCON:  
        I = I+SCON$W; 
        GOTO SI1; 
$SLC: 
        I = I+SLC$W;
        GOTO SI1; 
$STSL:  
        I = I + STSL$W; 
        GOTO SI1; 
$SWCH:  
        I = I+SWCH$W; 
        GOTO SI1; 
$TABL:  
         LDST[I]=0;                                                      21FEB77
        LSEQ[I] = 0;
    USES[I] = 0;      #MAKE USES LIST EMPTY#                             SOPT 
        I = I+TABL$W; 
        GOTO SI1; 
$TEMP:  
        LSEQ[I] = 0;
        USES[I] = 0;
        WELB[I] = TRUE;                             #TEMP IS WELLBEHAVD#
        BREG[I] = 0;
        I = I+TEMP$W; 
        GOTO SI1; 
$TEXT:  
        I = I + TEXT$W; 
        GOTO SI1; 
$TITM:  
        LSEQ[I] = 0;
    USES[I] = 0;      #MAKE USES LIST EMPTY#                             SOPT 
        I = I+TITM$W; 
        GOTO SI1; 
SI900:  
    END  # CG2STI # 
CONTROL EJECT;
$BEGIN
XDEF PROC ICFTDUMP; 
    PROC ICFTDUMP;
    BEGIN 
        ARRAY  ALINE[0:11] S(1);
            ITEM C C(0,0,BYTWD);
        I = -1; 
        IF KERRY THEN 
        BEGIN 
            PRINT("(11H1KERRY SEQ=O4,4H BI=O6/)");
            LIST(SEQ);
            LIST(BI); 
            ENDL; 
        END 
        ELSE  # DO JIM #
        BEGIN 
  PRINT("(7H1JIM   10(1X,O6),/,7X,10(1X,O6),/,7X,8(1X,O6),/,7X,I5,
                 1X,O2,1X,O20,/)"); 
                 LIST(SEQ); LIST(BI); LIST(NBI); LIST(LOOPL); 
                 LIST(LBS); LIST(LGS); LIST(LPS); LIST(GUSES);
                 LIST(PUSES); LIST(GSTORE); LIST(ATEMP); LIST(BTEMP); 
                 LIST(FULL); LIST(ICFTJ); LIST(LPRC); LIST(TIALP);
                 LIST(SUCTI); LIST(NICLOP); LIST(ICFBI);
                 LIST(OPTERM); LIST(INVIL); LIST(LOPLAB); LIST(TIAF); 
                 LIST(MEP); LIST(TEMPA1); LIST(FVTEMP); LIST(RETEMP); 
                 LIST(FREZA1); LIST(LINE); LIST(MARKCTR);LIST(AVAIL); 
            ENDL; 
        END 
LINE1:  CALL  BLANKC; 
        C[2] = "         M";
        C[3] = "OP=      R";
        C[4] = "EFCT=     ";
        C[5] = " FOL=     ";
        C[6] = " BOL=     ";
        C[7] = " NPRED=   ";
        C[8] = "   CNO=   ";
        C[9] = "   TSYM=  ";
        C[10] ="      PFF=";
        CALL  BINOCT(ALINE,  1,I        ,4);
        CALL  BINOCT(ALINE, 34,MOP[I]   ,4);
        CALL  BINOCT(ALINE, 45,REFCT[I] ,4);
        CALL  BINOCT(ALINE, 55,FOL[I]   ,4);
        CALL  BINOCT(ALINE, 65,BOL[I]   ,4);
        CALL  BINOCT(ALINE, 77,NPRED[I] ,4);
        CALL  BINOCT(ALINE, 87,CNO[I]   ,4);
        CALL  BINOCT(ALINE, 98,TSYM[I]  ,6);
        CALL  BINOCT(ALINE,110,PFF[I]   ,8);
        CALL  CHRCHR(ALINE,  7,BCDOP[OPCD[I]],4); 
        CALL ICFOPN(OPN1[I],13,OPN1TP[OPCD[I]]);
        CALL ICFOPN(OPN2[I],21,OPN2TP[OPCD[I]]);
              PTLSTV (ALINE ,12); 
LINE2:  CALL BLANKC;
        C[2] = "         S";
        C[3] = "TI=       ";
        C[4] = "I=   J=   ";
        C[5] = "K=        ";
        C[6] = "AT=   AINV";
        C[7] = "S=   MISC=";
        C[8] = "         S";
        C[9] = "AREG=   SX";
        C[10] ="REG=   CIS";
        C[11] ="R=        ";
        CALL BINOCT(ALINE, 34,STI[I]  ,5);
        CALL BINOCT(ALINE, 42,IDES[I] ,1);
        CALL BINOCT(ALINE, 47,JDES[I] ,1);
        CALL BINOCT(ALINE, 52,KDES[I] ,6);
        CALL BINOCT(ALINE, 63,AT[I]   ,1);
        CALL BINOCT(ALINE, 72,AINVS[I],1);
        J = B<24,12>ICFW4[I]; 
        CALL BINOCT(ALINE,80,J,4);
        CALL BINOCT(ALINE, 95,SAREG[I],1);
        CALL BINOCT(ALINE,104,SXREG[I],1);
        CALL BINOCT(ALINE,112,CISR[I] ,1);
              PTLSTV (ALINE ,12); 
#     PRINT BASE AND BASE-PLUS-SUBSCRIPT CHAIN ITEMS                   #
        CALL BLANKC; # BLANK PRINT LINE                                #
        C[2]= "         B"; 
        C[3]= "CHN=      "; 
        C[4]= "BSCHN=    "; 
        CALL BINOCT(ALINE, 35, BCHN[I], 4); 
        CALL BINOCT(ALINE, 47, BSCHN[I], 4);
        PTLSTV(ALINE,12); 
        CALL BLANKC;
LINE3:  C[3] = " SUCCS=   ";
        K = STI[I]; 
LINE3A: J=37;   # INITIALIZE PRINT COLUMN POSITION                    # 
LINE3B: IF K GT 0 THEN # THERE IS ANOTHER SUCCESSOR LINK               #
            BEGIN 
                CALL BINOCT(ALINE, J, ISUC[K],4); 
                J = J+5;
                K = LSUC[K];
                IF J LE 107 AND K NE 0 THEN 
                    BEGIN 
                        CALL CHRCHR(ALINE,J-1,",",1); 
                        GOTO  LINE3B; 
                    END 
LINE3C:       PTLSTV ( ALINE , 12 );
                CALL BLANKC;
                GOTO LINE3A;
            END 
        IF J NE 37 THEN GOTO LINE3C;
        IF OPCD[I] NE QICFOP"EOS" AND FOL[I] GE 0 THEN
            BEGIN 
                I = FOL[I]; 
                GOTO LINE1; 
            END     BEGIN END  # TO FIX SPEC BUG  # 
#   BLANKC -- IS USED BY ICFTDUMP TO SET ALINE TO BLANKS              # 
    PROC BLANKC;
        BEGIN 
        ITEM X; 
            FOR X = 0 STEP 1 UNTIL 11 DO
                C[X] = " "; 
        END  #  BLANKC                                                # 
#   ICFOPN  -- PLACES ICF OPERAND NAME IN PRINT LINE                  # 
    PROC ICFOPN(OPI,LINEI,OPTYPE);
        BEGIN 
            ITEM OPI; 
            ITEM LINEI; 
            ITEM OPTYPE;
            ITEM X; 
            IF OPTYPE NE 0 OR OPI EQ 0 THEN 
                BEGIN # CONSIDER OPI TO BE AN IMMEDIATE CONSTANT      # 
                    CALL BINOCT(ALINE,LINEI,OPI,6); 
                    GOTO ICFOPN10;
                END 
            IF OPI LT 0 THEN # IT IS AN ICF POINTER                   # 
                BEGIN 
                    CALL BINOCT(ALINE,LINEI,BI-OPI,4);
                    GOTO ICFOPN10;
                END 
            IF CLAS[OPI] EQ S"CONS" THEN  # OPERAND IS A CONSTANT     # 
                BEGIN 
                    CALL CHRCHR(ALINE,LINEI,"=",1); 
ICFOPN5:            CALL BINOCT(ALINE,LINEI+1,OPI,6); 
                    GOTO ICFOPN10;
                END 
            IF NNAM[OPI] THEN 
                BEGIN 
                    CALL CHRCHR(ALINE,LINEI,"T",1); 
                    GOTO ICFOPN5; 
                END 
            CALL FIND(OPI,X); 
            CALL CHRCHR(ALINE,LINEI,NAME[X],6); 
ICFOPN10: END  # ICFOPN  #
ICFTDE: 
    END  # ICFTDUMP                                                   # 
  
#**********************************************************************#
  
# DB                                                                   #
#                                                                      #
#         DB$ IS CALLED TO DO DEBUG PRINTS IN CG2.                     #
#                                                                      #
#         IT CAN BE CALLED WITH A VARIABLE NUMBER OF PARAMETERS.       #
#         THE PARAMETER LIST TERMINATOR IS A PARM WHICH IS ".".        #
#                                                                      #
#         -DB$- IS CALLED THROUGH AN INTERFACE ROUTINE -DB- BECAUSE    #
#         THE OVERHEAD OF SETTING UP ALL THE PARAMETERS BEFORE FINDING #
#         OUT WHETERE ANY TRACES TO BE PRINTED OR NOT IS UNACCEPTABLE. #
    XDEF PROC DB$;
    PROC  DB$(FM,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15,
        P16,P17,P18,P19,P20,P21,P22,P23,P24,P25,P26,P27,P28,P29,P30); 
    BEGIN 
        ITEM FM,P1 C(10),P2 C(10),P3 C(10),P4 C(10),P5 C(10),P6 C(10),
             P7 C(10),P8 C(10),P9 C(10),P10 C(10),P11 C(10),P12 C(10),
             P13 C(10),P14 C(10),P15 C(10),P16 C(10),P17 C(10),P18 C(10)
             ,P19 C(10),P20 C(10),P21 C(10),P22 C(10),P23 C(10),
             P24 C(10),P25 C(10),P26 C(10),P27 C(10),P28 C(10), 
             P29 C(10),P30 C(10); 
        IF KERRY THEN 
            BEGIN 
                IF B<7>INTOPS EQ 0 THEN GOTO JD10;
            END 
        ELSE  IF B<8> INTOPS EQ 0 THEN GOTO JD10; 
        PRINT(FM);
        IF P1  EQ "." THEN GOTO JD9;  LIST(P1 );
        IF P2  EQ "." THEN GOTO JD9;  LIST(P2 );
        IF P3  EQ "." THEN GOTO JD9;  LIST(P3 );
        IF P4  EQ "." THEN GOTO JD9;  LIST(P4 );
        IF P5  EQ "." THEN GOTO JD9;  LIST(P5 );
        IF P6  EQ "." THEN GOTO JD9;  LIST(P6 );
        IF P7  EQ "." THEN GOTO JD9;  LIST(P7 );
        IF P8  EQ "." THEN GOTO JD9;  LIST(P8 );
        IF P9  EQ "." THEN GOTO JD9;  LIST(P9 );
        IF P10 EQ "." THEN GOTO JD9;  LIST(P10);
        IF P11 EQ "." THEN GOTO JD9;  LIST(P11);
        IF P12 EQ "." THEN GOTO JD9;  LIST(P12);
        IF P13 EQ "." THEN GOTO JD9;  LIST(P13);
        IF P14 EQ "." THEN GOTO JD9;  LIST(P14);
        IF P15 EQ "." THEN GOTO JD9;  LIST(P15);
        IF P16 EQ "." THEN GOTO JD9;  LIST(P16);
        IF P17 EQ "." THEN GOTO JD9;  LIST(P17);
        IF P18 EQ "." THEN GOTO JD9;  LIST(P18);
        IF P19 EQ "." THEN GOTO JD9;  LIST(P19);
        IF P20 EQ "." THEN GOTO JD9;  LIST(P20);
        IF P21 EQ "." THEN GOTO JD9;  LIST(P21);
        IF P22 EQ "." THEN GOTO JD9;  LIST(P22);
        IF P23 EQ "." THEN GOTO JD9;  LIST(P23);
        IF P24 EQ "." THEN GOTO JD9;  LIST(P24);
        IF P25 EQ "." THEN GOTO JD9;  LIST(P25);
        IF P26 EQ "." THEN GOTO JD9;  LIST(P26);
        IF P27 EQ "." THEN GOTO JD9;  LIST(P27);
        IF P28 EQ "." THEN GOTO JD9;  LIST(P28);
        IF P29 EQ "." THEN GOTO JD9;  LIST(P29);
        IF P30 EQ "." THEN GOTO JD9;  LIST(P30);
JD9:    ENDL; 
JD10: 
    END  #  DB  # 
  
#**********************************************************************#
$END
CG2W: 
$BEGIN
        IF INTOPS LT 0 THEN CALL SDUMP(O"777"); 
$END
    # PUT A "TERM" AT END OF CODE FILE.                                #
        CALL CANNED(CNCD8); 
        CALL KZ00; # EMPTIES FINAL CODE FILE BUFFER                    #
         SSIZ[CSLC] = CLC[0]/4;   # SAVE LENGTH OF CODE CONTROL SECTION#
         ASEQ[LENT[CSLC]] = 0;    # GIVE NULL LINK TO END OF CODE CHAIN#
    END # CG2 # 
 TERM 
