SYMSERV 
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
