Retro1.org codex

PROC BZFILL(CHAR,(TYP),(NUM)); 
#
          IDENT  BZFILL
          TITLE  BZFILL - BLANK OR ZERO FILLS A CHARACTER ITEM.
#
 
      BEGIN  # BZFILL #
 
#
***   BZFILL - BLANK OR ZERO FILLS A CHARACTER ITEM.
*
*     COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
*
*     PROC BZFILL(CHAR,(TYP),(NUM))
*
*     ENTRY   (TYP)  = TYPE OF FILLING REQUIRED.
*                    = 0 (S"BFILL"), BLANK FILLING.
*                    = 1 (S"ZFILL"), ZERO FILLING.
*             (NUM)  = LENGTH OF CHARACTER ITEM IN NUMBER
*                      OF CHARACTERS.
*
*     EXIT    (CHAR) = BLANK OR ZERO FILLED CHARACTER.
*
*     NOTES   DEPENDING ON THE TYPE OF CONVERSION, ZEROES
*             ARE REPLACED BY BLANKS OR BLANKS BY ZEROES.
#
 
      ITEM CHAR       C(240);        # ITEM TO BE BLANK/ZERO FILLED #
      ITEM TYP        U;             # TYPE OF FILLING REQUIRED #
      ITEM NUM        I;             # LENGTH OF *CHAR* IN NUMBER OF
                                       CHARACTERS #
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMAMSS
*CALL COMABZF
 
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
 
CONTROL EJECT;
 
#
*     START OF EXECUTABLE CODE.
#
 
      IF TYP EQ TYPFILL"BFILL"
      THEN
        BEGIN  # BLANK FILL #
        FASTFOR I = 0 STEP 1 UNTIL NUM-1
        DO
          BEGIN
          IF C<I,1>CHAR EQ 0         # REPLACE ZEROES BY BLANKS #
          THEN
            BEGIN
            C<I,1>CHAR = " ";
            END
 
          END
 
        RETURN;
        END  # BLANK FILL #
 
      IF TYP EQ TYPFILL"ZFILL"
      THEN
        BEGIN  # ZERO FILL #
        FASTFOR I = 0 STEP 1 UNTIL NUM-1
        DO
          BEGIN
          IF B<I*6,6>CHAR EQ O"55"   # REPLACE BLANKS BY ZEROES #
          THEN
            BEGIN
            B<I*6,6>CHAR = 0;
            END
 
          END
 
        RETURN;
 
        END  # ZERO FILL #
 
      END  # BZFILL #
 
#
          END
#
    TERM
PROC LOFPROC((LFN));
#
          IDENT  LOFPROC
          TITLE  LOFPROC - LIST OF FILES PROCESSOR.
#
 
      BEGIN  # LOFPROC #
 
#
***   LOFPROC - LIST OF FILES PROCESSOR.
*
*     *LOFPROC* IS USED TO CREATE A LIST OF LOCAL FILE NAMES, AND ALSO
*     TO RETURN THE FILES NAMED IN THIS LIST.
*
*     PROC LOFPROC((LFN))
*
*     ENTRY    (LFN) = NONZERO, LOCAL FILE NAME TO BE ADDED TO THE
*                      LIST OF FILES.
*                    = 0, ALL FILES IN THE LIST ARE TO BE RETURNED.
*
*     EXIT     THE SPECIFIED FILE HAS BEEN ADDED TO THE LIST, OR ALL
*              FILES IN THE LIST HAVE BEEN RETURNED.
#
 
      ITEM LFN       I;              # FILE NAME TO BE ADDED TO LIST #
 
#
****  PROC LOFPROC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # BLANK OR ZERO FILL ITEM #
        PROC RETERN;                 # RETURN FILE #
        PROC ZSETFET;                # INITIALIZE FET #
        END
 
#
****  PROC LOFPROC - XREF LIST END.
#
 
      DEF LOFMAX     #15#;           # MAXIMUM LENGTH OF FILE LIST #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMAMSS
*CALL COMAFET
 
      ITEM I          I;             # INDUCTION VARIABLE #
      ITEM ORD        U = 0;         # CURRENT TABLE ORDINAL #
 
      ARRAY LFET [0:0] S(SFETL); ;   # FET USED FOR *RETURN* REQUEST #
      ARRAY LOF [0:LOFMAX] S(1);     # LIST OF FILES TABLE #
        BEGIN
        ITEM LOF$WRD    U(00,00,60);  # FULL WORD DEFINITION #
        ITEM LOF$LFN    C(00,00,07);  # LOCAL FILE NAME #
        END
 
                                               CONTROL EJECT;
 
      IF LFN NQ 0 AND ORD LQ LOFMAX
      THEN                           # ADD LFN TO LIST OF FILES #
        BEGIN
        BZFILL(LFN,1,7);
        LOF$WRD[ORD] = LFN;
        ORD = ORD + 1;
        RETURN;
        END
 
      IF LFN EQ 0
      THEN                           # RETURN ALL FILES LISTED #
        BEGIN  # RETURN FILES #
        ZSETFET(LOC(LFET[0]),"",0,0,SFETL);
 
        SLOWFOR I = 0 STEP 1 WHILE I LS ORD
        DO
          BEGIN
          FET$LFN[0] = LOF$LFN[I];
          RETERN(LFET[0],RCL);
          END
 
        END  # RETURN FILES #
 
      RETURN;
      END  # LOFPROC #
 
#
          END
#
    TERM
PROC MSG((DFMSG),(OP));
#
          IDENT  MSG
          TITLE  MSG - DISPLAY DAYFILE MESSAGE.
#
 
      BEGIN  # MSG #
 
#
***   MSG - DISPLAY DAYFILE MESSAGE.
*
*     *MSG* SEARCHES A MESSAGE FOR A TERMINATING CHARACTER AND
*     ZERO FILLS THE MESSAGE FROM THE TERMINATOR TO THE END
*     OF THE MESSAGE.
*
*     PROC MSG((DFMSG),(OP))
*
*     ENTRY      (DFMSG) - MESSAGE TO BE DISPLAYED, 80 CHARACTER
*                          MAXIMUM.
*                (OP)    - MESSAGE ROUTING OPTION.
*                          (VALUES DEFINED IN *MESSAGE* MACRO ROUTINE)
*
*     EXIT       THE MESSAGE HAS BEEN DISPLAYED AT THE LOCATION
*                SPECIFIED BY (OP).
#
 
      ITEM DFMSG      C(80);         # MESSAGE TEXT #
      ITEM OP         I;             # MESSAGE ROUTING OPTION #
 
#
****  PROC MSG - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # ISSUE MESSAGE #
        END
 
#
****  PROC MSG - XREF LIST END.
#
 
      DEF BLANK #" "#;               # BLANK CHARACTER #
      DEF TERMCHAR #";"#;            # TERMINATOR CHARACTER #
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMAMSS
 
      ITEM I          I;             # LOOP COUNTER #
      ITEM CP         I;             # CHARACTER POSITION #
 
CONTROL EJECT;
 
      CP = 0;
      FASTFOR I = 0 STEP 1 WHILE I LS 80 AND CP EQ 0
      DO                             # FIND TERMINATOR #
        BEGIN
        IF C<I,1>DFMSG EQ TERMCHAR
        THEN
          BEGIN
          CP = I;
          END
 
        END
 
      IF CP NQ 0
      THEN                           # ZERO FILL END OF MESSAGE #
        BEGIN
        B<CP*6,(80-CP)*6>DFMSG = 0;
        END
 
      MESSAGE(DFMSG,OP);             # ISSUE MESSAGE #
      RETURN;
      END  # MSG #
 
#
          END
#
    TERM
PROC RESTPFP((OPTION));
#
          IDENT  RESTPFP
          TITLE  RESTPFP - RESTORE USER *PFP* AND ABORT OR RETURN.
#
 
      BEGIN  # RESTPFP #
 
#
**    RESTPFP - RESTORE USER *PFP* AND ABORT OR RETURN.
*
*     *RESTPFP* RESTORES THE USER-S FAMILY AND USER INDEX, AND
*     OPTIONALLY CALLS *LOFPROC* TO RETURN ANY LISTED FILES.
*
*     PROC RESTPFP((OPTION))
*
*     ENTRY     (OPTION) - PROCESSING OPTION (VALUES DEFINED IN
*                          *COMAMSS*).
*                        = *PFP$ABORT*, RESTORE *PFP*, RETURN ANY
*                          LISTED FILES, AND ABORT PROCESSING.
*                        = *PFP$END*, RESTORE *PFP*, RETURN ANY LISTED
*                          FILES, AND RETURN TO CALLING PROGRAM.
*                        = *PFP$RESUME*, RESTORE *PFP* AND RETURN TO
*                          CALLING PROGRAM (NO FILES RETURNED).
*               (USER$FAM) = USER-S CURRENT FAMILY (IN *APFPCOM*).
*               (USER$UI)  = USER-S CURRENT USER INDEX (IN *APFPCOM*).
*
*     EXIT      THE USER INDEX AND FAMILY OF THE USER HAVE BEEN
*               RESTORED.  DEPENDING ON THE VALUE OF *OPTION*,
*               LISTED FILES MAY HAVE BEEN RETURNED, AND/OR
*               PROCESSING MAY HAVE BEEN ABORTED.
*
*     MESSAGE   * PROGRAM ABNORMAL, RESTPFP.*.
#
 
      ITEM OPTION     I;             # PROCESSING OPTION #
 
#
****  PROC RESTPFP - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ABORT;                  # ISSUE ABORT #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        END
 
#
****  PROC RESTPFP - XREF LIST BEGIN.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
 
*CALL COMAMSS
*CALL COMAPFP
 
      ARRAY PFPMSG [0:0] S(3);       # ABNORMAL CONDITION MESSAGE #
        BEGIN
        ITEM PFPLINE    C(00,00,28) =[  # MESSAGE LINE #
        " PROGRAM ABNORMAL, RESTPFP."];
        ITEM PFPZERO    U(02,48,12)=[0];  # ZERO BYTE TERMINATOR #
        END
 
                                               CONTROL EJECT;
 
#
*     RESTORE THE PERMANENT FILE PARAMETERS TO THE USER VALUES.
#
 
      PFP$WRD0[0] = 0;
      PFP$FAM[0] = USER$FAM[0];
      PFP$UI[0] = USER$UI[0];
      PFP$PACK[0] = USER$PACK[0];
      PFP$FG1[0] = TRUE;
      PFP$FG2[0] = TRUE;
      PFP$FG4[0] = TRUE;
      SETPFP(PFP[0]);
      IF PFP$STAT[0] NQ OK
      THEN
        BEGIN
        MESSAGE(PFPMSG[0],UDFL1);
        ABORT;
        END
 
#
*     OPTIONALLY RETURN LISTED FILES.
#
 
      IF OPTION NQ PFP$RESUME
      THEN
        BEGIN
        LOFPROC(0);
        END
 
#
*     OPTIONALLY ABORT PROCESSING.
#
 
      IF OPTION EQ PFP$ABORT
      THEN                           # ABORT REQUESTED #
        BEGIN
        ABORT;
        END
 
      RETURN;
      END  # RESTPFP #
 
#
          END
#
    TERM
PROC SETNM((NAME),(SRCHCHAR),(TERMCHAR),(MSGBUF),ASMBUF);
#
          IDENT  SETNM
          TITLE  SETNM - SET NAME IN MESSAGE.
#
      BEGIN  # SETNM #
 
#
***   SETNM - SET NAME IN MESSAGE.
*
*     *SETNM* REPLACES OCCURENCES OF THE SEARCH CHARACTER WITHIN A
*     MESSAGE OR LINE WITH THE CHARACTERS OF THE GIVEN NAME OR
*     NUMBER, ELIMINATING ALL EXCESS OCCURENCES OF THE SEARCH
*     CHARACTER.  THE TERMINATOR CHARACTER IS REPLACED BY AN END OF
*     LINE IN THE NEW MESSAGE.  THE ORIGINAL MESSAGE MUST CONTAIN A
*     SUFFICIENT NUMBER OF SEARCH CHARACTERS (USUALLY CONSECUTIVE)
*     TO ALLOW FOR REPLACEMENT BY THE NAME OR NUMBER (UP TO 10
*     CHARACTERS).  THE MESSAGE MUST NOT CONTAIN COLONS (00B)
*     SINCE THEY WILL BE INTERPRETED AS EOL.
*
*     PROC SETNM((NAME),(SRCHCHAR),(TERMCHAR),(MSGBUF),ASMBUF)
*
*     ENTRY  (NAME)     - DISPLAY CODE NAME OR NUMBER TO BE SET IN
*                         THE MESSAGE, LEFT JUSTIFIED, BLANK OR BINARY
*                         ZERO FILLED.  IF (NAME) .EQ. 0, ALL SEARCH
*                         CHARACTER OCCURENCES WILL BE DELETED.
*            (SRCHCHAR) - DISPLAY CODE SEARCH CHARACTER, LEFT
*                         JUSTIFIED.
*            (TERMCHAR) - DISPLAY CODE MESSAGE TERMINATION CHARACTER,
*                         LEFT JUSTIFIED.  IF (TERMCHAR) .EQ. 0, THE
*                         MESSAGE IS TERMINATED BY EOL.
*            (MSGBUF)   - MESSAGE OR LINE (MAXIMUM OF 80 CHARACTERS).
*
*     EXIT   (ASMBUF) - MESSAGE WITH THE GIVEN NAME OR NUMBER
*                       ENTERED IN PLACE OF THE SEARCH CHARACTERS
*                       END TERMINATED BY EOL.
#
 
      ITEM NAME       C(10);         # REPLACEMENT NAME OR NUMBER #
      ITEM SRCHCHAR   C(1);          # SEARCH CHARACTER #
      ITEM TERMCHAR   C(1);          # TERMINATING CHARACTER #
      ITEM MSGBUF     C(80);         # MESSAGE OR LINE #
      ITEM ASMBUF     C(80);         # ASSEMBLY BUFFER #
 
#
****  PROC SETNM - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # BLANK/ZERO FILL ITEM #
        END
 
#
****  PROC SETNM - XREF LIST END.
#
 
      DEF BLANK      #" "#;          # BLANK CHARACTER #
      DEF ODDNUM(I)  #(((I)/2)*2) NQ (I)#;  # ODD NUMBER TEST #
 
      DEF LISTCON    #0#;            # COMDECK LIST CONTROL #
*CALL COMAMSS
*CALL COMABZF
 
      ITEM APOS       I;             # ASSEMBLY BUFFER POSITION #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM NPOS       I;             # *NAME* POSITION #
                                               CONTROL EJECT;
 
      APOS = 0;
      NPOS = 0;
      BZFILL(NAME,TYPFILL"ZFILL",10);
 
      SLOWFOR I = 0 STEP 1 WHILE I LS 80  ##
        AND C<I,1>MSGBUF NQ TERMCHAR
      DO
        BEGIN  # ASSEMBLE MESSAGE #
        IF C<I,1>MSGBUF EQ SRCHCHAR
        THEN
          BEGIN  # TRANSFER *NAME* #
          IF B<NPOS*6,6>NAME NQ 0 AND NPOS LS 10
          THEN                       # REPLACE SEARCH CHARACTER #
            BEGIN
            C<APOS,1>ASMBUF = C<NPOS,1>NAME;
            NPOS = NPOS + 1;
            END
 
          ELSE                       # SKIP SEARCH CHARACTER #
            BEGIN
            TEST I;
            END
 
          END  # TRANSFER *NAME* #
 
        ELSE                         # TRANSFER MESSAGE #
          BEGIN
          C<APOS,1>ASMBUF = C<I,1>MSGBUF;
          END
 
        APOS = APOS + 1;             # ADVANCE *ASMBUF* POSITION #
        END  # ASSEMBLE MESSAGE #
 
      IF ODDNUM(APOS)
      THEN
        BEGIN  # ODD NUMBER OF CHARACTERS #
        IF C<APOS-1,1>ASMBUF EQ BLANK
        THEN                         # DELETE TRAILING BLANK #
          BEGIN
          APOS = APOS - 1;
          END
 
        ELSE                         # ADD TRAILING BLANK #
          BEGIN
          C<APOS,1>ASMBUF = " ";
          APOS = APOS + 1;
          END
 
        END  # ODD NUMBER OF CHARACTERS #
 
      B<APOS*6,12>ASMBUF = 0;        # ADD MESSAGE TERMINATOR #
 
      END  # SETNM #
 
#
          END
#
    TERM
PROC ZFILL(ZBUF,(WDLEN));
#
          IDENT  ZFILL
          TITLE  ZFILL - ZERO FILLS A BUFFER.
#
 
      BEGIN  # ZFILL #
 
#
***   ZFILL - ZERO FILLS A BUFFER.
*
*     PROC ZFILL(ZBUF,(WDLEN))
*
*     ENTRY   (WDLEN) = NUMBER OF WORDS TO BE ZERO FILLED.
*
*     EXIT    (ZBUF)  = ZERO FILLED BUFFER.
#
 
      ARRAY ZBUF [0:0] ;             # ARRAY TO BE ZERO FILLED #
        BEGIN
        ITEM ZWORD      U(00,00,60);
        END
 
      ITEM WDLEN      I;             # NUMBER OF WORDS TO BE ZEROED #
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMAMSS
 
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
 
CONTROL EJECT;
 
#
*     ZERO FILL THE SPECIFIED NUMBER OF
*     WORDS IN THE BUFFER.
#
 
      FASTFOR I = 0 STEP 1 UNTIL WDLEN-1
      DO
        BEGIN
        ZWORD[I] = 0;
        END
 
      END  # ZFILL #
 
#
          END
#
      TERM
PROC ZSETFET((ADDR),(LFN),(FWA),(LEN),(FETL));
#
          IDENT  ZSETFET
          TITLE  ZSETFET - INITIALIZES A *FET*.
#
 
      BEGIN  # ZSETFET #
 
#
***   ZSETFET - INITIALIZES A FILE ENVIRONMENT TABLE.
*
*     THIS PROCEDURE CREATES A *FET* AT THE SPECIFIED
*     ADDRESS AND SETS STANDARD FIELDS.  OTHER FIELDS MUST BE SET
*     BY THE USER.
*
*     PROC ZSETFET((ADDR),(LFN),(FWA),(LEN),(FETL)).
*
*     ENTRY   (ADDR) - ADDRESS *FET* IS TO START AT.
*             (LFN)  - NAME OF FILE TO BE ACCESSED.
*             (FWA)  - FIRST WORD ADDRESS OF *CIO* BUFFER.
*             (LEN)  - LENGTH OF THE *CIO* BUFFER.
*             (FETL) - LENGTH OF THE *FET*.
*
*     EXIT    *FET* IS INITIALIZED (I.E. *FIRST*, *IN*, *OUT*, AND
*             *LIMIT* POINTERS , AND *FET* LENGTH FIELDS ARE SET
*             AND THE *LFN* FIELD IS ZERO FILLED).
 
**
*
*     NOTES   VALUES SPECIFIED BY PARAMETERS ARE PLACED IN THE
*             APPROPRIATE ARRAY FIELDS, AND THE POINTER OF BASED
*             ARRAY *FETSET* IS SET TO *ADDR*.
#
 
 
      ITEM ADDR       U;             # ADDRESS OF *FET* #
      ITEM LFN        C(7);          # FILE NAME #
      ITEM FWA        U;             # *FWA* OF *CIO* BUFFER #
      ITEM LEN        U;             # LENGTH OF *CIO* BUFFER #
      ITEM FETL       U;             # LENGTH OF *FET* #
 
#
****  PROC ZSETFET - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # ZERO OR BLANK FILLS ITEM #
        PROC ZFILL;                  # ZERO FILLS AN ARRAY #
        END
 
#
****  PROC ZSETFET - XREF LIST END.
#
 
      DEF MINFETL   #5#;             # MINIMUM *FET* LENGTH #
 
      DEF LISTCON   #0#;             # CONTROLS LISTING OF COMDECKS #
 
*CALL COMAMSS
*CALL COMABZF
*CALL COMAFET
CONTROL EJECT;
 
#
*     ZERO FILL *FET* AND SET STANDARD FIELDS.
#
 
      P<FETSET> = ADDR;
      ZFILL(FETSET[0],FETL);
      BZFILL(LFN,TYPFILL"ZFILL",7);  # ZERO-FILL FILE NAME #
      FET$LFN[0] = LFN;
      FET$LOCK[0] = TRUE;
      FET$FRST[0] = FWA;
      FET$IN[0] = FWA;
      FET$OUT[0] = FWA;
      FET$LIM[0] = FWA + LEN;
      FET$L[0] = FETL - MINFETL;     # SET LENGTH OF *FET* #
      RETURN;
      END  # ZSETFET #
 
#
          END
#
    TERM