*DECK SETLIB
USETEXT CCTTEXT 
USETEXT SSTEXT
          PROC  SETLIB; 
  
#**       SETLIB -  SET LIBFET AND LIBADDR FOR COPY                    #
#                                                                      #
#     CALLING SEQUENCE-                                                #
#         SETLIB:                                                      #
#                                                                      #
#     GIVEN-                                                           #
#         CURRENT TOKEN IS "COPY".                                     #
#         CCT                                                          #
#                                                                      #
#     DOES-                                                            #
#         IF AN ERROR IS ENCOUNTERED,                                  #
#           SETS ERROR = TRUE                                          #
#         ELSE                                                         #
#           SETS LIBFET AND LIBADDR READY FOR GETWA.                   #
  
          BEGIN 
  
  
*CALL BASEFET 
  
*CALL BUG020C$
  
  
*CALL CHAR$ 
  
  
*CALL LISTCTL 
  
*CALL SYSFET
  
          STATUS  TKNTYPE 
*CALL TKNTYPE 
  
          XREF
              BEGIN 
              PROC  CBLIST;            # COBOL LISTING ROUTINE         #
              PROC  INTERCEPTOR;       # ISSUE DIAGNOSTIC              #
              PROC  GETWA;             # GET FROM WORD-ADDRESSABLE FILE#
              FUNC  OCT      C(20);    # OCTAL DISPLAY VALUE           #
              FUNC  DEC      C(10);    # DECIMAL DISPLAY VALUE         #
              PROC  OPEN;              # OPEN A FILE                   #
              PROC  GETSTR;            # GET A TOKEN STRING            #
              PROC  ABORT;             # INTERNAL COMPILER ERROR       #
              PROC  FILLRBZ;           # FILL ON RIGHT WITH BIN ZEROS  #
              PROC  RETRN;             # RETURN THE BUFFER AND FET     #
              PROC  SSDIAGS;           # SSCANNER DIAGNOSTIC PROCESSOR #
              ITEM  COPYDONE B;        # FLAG TO INDICATE A COPY PRESEN#
              END 
  
          DEF  DIAGNOS(SEV,NUM,LIN,COL) 
#$BEGIN DBDIAG(SEV,NUM,LIN,COL);$END INTERCEPTOR(COL,LIN,NUM-1000,SEV)#;
          DEF  F             #0#;      # SEVERITY   (IGNORED)          #
          DEF  W             #0#;      # SEVERITY   (IGNORED)          #
          DEF  D1602         #602#; 
          DEF  D1079         #079#; 
          DEF D1080          #080#; 
          DEF  D1081         #081#; 
  
          ITEM  GOODNAME     B;        # IFF NAME IS GOOD              #
          ITEM  I            I;        # SCRATCH                       #
          ITEM  LIBCOLUMN    I;        # COLUMN NO. OF LIBRARY-NAME    #
          ITEM  LIBLINE      I;        # LINE NO. OF LIBRARY-NAME      #
          ITEM  LIBNAME      I;        # LIBRARY NAME FOR THIS COPY    #
          ITEM  PREVLIBNAME  I;        # NAME OF PREVIOUS LIBRARY      #
          ITEM  TEXTCOLUMN   I;        # COLUMN NO. OF TEXT-NAME TOKEN #
          ITEM  TEXTLINE     I;        # LINE NO. OF TEXT-NAME TOKEN   #
          ITEM  TEXTNAME     I;        # TEXT-NAME FOR THIS COPY       #
          ITEM  WC           I;        # WORD COUNT                    #
  
  
          PROC  GOTOBADLIB; 
              BEGIN          # END-OF-DATA PROCEDURE FOR GETWA         #
              GOTO NOTHERE; 
              END 
  
  
          $BEGIN
          ITEM  C10          C(10);    # SCRATCH                       #
          ITEM  LINE         C(110);   # DEBUG PRINT LINE              #
  
          PROC  DBDIAG(SEV, NUM, LIN, COL); 
          BEGIN 
          ITEM  SEV          I;        # SEVERITY (IGNORED)            #
          ITEM  NUM          I;        # ERROR NUMBER                  #
          ITEM  LIN          I;        # LINE NUMBER                   #
          ITEM  COL          I;        # COLUMN NUMBER                 #
          IF BUG020C$CPY               # IF DEBUGGING "COPY"           #
           OR BUG020C$TKN  THEN        #   OR "TOKENS"                 #
              BEGIN 
              LINE = "*** DIAGNOS(SEV,9999,99999,99)";
              C10 = DEC(NUM); 
              C<16,4>LINE = C<0,4>C10;
              C10 = DEC(LIN); 
              C<21,5>LINE = C<0,5>C10;
              C10 = DEC(COL); 
              C<27,2>LINE = C<0,2>C10;
              CBLIST(LISTCTL"LINE", LINE, 30);
              END 
          END # OF DBDIAG # 
  
          $END
CONTROL EJECT;
  
          ERROR = FALSE;               # NO ERROR YET                  #
  
#     PROCESS <TEXT-NAME>                                              #
  
          GETSTR; 
          IF CLATYPE NQ TKNTYPE"AW"  THEN 
              BEGIN 
              # (THE TEXT-NAME IS MISSING FROM THIS COPY STATEMENT.    #
              #  THE COPY STATEMENT IS IGNORED.)                       #
              SSDIAGS(D1079); 
              ERROR = TRUE; 
#***#         RETURN; 
              END 
          IF C<9,21>SAREA[0] NQ " "  THEN 
              BEGIN 
              # (THIS TEXT-NAME IS LONGER THAN 9 CHARACTERS.           #
              #  ONLY THE LEFT 9 CHARACTERS ARE USED.)                 #
              SSDIAGS(D1080); 
              END 
          TEXTNAME = 0; 
          C<0,9>TEXTNAME = C<0,9>SAREA[0];
          FILLRBZ(TEXTNAME);   # REPLACE TRAIL SPACES WITH BIN ZEROS #
          TEXTLINE = CLALINE;          # SAVE IN CASE NAME NOT ON LIB  #
          TEXTCOLUMN = CLACOLUMN; 
  
#     PROCESS  [ (IN/OF) <LIBRARY-NAME> ]                              #
  
          LIBLINE = TEXTLINE;          # SAVE IN CASE BAD LIBRARY      #
          LIBCOLUMN = 0;               # (IN CASE BAD DEFAULT LIBRARY) #
          GETSTR;                      # GET TOKEN AFTER TEXT-NAME     #
          LIBNAME = O"55555555555555555555";  # CLEAR LIBNAME          #
          IF NOT (CLATYPE EQ TKNTYPE"AW"
                  AND (C<0,3>SAREA[0] EQ "IN "
                       OR C<0,3>SAREA[0] EQ "OF "))  THEN 
              BEGIN 
              C<0,7>LIBNAME = C<0,7>CCTLIBFILE; 
#***#         GOTO HAVELIBNAME; 
              END 
          IF CCTFIPSLEVEL LS 4
          THEN BEGIN
               # FIPS=4 SUPPORTS COPY TEXT-NAME # 
               # OF/IN LIBRARY-NAME # 
               SSDIAGS(D1602);
               END
          GETSTR;                      # SKIP THE -IN- OR -OF-         #
          GOODNAME = TRUE;             # GUESS THAT THE NAME IS GOOD   #
          IF CLATYPE NQ TKNTYPE"AW"  THEN 
              GOODNAME = FALSE; 
          IF B<0,6>SAREA[0] GR CHAR$Z  THEN 
              GOODNAME = FALSE; 
          FOR I = 1 STEP 1 UNTIL 6  DO
              BEGIN 
              IF C<I,1>SAREA[0] EQ "-"  THEN
                  GOODNAME = FALSE; 
              END 
          IF NOT GOODNAME  THEN 
              BEGIN 
              # (THIS LIBRARY-NAME IS NOT A LEGAL FILE NAME.           #
              #  THE COPY STATEMENT IS IGNORED.)                       #
              SSDIAGS(D1081); 
              ERROR = TRUE; 
#***#         RETURN; 
              END 
          C<0,7>LIBNAME = C<0,7>SAREA[0]; 
          LIBLINE = CLALINE;           # SAVE IN CASE BAD LIBRARY      #
          LIBCOLUMN = CLACOLUMN;
          GETSTR; 
  
HAVELIBNAME:  
          FILLRBZ(LIBNAME);   # REPLACE TRAIL SPACES WITH BIN ZEROS # 
  
          IF LIBNAME EQ PREVLIBNAME 
          AND COPYDONE
          THEN
              GOTO LOOKFORDECK;  # SAME LIBRARY AS PREV - DONT OPEN # 
          IF COPYDONE 
          THEN
              RETRN(LIBFET);   # NOT FIRST COPY - RETURN OLD BUFFER # 
          ELSE
              COPYDONE = TRUE;
          PREVLIBNAME = LIBNAME;
#     OPEN THE LIBRARY FILE                                            #
  
          P<FETS> = LIBFET1[0]; 
          FET$LFN = C<0,7>LIBNAME;
          FET$FWAI = LOC(UP$);         # ADDRESS OF INDEX BUFFER       #
          FET$R = 1;                   # RANDOM BIT                    #
          FET$LENI = 5;                # LENGTH OF INDEX BUFFER        #
          # (3 SHOULD WORK, BUT RANDOM PL-S WITH LABELS HAVE BEEN      #
          #  APPEARING, REQUIRING AN EXTRA 2 WORDS)                    #
          OPEN(LIBFET); 
  
          $BEGIN
          IF BUG020C$CPY  THEN         # IF DEBUGGING -COPY-           #
              BEGIN 
              LINE = "SETLIB- RANDOM INDEX IS"; 
              C<24,20>LINE = OCT(UP$WORD, 0, 20); 
              C<54,20>LINE = OCT(UP$WORD1, 0, 20);
              C<84,20>LINE = OCT(UP$WORD2, 0, 20);
              CBLIST(LISTCTL"LINE", LINE, 105); 
              END 
          $END
  
          MCC = UP$C;                  # MASTER CONTROL CHARACTER      #
          UPI$DECKS = UP$DLLRA*64 - 63; 
          UPI$IDENTS = UP$DIRRA*64 - 63;
          UPL$DECKS = UP$DLL; 
  
          IF UP$7000[0] NQ O"7000"  THEN
              BEGIN 
BADLIB:                                #(HERE FROM -GETWA- ERROR)      #
              # (THIS LIBRARY IS NOT A RANDOM -UPDATE- LIBRARY.        #
              #  THE COPY STATEMENT IS IGNORED.)                       #
              DIAGNOS("F", 1082, LIBLINE, LIBCOLUMN); 
              ERROR = TRUE; 
#***#         RETURN; 
              END 
  
#     SEARCH THE DECK LIST FOR <TEXT-NAME>                             #
  
 LOOKFORDECK: 
          LIBADDR = UPI$DECKS;
          FOR I = 1 STEP 2 UNTIL UPL$DECKS DO 
              BEGIN 
              GETWA(LIBFET, LOC(UP$), 2, LIBADDR, GOTOBADLIB);
              LIBADDR = LIBADDR + 2;
              IF B<0,54>TEXTNAME EQ UP$DECKNAME  THEN 
                  BEGIN 
                  LIBADDR = UP$IDECK*64 - 63; 
#***#             GOTO SKIPDECK;
                  END 
              END 
NOTHERE:  
          # (THIS TEXT-NAME IS NOT ON THE INDICATED LIBRARY.           #
          #  THE COPY STATEMENT IS IGNORED.)                           #
          DIAGNOS("F", 1083, TEXTLINE, TEXTCOLUMN); 
          ERROR = TRUE; 
#***#     RETURN; 
  
#     SKIP THE -DECK- CARD                                             #
  
SKIPDECK: 
          GETWA(LIBFET, LOC(UP$), 1, LIBADDR, GOTOBADLIB);
          LIBADDR = LIBADDR + 1;
          WC = UP$WC;                  # WORD COUNT OF COMPRESSED TEXT #
          FOR I=I WHILE NOT UP$CHBFLAG  DO
              BEGIN 
              GETWA(LIBFET, LOC(UP$), 1, LIBADDR, GOTOBADLIB);
              LIBADDR = LIBADDR + 1;
              END 
          $BEGIN
          IF WC GR 16  THEN 
              ABORT;
          $END
          GETWA(LIBFET, LOC(UP$), WC, LIBADDR, GOTOBADLIB); 
          IF C<0,1>UP$WORD NQ MCC  THEN 
#***#         GOTO BADLIB;
          IF C<1,4>UP$WORD EQ "DECK"
           AND (C<5,1>UP$WORD GQ " "
                OR B<30,6>UP$WORD EQ O"00")  THEN 
#***#         GOTO GOODLIB;            # FIRST CARD IS <MCC>DECK<DELIM>#
          IF C<1,2>UP$WORD EQ "DK"
           AND (C<3,1>UP$WORD GQ " "
                OR B<18,6>UP$WORD EQ O"00")  THEN 
#***#         GOTO GOODLIB;            # FIRST CARD IS <MCC>DK<DELIM>  #
          IF C<1,7>UP$WORD EQ "COMDECK" 
           AND (C<8,1>UP$WORD GQ " "
                OR B<48,6>UP$WORD EQ O"00")  THEN 
#***#         GOTO GOODLIB;            # FIRST IS <MCC>COMDECK<DELIM>  #
          IF C<1,3>UP$WORD EQ "CDK" 
           AND (C<4,1>UP$WORD GQ " "
                OR B<24,6>UP$WORD EQ O"00")  THEN 
#***#         GOTO GOODLIB;            # FIRST CARD IS <MCC>CDK<DELIM> #
  
#***#     GOTO BADLIB;                 # FIRST CARD IS BAD             #
  
GOODLIB:                     # (HERE FROM ABOVE FOUR TESTS)            #
          LIBADDR = LIBADDR + WC; 
  
          END # SETLIB #
          TERM
