*DECK COBIO 
          IDENT    COBIO
          TITLE  COBIO - COBOL COMPILER CENTRAL INPUT-OUTPUT ROUTINE
  
          MACHINE  ANY,I
          COMMENT  CENTRAL INPUT-OUTPUT ROUTINE 
          SYSCOM B1 
          LDSET  LIB=SYSLIB  LOAD FROM SYSLIB FIRST 
          LDSET  PRESET=ZERO
          SPACE  4
***       COBIO - COBOL COMPILER CENTRAL INPUT-OUTPUT ROUTINE 
* 
*         THESE ROUTINES ARE USED TO INTERFACE TO THE MACE I/O ROUTINES.
* 
*         A FILE SHOULD ONLY BE OPENED AND CLOSED IF IT IS A RANDOM 
*         FILE AND THE RANDOM INDEX NEEDS TO BE READ OR WRITTEN.
* 
*         A FILE IS REWOUND ONLY WHEN THE ROUTINE -REWIND- IS CALLED
* 
*         THE FOLLOWING CRM RECORD TYPES ARE SUPPORTED
*                SEQUENTIAL FILES: RT=Z/W/U 
*                RANDOM FILES: RT=U 
* 
*         CALLING SEQUENCES: (ALL CALLS ARE IN SYMPL) 
*                FET = INDIRECT ADDRESS OF THE FET
*                WSA = INDIRECT ADDRESS OF THE RECORD AREA
*                FL  = SIZE OF THE RECORD AREA
*                      (IN CHARS IF SQ, IN WORDS IF WA) 
*                DX  = DATA EXIT ROUTINE
*                WA  = WORD ADDRESS OF RANDOM FILE (FIRST ADDRESS = 1)
*                RL  = SIZE OF RECORD READ (IN CHARS) 
* 
*         TO READ A SEQUENTIAL RECORD 
*                GETSQ (FET, WSA, FL, DX, RL);
* 
*         TO WRITE A SEQUENTIAL RECORD
*                PUTSQ (FET, WSA, FL);
*                    IF (FL=0) THE BUFFER IS FLUSHED
* 
*         TO BACKSPACE A SEQUENTIAL FILE 1 RECORD 
*                BKSPSQ (FET);
*                THIS ROUTINE IS IN THE SSCANNER OVERLAY
* 
*         TO READ A RANDOM RECORD 
*                GETWA (FET, WSA, FL, WA, DX);
* 
*         TO WRITE A RANDOM RECORD
*                PUTWA (FET, WSA, FL, WA);
* 
*                WA MUST BE A MULTIPLE OF 64 + 1 (PRU BOUNDARY) 
*                FL MUST BE A MULTIPLE OF 64 (FULL PRUS)
* 
*         TO OPEN A FILE - REQUIRED ONLY FOR READING THE RANDOM INDEX 
*                OPEN (FET);
* 
*         TO CLOSE A FILE - REQUIRED ONLY FOR WRITING THE RANDOM INDEX
*                CLOSE (FET); 
* 
*         TO RETURN A FILE TO THE SYSTEM
*                RETRN (FET); 
* 
*         TO REWIND A FILE
*                REWIND (FET);
          LIST   F,X
*CALL     COBIOM
          LIST   *
 C.GETSQ  SPACE  4
          ENTRY  C.GETSQ
 C.GETSQ  DATA   0
          SA4    *-1
          BX6    X4 
          SX7    B4 
          SA6    GETSQ
          SA7    T.RL 
          SX6    B5 
          SA6    T.DX 
          EQ     GETSQ0 
 GETSQ    SPACE  4,4
          ENTRY  GETSQ
 GETSQ    DATA   0
          MX6    1           FLAG AS GET
          RJ     INITSQ      SET B6=WSA,B7=FL 
 GETSQ0   BSS    0           ENTRY FOR COMPASS CALLED 
          MX7    42          MASK FOR FILE NAME 
          SX1    33B         MASK FOR FILE MODE AND COMPLETE BIT
          BX7    X7+X1         COMBINED 
          SA1    X2          GET FET+0
          BX7    X7*X1       EXTRACT NAME AND MODE
          LX1    -1 
          PL     X1,GETSQ9   DONT STORE IF FILE IS BUSY 
          SX1    10B
          BX7    X7+X1       PRETEND WE JUST DID A READ 
          SA7    X2          STORE READ COMPLETE CODE 
 GETSQ9   BSS    0
          FETCH  X2,RT,X5 
          =X6    X5-#ZT#
          NZ     X6,GETSQ1   JIF NOT RT=Z 
          READH  X2,B6,B7    READ 1 Z-TYPE RECORD 
 NOS1     IFC    EQ,*"OSNAME"*KRONOS* 
          NZ     X1,GETSQ3   JP IF EOR OR EOF 
          FETCH  X2,CONF,X5  GET CONNECTED FILE BIT 
          PL     X5,GETSQ3   JP IF NOT CONNECTED FILE 
*    ON NOS FOR SOME UNKNOWN REASON AN EOR IS RETURNED ON EACH READ 
*    CLEAR THIS EOR SO THERE WILL NOT BE ON NEXT READ 
          SA3    X2 
          MX7    42 
          SX6    3           MODE AND COMPLETE BIT
          BX7    X7+X6
          BX7    X7*X3
          SA7    A3           CLEAR EOR 
          EQ     GETSQ3      GO ON
 NOS1     ELSE
          EQ     GETSQ3 
 NOS1     ENDIF 
 GETSQ1   BSS    0
          =X5    X5-#WT#
          NZ     X5,GETSQ2   JIF NOT RT=W 
          READO  X2          READ W-CONTROL WORD
          SB7    X6          WORD COUNT TO B7 
          SX5    10 
          IX6    X6*X5
          SA6    T.FL        SAVE RECORD LENGTH 
 GETSQ2   BSS    0
          READW  X2,B6,B7    READ THE RECORD
 GETSQ3   BSS    0
          SA3    T.RL 
          ZR     X3,GETSQ5   JIF RL NOT SPECIFIED 
          SA5    T.FL 
          BX6    X5 
          SA6    X3          STORE NUMBER OF WORDS READ 
 GETSQ5   BSS    0
          ZR     X1,GETSQ    JIF NOT EOF
          ZR     X3,GETSQ6   JIF RL NOT SPECIFIED 
          MX6    0           SET NUMBER OF WORDS READ TO ZERO 
          SA6    A6          RESET RL TO 0
 GETSQ6   BSS    0
          SA3    T.DX 
          ZR     X3,GETSQ    JIF DATA-EXIT NOT SPECIFIED
          SB2    X3 
          JP     B2          JUMP TO DX 
 C.PUTSQ  SPACE  4
          ENTRY  C.PUTSQ
 C.PUTSQ  DATA   0
          SA4    *-1
          BX6    X4 
          SA6    PUTSQ
          EQ     PUTSQ0 
 PUTSQ    SPACE  4,4
          ENTRY  PUTSQ
 PUTSQ    DATA   0
          MX6    0           FLAG AS PUT
          RJ     INITSQ      SET B6=WSA,B7=FL 
          SX3    10 
          SX1    B7          RECORD LENGTH IN WORDS 
          IX1    X1*X3       RL IN CHARS ROUNDED TO WORDS 
          SA3    T.FL        RL IN CHARS AS REQUESTED BY CALLER 
          IX1    X1-X3       NUMBER OF CHARS TO PAD 
          SX3    6
          IX1    X1*X3       NUMBER OF BITS TO PAD
          SB2    X1-1 
          NG     B2,NOPAD    JIF NO PADDING NEEDED
          MX0    1
          AX0    B2 
          SB2    B2+B1
          LX0    B2          WE JUST MADE A MASK OF B2 BITS 
          SA5    =10H 
          BX6    X0*X5       EXTRACT THE NEEDED AMOUNT OF BLANKS
          SA0    B6+B7       POINT TO LWA +1 OF BUFFER
          SA5    A0-B1
          BX7    X5 
          SA7    =SSAVELW    SAVE LAST WORD 
          SX7    A5 
          SA7    SAVELWA     SAVE LAST WORD ADDRESS 
          BX5    -X0*X5 
          BX6    X5+X6
          SA6    A5          RESTORE LAST WORD OF USER BUFFER 
 NOPAD    BSS    0
 PUTSQ0   BSS    0           ENTRY FOR COMPASS CALL 
          EQ     B7,PUTSQ4   FLUSH IF FL=0
          FETCH  X2,RT,X5 
          =X6    X5-#ZT#
          NZ     X6,PUTSQ1   JIF NOT RT=Z 
          WRITEH X2,B6,B7    WRITE Z-TYPE RECORD
          EQ     PUTSQ3 
 PUTSQ1   BSS    0
          =X5    X5-#WT#
          NZ     X5,PUTSQ2   JIF NOT RT=W 
          SX6    B7 
          WRITEO X2          WRITE PSEUDO CONTROL WORD
 PUTSQ2   BSS    0
          WRITEW X2,B6,B7    WRITE THE RECORD 
 PUTSQ3   BSS    0
          SA2    SAVELWA     GET ADDRESS OF LAST WORD OF REC AREA 
          ZR     X2,PUTSQ    EXIT IF LAST WORD NOT SAVED
          SA1    SAVELW      GET LAST WORD
          MX7    0
          BX6    X1 
          SA6    X2          RESTORE LAST WORD OF REC AREA
          SA7    A2          CLEAR LW FLAG
          EQ     PUTSQ       EXIT 
 SAVELWA  DATA   0
 PUTSQ4   BSS    0           FLUSH CIO BUFFER 
          WRITER X2,R 
          EQ     PUTSQ       EXIT 
 INITSQ   SPACE  4,4
 INITSQ   DATA   0           INITALIZE SEQUENTIAL I/O 
          SA2    X1          GET FET
          SA6    =SGETFLAG   SAVE GET OR PUT FLAG 
          RJ     INITBUF     SET UP CIO BUFFERS 
          SA3    A1+B1       ADDRESS OF WSA 
          SA4    X3          WSA
          SB6    X4 
          SA3    A3+B1       ADDRESS OF FL
          SA4    X3          GET FL 
          BX6    X4          AND SAVE 
          SA6    T.FL        IN CHARS 
          SX6    314632B     1/10 (2 ** 20) 
          SX4    X4+9        AND
          SA5    GETFLAG
          IX6    X4*X6
          AX6    20          1/10 
          SB7    X6          IN WORDS 
          ZR     X5,INITSQ   JP IF A PUT - NO MORE PARAMS 
          SA3    A3+B1       ADDRESS OF DX PROCESSING 
          BX6    X3 
          SA6    T.DX 
          ZR     X3,INITSQ1  JIF NO MORE PARAMETERS 
          SA3    A3+B1       RECORD LENGTH RETURN ADDRESS 
 INITSQ1  BSS    0
          BX6    X3 
          SA6    T.RL 
          EQ     INITSQ 
 GETWA    SPACE  4,4
          ENTRY  GETWA
 GETWA    DATA   0
          RJ     INITWA 
          MX7    42          MASK FOR FILE NAME 
          SX1    33B         MASK FOR FILE MODE AND COMPLETE BIT
          BX7    X7+X1         COMBINED 
          SA1    X2          GET FET+0
          SB2    100B 
          LX1    -1 
          NG     X1,GETWA0   JP IF I-O COMPLETE 
          RECALL X2          WAIT FOR LAST IO 
          SA1    X2          GET FIRST WORD OF FET AGAIN
          LX1    -1          POSITION 
 GETWA0   BSS    0
          LX1    1           RE-POSITION
          BX7    X7*X1       GET NAME, EOR-EOF BITS, MODE AND COMP BITS 
          SX1    10B
          BX7    X7+X1       PRETEND WE JUST DID A READ 
          SA7    X2          STORE READ COMPLETE CODE 
          STORE  X2,R=B1     RESET RANDOM OPS 
          NE     B5,GETWA2   IF   (RWA=0) 
          LT     B7,B2,GETWA2            OR (RL<100B) 
                             THEN 
          STORE  X2,FIRST=B6      FIRST=IN=OUT=WSA     * SET POINTERS 
          SX6    B6                                    * TO WSA 
          SA6    X2+IN
          SA6    X2+OUT 
          SX6    B6+B7            LIMIT=WSA+RL+1
          SX6    X6+B1
          STORE  X2,LIMIT=X6
          STORE  X2,RR=B4         RR=RSA
          READ   X2,R             READ RECORD INTO WSA
          SA3    T.WA        GET WA FROM MEMORY 
          SX4    B7          X4 := RL 
          IX3    X3+X4       WA+RL
          STORE  X2,CWA=X3   CA := WA + RL
          FETCH  X2,LIMIT,X3
          SA1    X2+IN
          IX4    X3-X1
          SB7    X4-1             B7=LIMIT-IN-1        * POINT B6,B7
          SB6    X1               B6=IN                * TO REMAINDER 
          SA1    T.LIMIT          LIMIT=T.LIMIT        * OF DATA
          STORE  X2,LIMIT=X1
          SA1    T.FIRST          FIRST=IN=OUT=T.FIRST * RESET BUFFER 
          STORE  X2,FIRST=X1                           * POINTERS 
          BX6    X1 
          SA6    X2+IN
          SA6    X2+OUT 
          ZR     B7,GETWA5   JP IF FULL PRU READ
          STORE  X2,R=B0               SET AS SEQUENTIAL READ 
          READW  X2,B6,B7              READ REMAINDER OF RECORD 
          EQ     GETWA4 
 GETWA2   FETCH  X2,CWA,X1   ELSE IF (CWA=WA)          * IF WE GET HERE,
          SA5    T.WA        GET WA FROM MEMORY 
          IX1    X1-X5                                 * THE SAME AS A
          NZ     X1,GETWA3                             * READ-NEXT. 
                                  THEN
          STORE  X2,R=B0               SET AS SEQUENTIAL READ 
          SA3    T.WA         GET WA FROM MEMORY
          SX4    B7           X4 := RL
          IX3    X3+X4        WA+RL 
          STORE  X2,CWA=X3    CWA := WA + RL
          READW  X2,B6,B7              SEQUENTIAL READ
          EQ     GETWA4 
 GETWA3   STORE  X2,RR=B4         ELSE RR=RSA 
          FETCH  X2,FIRST,X6           IN=OUT=FIRST 
          SA6    X2+IN
          SA6    X2+OUT 
          SA3    T.WA         GET WA FROM MEMORY
          SX4    B7           X4 := RL
          IX3    X3+X4        WA+RL 
          STORE  X2,CWA=X3    CWA := WA + RL
          READ   X2,R                  READ INTO CIO BUFFER 
          SA5    X2+OUT 
          SX6    X5+B5
          SA6    A5 
          STORE  X2,R=B0               SET AS SEQUENTIAL READ 
          READW  X2,B6,B7              MOVE RECORD TO WSA 
 GETWA4   BSS    0                ENDIF 
 GETWA5   BSS    0           ENDIF
          ZR     X1,GETWA    RETURN IF NOT EOF OR EOR 
          STORE  X2,CWA=0    EOF OR EOR - DO RANDOM READ NEXT TIME
          SA3    T.DX 
          ZR     X3,GETWA    RETURN IF DATA-EXIT NOT SPECIFIED
          SB2    X3 
          SA1    GETWA
          BX6    X1 
          SA6    B2 
          JP     B2+1 
 PUTWA    SPACE  4,4
          ENTRY  PUTWA
 PUTWA    DATA   0
          RJ     INITWA 
          NZ     B5,PUTWAER  JP IF RWA NQ 0 
          SX4    B7+77B      RL 
          AX4    6           GIVES PRUS 
          LX4    6           ROUNDED
          SB7    X4 
          AX4    6
          FETCH  X2,NRSA,X5  GET NEXT SECTOR
          SB2    X5          SAVE IT
          SX0    B6+B7       WSA + RL 
          GT     B4,B2,PUTWAER     JP IF PAST END OF FILE -ERROR
          EQ     B4,B2,PUTWA1      JP IF WRITING AT END 
          SX3    X4+B4       PRUS TO BE WRITTEN + RSA = ENDING SECTOR +1
          IX4    X5-X3       NRSA - SECTOR AFTER END OF WRITE 
          PL     X4,PUTWA1   JP IF THIS WRITE FITS IN EXISTING FILE 
          LX4    6           GIVES WORDS LEFT OVER (NEGATIVE) 
          IX0    X0+X4       BACK OFF EXTRA WORDS 
 PUTWA1   BSS    0
          STORE  X2,FIRST=B6 THEN FIRST=WSA            * SET POINTERS 
          BX6    X0 
          SA6    X2+IN       IN = WSA + RL - OVERFLOW IF ANY
          SX7    B6               OUT = WSA 
          SA7    X2+OUT 
          SX6    B6+B7            LIMIT=WSA+RL+1
          SX6    X6+B1
          STORE  X2,LIMIT=X6
          EQ     B2,B4,PUTWA2      JP IF WRITING AT END OF FILE 
          STORE  X2,RR=B4         RR=RSA
          REWRITE  X2,R      REWRITE THE PRU(S) IN QUESTION 
          PL     X4,PUTWA5   JP IF NO OVERLAP AT END OF FILE
          SA5    X2+IN
          IX6    X5-X4       IN + OVERLAP 
          SA6    X2+IN
 PUTWA2   BSS    0
          STORE  X2,RR=RTNWD PLACE TO RETURN ADDR 
          WRITE  X2,R        ADD TO THE END OF THE FILE 
          SX6    B7 
          AX6    6
          SX4    X6+B4       NBR PRUS + RSA = NEW LRSA
          STORE  X2,NRSA=X4  UPDATE NEXT SECTOR ADDRESS 
 PUTWA5   BSS    0
          SA1    T.FIRST          FIRST=IN=OUT=T.FIRST * RESET BUFFER 
          STORE  X2,FIRST=X1                           * POINTERS 
          BX6    X1 
          SA6    X2+IN
          SA6    X2+OUT 
          SA1    T.LIMIT          LIMIT=T.LIMIT 
          STORE  X2,LIMIT=X1
          STORE  X2,CWA=B3+B7      UPDATE CURRENT POSITION
          EQ     PUTWA       EXIT 
 PUTWAER  BSS    0
          JP     *+400000B   ERROR - MUST WRITE FULL PRUS ON PRU BOUNDAR
 RTNWD    DATA   0
 INITWA   SPACE  4,4
 INITWA   DATA   0           INITIALIZE FOR RANDOM PROCESSING 
* 
*                            SETS 
*                                  B3 = WA - WORD ADDRESS 
*                                  B4 = RSA - REL SECTOR ADDRESS
*                                  B5 = RWA - REL WORD ADDRESS(0@RWA@63)
*                                  B6 = WSA - WORKING STORAGE ADDRESS 
*                                  B7 = RECORD LENGTH 
          SA2    X1                GET FET
          RJ     INITBUF     SET UP CIO BUFFERS 
          SA3    A1+B1             ADDRESS OF WSA 
          SA4    X3                WSA
          SB6    X4 
          SA3    A3+B1             ADDRESS OF FL
          SA4    X3 
          SB7    X4 
          SA3    A3+B1             ADDRESS OF WA
          SA4    X3 
          SB3    X4 
          BX6    X4          18 BITS IS OK FOR PUTWA BUT
          SA6    T.WA          NOT FOR GETWA - USE 60 BITS HERE 
          SX5    100B-1 
          IX3    X4+X5
          MX5    -6 
          BX5    -X5*X3 
          SB5    X5          RELATIVE WORD ADDRESS
          AX3    6
          SB4    X3          RELATIVE SECTOR ADDRESS
          SA3    A3+B1       ADDRESS OF DX
          BX6    X3 
          SA6    T.DX 
          FETCH  X2,FIRST,X6 SAVE FIRST AND LIMIT 
          SA6    T.FIRST
          FETCH  X2,LIMIT,X6
          SA6    T.LIMIT
          EQ     INITWA      RETURN 
 ASGNBUF  SPACE  5
**
*         ASGNBUF - ASSIGN BUFFER 
* 
*         CALL FROM SYMPL - ASGNBUF (FET);
*                FET IS WORD WITH ADDRESS OF FET IN IT
* 
          ENTRY  ASGNBUF
 ASGNBUF  DATA   0
          SA2    X1          GET ADDR OF FET INTO X2
          RJ     INITBUF     ASSIGN BUFFER
          EQ     ASGNBUF
 INITBUF  SPACE  4,4
          ENTRY  INITBUF
 INITBUF  DATA   0
          SB1    1
          FETCH  X2,OPFL,X5  GET OPEN FLAG
          NG     X5,INITBUF  EXIT IF ALREADY OPEN 
          STORE  X2,OPFL=YES SET AS OPEN
          STORE  X2,LEN=3    SET FET LENGTH 
          STORE  X2,NRSA=1   SET NEXT SECTOR TO 1 
          STORE  X2,CWA=1    RESET CURRENT WORD ADDRESS 
          FETCH  X2,FIRST,X3
          ZR     X3,INITB1   JP IF NO BUFFER ASSIGNED 
          SB3    A1          SAVE A1
          RJ     RETRNF      RETURN THE FILE IF IT EXISTS 
          SA1    B3          RESTORE A1 
          EQ     INITBUF
 INITB1   BSS    0
          STORE  X2,BUFA=YES SET CMM BUFFER ASGD
          SX0    A1          SAVE PARAMETER LIST
          SA0    X2          SAVE FET 
*      CMM MAY CALL THE OVERFLOW ROUTINE IN VIRTUAL.  THEREFORE,
*      ALL VALUES WHICH MAY BE CHANGED BY THIS ROUTINE (IT MAY CALL 
*      GETWA AND PUTWA) MUST BE SAVED IN A STACK FOR RE-ENTRANCY. 
*      CALLS TO GETWA AND PUTWA NEVER ASSIGN BUFFERS. 
          SA3    STACK       SAVE STACK POINTER 
          SX6    A1 
          LX6    36 
          SA4    INITBUF
          SA5    T.FIRST
          BX7    X4          INITBUF
          SA7    X3          SAVE INITBUF ENTRY 
          LX5    18 
          BX6    X6+X5       A1 AND T.FIRST 
          SX2    X2 
          BX6    X6+X2       A1,T.FIRST AND X2
          SA6    A7+B1       SAVE THESE 
          SA5    T.DX 
          SA4    T.LIMIT
          SX7    X5 
          LX7    18 
          BX7    X4+X7       T.DX AND T.LIMIT 
          SA7    A6+B1       SAVE THESE 
          SX6    X3+3        BUMP POINTER 
          SA6    A3          RESET IT 
          SA1    GID
          PL     X1,INB.1    JIF GROUP ID ASSIGNED
          SA1    AGRPL       GET PARAMETER LIST 
          RJ     =XCMM$AGR   ASSIGN GROUP ID
          SA6    GID         SAVE THE GID 
 INB.1    SA1    ALFPL       GET PARAMETER LIST 
          FETCH  A0,LIMIT,X6  GET BFS 
          SA6    ALFSZ       PUT IN PARAM 
          RJ     =XCMM$ALF   ALLOCATE BLOCK 
          SA5    NBLK        GET NUMBER OF BLOCKS IN USE
          SX6    X5+B1
          SA6    A5          BUMP IT
          SA3    STACK       GET SAVE STACK POINTER 
          SX6    X3-3        DECREMENT STACK POINTER
          SA6    A3 
          SA4    X6          GET WORD WITH INITBUF INI IT 
          SA5    A4+B1       GET WORD WITH A1, T.FIRST AND X2 
          BX7    X4 
          SA7    INITBUF     RESTORE ENTRY
          SA4    A5+B1       GET WORD WITH T.LIMIT AND T.DX 
          SX2    X5          RESTORE X2 
          AX5    18 
          SX6    X5 
          SA6    T.FIRST     RESTORE
          AX5    18 
          SX0    X5          RESTORE PARAMETER LIST ADDR TO X0
          SX7    X4          T.LIMIT
          SA7    T.LIMIT     RESTORE IT 
          AX4    18 
          SX6    X4          T.DX 
          SA6    T.DX        RESTORE IT 
          RJ     *+1         CLEAR INSTRUCTION STACK
 +        DATA   0           RJ WORD
          STORE  X2,FIRST=X1 SAVE FWA OF BLOCK
          BX6    X1 
          SA6    X2+IN
          SA6    X2+OUT 
          FETCH  X2,LIMIT,X3
          IX6    X3+X1
          STORE  X2,LIMIT=X6
          FETCH  X2,RT,X5    RECORD TYPE
          SX5    X5-#ZT#
          NZ     X5,INBEX    JP IF NOT ZERO BYTE RECORDS
*       PUT FILE NAME AND FET POINTER IN LIST OF FILES
*       END NOT CHECKED SINCE THERE CANNOT BE MORE THAN 10
          SA1    X2          GET FILE NAME
          SB6    3           LIST STARTS AT RA+3
          MX6    42 
          BX1    X6*X1       MAXK OFF OTHER STUFF 
          SX7    3           COMPLETE AND BINARY BIT
          BX7    X7+X1
          SA7    A1          CLEAR CODE AND STATUS FROM FET 
 INBFSP   BSS    0           FIND ZE RO TERMINATOR WORD 
          SA5    B6 
          SB6    B6+B1
          ZR     X5,INBFZW   JP IF VACANT CELL FOUND
          BX5    X6*X5       MAXK OFF FILE NAME 
          IX7    X5-X1
          NZ     X7,INBFSP   JP IF THIS IS NOT THE SAME FILE
 INBFZW   BSS    0
          SX2    X2 
          BX6    X1+X2       PUT IN ADDRESS OF FET
          SA6    A5          TO LIST
 INBEX    BSS    0
          SA1    X0          GET PARAMETER LIST 
          EQ     INITBUF     RETURN 
 OPEN     SPACE  4
          ENTRY  OPEN 
 OPEN     DATA   0
          SA2    X1 
          RJ     INITBUF
          OPEN   X2,,RCL
          EQ     OPEN 
 CLOSE    SPACE  4
          ENTRY  CLOSE
 CLOSE    DATA   0
          SA2    X1 
          RJ     INITBUF
          STORE  X2,OPFL=NO  SET NOT OPEN 
          STORE  X2,R=B0     CLEAR RANDOM OPS 
          CLOSE  X2,,RCL
          EQ     CLOSE
 RETRN    SPACE  4
          ENTRY  C.RETRN
 C.RETRN  DATA   0           COMPASS ENTRY POINT
          SA1    *-1
          BX6    X1 
          SA6    RETRN
          EQ     RETRN.1
          ENTRY  RETRN
 RETRN    DATA   0
          SB1    1
          SA2    X1 
 RETRN.1  BSS    0
          STORE  X2,OPFL=NO  SET NOT OPEN 
          RJ     RETRNF      RETURN THE FILE IF IT IS A SCRATCH ONE 
          ZR     X1,RETRN.2  JP IF FILE RETURNED
          CLOSE  X2,NR,RCL   CLOSE THE FILE 
 RETRN.2  BSS    0
          FETCH  X2,BUFA,X5  GET BUFFER ASGD FLAG 
          PL     X5,RETRN    JP IF CMM BUFFER NOT ASSIGNED
          STORE  X2,BUFA=NO  CLEAR
          FETCH  X2,FIRST,X1
          ZR     X1,RETRN    JP IF NO BUFFER ASSIGNED 
          STORE  X2,FIRST=0 
          MX6    0
          SA6    X2+IN
          SA6    X2+OUT 
          FETCH  X2,LIMIT,X5
          IX6    X5-X1
          STORE  X2,LIMIT=X6
          BX6    X1 
          SA6    ALFSZ       PUT FWA OF BLOCK IN PARAM
          SA1    FRFPL       GET PARAM LIST 
          RJ     =XCMM$FRF   FREE BLOCK 
          SA5    NBLK        GET NUMBER OF BLOCKS IN USE
          SX6    X5-1 
          SA6    A5          DECREMENT IT 
          NZ     X6,RETRN    EXIT IF MORE BLOCKS LEFT 
          SA1    FGRPL       GET PARAMETER LIST 
          RJ     =XCMM$FGR   FREE GROUP 
          MX6    1
          SA6    GID         SET NEGATIVE 
          EQ     RETRN       EXIT 
 RETRNF   SPACE  5
 RETRNF   DATA   0           RETURN A SCRATCH FILE - ALSO RECALL IF BUSY
          SA1    X2 
          BX6    X1 
          LX6    59 
          NG     X6,RETRN.0  JP IF NOT BUSY 
          SX3    A1          SAVE A1
          RECALL X3          WAIT FOR IO TO COMPLETE
          SA1    X3          RESTORE A1 AND X1
 RETRN.0  BSS    0
          AX1    24 
          SA5    =6RZZZZZ4   COBOL SCRATCH FILE 
          IX1    X1-X5
          NZ     X1,RETRNF   JIF NOT SCRATCH FILE 
          FETCH  X2,FIRST,X6
          SA6    T.FIRST
          FETCH  X2,LIMIT,X6
          SA6    T.LIMIT
          STORE  X2,FIRST=100B     GIVE BUFFER POINTERS A DUMMY 
          SX6    100B          VALUE TO MAKE THE OPERATING
          SA6    X2+IN         SYSTEM HAPPY 
          SA6    X2+OUT 
          STORE  X2,LIMIT=202B
          STORE  X2,R=B0     CLEAR RANDOM BIT 
          RETURN X2,RCL 
          STORE  X2,R=B1     RESET RANDOM BIT 
          SA1    T.FIRST
          STORE  X2,FIRST=X1
          BX6    X1 
          SA6    X2+IN
          SA6    X2+OUT 
          SA1    T.LIMIT
          STORE  X2,LIMIT=X1
          MX1    0           FLAG AS RETURNED 
          EQ     RETRNF      EXIT 
 REWIND   SPACE  4
          ENTRY  C.REWND
 C.REWND  DATA   0
          SA1    *-1
          BX6    X1 
          SA6    REWIND 
          EQ     REWND.1
          ENTRY  REWIND 
 REWIND   DATA   0
          SA2    X1 
 REWND.1  BSS    0
          RJ     INITBUF
          REWIND X2,RCL 
          STORE  X2,CWA=B1
          EQ     REWIND 
  
  
  
  
  
          ENTRY  BKSPREC
 BKSPREC  DATA   0
          SA2    X1 
          SKIPB  X2,1,0,R 
          FETCH  X2,FIRST,X4
          BX6    X4 
          SA6    X2+IN
          SA6    X2+OUT 
          STORE  X2,CWA=B1
          EQ     BKSPREC
 SCRATCH  SPACE  4,4
**        SCRATCH STORAGE 
* 
 GID      DATA   -1          GROUP ID 
 NBLK     DATA   0           NUMBER OF DATA BLOCKS IN USE 
 T.DX     DATA   0
 T.FIRST  DATA   0
 T.FL     DATA   0
 T.LIMIT  DATA   0
 T.RL     DATA   0
 T.WA     DATA   0
 ALFPL    VFD    60/ALFSZ    PARAMETER LIST FOR CMM$ALF 
          VFD    60/ZERO
 FGRPL    VFD    60/GID      P LIST FOR FGR AND PART OF ALF 
 FRFPL    VFD    60/ALFSZ 
 ALFSZ    DATA   0
 ZERO     DATA   0           WORD OF BINARY ZERO
 AGRPL    VFD    60/ZERO
 STACK    VFD    42/0,18/*+1
          BSS    6           STACK IS TWO DEEP
          TITLE  MISCELLANEOUS COMPASS PROCEDURES 
**        FILLRBZ -  FILL RIGHT BLANKS WITH BINARY ZEROS
* 
*         FILLRBZ(WORD) 
  
  
          ENTRY  FILLRBZ
 FILLRBZ  CON    *           ENTRY/EXIT WORD
          SA2    X1          WORD 
          MX0    -6          77777777777777777700B
          SX3    1R          BLANK
  
 FILLRBZ1 BX4    -X0*X2      ISOLATE NEXT CHARACTER 
          ZR     X4,FILLRBZA JP IF ALREADY A BINARY ZERO
          IX4    X4-X3
          NZ     X4,FILLRBZ2 IF NOT BLANK,  GO FINISH 
          BX2    X2-X3       CONVERT BLANK TO BINARY ZERO 
 FILLRBZA BSS    0
          LX0    6           LOOK AT NEXT CHAR TO THE LEFT
          LX3    6
          NZ     X2,FILLRBZ1 JP IF NOT ALL ZEROS NOW
  
  
 FILLRBZ2 BX6    X2          STORE RESULT 
          SA6    X1 
          EQ     FILLRBZ     EXIT 
          SPACE  4
          SPACE  4
*         GTBASEA IS CALLED FROM SYMPL AS A FUNCTION TO RETURN THE
*         BASE ADDRESS OF AN ARRAY  -  X = GTBASEA (ARRAY); 
*         IT IS CALLED ONLY FROM TABINIT
* 
          ENTRY GTBASEA 
 GTBASEA  DATA   0           RETURN BASE ADDR OF ARRAY - KLUDGE FOR SYM 
          BX6    X1 
          EQ     GTBASEA
          SPACE  4
*         INDREF IS CALLED AS A SYMPL FUNCTION TO RETURN AN INDIRECT
*         REFERENCE.
*         YYY = INDREF (XXX); 
*         XXX CONTAINS THE ADDRESS OF THE WORD WE WANT THE CONTENTS OF
*         THE FUNCTION WILL RETURN THE CONTENTS.
*         THIS FUNCTION IS USED FOR INPUT-OUTPUT IN THE ROUTINE VIRTUAL 
* 
          ENTRY  INDREF 
 INDREF   DATA   0
          SA1    X1          GET ADDRESS OF PLACE 
          SA2    X1          GET CONTENTS OF PLACE
          BX6    X2          RETURN IT
          EQ     INDREF 
          SPACE  4
          SPACE  3
          ENTRY  ZRPARAM     A BINARY ZERO PARAMETER FOR TERM OF CALLS
          LOC    0
 ZRPARAM  BSS    0
          LOC    *
          END 
