Retro1.org codex

PROC BZFILL(CHAR,(TYP),(NUM)); 
# TITLE BZFILL - BLANK OR ZERO FILLS A CHARACTER ITEM.                #
 
      BEGIN  # BZFILL #
 
#
**    BZFILL - BLANK OR ZERO FILLS A CHARACTER ITEM.
*
*     PROC BZFILL(CHAR,(TYP),(NUM))
*
*     ENTRY   (TYP)  = TYPE OF FILLING REQUIRED.
*                    = S"BFILL", BLANK FILLING.
*                    = 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 COMBFAS
*CALL COMBBZF
 
      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 #
 
    TERM
PROC LOFPROC((LFN));
# 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 COMBFAS
*CALL COMBFET
 
      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 #
 
    TERM
PROC MSG((DFMSG),(OP));
# 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 *COMBFAS*)
*
*     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 COMBFAS
 
      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 #
 
    TERM
PROC RESTPFP((OPTION));
# 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
*                          *COMBFAS*).
*                        = *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 COMBFAS
*CALL COMBPFP
 
      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 FAMILY AND USER INDEX TO USER VALUES.
#
 
      PFP$WRD0[0] = 0;
      PFP$FAM[0] = USER$FAM[0];
      PFP$UI[0] = USER$UI[0];
      PFP$FG1[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 #
 
    TERM
PROC ZFILL(ZBUF,(WDLEN));
# 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 COMBFAS
 
      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 #
 
      TERM
PROC ZSETFET((ADDR),(LFN),(FWA),(LEN),(FETL));
# 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 COMBFAS
*CALL COMBBZF
*CALL COMBFET
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 #
 
    TERM