*DECK SETCOPY 
USETEXT CCTTEXT 
USETEXT SSTEXT
          PROC  SETCOPY;
  
#**       SETCOPY -  SET INFORMATION FROM COPY STATEMENT               #
#                                                                      #
#     CALLING SEQUENCE-                                                #
#         SETCOPY:                                                     #
#                                                                      #
#     GIVEN-                                                           #
#         CURRENT TOKEN IS *COPY*.                                     #
#                                                                      #
#     DOES-                                                            #
#         READS COPY STATEMENT.                                        #
#         IF ERRORS THEN                                               #
#           ISSUES DIAGNOSTIC(S) AND IGNORES TOKENS                    #
#         ELSE                                                         #
#           SETS FORMAL AND ACUTAL PARAMETER INFORMATION,              #
#           INITIALIZES TARGET ARRAY,                                  #
#           INITIALIZES LIBFET                                         #
  
  
          BEGIN 
  
          CONTROL PACK; 
  
  
  
 $BEGIN 
*CALL CPMCOMM 
 $END 
  
          XREF               # EXTERNAL PROCEDURES                     #
              BEGIN 
              PROC  ABORTSS;           # COMPILER ABORT                #
              FUNC  CMM$AGR  I;        # ACQUIRE GROUP-ID              #
              PROC  CMM$ALV;           # ALLOCATE VARYING-POS. BLOCK   #
              PROC  CMM$FGR;           # FREE GROUP OF CMM BLOCKS      #
              PROC  CMM$GLV;           # GROW AT LAST OF VARYING BLOCK #
              PROC  GETPIC;            # GET PICTURE CHARACTER-STRING  #
              PROC  GETPLINDEX;        # GET INDEX TO PRINT LINE ENTRY #
              PROC  GETSTR;            # GET STRING                    #
              PROC  INTERCEPTOR;       # ISSUE DIAGNOSTIC              #
              PROC  READIT;            # READ A LINE                   #
              PROC  SETLINE;           # SET ACHR FOR -GETSTR-         #
              PROC  SETLIB;            # SET LIBFET AND LIBADDR        #
              PROC  SETPAIR;           # SET UP FORMAL/ACTUAL PAIR     #
              PROC  SSDIAGS;
              END 
  
 #   DIAGNOSTICS ISSUED IN SETCOPY     #
  
          DEF D1084 #084#;
          DEF D1085 #085#;
          DEF D1086 #086#;
          DEF D1603 #603#;
  
          ITEM  C            I;        # CHARACTER OFFSET              #
          ITEM  COPYVLN      I;        # V.L.N. OF "COPY"              #
          ITEM  DONE         B;        # FLAG END OF ITERATION         #
          ITEM  F            I;        # TO FIRST LINE OF COPY STMT    #
          ITEM  I            I;        # SCRATCH                       #
          ITEM  L            I;        # TO LAST LINE OF COPY STMT     #
          ITEM  LIBTKNISPIC  B;        # IFF LIBRARY TOKEN IS PIC      #
          ITEM  NWORDS       I;        # SCRATCH                       #
          ITEM  TKN          I;        # INDEX TO TOKEN ENTRY          #
          ITEM  W            I;        # WORD OFFSET                   #
                                       # (ALSO SEV=WARNING,  IGNORED)  #
          ITEM  WARN         B;        # WARN WHERE END OF COPY STMT IS#
     XREF ITEM  STCOPY       B; 
  
          STATUS  TKNTYPE 
*CALL TKNTYPE 
  
CONTROL EJECT;
  
*CALL BUG020C$
  
*CALL LISTCTL 
  
          $BEGIN
  
          XREF
              BEGIN 
              PROC  CBLIST;            # COBOL LISTING ROUTINE         #
              FUNC  DEC      C(10);    # L.J.B.F. DECIMAL VALUE        #
              END 
  
          ITEM  C10          C(10);    # SCRATCH                       #
          ITEM  LINE         C(140);   # DEBUG PRINT LINE              #
  
          $END
CONTROL EJECT;
          PROC ALLOCBLK ((SIZE), PTRADD); 
 #
      ALLOCATE A CMM BLOCK FOR A TABLE
 #
  
          BEGIN 
          ITEM SIZE;
          ITEM PTRADD;
  
          CMM$ALV (SIZE,1,3,GROUP$REPL,PTRADD,0); 
          RETURN; 
          END 
CONTROL EJECT;
  
          $BEGIN
          IF BUG020C$CPY  THEN
              BEGIN 
              LINE = "*** COPY STATEMENT FOUND ***********************";
              CBLIST(LISTCTL"LINE", LINE, 48);
              END 
          $BEGIN
          CPMCOPYCOUNT = CPMCOPYCOUNT + 1;
          $END
          $END
  
          REPLACING = FALSE;
          COPYVLN = CLAVLN;            # REMEMBER WHERE "COPY" IS      #
          COPYCOLUMN = CLACOLUMN; 
          CHECKINGCOPY = TRUE;         # DO NOT PRINT THE COPY STMT    #
  
#     PROCESS  <TEXT-NAME> [ (OF/IN) <LIBRARY-NAME> ]                  #
#     SET UP LIBFET, LIBADDR                                           #
  
          SETLIB; 
          IF ERROR  THEN
#***#         GOTO FINDEND;            # GO FIND END OF COPY STATEMENT #
  
#     [ REPLACING (,<FORMAL-PARAMETER> BY <ACTUAL-PARAMETER>)... ]     #
  
          IF CLATYPE EQ TKNTYPE"AW" 
           AND C<0,10>SAREA[0] EQ "REPLACING "  THEN
              BEGIN 
              IF CCTFIPSLEVEL LS 4
              THEN BEGIN
                   # FIPS=4 SUPPORTS COPY REPLACING # 
                  SSDIAGS(D1603); 
                   END
              $BEGIN
              CPMCREPCOUNT = CPMCREPCOUNT + 1;
              $END
              REPLACING = TRUE; 
              $BEGIN
              IF P<APNTKNS> NQ 0
               OR P<APARRAY> NQ 0 
               OR P<APSTRING> NQ 0
               OR P<FPNTKNS> NQ 0 
               OR P<FPARRAY> NQ 0 
               OR P<FPSTRING> NQ 0
               OR P<TARRAY> NQ 0
               OR P<TSTRING> NQ 0  THEN 
                  ABORTSS("SETCOPY-2"); 
              $END
  
              GROUP$REPL = CMM$AGR(1); # HOPEFULLY ALLOCATE BELOW HHA  #
  
              ALLOCBLK (1, P<APNTKNS>); 
              NPAIRS = 0; 
  
              ALLOCBLK (2, P<APARRAY>); 
              API$NXTARRAY = 1; 
  
              ALLOCBLK (4+26, P<APSTRING>); 
              API$MAXSTRGW = 4; 
              API$NXTSTRGW = 0; 
              API$NXTSTRGC = 0; 
              C<0,240>AP$STRING[0] = " "; 
              C<0,60>AP$STRING[24] = " "; 
  
              ALLOCBLK (1, P<FPNTKNS>); 
  
              ALLOCBLK (1, P<FPARRAY>); 
              FPI$NXTARRAY = 1; 
              MAXFPTKNS = 0;
  
              ALLOCBLK (4+26, P<FPSTRING>); 
              FPI$MAXSTRGW = 4; 
              FPI$NXTSTRGW = 0; 
              FPI$NXTSTRGC = 0; 
              C<0,240>FP$STRING[0] = " "; 
              C<0,60>FP$STRING[24] = " "; 
              GETSTR; 
              FOR I=I WHILE CLATYPE NQ TKNTYPE"EOD" 
               AND NOT (CLATYPE EQ TKNTYPE"PUNC"
                        AND C<9,1>CLAVALUE EQ ".")  DO
                  BEGIN                # NOT SEP. PERIOD OR END-OF-DATA#
                  IF CLATYPE EQ TKNTYPE"PUNC" 
                   AND (C<9,1>CLAVALUE EQ "," 
                        OR C<9,1>CLAVALUE EQ ";")  THEN 
                      GETSTR; 
                  CMM$GLV(APNTKNS, 1);
                  CMM$GLV(FPNTKNS, 1);
                  SETPAIR;
                  IF ERROR THEN 
#***#                 GOTO FINDEND;    # GO FIND END OF COPY STATEMENT #
                  END 
              END 
          IF CLATYPE EQ TKNTYPE"EOD"  THEN
#***#         GOTO DIAGEOD;            # GO DIAGNOSE PREMATURE EOD     #
  
#     ENSURE THAT WE HAVE A TERMINATING PERIOD                         #
  
          IF CLATYPE NQ TKNTYPE"PUNC" 
           OR C<9,1>CLAVALUE NQ "."  THEN 
#***#         GOTO DIAGSYN;            # GO DIAGNOSE SYNTAX ERROR      #
  
#     SET THE -IGNORE- FLAG ON ALL LINES CONTAINING                    #
#     ANY OF THE COPY STATEMENT                                        #
  
          FOR F = PLI$FIRST WHILE PL$VLN[F] NQ COPYVLN  DO
              BEGIN                    # LOOK FOR FIRST LINE           #
              F = PL$NEXT[F]; 
              $BEGIN
              IF F EQ 0  THEN 
                  ABORTSS("SETCOPY-1"); 
              $END
              END 
          LN = PL$LINE[F];     # RESET LINE NUMBER #
          FOR L = F WHILE PL$VLN[L] NQ CLAVLN  DO 
              BEGIN                    # LOOK FOR LAST LINE            #
              PL$FLAGI[L] = TRUE;      # SET -IGNORE- FLAG             #
              L = PL$NEXT[L];          # ADVANCE TO NEXT LINE          #
              LN = PL$LINE[L];
              END 
          PL$FLAGI[L] = TRUE;          # SET -IGNORE- ON LAST LINE     #
  
#     ALLOW THE -COPY- STATEMENT TO BE PRINTED                         #
  
  
#     IF CHARACTERS PRECEDED THE "COPY", GENERATE A LINE               #
  
          IF C<7,COPYCOLUMN-8>PL$10CHARS[F] NQ " " THEN 
              BEGIN 
              GETPLINDEX(I);
              C<0,100>PL$10CHARS[I] = " ";
              IF CCTPSQ  THEN          # IF USER SEQUENCE NUMBERS      #
                  C<1,5>PL$10CHARS[I] = "00000";
              C<7,COPYCOLUMN-8>PL$10CHARS[I]
                                       = C<7,COPYCOLUMN-8>PL$10CHARS[F];
              PL$INIT[I] = 0;          # CLEAR PL$ FIELDS              #
              PL$NEXT[I] = PL$NEXT[L]; # INSERT THIS LINE AFTER THE    #
              PL$NEXT[L] = I;          #   LAST IGNORED LINE           #
              PLI$CURRENT = I;
              PL$FLAGN[I] = TRUE;      # THIS LINE IS GENERATED        #
              PL$READY[I] = TRUE;      # THIS LINE IS READY TO PRINT   #
              LN = LN + 1;
              PL$LINE[I] = LN;         # ASSIGN NEXT SEQUENTIAL LINE NO#
              PL$VLN[I] = PL$VLN[F];
              $BEGIN
              IF BUG020C$CPY  THEN
                  BEGIN 
                  LINE = "SETCOPY- NEW PLI$CURRENT=99 ("; 
                  C10 = DEC(PLI$CURRENT); 
                  C<25,2>LINE = C<0,2>C10;
                  C<29,90>LINE = C<0,90>PL$10CHARS[PLI$CURRENT];
                  C<119,1>LINE = ")"; 
                  CBLIST(LISTCTL"LINE", LINE, 120); 
                  END 
              $END
              END 
  
#     IF CHARACTERS FOLLOW THE "COPY", GENERATE A LINE                 #
  
          IF C<CLACOLUMN,72-CLACOLUMN>PL$10CHARS[L] NQ " " THEN 
          #CLACOLUMN - 1 IS SYMPL CHAR OFFSET IN PL$10CHARS            #
              BEGIN 
              GETPLINDEX(I);
              C<0,100>PL$10CHARS[I] = " ";
              IF CCTPSQ THEN                #IF USER SEQUENCE NUMBERS  #
                  C<1,5>PL$10CHARS[I] = "00000";
              C<CLACOLUMN,72-CLACOLUMN>PL$10CHARS[I] =
                  C<CLACOLUMN,72-CLACOLUMN>PL$10CHARS[L]; 
              PL$INIT[I] = 0;     # CLEAR PL$ FIELDS                   #
              PL$NEXT[I] = PL$NEXT[PLI$CURRENT];  #INSERT THIS LINE    #
              PL$NEXT[PLI$CURRENT] = I;           #BEFORE CURRENT LINE #
                                  #WHICH SHOULD BE AFTER LAST COPY LINE#
              PL$FLAGN[I] = TRUE;       # THIS LINE IS GENERATED       #
              PL$READY[I] = FALSE;
                                        #LINE NUMBER NOT NECCESSARY    #
                                        #READIT WILL ASSIGN ONE        #
              PL$VLN[I] = PL$VLN[L];    #AFTER THE COPY                #
  
              $BEGIN
              IF BUG020C$CPY THEN 
                  BEGIN 
                  LINE = "SETCOPY - VLN 99 GENERATED (";
                  C10 = DEC(I); 
                  C<14,2>LINE = C<0,2>C10;
                  C<28,90>LINE = C<0,90>PL$10CHARS[I];
                  C<118,1>LINE = ")"; 
                  CBLIST(LISTCTL"LINE",LINE,120); 
                  END 
              $END
  
              END 
  
#     SEPARATE AND SAVE LINE(S) AFTER PLI$CURRENT                      #
  
          PLI$NEXTSRC = PL$NEXT[PLI$CURRENT]; 
          PLI$LASTSRC = PLI$LAST; 
  
#     SWITCH SO LINES WILL COME FROM LIBRARY                           #
  
          READLIB = TRUE; 
          EODFLAG = FALSE;             # CLEAR IN CASE THE COPY        #
                                       #   STMT IS ON THE LAST LINE    #
          SOURCEACHR = ACHR;     # SAVE ACHR# 
  
#     SET UP A NEW REAL LINE FOR PLI$LAST                              #
  
          DONE = FALSE; 
          I = PLI$CURRENT;
          FOR I=I WHILE NOT DONE  DO
              BEGIN 
              GETPLINDEX(PLI$LAST);    # GET INDEX TO PRINT LINE ENTRY #
              PL$INIT[PLI$LAST] = 0;   # INITIALIZE FIELDS             #
                  PL$NEXT[I] = PLI$LAST;  # LINK THIS TO PREVIOUS LINE #
                  I = PLI$LAST; 
              READIT(PLI$LAST);        # SET 90 CHRS, ETC.             #
              IF NOT READLIB  THEN
                  BEGIN                # TEXT WAS ALL COMMENTS         #
                  $BEGIN
                  IF BUG020C$CPY  THEN
                      CBLIST(LISTCTL"LINE", 
                                "  SETCOPY- TEXT WAS ALL COMMENTS", 32);
                  $END
                  IF REPLACING  THEN   # IF CMM BLOCKS ALLOCATED       #
                      BEGIN            #   RELEASE THEM                #
                      CMM$FGR(GROUP$REPL);       # (THIS AND FOLLOWING #
                      $BEGIN                     #  CODE IS IDENTICAL  #
                      P<APNTKNS> = 0;            #  TO THE CODE IN     #
                      P<APARRAY> = 0;            #  TKNCLAS JUST AFTER #
                      P<APSTRING> = 0;           #  STATE5)            #
                      P<FPNTKNS> = 0; 
                      P<FPARRAY> = 0; 
                      P<FPSTRING> = 0;
                      P<TARRAY> = 0;
                      $END
                      P<TSTRING> = 0;  # (CHECKED BY -SKIPCLA-)        #
                      END 
                  # CSTATE = 1 #
                  REPLACING = FALSE;
          CHECKINGCOPY = FALSE; 
                  STCOPY = FALSE; 
#***#             RETURN; # FROM SETCOPY #
                  END 
              DONE = NOT PL$COMMENT[PLI$LAST];
              END                      # LOOP IF COMMENT LINE          #
          TKNFROMLIB = TRUE;           # TOKENS SHOULD FILL T$         #
          CHECKINGCOPY = FALSE; 
  
#     INITIALIZE -GETSTR- SO IT GETS TOKENS FROM THE LIBRARY           #
  
          SETLINE;                     # SET ACHR FOR READLIB=TRUE     #
  
#     IF REPLACING, INITIALIZE TARGET STRING                           #
  
              NTARGETS = 1;            # INITIALIZE NTARGETS   #
          IF REPLACING
           AND MAXFPTKNS NQ 1  THEN    # (NO SETUP FOR 1 TOKEN)        #
              BEGIN 
              ALLOCBLK (2*MAXFPTKNS, P<TARRAY>);
              TI$MAXARRAY = MAXFPTKNS;
              TI$NXTARRAY = 1;
  
              TI$MAXSTRGW = (MAXFPTKNS + 9)/10 + 3; 
              ALLOCBLK (TI$MAXSTRGW+26, P<TSTRING>);
              TI$NXTSTRGW = 0;
              TI$NXTSTRGC = 0;
  
              $BEGIN
              C<0,140>T$STRING[0] = " ";
              FOR I = 0 STEP 1 UNTIL (MAXFPTKNS - 1)/10  DO 
                  C<0,10>T$STRING[I] = "??????????";
              $END
              FOR I = 1 STEP 1 UNTIL MAXFPTKNS  DO
                  BEGIN 
                  T$WO[I] = (I - 1)/10; 
                  T$CO[I] = I - 1 - 10*T$WO[I]; 
                  T$L[I] = 0; 
                  END 
              NTARGETS = MAXFPTKNS; 
              T$LSTRING = MAXFPTKNS - 1;         # NO. CHRS IN T$STRING#
              NONLIBFPTKNS = 0;        # ALL TARGET TOKENS FROM LIB    #
              END # OF SETTING UP TARGET SEQUENCE # 
  
#     SET NEXT STATE                                                   #
  
          IF REPLACING  THEN
              BEGIN 
              IF NFPPUNCS EQ 0  THEN
                  CSTATE = 2;          # COPY REPLACING W/O FP PUNC    #
              ELSE
                  CSTATE = 3;          # COPY REPLACING WITH FP PUNC   #
              END 
CONTROL EJECT;
  
          $BEGIN
          IF BUG020C$CPY  THEN
              BEGIN 
              IF NOT REPLACING  THEN
                  BEGIN 
                  LINE = "NOT REPLACING"; 
                  CBLIST(LISTCTL"LINE", LINE, 13);
                  END 
              ELSE
                  BEGIN 
                  LINE =
                  "REPLACING-  NPAIRS=99   MAXFPTKNS=999   NFPPUNCS=99";
                  C10 = DEC(NPAIRS);
                  C<19,2>LINE = C<0,2>C10;
                  C10 = DEC(MAXFPTKNS); 
                  C<34,3>LINE = C<0,3>C10;
                  C10 = DEC(NFPPUNCS);
                  C<49,2>LINE = C<0,2>C10;
                  CBLIST(LISTCTL"LINE", LINE, 50);
                  END 
              LINE = "*** COPY STATEMENT HAS BEEN ANALYZED ***********";
              CBLIST(LISTCTL"LINE", LINE, 49);
              END 
          $END
  
          RETURN; # FROM SETCOPY #
CONTROL EJECT;
  
#     DIAGNOSE SYNTAX ERROR                                            #
  
DIAGSYN:  
          # (THIS SHOULD HAVE BEEN A PERIOD TO PROPERLY TERMINATE THE  #
          #  COPY STATEMENT.  THE COPY STATEMENT IS IGNORED.)          #
          SSDIAGS (D1084);
  
#     FIND THE END OF THE COPY STATEMENT                               #
  
FINDEND:  
          WARN = FALSE; 
          FOR I=I WHILE CLATYPE NQ TKNTYPE"EOD" 
           AND NOT (CLATYPE EQ TKNTYPE"PUNC"
                    AND C<9,1>CLAVALUE EQ ".")  DO
              BEGIN 
              IF CLATYPE EQ TKNTYPE"PTDELIM"  THEN
                  BEGIN 
                  WARN = TRUE;         # TELL USER WHERE IT ENDS       #
                  GETSTR;              # SKIP THE ==                   #
                  FOR I=I WHILE CLATYPE NQ TKNTYPE"PTDELIM" 
                   AND CLATYPE NQ TKNTYPE"EOD"  DO
                      GETSTR; 
                  END # OF SKIPPING PSEUDO-TEXT # 
              GETSTR; 
              END 
          IF WARN  THEN 
              BEGIN 
              # (THE IGNORED COPY STATEMENT ENDS HERE.)                #
              SSDIAGS (D1085);
              END 
          IF REPLACING THEN          # IF CMM BLOCKS ALLOCATED #
              BEGIN 
              CMM$FGR(GROUP$REPL);   # RELEASE THEM            #
              $BEGIN
              P<APNTKNS> = 0; 
              P<APARRAY> = 0; 
              P<APSTRING> = 0;
              P<FPNTKNS> = 0; 
              P<FPARRAY> = 0; 
              P<FPSTRING> = 0;
              P<TARRAY> = 0;
              $END
              P<TSTRING> = 0; 
              END 
          READLIB = FALSE;             # IGNORE THE COPY STATEMENT     #
          REPLACING = FALSE;
          RETURN; # FROM SETCOPY #
  
  
  
  
#     DIAGNOSE PREMATURE END-OF-DATA                                   #
  
DIAGEOD:  
          # (THE SOURCE PROGRAM ENDED BEFORE THE TERMINATING PERIOD    #
          #  FOR THE COPY STATEMENT.)                                  #
          SSDIAGS (D1086);
          IF REPLACING THEN          # IF CMM BLOCKS ALLOCATED #
              BEGIN                # RELEASE THEM     # 
              CMM$FGR(GROUP$REPL);
              $BEGIN
              P<APNTKNS> = 0; 
              P<APARRAY> = 0; 
              P<APSTRING> = 0;
              P<FPNTKNS> = 0; 
              P<FPARRAY> = 0; 
              P<FPSTRING> = 0;
              P<TARRAY> = 0;
              $END
              P<TSTRING> = 0; 
              END 
          READLIB = FALSE;             # IGNORE THE COPY STATEMENT     #
          REPLACING = FALSE;
          RETURN; # FROM SETCOPY #
  
  
          END # SETCOPY # 
          TERM
