*DECK             SDUMP 
USETEXT   TSOURCE 
USETEXT   TSYMCNS 
USETEXT   TCEXECQ 
USETEXT   TCEXEC
PROC SDUMP(PHS);
      ITEM PHS; 
$BEGIN
  BEGIN 
  
  
  
  
#     COMDECKS                                                         #
  
*CALL COMEX 
  
*CALL     DMPCM6
  
*CALL     SYMT6C
  
  
  
  
         DEF FULLDUMP #30#;        # INTOPS BIT FOR *=4                #
         ITEM I,J,K,M,N;
         ITEM ERR B=FALSE;
         ITEM ENDMSG C(24)="END OF SYMBOL TABLE DUMP";
         ITEM FULLDMP      B;      # TRUE IF FULL DUMP SELECTED (*=4)  #
                                   # *=4 ONLY SELECTS THE DUMP MODE    #
                                   # (FULL OR PART)   IT MAY BE USED   #
                                   # IN CONJUNCTION WITH ANOTHER OPTION#
                                   # WHICH ACTIVATES A SYM TABLE DUMP  #
         ITEM STRING C(72);        # DTXT CHARACTER STRING             #
  
         XREF PROC BINOCT;
         XREF PROC FRMNME;
         XREF PROC CHRCHR;
         XREF PROC PTLSTV;
         ARRAY CLSIZE [0:QCLAS"QCLAS$"] S(1); 
           BEGIN
           ITEM CLSLNG I(0,0,BITNWD) =   # SYMBOL TABLE ENTRY LENGTHS  #
            [0     ,               # NULL                              #
             NAME$W,
             DATA$W,
             ARRY$W,
             TABL$W,
             CONS$W,
             TEMP$W,
             LABL$W,
             CLOS$W,
             PROC$W,
             FUNC$W,
             SWCH$W,
             FILE$W,
             EMPT$W,
             OVER$W,
             DUMY$W,
             PROG$W,
             DEF$W ,
             SLC$W ,
             STRG$W,
             INSC$W,
             MON$W ,
             BPAR$W,
             TITM$W,
             SCON$W,
             COMM$W,
             FPAR$W,
             STSL$W,
             VALU$W,
             SNAM$W,
             ADCN$W,
             DTXT$W,
             TEXT$W]; 
           END
         CONTROL EJECT; 
  
PROC SHDR;
  BEGIN 
  
  
#----------------------------------------------------------------------#
#                                                                      #
#        P R O C   S H D R                                             #
#                                                                      #
#        PRINTS HEADINGS FOR SYMBOL TABLE DUMP.                        #
#                                                                      #
#----------------------------------------------------------------------#
  
  
         ITEM HD1 C(21)="SYMBOL TABLE CONTENTS";
         ITEM HD2 C(3)="LOC"; 
         ITEM HD3 C(9)="CLAS NAME"; 
         ITEM HD4 C(5)="ITEMS"; 
         ITEM X I;
         FOR X=1 STEP 1 UNTIL WRDNLN DO 
              PRTARY[X]=" ";
         PTLSTV(PL,1);  PRTARY[1]=" ";
         CHRCHR(PL,TAB1,HD1,21);
         PTLSTV(PL,(21+BYTNWD)/BYTNWD);      #HDR#
         FOR X=1 STEP 1 UNTIL (21+BYTNWD)/BYTNWD DO 
              PRTARY[X]=" ";
         PTLSTV(PL,1);  PRTARY[1]=" ";
         CHRCHR(PL,TAB1,HD2,3); 
         CHRCHR(PL,TAB2,HD3,9); 
         CHRCHR(PL,TAB3,HD4,5); 
         PTLSTV(PL,(TAB3+BYTNWD+6)/BYTNWD); 
         FOR X=1 STEP 1 UNTIL (TAB3+BYTNWD+6)/BYTNWD DO 
              PRTARY[X]=" ";
  END 
         CONTROL EJECT; 
  
PROC SDMP(PH,PTR,EF); 
  BEGIN 
  
  
#----------------------------------------------------------------------#
#                                                                      #
#        P R O C   S D M P                                             #
#                                                                      #
#        PRINTS A SYMBOL TABLE ENTRY IN THE FORMAT:                    #
#        INDEX   S"CLAS"   FIELDS APROPOS S"CLAS AND COMPILER PHASE    #
#                                                                      #
#        INPUT PARAMETERS                                              #
#          PH  -- COMPILER PHASE (FOR DETERMINING APPLICABLE FIELDS    #
#          PTR -- POINTER TO CURRENT SYMBOL TABLE ENTRY                #
#        OUTPUT PARAMETER                                              #
#          EF -- ERROR FLAG (FALSE IF NO ERRORS FROM SDMP)             #
#                                                                      #
#----------------------------------------------------------------------#
  
  
         ITEM PH I;                    #CALLING PHASE NUMBER# 
         ITEM PTR I;                   #SYMBOL TABLE POINTER# 
         ITEM EF B; 
         ITEM I,J,K,M,N,X;
         ARRAY [0:10] S(1); 
           ITEM TABCHR I(0,0,BITNWD)= 
             [0,TAB3,TAB4,TAB5,TAB6,TAB7,TAB8,TAB9,0,0] ; 
         ITEM ERMSG1 C(31)=" ILLEGAL SYMTBL PTR- "; 
         ITEM ERMSG2 C(12)="CLASS ERROR ";
         EF=FALSE;
         IF PTR LS SYMSTART OR PTR GR NXTAV THEN GOTO SDMP1; #BAD LINK# 
         BINOCT(PL,TAB1,PTR,6);              #ENTRY INDEX#
         IF CLAS[PTR] GR CLASUP    # ILLEGAL CLAS                      #
         THEN 
           BEGIN
           GOTO SDMP3;
           END
         FRMNME(PTR,TAB2);                   #FORMAT CLAS/NAME# 
         CHRCHR(PL,TAB3-1," ",2);           #BLANK OUT LONG NAMES#
         M=PH;
         N=0; 
         B<BITNWD-CLAS[PTR]> N=1; 
         TABCHR[0]=1; 
         FOR I=0 STEP 1 UNTIL STDENT DO                          BEGIN
              IF  (SPHS[I] LAN M) EQ 0 THEN TEST; 
              IF  (SCLS[I] LAN N) EQ 0 THEN TEST; 
              J=TABCHR[TABCHR[0]];
              CHRCHR(PL,J,SBCD[I],4);  J=J+4; 
              CHRCHR(PL,J,"=",1);  J=J+1; 
              K=(SNBT[I]+2)/3;
              X=B<SFBT[I],SNBT[I]>SYM0[PTR+SWRD[I]];
              BINOCT(PL,J,X,K);  J=J+K; 
SDMPA:        TABCHR[0]=TABCHR[0]+1;         #STEP TO NEXT TAB# 
              IF TABCHR[TABCHR[0]] EQ 0 THEN                     BEGIN
                   K=(J+BYTNWD+1)/BYTNWD; 
                   PTLSTV(PL,K);             #PRINT FULL LINE#
                   FOR J=1 STEP 1 UNTIL K DO
                        PRTARY[J]=" ";
                   TABCHR[0]=1; 
                   TEST I;                                       END
              IF J GR TABCHR[TABCHR[0]] THEN GOTO SDMPA;         END
         IF TABCHR[0] NQ 1 THEN                                  BEGIN
              IF TABCHR[TABCHR[0]] EQ 0 THEN K=WRDNLN;
              ELSE K=(TABCHR[TABCHR[0]]+BYTNWD)/BYTNWD; 
              PTLSTV(PL,K); 
              FOR J=1 STEP 1 UNTIL K DO 
                   PRTARY[J]=" ";                                END
         RETURN;
SDMP1:   CHRCHR(PL,TAB1,ERMSG1,31);          #ILLEGAL POINTER#
         X=PTR; 
         J = BITNWD / 3;
         K = (TAB3 + J + BYTNWD) / BYTNWD;
         BINOCT(PL,TAB3,X,J); 
         PTLSTV(PL,K);
         FOR J=1 STEP 1 UNTIL K DO
              PRTARY[J]=" ";
         EF=TRUE; 
         RETURN;
SDMP3:   CHRCHR(PL,TAB2,ERMSG2,12);          #BAD CLASS FIELD#
         J=BITNWD/3;  K=(TAB3+J+BYTNWD)/BYTNWD; 
         FOR I=0 STEP 1 UNTIL AVGSZE DO                          BEGIN
              X=SYM0[PTR+I] ; 
              BINOCT(PL,TAB3,X,J);
              PTLSTV(PL,K); 
              FOR X=1 STEP 1 UNTIL K DO 
                   PRTARY[X]=" "; 
              X=PTR+I+1 ; 
              BINOCT(PL,TAB1,X,5);                               END
         EF=TRUE; 
         RETURN;
  END 
      CONTROL EJECT;
  
      PROC HTDMP;                  # HASH TABLE DUMP                   #
  
      BEGIN 
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     P R O C   H T D M P                                              #
#                                                                      #
#     PRINT HASH TABLE DUMP HEADING AND HASH TABLE.  HTDMP IS CALLED   #
#     ONLY IF *=4 IS SELECTED IN CONJUNCTION WITH A SYMBOL TABLE DUMP  #
#     OPTION (*=34 OR *=N4).                                           #
#                                                                      #
#----------------------------------------------------------------------#
  
  
      ITEM HASHLINK     I;         # HASH TABLE LINK                   #
      ITEM HD5          C(15) = "HASH TABLE DUMP";
      ITEM HD6          C(15) = "LOC     CONTENT";
  
      FOR I = 1 STEP 1
        UNTIL WRDNLN
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK-FILL PL                     #
        END 
      PTLSTV (PL,1);               # PRINT BLANK LINE                  #
  
      CHRCHR (PL,TAB1,HD5,15);     # MOVE HD5 TO PL                    #
      PTLSTV (PL,(15 + BYTNWD) / BYTNWD);   # PRINT HD5                #
  
      FOR I = 1 STEP 1
        UNTIL (15 + BYTNWD) / BYTNWD
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK USED PART OF PL             #
        END 
      PTLSTV (PL,1);               # PRINT BLANK LINE                  #
  
      CHRCHR (PL,TAB1,HD6,15);     # MOVE HD6 TO PL                    #
      PTLSTV (PL,(15 + BYTNWD) / BYTNWD);   # PRINT HD6                #
  
      FOR I = 1 STEP 1
        UNTIL (15 + BYTNWD) / BYTNWD
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK USED PART OF PL             #
        END 
  
      J = (TAB2 + 6 + BYTNWD) / BYTNWD; 
  
      FOR I = 0 STEP 1
        UNTIL 127 
      DO
        BEGIN 
        BINOCT (PL,TAB1,I,6); 
        HASHLINK = HLNK[I]; 
        BINOCT (PL,TAB2,HASHLINK,6);
        PTLSTV (PL,J);             # PRINT HASH TABLE ENTRY            #
        END 
  
      FOR I = 1 STEP 1
        UNTIL J 
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK USED PART OF PL             #
        END 
  
      RETURN; 
      END 
      CONTROL EJECT;
  
      PROC STPDMP;                 # SYMBOL TABLE POINTER DUMP         #
  
      BEGIN 
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     P R O C   S T P D M P                                            #
#                                                                      #
#     PRINT SYMBOL TABLE POINTERS HEADING AND SYMBOL TABLE POINTER     #
#     VALUES (APLC THRU STLC IN CEXEC).  STPDMP IS CALLED ONLY IF *=4  #
#     IS SELECTED IN CONJUNCTION WITH A SYMBOL TABLE DUMP OPTION       #
#     (*=34 OR *=N4).                                                  #
#                                                                      #
#----------------------------------------------------------------------#
  
  
      ITEM HD7          C(21) = "SYMBOL TABLE POINTERS";
  
      PTLSTV (PL,1);               # PRINT BLANK LINE                  #
  
      CHRCHR (PL,TAB1,HD7,21);     # MOVE HD7 TO PL                    #
      PTLSTV (PL,(21 + BYTNWD) / BYTNWD);   # PRINT HD7                #
  
      FOR I = 1 STEP 1
        UNTIL (21 + BYTNWD) / BYTNWD
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK USED PART OF PL             #
        END 
      PTLSTV (PL,1);               # PRINT BLANK LINE                  #
  
      J = (TAB2 + 6 + BYTNWD) / BYTNWD; 
  
      CHRCHR (PL,TAB1,"SPLC  = ",8);
      BINOCT (PL,TAB2,SPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"APLC  = ",8);
      BINOCT (PL,TAB2,APLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"CPLC  = ",8);
      BINOCT (PL,TAB2,CPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"DPLC  = ",8);
      BINOCT (PL,TAB2,DPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"LPLC  = ",8);
      BINOCT (PL,TAB2,LPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"TPLC  = ",8);
      BINOCT (PL,TAB2,TPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"UPLC  = ",8);
      BINOCT (PL,TAB2,UPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"XPLC  = ",8);
      BINOCT (PL,TAB2,XPLC,6);
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"ESPLC = ",8);
      BINOCT (PL,TAB2,ESPLC,6); 
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"NONAM = ",8);
      BINOCT (PL,TAB2,NONAM,6); 
      PTLSTV (PL,J);
  
      CHRCHR (PL,TAB1,"STLC  = ",8);
      BINOCT (PL,TAB2,STLC,6);
      PTLSTV (PL,J);
  
      FOR I = 1 STEP 1
        UNTIL J 
      DO
        BEGIN 
        PRTARY[I] = " ";           # BLANK USED PART OF PL             #
        END 
  
      RETURN; 
      END 
      CONTROL EJECT;
  
#        S D U M P   E N T R Y                                         #
  
         IF B<FULLDUMP>INTOPS EQ 1   # ESTABLISH FULL DUMP FLAG        #
         THEN 
           BEGIN
           FULLDMP = TRUE;
           END
         ELSE 
           BEGIN
           FULLDMP = FALSE; 
           END
         IF FULLDMP 
         THEN 
           BEGIN
           HTDMP; 
           STPDMP;
           END
         SHDR;
         I = SYMSTART;             # FWA OF SYMBOL TABLE               #
SDUMP1:  IF I GQ NXTAV THEN GOTO FIN; 
  
         IF CLAS[I] EQ S"DTXT"     # HANDLE S"DTXT" HERE               #
         THEN 
           BEGIN
           BINOCT (PL,TAB1,I,6);
           CHRCHR (PL,TAB2,"DTXT",4); 
           CHRCHR (PL,TAB3,"STRING C(72)=",13); 
           K = 0; 
           FOR J = 1 STEP 2 
             WHILE J LQ (NCHR[I] * 2 - 1) 
               AND J LS 120 
           DO 
             BEGIN
             C<K,1>STRING = C<J,1>NAME[I];
             K = K + 1; 
             END
           CHRCHR (PL,48,STRING,K); 
           PTLSTV (PL,(47 + K) / BYTNWD + 1); 
           FOR J = 1 STEP 1 
             UNTIL (47 + K) / BYTNWD + 1
           DO 
             BEGIN
             PRTARY[J] = " "; 
             END
           I = I + DTXT$W + (NCHR[I] + BYTNDEFWD - 1) / BYTNDEFWD;
           GOTO SDUMP1; 
           END
  
         IF  CLAS[I] EQ S"SNAM" 
         THEN 
           BEGIN
           SDMP(PHS,I,ERR); 
           I = I + SNAM$W + (NCHR[I] + BYTNWD - 1)/BYTNWD;
           GOTO SDUMP1; 
           END
  
         IF CLAS[I] EQ S"NAME"
         THEN 
           BEGIN
           IF FULLDMP              # IF FULL DUMP SELECTED             #
           THEN 
             BEGIN
             SDMP (PHS,I,ERR);     # DUMP S"NAME" ENTRY                #
             END
           I = I + NAME$W + (NCHR[I] + BYTNWD - 1) / BYTNWD;
           GOTO SDUMP1; 
           END
  
          SDMP(PHS,I,ERR);
          IF  ERR 
          THEN
            BEGIN 
            GOTO FIN; 
            END 
  
         I=I+CLSLNG[CLAS[I]]; 
         GOTO SDUMP1; 
  
FIN:     CHRCHR(PL,TAB1,ENDMSG,24); 
         PTLSTV(PL,(24+BYTNWD-1)/BYTNWD); 
  
         RETURN;
         CONTROL EJECT; 
ENTRY PROC SDUMPC(PHS,PTR); 
         ITEM PTR          I;      # SYMBOL TABLE INDEX                #
         ITEM XX,YY;
         ITEM ERMSG C(33)="CHAIN TERMINATED WITH ERROR ENTRY";
         XX=PTR;
         SHDR;
SDMPC1:  SDMP(PHS,XX,ERR);
         IF ERR THEN GOTO SDMPC2; 
         IF CLAS[XX] EQ S"SLC" THEN                              BEGIN
              IF BABY[XX] EQ 0 THEN RETURN; 
              XX=BABY[XX]; GOTO SDMPC1;                          END
         IF ASEQ[XX] EQ 0 THEN RETURN;
         XX=ASEQ[XX]; 
         GOTO SDMPC1; 
SDMPC2:  CHRCHR(PL,TAB1,ERMSG,33);
         YY=(TAB1+33+BYTNWD-1)/BYTNWD;
         PTLSTV(PL,YY); 
         FOR XX=1 STEP 1 UNTIL YY DO
              PRTARY[XX]=" "; 
         RETURN;
  
  
ENTRY PROC SDUMPE(PHS,PTR); 
         SHDR;  SDMP(PHS,PTR,ERR);  RETURN; 
  END 
$END
TERM
