Retro1.org codex

*DECK LFGREFP 
USETEXT LFGFET,LFGIOD,LFGFN,LFGIB,LFGWB 
      PROC LFGREFP(PN,WC,SUCCESS,DIRBUF); 
      BEGIN                  # REFORMAT PICB                           #
*IF DEF,IMS 
# 
**    LFGREFP - REFORMAT PICB.
* 
*     M. E. VATCHER  81/02/23 
* 
*     LFGREFP REFORMATS A PICB AND WRITES IT TO THE NLF.
* 
*     PROC LFGREFP(PN,WC,SUCCESS) 
* 
*     ENTRY PN        PARTITION NAME
*           WC        16 BIT WORD COUNT OF INPUT RECORD 
* 
*     EXIT  SUCCESS   SUCCESSFUL COMPLETION INDICATOR 
* 
*     METHOD
* 
*     READ A RECORD 
*     SAVE CURRENT RANDOM INDEX ON NLF
*     PUT PARTITION NAME IN FIRST WORD OF PICB
*     PUT NDCB ADDRESS IN SECOND WORD OF PICB 
*     WHILE THERE ARE STILL DIRECTIVES IN THE INPUT BUFFER
*       GET NEXT 64 BIT DIRECTIVE FROM THE INPUT BUFFER 
*       REFORMAT THE DIRECTIVE
*     WRITE PICB TO NLF 
*     MAKE A DIRECTORY ENTRY FOR THE PICB 
*     END 
* 
# 
*ENDIF
 
# 
****  PROC LFGREFP - XREF LIST BEGIN. 
# 
 
      XREF
        BEGIN 
        ITEM IFET U;         # FWA OF INPUT FILE FET                   #
        ITEM OUTPUT U;       # FWA OF OUTPUT FILE FET                  #
        ITEM WFET U;         # FWA OF NLF FET                          #
 
        PROC LFGMDE;         # MAKE DIRECTORY ENTRY                    #
        PROC LFGRDER;        # SEND READ ERROR MESSAGE                 #
        PROC LFGRDSR;        # READ SEQUENTIAL RECORD                  #
        PROC WRITEC;         # WRITE LINE TO CIO BUFFER                #
        PROC WRITER;         # WRITE RECORD                            #
        FUNC XCDD C(10);     # CONVERT INTEGER TO DECIMAL DISPLAY CODE #
        FUNC XSFW C(10);     # SPACE FILL WORD                         #
        END 
 
# 
****
# 
 
 
      ITEM CODE U;           # DIRECTIVE CODE                          #
      ITEM CRI U;            # CURRENT RANDOM INDEX ON NLF             #
      ITEM DIRC U;           # DIRECTIVE COUNT                         #
      ITEM ENDS U;           #NUMBER OF END DIRECTIVES                 #
      ITEM I U;              #LOOP INDEX                               #
      ITEM IBIT U;           # CURRENT INPUT BIT IN IBUF               #
      ITEM IWORD U;          # CURRENT INPUT WORD IN IBUF              #
      ITEM J U;              # LOOP INDEX                              #
      ITEM OWORD U;          # LAST 60 BITS OF 64 BIT DIRECTIVE        #
      ITEM PN C(10);         # PARTITION NAME                          #
      ITEM STATIS U;
      ITEM SUCCESS B; 
      ITEM TEMPC C(10); 
      ITEM WC U;             # 16 BIT WORD COUNT OF INPUT RECORD       #
      ARRAY DIRBUF [0:0] S(2);         # DIRECTORY BUFFER              #
        BEGIN 
        ITEM DIR$ENT    I(00,00,60);
        END 
 
      ARRAY MANYEND [0:0] S(5); 
        BEGIN 
        ITEM MANYEND1 C(0,0,45) = 
          [" TOO MANY END DIRECTIVES ON XXXXXXX FILE NNN."];
        ITEM MANYLFN C(2,48,7); 
        ITEM MANYFILE C(4,6,3); 
        ITEM MANYZ U(4,30,30) = [ 0 ];
        END 
 
      ARRAY ILLDIR [0:0] S(5);
        BEGIN 
        ITEM ILLDIR1 C(0,0,47) =
          ["     BAD DIRECTIVE IN PICB ON XXXXXXX FILE NNN."];
        ITEM ILLLFN C(3,0,7); 
        ITEM ILLFILE C(4,18,3); 
        ITEM ILLZ U(4,42,18) = [ 0 ]; 
        END 
 
      ARRAY FEWEND [0:0] S(6);
        BEGIN 
        ITEM FEWEND1 C(0,0,55) =
          [" NOT ENOUGH END DIRECTIVES IN PICB IN XXXXXXX FILE NNN."];
        ITEM FEWLFN C(3,48,7);
        ITEM FEWFILE C(5,6,3);
        ITEM FEWZ U(5,30,30) = [ 0 ]; 
        END 
      CONTROL EJECT;
      PROC REFDUMP(OWORD);
      BEGIN 
 
      ITEM OWORD U; 
 
      B<0,4>WBUF[J] = 0;
      B<4,8>WBUF[J] = B<0,4>OWORD;
      B<12,24>WBUF[J] = B<4,24>OWORD; # BEGINNING ADDRESS              #
      B<36,24>WBUF[J] = B<36,24>OWORD; # ENDING ADDRESS                #
      END 
 
 
      PROC REFLOAD(OWORD);
      BEGIN 
 
*CALL LFGASCI 
 
      ITEM OWORD U; 
      ITEM ACHAR U; 
 
      WBUF[J] = 0;           # CLEAR ENTRY                             #
      B<0,4>WBUF[J] = 1;     # LOAD CODE                               #
      ACHAR = B<5,7>OWORD;
      B<12,6>WBUF[J] = C<ACHAR,1>ASCIITAB; # CONVERT TO DISPLAY CODE   #
      ACHAR = B<13,7>OWORD; 
      B<18,6>WBUF[J] = C<ACHAR,1>ASCIITAB;
      ACHAR = B<21,7>OWORD; 
      B<24,6>WBUF[J] = C<ACHAR,1>ASCIITAB;
      ACHAR = B<29,7>OWORD; 
      B<30,6>WBUF[J] = C<ACHAR,1>ASCIITAB;
      ACHAR = B<37,7>OWORD; 
      B<36,6>WBUF[J] = C<ACHAR,1>ASCIITAB;
      ACHAR = B<45,7>OWORD; 
      B<42,6>WBUF[J] = C<ACHAR,1>ASCIITAB;
      END 
 
 
      PROC REFSTART(OWORD); 
      BEGIN 
 
      ITEM OWORD U; 
 
      B<0,4>WBUF[J] = 2;     # START CODE                              #
      B<4,8>WBUF[J] = B<0,4>OWORD;
      B<12,48>WBUF[J] = 0;
      END 
 
 
      PROC REFSNCB(OWORD);
      BEGIN                  # REFORMAT SEND NCB DIRECTIVE             #
 
      ITEM OWORD U; 
 
      B<0,4>WBUF[J] = 5;     # SEND NCB CODE                           #
      B<4,8>WBUF[J] = 0;
      B<12,24>WBUF[J] = B<4,24>OWORD; # BEGINNING ADDRESS              #
      B<36,8>WBUF[J] = 0; 
      B<44,16>WBUF[J] = B<44,16>OWORD; # SIZE OF NCB                   #
      END 
 
 
      PROC REFOTHER(CODE);
      BEGIN                  # REFORMAT OTHER KIND OF DIRECTIVE        #
 
      ITEM CODE U;
 
      B<0,4>WBUF[J] = CODE; 
      B<4,56>WBUF[J] = 0; 
      END 
      CONTROL EJECT;
      PROC GN64B(CODE,OWORD); 
      BEGIN                  # GET NEXT 64 BITS                        #
 
      ITEM BITCOUNT U;
      ITEM CODE U;
      ITEM OBIT U;
      ITEM OWORD U; 
 
      CODE = 0; 
      OWORD = 0;
      B<56,4>CODE = B<IBIT,4>IBUF[IWORD]; # GET FIRST FOUR BITS        #
      IBIT = IBIT + 4;
      BITCOUNT = 4;          #NUMBER OF BITS TRANSFERRED               #
      IF IBIT EQ 60 
      THEN                   # GO ON TO NEXT INPUT WORD                #
        BEGIN 
        IBIT = 0; 
        IWORD = IWORD + 1;
        END 
 
#     GET BITS UNTIL INPUT WORD BOUNDARY                               #
 
      B<0,60 - IBIT>OWORD = B<IBIT,60 - IBIT>IBUF[IWORD]; 
      OBIT = 60 - IBIT;      # SAVE TO GET BITS FROM NEXT INPUT WORD   #
      BITCOUNT = BITCOUNT + 60 - IBIT;
      IBIT = 0; 
      IWORD = IWORD + 1;
      IF BITCOUNT EQ 64 
      THEN
        RETURN;              # ***** EXIT *****                        #
 
#     GET REST OF BITS FROM NEXT INPUT WORD                            #
 
      B<OBIT,64-BITCOUNT>OWORD = B<0,64 - BITCOUNT>IBUF[IWORD]; 
      IBIT = 64 - BITCOUNT; 
      END 
      CONTROL EJECT;         # REFPICB CODE STARTS HERE                #
      SUCCESS = TRUE; 
      ENDS = 0; 
      IBIT = 0; 
      IWORD = 0;
      LFGRDSR(LOC(IFET),STATIS); # READ PICB                           #
      IF STATIS NQ RDEOR AND STATIS NQ RDBFULL
      THEN
        BEGIN 
        LFGRDER(STATIS);
        SUCCESS = FALSE;
        RETURN;              # ***** EXIT *****                        #
 
        END 
      P<SIOFET> = WFET; 
      CRI = FETCRI[0];       # SAVE CURRENT RANDOM INDEX ON NLF        #
      FETOUT[0] = FETFST[0]; # FETIN IS SET LATER                      #
      B<0,36>WBUF[0] = B<0,36>PN; # PUT IN VARIANT NAME                #
      B<36,24>WBUF[0] = 0;
      B<0,36>WBUF[1] = 0; 
      GN64B(CODE,OWORD);
      B<36,24>WBUF[1] = B<36,24>OWORD; # PUT IN NDCB ADDRESS           #
      B<0,24>WBUF[2] = "DPCB"; # DPCB HEADER                           #
      B<24,36>WBUF[2] = 0;
      DIRC = WC/4 - 1;       # NUMBER OF DIRECTIVES                    #
      J = 3;
      FOR I = 1 STEP 1 UNTIL DIRC DO
        BEGIN 
        GN64B(CODE,OWORD);   # GET NEXT 64 BITS                        #
        IF CODE EQ 0
        THEN
          REFDUMP(OWORD); 
        ELSE IF CODE EQ 1 
        THEN
          REFLOAD(OWORD); 
        ELSE IF CODE EQ 2 
        THEN
          REFSTART(OWORD);
        ELSE IF CODE EQ 5 
        THEN
          REFSNCB(OWORD); 
        ELSE IF CODE EQ 4 OR CODE EQ 6
        THEN
          REFOTHER(CODE); 
        ELSE IF CODE EQ 15
        THEN
          BEGIN 
          ENDS = ENDS + 1;
          IF ENDS GQ 4
          THEN               # TOO MANY END DIRECTIVES                 #
            BEGIN 
            TEMPC = XSFW(FNAME[LFN]); 
            MANYLFN[0] = C<0,7>TEMPC; 
            TEMPC = XCDD(FILENUM);
            MANYFILE[0] = C<7,3>TEMPC; # SET FILE NUMBER IN MESSAGE    #
            WRITEC(OUTPUT,MANYEND); 
            WRITER(OUTPUT,"R"); # SEND MESSAGE TO OUTPUT               #
            SUCCESS = FALSE;
            RETURN;          # ***** EXIT *****                        #
 
            END 
          REFOTHER(CODE); 
          IF ENDS EQ 1
          THEN               # END OF DPCB                             #
            BEGIN 
            J = J + 1;
            B<0,24>WBUF[J] = "LPCB"; # PUT IN LPCB HEADER              #
            B<24,36>WBUF[J] = 0;
            B<24,12>WBUF[1] = J - 2; # SAVE DPCB LENGTH                #
            END 
          ELSE IF ENDS EQ 2 
          THEN               # END OF LPCB                             #
            BEGIN 
            J = J + 1;
            B<0,24>WBUF[J] = "SPCB";
            B<24,36>WBUF[J] = 0;
            B<12,12>WBUF[1] = J - 2 - B<24,12>WBUF[1]; # LPCB LENGTH   #
            END 
          ELSE IF ENDS EQ 3 
          THEN               # FILL IN SPCB LENGTH                     #
            BEGIN 
            B<0,12>WBUF[1] = J - 1 - B<12,12>WBUF[1]
              - B<24,12>WBUF[1]; # LENGTH OF SPCB                      #
            END 
          END 
        ELSE
          BEGIN              # ILLEGAL DIRECTIVE CODE                  #
          TEMPC = XSFW(FNAME[LFN]); 
          ILLLFN[0] = C<0,7>TEMPC;
          TEMPC = XCDD(FILENUM);
          ILLFILE[0] = C<7,3>TEMPC; 
          WRITEC(OUTPUT,ILLDIR);
          WRITER(OUTPUT,"R"); # SEND MESSAGE TO OUTPUT                 #
          SUCCESS = FALSE;
          RETURN;            # ***** EXIT *****                        #
 
          END 
        J = J + 1;
        END                  #GET NEXT 64 BITS                         #
      IF ENDS LQ 2
      THEN                   # NOT ENOUGH END DIRECTIVES               #
        BEGIN 
        TEMPC = XSFW(FNAME[LFN]); 
        FEWLFN[0] = C<0,7>TEMPC;
        TEMPC = XCDD(FILENUM);
        FEWFILE[0] = C<7,3>TEMPC; 
        WRITEC(OUTPUT,FEWEND);
        WRITER(OUTPUT,"R"); 
        SUCCESS = FALSE;
        RETURN;              # ***** EXIT *****                        #
 
        END 
      FETIN[0] = FETFST[0] + DIRC + 5;
      WRITER(SIOFET,"R"); 
      LFGMDE(PN,CRI,DIRC + 5,SUCCESS,DIRBUF); 
      END TERM