*DECK,DMPELST 
*IF -DEF,TEST 
          IDENT DMPELST 
  
*                THIS DUMMY DECK GENERATES A 77-TABLE FOR *DMPELST* 
*         IN A SYSTEM-MODE COMPILER.  ITS PURPOSE IS TO KEEP THE
*         RELOCATABLE BINARY STRUCTURE IDENTICAL IN SYSTEM- OR
*         TEST-MODE COMPILER CONFIGURATION. 
  
  
  
 DMPELST  BSS    0
          ENTRY  DMPELST
  
  
  
          END 
*ENDIF
*IF DEF,TEST
      SUBROUTINE DMPELST (TYPE,ATYPE,LTYPE,CLABEL,NLABEL,FWAEL,RA1) 
  
  
C         PRODUCES FORMATTED DUMP OF E-LIST, PLUS STATEMENT TYPE AND
C     LABEL INFORMATION GENERATED BY *SCANNER*. 
  
      IMPLICIT INTEGER (A-Z)
  
      COMMON /DMPEL/  EOSCHK, LENEL, LENLEL, LISTCMD
  
      DIMENSION FWAEL(1), RA1(1)
      DIMENSION AUXCODE(3), CONCODE(7), ELCODE(21), HOLCODE(5)
  
      DATA AUXCODE / 5HRANGE, 5HINDEF, 5HVALID /
      DATA CONCODE / 3HLOG, 3HINT, 4HREAL, 3HDBL, 4HCPLX, 3HOCT, 3HHOL /
      DATA ELCODE/ 5HCON  , 
     .   5HNAME ,  5H)    ,  5H,    ,  5H*EOS*,  5H=    , 
     .   5H(    ,  5H.OR. ,  5H.AND.,  5H.NOT.,  5H.LE. , 
     .   5H.LT. ,  5H.GE. ,  5H.GT. ,  5H.NE. ,  5H.EQ. , 
     .   5H-    ,  5H+    ,  5H*    ,  5H/    ,  5H**                  /
      DATA HOLCODE / 5HHOL-H, 5HHOL-L, 5HHOL-R, 5H*ILL*, 5HHOL"" /
  
  
  
C         INITIALIZE. 
  
      LIST = LISTCMD
  
C         DON-T CHECK FOR ERRORS IF STATEMENT IS *BAD* (TYPE = 18)
C         AND LISTING IS OFF.  PREVENTS SPURIOUS ERROR MESSAGES WHEN
C         MAKING ROUTINE END-OF-STMT CHECKS IN TEST-MODE COMPILER.
  
      IF (LIST .EQ. 0 .AND. TYPE .EQ. 18)  GO TO 999
  
  
 10   ERRCNT = 0
      LIFFLG = 0
      LOOPCT = LENEL
  
C         FORMAT LABEL INFO.
  
      CLABL = CLABEL
      NLABL = NLABEL
      IF (CLABL .EQ. 0)  CLABL = " "
      IF (NLABL .EQ. 0)  NLABL = " "
  
C         MAIN LOOP.
  
 100  CONTINUE
  
C         SPECIAL-CASE *FORMAT*.
  
      IF (TYPE .NE. 9)  GO TO 120 
      IF (LIST .NE. 0)  PRINT 111, FWAEL(LOOPCT), FWAEL(LOOPCT) 
 111  FORMAT (28X, A10, 6X, O20)
      GO TO 600 
  
 120  CONTINUE
  
C         E-LIST DUMP LOOP. 
  
      DO 500 N = 1,LOOPCT 
      ERR = " " 
      EDPC = " "
  
      EL = FWAEL(LOOPCT+1-N)
      ELU = SHIFT( (EL .A. MASK(12)), -48 ) 
      ELL = EL .A. .N. MASK(12) 
      ECODE = ELU - 2000B 
      IF ( ECODE .LT. 0  .OR.  ECODE .GT. 24B )  GO TO 300
      E48 = EL .A. .N. MASK(12) 
  
C         SPECIAL CASE ITEMS WITH SAME E-LIST CODE, BUT DIFFERENT 
C         CONTENTS OF BITS 47-0.
  
      EDPC = ELCODE(ECODE+1)
      IF ( ECODE .NE. 0 )  GO TO 220
  
C         PROCESS TYPE CODE = 0.
  
      IF ( E48 .NE. 0 )  GO TO 201
      EDPC = ".F."
      GO TO 400 
  
 201  IF ( E48 .NE. 777776B )  GO TO 202
      EDPC = ".T."
      GO TO 400 
  
C         PROCESS CONSTANT (TYPE CODE = 0, LOWER 48 BITS .PL.). 
C         ONLY THE 1ST TEN CHARS OF *CONSTOR* ENTRY WILL BE LISTED. 
  
 202  CONTYPE = SHIFT(EL,-45) .A. .N. MASK(57)
      EDPC = "* BAD TYPE" 
      IF ( CONTYPE .GT. 6 )  GO TO 310
      CONTYPE = CONCODE(CONTYPE+1)
      CONLEN = SHIFT(EL,-18) .A. .N. MASK(48) 
      EDPC = "* BAD LEN"
      IF ( CONLEN .LE. 0  .OR. CONLEN .GT. 1320 )  GO TO 310
      CONADDR = EL .A. .N. MASK(42) 
      EDPC = "* BAD ADDR" 
      IF ( CONADDR .LT. 7000B  .OR.  CONADDR .GT. 32000B )  GO TO 310 
      CON = RA1(CONADDR)
      IF ( CONTYPE .NE. "HOL" )  GO TO 410
  
C         CHECK FOR VALID HOLLERITH CONSTANT TYPE CODES 0, 1, 2, 4. 
  
      HCONTYP = SHIFT(EL,-36) .A. .N. MASK(51)
      EDPC = "**BAD HOLL" 
      IF ( (56B .A. SHIFT(1,HCONTYP+1)) .EQ. 0 )  GO TO 310 
      CONTYPE = HOLCODE(HCONTYP+1)
      GO TO 410 
  
C         PROCESS VARIABLE NAME (TYPE CODE = 1).
  
 220  IF ( ECODE .NE. 1 )  GO TO 230
      EDPC = SHIFT(E48,12) .O. 2R 
      GO TO 400 
  
C         PROCESS TYPE CODES 2 - 24B. 
  
 230  IF ( ECODE .LT. 20B  .OR.  ECODE .GT. 22B )  GO TO 400
      IF (E48 .NE. 5 )  GO TO 400 
      EDPC = AUXCODE(ECODE-20B+1) 
      GO TO 400 
  
C         PROCESS BAD E-LIST ENTRY. 
  
 300  EDPC = " "
      GO TO 390 
  
 310  CONTINUE
  
 390  IF ( LIST .NE. 0 )  GO TO 391 
      LIST = 1
      GO TO 10
  
 391  ERR = "** ERROR *"
      ERRCNT = ERRCNT + 1 
      IF ( ERRCNT .LT. 11 )  GO TO 402
      PRINT 392 
 392  FORMAT (///, 1X, 56H***** MORE THAN 10 E-LIST ERRORS IN THIS STATE
     .MENT *****, ///)
      GO TO 600 
  
C         PRINT FORMATTED E-LIST. 
  
 400  IF ( LIST .EQ. 0 )  GO TO 404 
 402  PRINT 403, EDPC, ELU, ELL, ERR
 403  FORMAT (28X, A10, 6X, O4, 1X, O16, 55X, A10)
 404  IF ( ECODE - 4 )  500, 600, 500 
  
 410  IF (LIST .NE. 0)  PRINT 411, CON, ELU, ELL, CONLEN, CONTYPE, ERR
 411  FORMAT (28X, A10, 6X, O4, 1X, O16, 3X, *LEN = *, I4,
     . 3X, *TYPE = *, A5, 29X, A10) 
  
 500  CONTINUE
  
C         PRINT STATEMENT SUMMARY INFO. 
  
 600  IF (LIFFLG .NE. 0)  GO TO 620 
      IF (LIST .NE. 0)  PRINT 601, TYPE, ATYPE, CLABL, NLABL
 601  FORMAT (30X, *(TYPE) = *, I2, 3X, *(ATYPE) = *, I2, 3X, 
     . *(CLABEL) = *, A8, *(NLABEL) = *, A8)
  
C         REPEAT E-LIST DUMP FOR LOGICAL *IF* TARGET. 
  
      IF ( TYPE .NE. 17 )  GO TO 900
      IF (LIST .EQ. 0 .AND. LTYPE .EQ. 18)  GO TO 999 
      LIFFLG = 1
      LOOPCT = LENLEL 
      GO TO 100 
  
 620  IF ( LIST .NE. 0 )  PRINT 621, LTYPE, ATYPE 
 621  FORMAT (29X, *(LTYPE) = *, I2, 3X, *(ATYPE) = *, I2)
  
C         FINAL PROCESSING. 
  
 900  IF ( LIST .NE. 0 )  PRINT 901 
 901  FORMAT (2X) 
  
      IF ( EOSCHK .NE. 0  .A.  ECODE .NE. 4 )  PRINT 911
 911  FORMAT ( 24H ***** EOS MISSING ***** )
      EOSCHK = 0
  
      IF ( ERRCNT .NE. 0 )  PRINT 921, ERRCNT 
 921  FORMAT ( 6H *****, I10, 23H ERRORS IN E-LIST ***** )
  
 999  RETURN
      END 
*ENDIF
