*DECK CBLIST
USETEXT CCTTEXT 
       PROC CBLIST ((LFUNC), LLIST, LEN); 
          BEGIN 
          CONTROL PACK; 
   #
*  CBLIST IS A UTILITY SUBROUTINE THAT IS USED TO PROCESS ALL STANDARD
*     LISTABLE OUTPUT FROM THE COMPILER.  IT IS ALSO USED FOR PROCESSING
*     COMPILER DEBUGGING OUTPUT SUCH AS DUMPS AND TRACES. 
* 
*     IT PROVIDES FACILITIES FOR OPENING (INITIATING) AND CLOSING 
*     (TERMINATING) LISTING FILES AND FOR PAGE FORMATTING OF THE
*     LISTINGS.  THE FORMATTING FACILITIES PROVIDED INCLUDE PAGE
*     HEADINGS AND FOOTINGS AND AUTOMATIC PAGE NUMBERING. 
* 
*     THE PARAMETERS ARE
* 
*        LFUN = FUNCTION CODE.
*                0 =  NO SPACE BEFORE PRINTING
*                1 =  SINGLE SPACE BEFORE PRINTING
*                2 =  DOUBLE SPACE BEFORE PRINTING
*                3 =  PAGE EJECT
*                4 =  DEFINE TITLE
*                5 =  DEFINE SUBTITLE 
*                6 =  DEFINE FOOTING
*                7 =  DEFINE SUBFOOTING 
*                8 =  OPEN FILE 
*                9 =  CLOSE FILE
*               10 = DEFINE TITLE (SHORT TITLE FUNCTION DELETED)
*               11 =  RESET PAGE NR (FOR STACKED COMPILES ONLY) 
*               12 =  FORCE PAGE EJECT (FOR USE WITH "/" IN COL 7)
*               13 =  DEFINE ADDITIONAL FILE FOR USE UNTIL NEXT CLOSE 
* 
*        LLIST = CHARACTER STRING ARRAY - MAXIMUM 14 WORDS. 
* 
*        LEN  = LENGTH OF CHARACTER IN CHARACTERS.
* 
*                                                                      #
*CALL ASSEMOP 
*CALL   SYSFET
          ARRAY LLIST [13]  ; 
              ITEM LL   C(0,0,10)  ;
          ARRAY IHDR [13]   ; 
              ITEM IHD  C(0,0,10)  ;
          BASED ARRAY ISHDR [13]; 
              ITEM ISH  C(0,0,10)  ;
          ARRAY IFOOT [13]; 
              ITEM IFO  C(0,0,10)  ;
          BASED ARRAY ISFT [13];
              ITEM ISF  C(0,0,10)  ;
          ARRAY DTLN [13]   ; 
              ITEM DT   C(0,0,10)  ;
          ITEM   ALTFET      I = 0;    # ADDRESS OF SECOND FILE"S FET  #
          ITEM SPA C(10) = "         "; 
          ITEM LIT$S C(10) = "S         ";
          ITEM LIT$T C(10) = "T         ";
          ITEM LIT$0 C(10) = "0         ";
          ITEM LISTGID I=0; 
          ITEM SEGASGD B = FALSE; 
          ITEM ISHDRASGD B = FALSE; 
          ITEM ISFTASGD B = FALSE;
          ITEM MAX$LENGTH I;
          ITEM LINLIM  ;
          ITEM LFUNC  ; 
          ITEM LENG   ; 
          ITEM LEN   ;
          ITEM LINECNT   I = 0; 
          ITEM DBFLG   I = 0;   #   SET TO 1 IF DOUBLE SPACE MODE # 
  
          ITEM FRFLG   I = 0;   #  FIRST TIME FLAG #
  
          ITEM LPGCNT I = 1;
          ITEM I   ;
          ITEM LIMT   ; 
          ITEM ICC C(1)  ;
          ITEM JSHEAD  ;
          ITEM JHEAD   ;
          ITEM JFOOT   I = 0; 
          ITEM JSFOOT   I = 0;
          ITEM  TTFLAG   I; 
          SWITCH ROUTINES NONE, SINGLE, DOUBLE, EJECT, TITLE, SUBTITLE, 
            FOOTING, SUBFOOT, OPEN, CLOSE, TITLE, RESETPG,
              FORCE$EJECT,
              ALTFILE;
          XREF PROC PUTSQ;
          XREF PROC SHIFT  ;
          XREF FUNC  DECR C(10);
          XREF ITEM ZRPARAM;
          XREF FUNC CMM$AGR;
          XREF FUNC CMM$ALV;
          XREF PROC CMM$FGR;
          XDEF
              BEGIN 
              ITEM  CC$PD I = CB5$PDENS;   #  PRINT DENSITY # 
  
              ITEM  CC$PS I = 0;   # PAGE SIZE #
  
              ITEM  CC$PW I = 132; # PAGE WIDTH # 
  
              ITEM  CC$BL I = 0;   # BURSTABLE LISTING FLAG # 
           ARRAY PGSIZE [0:0] S(2); 
               BEGIN
                   ITEM JPD U(0,28,4);
                   ITEM JPS U(0,32,8);
                   ITEM JPW U(0,40,8);
                   ITEM SPD U(1,28,4);
                   ITEM SPS U(1,32,8);
                   ITEM SPW U(1,40,8);
               END
  
              ITEM  NOSHIFT B = FALSE;  # SET BY CALLER TO NOT SHIFT LN#
              ITEM PDCHWR B = FALSE;  # FLAG FOR PRINT DENS CH WRITTEN #
              ITEM LIT$PD C(10);
  
              END 
          CONTROL EJECT;
          PROC ASGNLINE (ADDR); 
#         ASGNLINE ASSIGNS A LINE THROUGH CMM AND PUTS SPACES INTO IT 
          THE ONE PARAMETER IS THE BASE LOCATION OF THE BASED ARRAY    #
          BEGIN 
          ITEM ADDR I;
          BASED ARRAY FILLSP [13];
              ITEM FILLSPITEM C(0,0,10);
          IF LISTGID EQ 0 
          THEN
              BEGIN   # NO GROUP ID ASSIGNED YET - DO SO #
              LISTGID = CMM$AGR (0);  # ABOVE HHA # 
              END 
          P<FILLSP> = CMM$ALV (14, 1, 0, LISTGID, ADDR, 0); 
          FOR I = 0 STEP 1 UNTIL 13 DO
              FILLSPITEM [I] = SPA; 
          RETURN; 
          END 
          CONTROL EJECT;
          PROC PUTREC ((FET), LINE, (LLEN));
              BEGIN 
  
              ITEM    FET    I; 
              ITEM    LLEN   I; 
  
              ARRAY   LINE [13];
                  ITEM    LWRD     C(0, 0, 10); 
              BASED ARRAY SEG [13]; 
                  ITEM    SWRD     C(0, 0, 10); 
  
              ITEM    ILEN   I; 
              ITEM    I      I;    # SCRATCH STORAGE #
              ITEM    J      I; 
              ITEM    JJ     I; 
              ITEM    K      I; 
              ITEM    KK     I; 
              ITEM    COL    I;    # COLUMN NUMBER #
              ITEM FIRSTPRINT B = TRUE; 
  
  
              PROC WRITE$LINE ((XLEN)); 
                  BEGIN 
                  ITEM       XLEN  I; 
  
                  PUTSQ(FET, LOC(LINE), XLEN);
                  IF  ALTFET NQ 0  THEN 
                      PUTSQ(ALTFET, LOC(LINE), XLEN); 
                  RETURN; 
                  END        # WRITELINE #
  
              PROC WRITE$SEG ((YLEN));
                  BEGIN 
                  ITEM       YLEN  I; 
  
                  PUTSQ(FET, LOC(SEG), YLEN); 
                  IF  ALTFET NQ 0  THEN 
                      PUTSQ(ALTFET, LOC(SEG), YLEN);
                  RETURN; 
                  END        # WRITE$SEG #
  
              ILEN = LLEN ; 
              IF FIRSTPRINT 
              THEN
                  BEGIN    # INITIALIZE PRINT DENSITY # 
                  FIRSTPRINT = FALSE; 
                  IF CC$PD EQ 3 
                  OR CC$PD EQ 4 
                  THEN
                      DBFLG = 1;   # DOUBLE SPACE IF 3 OR 4 LPI # 
                  IF CC$PD EQ 4 
                  OR CC$PD EQ 8 
                  THEN
                      LIT$PD = LIT$T;   # SET 8 LINES PER INCH #
                  ELSE
                      LIT$PD = LIT$S;   # SET 6 LINES PER INCH #
                  IF NOT CCTNOSTERM 
                  THEN
                      BEGIN 
                      PDCHWR = TRUE;   # FLAG AS WRITTEN FOR TERMPROG # 
                      PUTSQ (OUTFET, LOC(LIT$PD), 1);  # WRITE PD CHAR #
                   # SET LIT$PD TO JOB DEFAULT PD CHARACTER # 
                   # WHICH IS PRINTED ON JOB TERMINATION (TERMPROG) # 
                   # IF OTHER PRINT DENSITY WAS SELECTED. # 
                       IF JPD[0] EQ 8 
                       THEN 
                       BEGIN
                           PDCHWR = LIT$PD NQ LIT$T;
                           LIT$PD = LIT$T; # RESET TO 8 LINES/INCH #
                       END
                       ELSE 
                       BEGIN
                           PDCHWR = LIT$PD NQ LIT$S;
                           LIT$PD = LIT$S; # RESET TO 6 LINES/INCH #
                       END
                      END 
                  END 
  
              IF ILEN LQ MAX$LENGTH THEN
                  BEGIN 
                  WRITE$LINE (ILEN);
                  RETURN; 
                  END 
  
              I = (ILEN - 1) / 10;
              COL = ILEN - (I * 10) - 1;
 #
*        WE NOW STRIP TRAILING BLANKS, IF ANY 
 #
  
              FOR  J = I STEP -1 UNTIL 0  DO
                  BEGIN 
                  FOR  K = COL STEP -1 UNTIL 0  DO
  
                      BEGIN 
                      IF  C<K,1>LWRD[J] NQ " "  THEN
                          BEGIN 
                          IF ILEN LQ MAX$LENGTH THEN
                              BEGIN 
                              WRITE$LINE(ILEN); 
                              RETURN; 
                              END 
                          ELSE
                              GOTO TOO$LONG;
                          END 
                      ELSE
                          ILEN = ILEN - 1;
                      END 
                  COL = 9;
                  END 
              WRITE$LINE(10);      # BLANK LINE # 
              RETURN; 
  
 TOO$LONG:  
  
              IF NOT SEGASGD
              THEN
                  BEGIN  # LINE NOT ASSIGNED YET - DO SO #
                  ASGNLINE (P<SEG>);
                  SEGASGD = TRUE; 
                  END 
              WRITE$LINE (MAX$LENGTH);
              SWRD [0] = "  >>>>    ";
              COL = MAX$LENGTH; 
  
 PUT$LOOP:  
              FOR I = 1 STEP 1 UNTIL 13 
                 DO SWRD [I] = SPA; 
  
              FOR I = 10 STEP 1 UNTIL MAX$LENGTH - 1 DO 
                  BEGIN 
                  IF COL EQ ILEN THEN   # JP IF END OF LINE # 
                      GOTO PUT$IT;
                  J = I / 10; 
                  K = I - ( J * 10);
                  JJ = COL / 10;
                  KK = COL - (JJ * 10); 
                  COL = COL + 1;
                  C<K,1>SWRD[J] = C<KK,1>LWRD[JJ];
                  END 
  
 PUT$IT:  
  
              WRITE$SEG(I+1); 
              LINECNT = LINECNT + 1;
              IF  COL  LS  ILEN  THEN 
                  GOTO PUT$LOOP;
              RETURN; 
  
              END            # PUTREC # 
          CONTROL EJECT;
   #
*        PROCEDURE FOR WRITING HEADINGS 
  # 
          PROC HEAD  ;
              BEGIN 
              C<5,4>IHD[11] = "PAGE"; 
              I = DECR(LPGCNT); 
              C<0,7>IHD[12] = C<3,7>I;    #    PAGE NUMBER    # 
              LINECNT = 0;
              LPGCNT = LPGCNT + 1;
              IF CCTNOSTERM[0]
                  THEN BEGIN
                         PUTREC(OUTFET, SPA, 10); 
                         PUTREC(OUTFET, SPA, 10); 
                         PUTREC(OUTFET, SPA, 10); 
                       END
              IF CC$PW LS 130 
                  THEN BEGIN
                         PUTREC(OUTFET, IHDR, 60);
                         PUTREC(OUTFET, IHDR[6], 70); 
                         LINECNT = LINECNT + 1; 
                       END
              ELSE PUTREC(OUTFET, IHDR, 130); 
              IF JSHEAD NQ 0
                  THEN PUTREC(OUTFET, ISHDR, JSHEAD); 
              ELSE PUTREC(OUTFET, SPA, 10); 
              PUTREC(OUTFET, SPA, 10);
              RETURN  ; 
              END 
          PROC FOOT  ;
              BEGIN 
   #
*        PROCEDURE FOR WRITING FOOTINGS 
  # 
              IF JFOOT GR 0 THEN
                  BEGIN 
                   IF CCTNOSTERM[0] 
                       THEN PUTREC(OUTFET, SPA, 10);
                  PUTREC (OUTFET, IFOOT , JFOOT); 
                  LINECNT = LINECNT + 2;
                  END 
              IF JSFOOT GR 0 THEN 
                  BEGIN 
                  PUTREC (OUTFET, ISFT , JSFOOT); 
                  LINECNT = LINECNT + 1;
                  END 
              RETURN  ; 
              END 
          PROC WRIT  ;
              BEGIN 
   #
*        WRITE A DETAIL LINE
   #
              IF  CCTNOSTERM[0] 
                THEN
                  BEGIN 
                  FOR I = TTFLAG STEP -1 WHILE I GR 0 
                    DO PUTREC(OUTFET, SPA, 10); 
                  PUTREC(OUTFET, LLIST,  LENG); 
                  END 
              ELSE
                  BEGIN 
                  IF NOSHIFT
                  THEN
                      BEGIN 
                      C<0,1>LL[0] = ICC;
                      PUTREC(OUTFET, LLIST, LENG);  # DONT SHIFT LINE # 
                      END 
                  ELSE
                      BEGIN 
                      SHIFT(LLIST, DTLN, ICC, LENG);  # SHIFT LEFT 1 #
                      LENG = LENG + 1;
                      PUTREC(OUTFET, DTLN, LENG); 
                      END 
                  END 
              RETURN  ; 
              END 
          PROC MOVE (ISAV)  ; 
              BEGIN 
   #
*        STORE ALL TITLES 
   #
              ARRAY ISAV [13]  ;
                  ITEM IS   C(0,0,10)  ;
  
              IF  CCTNOSTERM[0] 
                THEN
                  BEGIN 
                  LIMT = LENG - 1;
                  FOR I = 0 STEP 1 WHILE LIMT GQ 0 DO 
                      BEGIN 
                      IS[I] = LL[I];
                      LIMT = LIMT - 10; 
                      END 
                  FOR I = I STEP 1 UNTIL 13 DO
                      IS[I] = SPA;   # BLANK FILL THE REST #; 
                  END 
              ELSE
                  BEGIN 
                  SHIFT(LLIST,ISAV,ICC,LENG); 
                  END 
              RETURN  ; 
              END 
          CONTROL EJECT;
   #
*        BEGIN CBLIST EXECUTABLE CODE 
   #
          IF FRFLG NQ 0 THEN
              GOTO SET$UP;
  
          FRFLG = 1;
          IF CCTNOSTERM 
          THEN
              MAX$LENGTH = CC$PW;  # NOS TERMINAL HAS NO CARR CTL # 
          ELSE
              MAX$LENGTH = CC$PW + 1;  # 1 FOR CARR CTL # 
         IF CC$PS EQ 0
         THEN BEGIN 
                   # ASKING US TO USE CB5$LINP #
                   LINLIM = CB5$LINP - 3; 
              END 
         ELSE BEGIN 
              # ASKING US TO USE CC$PS #
                LINLIM = CC$PS-3; 
              END 
SET$UP: 
  
  
          IF LFUNC NQ 3       #          EJECT                         #
            AND LFUNC NQ 8    #          OPEN                          #
            AND LFUNC NQ 9  THEN   #     CLOSE                         #
  
              BEGIN 
              LENG = LEN; 
              IF LENG GR 132  THEN
                  LENG = 132; 
              END 
          IF LFUNC EQ 0 OR LFUNC EQ 2 THEN
              IF LINECNT EQ 0 THEN
                  BEGIN 
                  LFUNC = 1  ;
                  GOTO BRAN  ;
                  END 
          IF LFUNC EQ 1 OR LFUNC EQ 2 THEN
              BEGIN 
              I = LINECNT + LFUNC  ;
              IF I GR LINLIM THEN 
                  BEGIN 
                  IF LPGCNT NQ 1
                  THEN
                      FOOT;  # FOOTINGS IF NOT FIRST PAGE # 
                  HEAD  ; 
                  LFUNC = 1  ;
                  GOTO SINGLE  ;
                  END 
              END 
BRAN: 
          GOTO ROUTINES[LFUNC]  ; 
          RETURN; 
   #
*        NO SPACE BEFORE PRINTING 
   #
NONE: 
          ICC = "+";
          TTFLAG = 0; 
          WRIT  ; 
          RETURN; 
   #
*        SINGLE SPACE BEFORE PRINTING 
   #
SINGLE: 
          IF DBFLG EQ 0 THEN
              BEGIN 
              ICC = " ";
              TTFLAG = 0; 
              WRIT; 
              LINECNT = LINECNT + 1;
              END 
          ELSE
              BEGIN 
              ICC = "0";
              TTFLAG = 1; 
              WRIT; 
              LINECNT = LINECNT + 2;
              END 
  
          RETURN; 
   #
*        DOUBLE SPACE BEFORE PRINTING 
   #
DOUBLE: 
          IF DBFLG EQ 0 THEN
              BEGIN 
              ICC = "0";
              TTFLAG = 1; 
              WRIT; 
              LINECNT = LINECNT + 2;
              END 
          ELSE
              BEGIN 
               IF NOT CCTNOSTERM[0] 
                   THEN PUTREC(OUTFET, LIT$0, 1); 
              ICC = "0";
              TTFLAG = 3; 
              WRIT; 
              LINECNT = LINECNT + 4;
              END 
  
          RETURN; 
   #
*        PAGE EJECT 
   #
EJECT:  
          IF LINECNT NQ 0 AND LPGCNT NQ 1 THEN
              FOOT  ; 
          IF  CC$BL EQ 0  THEN
              BEGIN 
              IF  ( LINECNT + 8 )  LQ  LINLIM  THEN 
                  BEGIN 
                  PUTREC (OUTFET, SPA,  1); 
                  IF CCTNOSTERM[0]
                      THEN BEGIN
                             PUTREC(OUTFET, SPA, 10); 
                             PUTREC(OUTFET, SPA, 10); 
                           END
                   ELSE C<0,1>IHD[0] = "-"; 
                   IF CC$PW LS 130
                       THEN BEGIN 
                              PUTREC(OUTFET, IHDR, 60); 
                              PUTREC(OUTFET, IHDR[6], 30);
                            END 
                       ELSE PUTREC(OUTFET, IHDR, 90); 
                   IF NOT CCTNOSTERM[0] 
                       THEN C<0,1>IHD[0] = "1"; 
                  IF  JSHEAD NQ 0  THEN 
                      BEGIN 
                      PUTREC (OUTFET, ISHDR,  JSHEAD);
                      END 
                  ELSE
                      BEGIN 
                      PUTREC(OUTFET, SPA, 10);
                      END 
                  PUTREC (OUTFET, SPA,  1); 
                  LINECNT = LINECNT + 6;
                  RETURN; 
                  END 
              ELSE
                  HEAD; 
              END 
          ELSE
              HEAD; 
          RETURN; 
   #
*        DEFINE TITLE 
   #
TITLE:  
          ICC = "1";
          MOVE (IHDR)  ;
          JHEAD = 130  ;
          RETURN; 
   #
*        DEFINE SUBTITLE
   #
SUBTITLE: 
          IF NOT ISHDRASGD
          THEN
              BEGIN 
              ISHDRASGD = TRUE; 
              ASGNLINE (P<ISHDR>);
              END 
          ICC = " ";
          MOVE (ISHDR)  ; 
          JSHEAD = LENG + 1  ;
          RETURN; 
   #
*        DEFINE FOOTING 
   #
FOOTING:  
          IF JFOOT EQ 0 THEN
              LINLIM = LINLIM - 2;
          ICC = "0";
          MOVE (IFOOT)  ; 
          JFOOT = LENG + 1  ; 
          RETURN; 
   #
*        DEFINE SUBFOOTING
   #
SUBFOOT:  
          IF NOT ISFTASGD 
          THEN
              BEGIN 
              ISFTASGD = TRUE;
              ASGNLINE (P<ISFT>); 
              END 
          IF  JSFOOT EQ 0 THEN
              LINLIM = LINLIM - 1;
          ICC = " ";
          MOVE (ISFT)  ;
          JSFOOT = LENG + 1  ;
          RETURN; 
   #
*        OPEN FILE
   #
OPEN: 
          IF  LPGCNT EQ 1  THEN   #  FORCE EJECT ON FIRST PAGE         #
  
              LINECNT = LINLIM + 5; 
          IF  CC$BL NQ 0  THEN
              LINECNT = 0;
          FOR I = 0 STEP 1 UNTIL 13 DO
              IHD[I] = SPA  ; 
          IF LISTGID NQ 0 
          THEN
              BEGIN  # SOME BLOCKS ASSIGNED - FREE THEM UP #
              CMM$FGR (LISTGID);
              LISTGID = 0;
              ISHDRASGD = FALSE;
              ISFTASGD = FALSE; 
              SEGASGD = FALSE;
              END 
          JHEAD = 130;
          IHD[0] = "1"; 
          JSHEAD = 0  ; 
          IF  JFOOT NQ 0 THEN 
              LINLIM = LINLIM + 2;
          IF JSFOOT NQ 0 THEN 
              LINLIM = LINLIM + 1;
          JFOOT = 0  ;
          JSFOOT = 0  ; 
          RETURN; 
   #
*        CLOSE FILE 
   #
CLOSE:  
          FOOT  ; 
          IF  JFOOT NQ 0 THEN 
              BEGIN 
              LINLIM = LINLIM + 2;
              LINECNT = LINECNT + 2;
              END 
  
          IF JSFOOT NQ 0 THEN 
              BEGIN 
              LINLIM = LINLIM + 1;
              LINECNT = LINECNT + 1;
              END 
          JFOOT = 0;
          JSFOOT = 0; 
          JSHEAD = 0; 
         IF  ALTFET NQ 0  THEN
              PUTSQ(ALTFET, 0, 0);     # FLUSH BUFFER # 
          ALTFET = 0; 
          RETURN; 
   #
*          RESET PAGE COUNTER 
   #
RESETPG:  
          LPGCNT = 1; 
  
          RETURN; 
 #
*        FORCE PAGE EJECT 
 #
 FORCE$EJECT: 
          IF LINECNT NQ 0 AND LPGCNT NQ 1 THEN
              FOOT; 
          HEAD; 
          RETURN; 
 #
*        DEFINE ALTERNATE FILE
 #
 ALTFILE: 
          ALTFET = LEN; 
          RETURN; 
   #
*        END OF PROGRAM 
   #
          END 
          TERM
