Retro1.org codex

          IDENT  PACK,PACK,PACK
          ABS
          SST
          SYSCOM B1
          ENTRY  PACK
          ENTRY  RFL=
          TITLE  PACK - PACK FILE TO ONE RECORD.
*COMMENT  PACK - PACK FILE TO ONE RECORD.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
          SPACE  4
***       PACK - PACK FILE TO ONE RECORD.
*         W.T. SACKETT.  71/01/20.
          SPACE  4
***       PACK REMOVES ALL *EOR* AND *EOF* MARKS FROM A SPECIFIED FILE
*         AND COPIES IT AS ONE RECORD TO ANOTHER FILE.  IF NO THIRD
*         PARAMETER IS SPECIFIED, THE READ IS FROM *BOI* TO *EOI*.
*         DIRECT ACCESS FILES MAY BE PACKED.  PACK(A) AND PACK(A,A)
*         RETAIN FILE TYPES.  IN PACK(A,B), B REMAINS AS SPECIFIED
*         PRIOR TO THE PACK.
          SPACE  4,10
***       THE COMMAND.
*
*         PACK(IFILE,OFILE,NR)
*
*         IFILE  NAME OF FILE TO BE PACKED.
*         OFILE  NAME OF FILE TO RECEIVE PACKED DATA.
*         NR     IF A THIRD PARAMETER IS SPECIFIED, IFILE IS NOT
*                REWOUND BEFORE THE PACK OCCURS.
*         PACK(A) = PACK(A,A).
          SPACE  4,10
***       DAYFILE MESSAGES.
*
*         * PACK COMPLETE.*
*         * PACK PARAMETER ERROR.* - NO FILE NAMES, NULL OUTPUT FILE
*           OR TOO MANY PARAMETERS.
*         * INCORRECT INPUT FILE.* - ATTEMPT TO PACK INPUT FROM A
*           FILE ASSIGNED TO A TIME-SHARING TERMINAL.
          SPACE  4
          ORG    110B
 PACK     SB1    1           (B1) = 1
          SX6    SBUF        ENTER POINTER TO OUTPUT BUFFER
          SA6    B0
          SA1    ACTR        CHECK ARGUMENT COUNT
          MX0    42          (X0) LEFT " 0 IF INDIRECT ACCESS INPUT FILE
          SB7    X1-1
          NG     B7,ERR1     IF NO PARAMETERS
          RETURN SCR,R
          SA3    ARGR        FIRST PARAMETER
          SA2    I
          BX5    X0*X3       (X5) = INPUT FILE NAME IF RENAME NEEDED
          ZR     X5,ERR1     IF NO INPUT FILE NAME
          BX6    -X0*X2
          BX7    X5+X6
          SA7    A2
          GT     B7,B1,PAC1  IF NO REWIND BEFORE PACK
          REWIND I
 PAC1     ZR     B7,PAC2     IF ONE PARAMETER
          SA1    A3+B1       NEXT PARAMETER
          IX2    X1-X3
          ZR     X2,PAC2     IF PACK(A,A)
          ZR     X1,ERR1     SECOND PARAMETER INDICATED BUT NULL
          SA2    SCR
          BX3    X0*X1
          BX1    -X0*X2
          BX6    X3+X1
          MX5    0           (X5) = 0 IF TWO FILES SPECIFIED
          SA6    SCR
          SB7    B7-2
          GE     B7,B1,ERR1  IF INCORRECT PARAMETER COUNT
 PAC2     SA1    I           SET FILE NAME IN *FILINFO* BLOCK
          SA2    FINB
          BX1    X0*X1
          BX6    X1+X2
          SA6    A2
          FILINFO  A2        GET FILE INFORMATION
          SA1    FINB+1      CHECK FILE TYPE AND DEVICE TYPE
          MX0    -6
          BX7    X7-X7       CLEAR RANDOM INDEX
          BX2    -X0*X1
          LX1    59-16
          SX0    X2-2        SET BACKCOPY FLAG FOR QUEUED FILE
          ZR     X0,PAC3     IF QUEUED FILE
          SX0    X2-4        SET BACKCOPY FLAG FOR DIRECT ACCESS FILE
          ZR     X0,PAC3     IF DIRECT ACCESS FILE
          NG     X1,ERR2     IF FILE TYPE *TT*
          LX1    59-15-59+16
          NG     X1,PAC3     IF FILE ON MASS STORAGE
          BX0    X0-X0       SET BACKCOPY FLAG FOR TAPE FILE
 PAC3     SA7    I+6
 PAC4     READEI I
 PAC5     READW  I,WBUF,WBUFL
          NG     X1,PAC6     IF END OF INFORMATION
          WRITEW SCR,WBUF,WBUFL
          EQ     PAC5        GO FINISH READ
 
 PAC6     SB7    B6-WBUF
          WRITEW SCR,WBUF,B7
          WRITER X2
          REWIND X2,R
          ZR     X5,END      IF TWO DIFFERENT FILES
          BX7    X5
          SX2    I
          NZ     X0,PAC8     IF BACKCOPY NOT REQUIRED
          SA3    PACA
          NZ     X3,PAC7     IF BACKCOPY COMPLETE
          SX6    B1
          SA6    A3
          REWIND X2,R
          SA1    X2          SWITCH NAMES IN FET
          SA3    SCR
          BX6    X1
          BX7    X3
          SA6    A3
          SA7    X2
          REWIND A3,R
          EQ     PAC4        COPY SCR TO I
 
 PAC7     RETURN  I          RETURN SCRATCH FILE
          EQ     END         END PACK
 
 PAC8     SA7    SCR+6       SET FET FOR *LFM* RENAME
          RECALL I
          STATUS I,P         GET FILE STATUS
          SA1    I+5         GET FNT ENTRY
          MX0    -6
          BX0    -X0*X1
          SX1    X0-NDST
          NZ     X1,PAC9     IF NOT *NO-AUTO-DROP* STATUS
          SETFS  SCR,NAD     RESTORE *NAD* STATUS
 PAC9     RENAME SCR
 END      MESSAGE (=C* PACK COMPLETE.*)
          ENDRUN
 
 ERR1     MESSAGE (=C* PACK PARAMETER ERROR.*)
          ABORT
 
 ERR2     MESSAGE (=C* INCORRECT INPUT FILE.*)
          ABORT
 
 PACA     CON    0           BACKCOPY FLAG
 
 FINB     BSS    0           *FILINFO* PARAMETER BLOCK
          VFD    42/0,6/5,12/1
          BSSZ   4
          SPACE  4
*         COMMON DECKS.
*
*CALL     COMCCIO
*CALL     COMCLFM
*CALL     COMCRDW
*CALL     COMCSYS
*CALL     COMCWTW
*CALL     COMCMAC
*CALL     COMSLFD
*
*         FETS AND BUFFERS.
 WBUFL    EQU    100B
 BUFL     EQU    1001B
 I        RFILEB IBUF,BUFL,(FET=8),(WSA=WBUF,WBUFL)
 SCR      RFILEB SBUF,BUFL,FET=8),(WSA=WBUF,WBUFL)
          USE    LITERALS
 IBUF     EQU    *
 WBUF     EQU    IBUF+BUFL
 SBUF     EQU    WBUF+WBUFL
 RFL=     EQU    SBUF+BUFL
          SPACE  4
          END