*DECK +LISTCOM
LISTCOM,T17.
*CALL USER
*CALL CHARGE
*CALL BANNER
FTN.
COMPASS(S=SYSTEXT)
PURGE(LISTCOM/NA) 
DEFINE(LISTCOM) 
LDSET(MAP=SBEX) 
LOAD(LGO) 
NOGO(LISTCOM) 
*WEOR,0 
      PROGRAM LISTCOM(OUTPUT) 
C 
C 
C         PRODUCES A LISTING ON OUTPUT OF ALL COMDECKS ON THE 
C         RANDOM *OLDPL*. 
C         *CALLS OF COMDECKS WITHIN COMDECKS ARE NOT EXPANDED.
C 
  
      COMMON /CARD/  FLAG, CARD(8), NAME, NUMBER
      INTEGER  FLAG, CARD, NAME, NUMBER 
  
      INTEGER  T, T1, SAVE(2), HDATE, HTIME, PAGENUM, LINENUM 
  
  
C         OPEN THE OLDPL, AND READ THE DIRECTORY
  
      CALL OPENPL 
      CALL DATE(HDATE)
      CALL TIME(HTIME)
      PAGENUM = 1 
  
C         PROCESS A RECORD  (I.E. A COMDECK OR DECK)
  
C  GET FIRST CARD OF RECORD 
   10 CALL GETCARD
C  IF END-OF-FILE 
      IF (FLAG .EQ. 2)  GO TO 200 
C  IF END-OF-RECORD 
      IF (FLAG .EQ. 1)  GO TO 100 
C  CHECK WHETHER A COMDECK
      T = CARD(1) .AND. 77777777777777770000B 
      T1 = 47031715040503130000B
      IF (T .EQ. T1)  GO TO 20
      T = CARD(1) .AND.77777700000000000000B
      T1 = 47030400000000000000B
      IF (T .NE. T1)  GO TO 100 
C  EJECT TO NEW PAGE
   20 SAVE(1) = CARD(1) 
      SAVE(2) = CARD(2) 
   25 PRINT 1001, SAVE, HDATE, HTIME, PAGENUM 
 1001 FORMAT("1COMMON DECKS", 10X, 2A10, 20X, 2A10, 6X, "PAGE", I6 //)
      PAGENUM = PAGENUM + 1 
      LINENUM = 4 
C  LIST ALL CARDS 
   30 IF (LINENUM .GT. 60)  GO TO 25
      PRINT 1002, CARD, NAME, NUMBER
 1002 FORMAT(1X,7A10,A2,1X,A10,I6)
      LINENUM = LINENUM + 1 
      CALL GETCARD
C  IF NOT END-OF-RECORD OR END-OF-FILE,  LOOP 
      IF (FLAG .EQ. 0)  GO TO 30
C  IF END-OF-RECORD,  GO PROCESS NEXT RECORD
      IF (FLAG .EQ. 1)  GO TO 10
C  END-OF-FILE
      GO TO 200 
  
  
  
C         SKIP THIS RECORD
  
  100 CALL SKIPREC
      GO TO 10
  
  
C         END-OF-FILE 
  
  200 STOP
  
      END 
*WEOR,0 
          IDENT  OPENPL 
          TITLE  OPENPL -  OPEN OLDPL AND INITIALIZE
          MACHINE  ANY
          COMMENT  OPEN OLDPL AND INITIALIZE
          B1=1
          SST 
 *USES    OPSYN  NIL
          SPACE  4
**        OPENPL -  OPEN OLDPL AND INITIALIZE 
* 
*         RJ     =X_OPENPL
* 
*         OPENS FILE OLDPL. 
*         READS INDEX AND DIRECTORY.
  
  
          ENTRY  OPENPL 
 OPENPL   CON    *           ENTRY/EXIT WORD
          SB1    1
  
*      OPEN THE OLDPL AND READ THE INDEX
  
          SA1    OLDPL       42/LFN, 18/CODE AND STATUS 
          MX0    42 
          BX6    X0*X1       42/LFN, 18/0 
          SX2    142B        OPEN, READ, BINARY 
          BX6    X6+X2
          SA6    A1          STORE INTO FET 
          SYSTEM CIO,RECALL,OLDPL 
         *USES   A1,X1,A6,X6
  
*      READ THE DIRECTORY 
  
          SA1    INDEX+1     12/0, 18/LENGTH, 30/DIRECTORY ADDRESS
          BX6    X1 
          SA6    OLDPL+6
          AX6    30 
          SB2    X6 
          SB3    LDIRECT
          GT     B2,B3,400000B+*
          SA6    DIRECT-1    STORE ACTUAL LENGTH
  
          SA1    OLDPL       42/LFN, 18/CODE AND STATUS 
          MX0    7*6
          BX6    X0*X1
          SX2    12B         READ BINARY
          BX6    X6+X2
          SA6    A1 
  
          SYSTEM CIO,RECALL,OLDPL 
  
*      REPLACE TRAILING BINARY ZEROS IN DIRECTORY WITH BLANKS 
  
          SA1    INDEX+1     12/0, 18/LENGTH, 30/DIRECTORY PRU ADDRESS
          AX1    30          LENGTH 
          SB7    X1          LENGTH 
 OPENPL1  SA5    DIRECT+B7-1
          MX0    -6          77777777777777777700B
          BX5    X0*X5       CLEAR RIGHT 6 BITS 
          SX1    1R 
          BX5    X5+X1
1         DUP    8
          LX0    6           SHIFT MASK FOR NEXT CHARACTER
          BX4    -X0*X5      EXTRACT NEXT CHARACTER 
          NZ     X4,OPENPL2  IF END OF NAME ENCOUNTERED 
          LX1    6           SHIFT BLANK CHARACTER TO PROPER POSITION 
          BX5    X5+X1       REPLACE BINARY ZERO CHARACTER WITH BLANK 
1         ENDD
 OPENPL2  LX6    X5 
          SA6    A5          REPLACE NAME 
          SB7    B7-B1       DECREMENT INDEX
          NZ     B7,OPENPL1  IF MORE NAMES,  LOOP 
  
*      SWITCH TO BUFFER FOR DECKS 
  
          SA1    OLDPL+1     42/MISCELLANEOUS, 18/FIRST 
          MX0    42 
          BX6    X0*X1       42/MISCELLANEOUS, 18/0 
          SX2    BUFFER 
          BX6    X2+X6       42/MISCELLANEOUS, 18/FWA BUFFER
          SA6    A1 
          SX6    BUFFER 
          SA6    A6+B1       IN 
          SA6    A6+B1       OUT
          SX6    BUFFER+LBUFFER 
          SA6    A6+B1       LIMIT
  
*      SET THE PRU ADDRESS TO THE FIRST DECK
  
          SX6    2
          SA6    OLDPL+6
  
*      INITIATE READING OF THE FIRST DECK 
  
          SA1    OLDPL       42/LFN, 18/CODE+STATUS 
          MX2    42 
          BX6    X2*X1       42/LFN, 18/CODE+STATUS 
          SX2    12B         READ BINARY
          IX6    X6+X2       42/LFN, 18/12B 
          SA6    A1 
          SYSTEM CIO,RECALL,OLDPL 
         *USES   A1,X1,A6,X6
  
*      CLEAR THE RANDOM BIT,  SO SUBSEQUENT READS WILL BE SEQUENTIAL
  
          SA1    OLDPL+1
          MX0    -1 
          LX0    47          BIT 47 IS THE RANDOM BIT 
          BX6    X0*X1
          SA6    A1 
  
*      EXIT 
  
          EQ     OPENPL 
          TITLE  DATA 
          ENTRY  OLDPL
 OLDPL    RFILEB DIRECT,LDIRECT,(IND=INDEX,LINDEX)
 LINDEX   EQU    101B 
 INDEX    BSS    LINDEX 
  
          USE    /DIRECT/ 
 LDIRECT  EQU    500
          CON    LDIRECT
 DIRECT   BSS    LDIRECT
          USE    *
  
          USE    /BUFFER/ 
 LBUFFER  EQU    10001B 
          CON    LBUFFER
 BUFFER   BSS    LBUFFER
          USE    *
          SPACE  4
          END 
          IDENT  GETCARD
          TITLE  GETCARD -  GET A CARD IMAGE FROM OLDPL 
          MACHINE  ANY,I
          COMMENT  GET A CARD IMAGE FROM OLDPL
          B1=1
          SPACE  4
**        GETCARD -  GET A CARD IMAGE FROM OLDPL
* 
*         CALL   GETCARD
* 
*         COMMON /CARD/ FLAG, CARD(8), NAME, NUMBER 
*         IMPLICIT INTEGER A-Z
*         SETS FLAG = 0 IF CARD, NAME, NUMBER SET.
*                   = 1 IF END-OF-RECORD ENCOUNTERED. 
*                   = 2 IF END-OF-FILE ENCOUNTERED, 
*                       OR IF THE NEXT WORD IS -YANK$$$-
*                       (I.E. FIRST WORD OF DECK LIST)
          EJECT 
 ABORT    MICRO  1,, 400000B+*
          SPACE  4
**        GETCHAR -  GET A CHARACTER FORM THE OLDPL 
* 
*         GETCHAR EOL=GET9
*        *USES   B5,A1,X1,A2,X2,A6,X6 
* 
*         SETS X3 = NEXT CHARACTER. 
*         DECREMENTS B3  (I.E. WORD COUNT). 
*         IF NO MORE WORDS ARE LEFT TO SUPPLY CHARACTERS, 
*         JUMPS TO -GET9- TO FILL REST OF CARD WITH BLANKS. 
  
  
 GETCHAR  MACROE EOL
          LOCAL  NEXT 
          NZ     B5,NEXT
          ZR     B3,EOL 
          RJ     GETWORD     X1 = WORD, X2 = FLAG 
         *USES   A1,X1,A2,X2,A6,X6
          SB3    B3-1        DECREMENT WORD COUNT 
          NZ     X2,"ABORT" 
          SB5    10 
 NEXT     LX1    6
          BX3    -X0*X1 
          SB5    B5-1 
 GETCHAR  ENDM
          SPACE  4
**        PUTCHAR -  PUT A CHARACTER INTO /CARD/
* 
*         X3 = CHARACTER TO BE APPENDED TO /CARD/ 
*         PUTCHAR EOC=GET6
*        *USES   B6,B7,A7,X7
* 
*         APPENDS THE CHARACTER IN X3 TO /CARD/.
*         IF THIS WAS THE LAST (72ND) CHARACTER,
*         JUMPS TO -GET6- TO FINISH UP AND EXIT.
  
  
 PUTCHAR  MACROE EOC
          LOCAL  NEXT 
          LX7    6
          BX7    X7+X3
          SB6    B6-1 
          NZ     B6,NEXT
          SA7    A7+B1
          BX7    X0-X0
          SB6    10 
 NEXT     SB7    B7-1 
          ZR     B7,EOC      GO FINISH UP 
 PUTCHAR  ENDM
  
  
 *USES    OPSYN  NIL
          EJECT 
          ENTRY  GETCARD
 GETCARD  CON    *           ENTRY/EXIT WORD
          SA0    =X_OLDPL 
          SB1    1
  
*      READ HEADER WORD 
  
 GET1     RJ     GETWORD     X1 = WORD,  X2 = FLAG
         *USES   A1,X1,A2,X2,A6,X6
                             X1 = 1/CHB FLAG  (=1 IFF LAST CHB WORD), 
                                  1/ACTIVE FLAG  (=1 IFF ACTIVE CARD),
                                  4/<UNUSED>, 
                                  18/WORD COUNT FOR THIS CARD 
                                  18/SEQUENCE NUMBER FOR THIS CARD, 
                                  2/CHB MISC. 
                                  16/INDEX TO DIRECTORY FOR THIS IDENT
          NZ     X2,GET16    IF NO WORD,  END-OF-RECORD OR END-OF-FILE
          SA2    YANK$$$
          MX3    42 
          IX2    X1-X2
          BX2    X3*X2
          ZR     X2,GET15    IF FIRST CARD OF DECK LIST 
          IX0    X1+X1       BIT 59 = 1 IFF ACTIVE CARD 
          PL     X0,GET12    IF INACTIVE CARD,  GO SKIP IT
          MX3    -16
          BX3    -X3*X1      INDEX TO DIRECTORY FOR IDENT 
          SA3    DIRECT+X3   IDENT NAME 
          BX6    X3 
          SA6    NAME 
          BX4    X1 
          AX4    18          SEQUENCE NUMBER
          SX6    X4          STRIP EXCESS BITS
          SA6    NUMBER      STORE
          AX4    18          WORD COUNT 
          SB3    X4 
  
*      SKIP CORRECTION HISTORY BYTES
  
 GET2     NG     X1,GET3     IF JUST READ LAST CHB WORD,  SKIP
          RJ     GETWORD     X1 = WORD,  X2 = FLAG
         *USES   A1,X1,A2,X2,A6,X6
          NZ     X2,"ABORT"  IF NO WORD,  ABORT 
          PL     X1,GET2     IF NOT LAST CHB WORD 
 GET3     BSS    0
  
*      COPY COMPRESSED IMAGE TO /CARD/
  
          MX0    -6          77777777777777777700B
          SB7    72          NUMBER OF CHARACTERS LEFT FOR /CARD/ 
          SB5    B0          NO. CHARACTERS LEFT FROM COMPRESSED WORD 
          SB6    10          NO. CHARACTERS LEFT FOR CURRENT /CARD/ WORD
          SA1    CARD-1 
          BX7    X1 
          SA7    A1          SET A7 
          BX7    X0-X0       CLEAR X7 
  
 GET4     GETCHAR EOL=GET9   SET X3 = CHARACTER 
         *USES   B5,A1,X1,A2,X2,A6,X6 
          ZR     X3,GET8     IF SPECIAL 
 GET5     PUTCHAR EOC=GET6   APPEND X3 TO CARD IMAGE
         *USES   X6,B7,A7,X7
          EQ     GET4        LOOP UNTIL IMAGE HAS 72 CHARACTERS 
  
  
*      FINISH UP AND EXIT 
  
 GET6     LX7    8*6         LEFT-JUSTIFY LAST 2 CHARACTERS 
          SA7    A7+B1       STORE THE LAST WORD OF /CARD/
          SX6    B0          FLAG = 0 MEANS CARD IS RETURNED
          SA6    FLAG 
  
          ZR     B3,GETCARD  IF END OF SOURCE WORDS FOR THIS CARD 
 GET7     RJ     GETWORD     X1 = WORD,  X2 = FLAG
         *USES   A1,X1,A2,X2,A6,X6
          NZ     X2,"ABORT"  IF END-OF-RECORD OR END-OF-FILE, ABORT 
          SB3    B3-1        DECREMENT COUNT OF SOURCE WORDS
          NZ     B3,GET7     IF MORE WORDS IN THIS CARD,  LOOP
          EQ     GETCARD     EXIT 
  
  
*      SPECIAL
  
 GET8     GETCHAR EOL=GET9   X3 = COUNT 
         *USES   B5,A1,X1,A2,X2,A6,X6 
          ZR     X3,GET9     IF END-OF-CARD 
          SX4    X3-1 
          NZ     X4,GET10    IF (X3+1) BLANK CHARACTERS 
  
*      COLON
  
          BX3    X3-X3       1R:  
          EQ     GET5        RESUME COPYING 
  
  
*      COPY BLANKS
  
 GET9     SX3    72 
 GET10    SB4    X3+1 
 GET11    SX3    1R 
          PUTCHAR EOC=GET6
         *USES   B6,B7,A7,X7
          SB4    B4-B1
          GT     B4,B1,GET11
          SX3    1R 
          EQ     GET5        RESUME NORMAL COPYING
  
  
*      SKIP THIS CARD 
  
 GET12    AX1    2*18        WORD COUNT 
          SB7    X1          NUMBER OF WORDS IN THIS CARD 
          NG     X1,GET14    IF JUST READ LAST CHB WORD,  SKIP
 GET13    RJ     GETWORD     X1 = WORD,  X2 = FLAG
         *USES   A1,X1,A2,X2,A6,X6
          NZ     X2,"ABORT"  IF NO WORD,  ABORT 
          PL     X1,GET13    IF NOT LAST CHB WORD,  LOOP
 GET14    RJ     GETWORD     X1 = WORD,  X2 = FLAG
         *USES   A1,X1,A2,X2,A6,X6
          NZ     X2,"ABORT"  IF NO WORD,  ABORT 
          SB7    B7-1        DECREMENT WORD COUNT 
          NZ     B7,GET14    IF MORE CARDS, LOOP
          EQ     GET1        TRY AGAIN
  
  
*      END-OF-RECORD OR END-OF-FILE 
  
 GET15    SX2    2           (YANK$$$ ENCOUNTERED)
 GET16    BX6    X2 
          SA6    FLAG 
          EQ     GETCARD
          SPACE  4
 YANK$$$  VFD    48/0LYANK$$$,12/0
  
          USE    /CARD/ 
 FLAG     BSS    1
 CARD     BSS    8
 NAME     BSS    1
 NUMBER   BSS    1
          USE    *
  
          USE    /DIRECT/ 
 LDIRECT  BSS    1
 DIRECT   BSS    500
          USE    *
  
          EXT    GETWORD
          SPACE  4
          END 
          IDENT  GETWORD
          TITLE  GETWORD -  GET A WORD FROM A FILE
          MACHINE  ANY
          COMMENT  GET A WORD FROM A FILE 
          B1=1
 *USES    OPSYN  NIL
          SPACE  4
**        GETWORD -  GET A WORD FROM A FILE 
* 
*         A0 = ADDRESS OF FET 
*         B1 = 1
* 
*         RJ     GETWORD
* 
*         SETS X2 = 0 IFF X1 = WORD FROM FILE 
*                 = 1 IFF END-OF-RECORD ENCOUNTERED.
*                 = 2 IFF END-OF-FILE ENCOUNTERED.
* 
*         USES-  X  - 1 2 - - - 6 - 
*                A  0 1 2 - - - 6 - 
*                B    * - - - - - -    *B1=1
  
  
          ENTRY  GETWORD
 GETWORD  CON    *           ENTRY/EXIT WORD
 GETWORD1 SA1    A0+3        OUT
          SA2    A1+B1       LIMIT
          SX2    X2 
          IX6    X1-X2
          ZR     X6,GETWORD2 IF WRAP-AROUND 
          SA2    A1-B1       IN 
          IX6    X1-X2
          ZR     X6,GETWORD3 IF BUFFER IS EMPTY 
          SX6    X1+B1
          SA6    A1          SET OUT = OUT + 1
          SA1    X1          (OUT-1)
          BX2    X2-X2       X2 = 0 MEANS WORD IS RETURNED
          EQ     GETWORD     EXIT 
  
  
*      WRAP-AROUND
  
 GETWORD2 SA2    A0+B1       FIRST
          BX6    X2 
          SA6    A0+3        SET OUT = FIRST
          EQ     GETWORD1    TRY AGAIN
  
  
*      BUFFER IS EMPTY
  
*         SINCE ALL PP CALLS FOR THIS FILE ARE WITH SUTO-RECALL,
*         THE BUFFER IS TRULY EMPTY 
 GETWORD3 SA1    A0          42/LFN, 18/CODE+STATUS 
          LX1    59-4        BIT 59 = 1 IFF EOR OR EOF
          NG     X1,GETWORD4 IF END-OF-FILE 
          SA1    A0          42/LFN, 18/CODE+STATUS 
          MX2    42 
          BX6    X2*X1       42/LFN, 18/0 
          SX1    12B         READ BINARY
          IX6    X6+X1
          SA6    A1 
  
          SYSTEM CIO,RECALL,A0
         *USES   A1,X1,A6,X6
  
          EQ     GETWORD1    TRY AGAIN
  
  
*      END-OF-RECORD OR END-OF-FILE ENCOUNTERED 
  
 GETWORD4 LX1    1           BIT 59 = 1 IFF END-OF-FILE 
          NG     X1,GETWORD5 IF END-OF-FILE 
          SA1    A0          42/LFN, 18/CODE+STATUS 
          MX2    42 
          BX6    X2*X1       42/LFN, 18/0 
          SX2    B1          SET CODE " EOR 
          IX6    X6+X2
          SA6    A1 
          EQ     GETWORD     EXIT WITH X2 = 1 
  
  
*      END-OF-FILE ENCOUNTERED
  
 GETWORD5 SA1    A0          42/LFN, 18/CODE+STATUS 
          SX2    X1          0 IFF CODE+STATUS = 777777B
          ZR     X2,400000B+*  IF ALREADY HIT END-OF-FILE 
          MX2    42 
          BX6    X2*X1       42/LFN, 18/0 
          BX6    -X2+X6      42/LFN, 18/777777B 
          SA6    A1 
          SX2    B1+B1       X2 = 2 MEANS END-OF-FILE 
          EQ     GETWORD     EXIT 
          SPACE  4
          END 
          IDENT  SKIPREC
          TITLE  SKIPREC -  SKIP A RECORD ON *OLDPL*
          MACHINE  ANY
          COMMENT  SKIP A RECORD ON *OLDPL* 
          B1=1
 *USES    OPSYN  NIL
          SPACE  4
**        SKIPREC -  SKIP A RECORD ON *OLDPL* 
* 
*         CALL SKIPREC
* 
*         SKIPS A RECORD ON FILE *OLDPL*. 
  
  
          ENTRY  SKIPREC
 SKIPREC  CON    *           ENTRY/EXIT WORD
 SKIPREC1 SA1    =X_OLDPL+2  IN 
          BX6    X1 
          SA6    =X_OLDPL+3  SET OUT = IN 
          SA1    =X_OLDPL    42/LFN, 18/CODE+STATUS 
          MX2    42 
          BX6    X2*X1       42/LFN, 18/0 
          SX2    12B         READ BINARY
          IX6    X6+X2       42/LFN, 18/12B 
          SA6    A1 
          BX3    X1          SAVE CURRENT STATUS
          SYSTEM CIO,RECALL,OLDPL 
         *USES   A1,X1,A6,X6
          LX3    59-4        BIT 59 = 1 IFF EOR OR EOF
          PL     X3,SKIPREC1 IF NOT YET END-OF-RECORD OR END-OF-FILE
  
          EQ     SKIPREC     EXIT 
          SPACE  4
          END 
*WEOR,17
