Refactoring RPG - Part 1
By Stephen West

Figure 3. CS8801.rpgle - Program to Refactor RPGLE Source Code


     H DFTACTGRP(*NO) ACTGRP(*NEW)
      //****************************************************************
      // Description:  Refactor RPGLE source code
      //****************************************************************
     FInputSrc  IF   F  132        DISK    UsrOpn
     FOutputSrc O    F  132        DISK

     FCspRemap  IF   E           K DISK    UsrOpn Prefix(rmap)
     FCspFields UF A E           K DISK    UsrOpn

      // Program Status Data Structure (PSDS).
     D                SDS
     D  psProgram              1     10a

      // Prototypes of called procedures.
     D spLoadRemaps    PR
     D spBuildFldRef   PR
     D spSetBltIns     PR
     D spSetFigCons    PR
     D spSetOpCode     PR
     D spZapFrmType    PR
     D spZapFirst5     PR
     D spZapHiLites    PR
     D spCvtToBlkLn    PR
     D spSetDate       PR
     D spUpdCondits    PR
     D spCvtFldDefs    PR
     D spSuppression   PR
     D spMiscellaneous...
     D                 PR

      // Compile-time array(s).
      // Using figCons to deal with "built-in" functions as well ... for now
     D figCons         S             10a   Dim(83) CTDATA PerRcd(1)             

      // Externalized scan/replace tables.
     D FromVal         S             10a   DIM(1000)
     D ToVal           S             10a   Dim(1000)

      // Miscellaneous data.
     D outSRCSEQ       S              6s 2
     D outSRCDAT       S              6s 0
     D outSRCDTA       S            120a
     D newSrcDAT       S              6s 0
     D newSrcDTA       S            120a
     D i               S              5u 0 Inz(0)
     D j               S              5u 0 Inz(0)
     D iRemaps         S              5u 0 Inz(0)
     D pvFormType      S              1a   Inz(' ')
     D FALSE           C                   '0'
     D TRUE            C                   '1'
     D pvStopFormat    S              1a   Inz(FALSE)
     D pvSuppressLine  S               n   Inz(*off)

      // The following fields are used in convertion to free-format.
     D firstDataSpec   S               n   Inz(*on)

      // *ENTRY parameter list.
     D main            PR                  ExtPgm('CS8801')
     D   cpZapFirst5                  4a
     D   cpZapFrmType                 4a
     D   cpSetDate                    7a
     D   cpSetOpCodes                 4a
     D   cpLowBltIns                  4a
     D   cpLowFigCons                 4a
     D   cpCvtToBlkLn                 4a
     D   cpUpdCondits                 4a
     D   cpZapHiLites                 4a

     D main            PI
     D   cpZapFirst5                  4a
     D   cpZapFrmType                 4a
     D   cpSetDate                    7a
     D   cpSetOpCodes                 4a
     D   cpLowBltIns                  4a
     D   cpLowFigCons                 4a
     D   cpCvtToBlkLn                 4a
     D   cpUpdCondits                 4a
     D   cpZapHiLites                 4a

      *
     IInputSrc  NS
     I                             s    1    6 2InSRCSEQ
     I                             s    7   12 0InSRCDAT
     I                             a   13  132  InSRCDTA

      /free
        // Beginning of Mainline
        pvStopFormat = FALSE;

        // Load the external remaps if remapping requested.
        If (cpSetOpCodes = '*YES');
          spLoadRemaps();
        EndIf;

        // Build file of field definitions.
        spBuildFldRef();

        Open InputSrc;
        Read InputSrc;
        DoW (NOT %eof);
          pvSuppressLine = *off;

          outSRCSEQ = InSRCSEQ;
          outSRCDAT = InSRCDAT;
          outSRCDTA = InSRCDTA;

          If (pvStopFormat = FALSE);
            Exsr srFormatLine;
          EndIf;

          If (NOT pvSuppressLine);
            Except OutputRec;
          EndIf;

          Read InputSrc;
        EndDo;
        Close InputSrc;

        // Normal termination.
        *inLR = *on;
        Return;

        // End of Mainline

        //*****************************************************************
        // Subroutine: FormatLine
        //*****************************************************************
        begSr srFormatLine;

          // Stop formatting once compile-time array data is encountered.
          If (%subst(InSRCDTA:1:2) <> '**');
            // Move field defs from calc spec to data spec.
            If (%subst(InSRCDTA:6:1) = 'D' and firstDataSpec);
              firstDataSpec = *off;
              spCvtFldDefs();
            EndIf;

            // Replace hilighting characters with a blank.
            If (cpZapHiLites = '*YES');
              spZapHiLites();
            EndIf;
			
            // Zap (blank out) the 'form type' on comment lines.
            If (cpZapFrmType = '*YES');
              spZapFrmType();
            EndIf;

            // Zap (blank out) the first 5 bytes of source line.
            If (cpZapFirst5 = '*YES');
              spZapFirst5();
            EndIf;

            // Blank out a comment line that consists only of an asterisk.
            If (cpCvtToBlkLn = '*YES');
              spCvtToBlkLn();
            EndIf;

            // Set the source line date.
            // *SAME is 0400101; *CURRENT is 0400102; *ZEROS is 0400203
            If (cpSetDate <> '0400101');
              spSetDate();
            EndIf;

            // Update RPG Conditionals to do compare to the right of the opcode.
            If (cpUpdCondits = '*YES');
              spUpdCondits();
            EndIf;

            // Convert the opcodes to predetermined, mixed-case letters.
            If (cpSetOpCodes = '*YES');
              spSetOpCode();
            EndIf;

            // Convert the built-in function names to lower-case letters.
            If (cpLowBltIns = '*YES');
              spSetBltIns();
            EndIf;

            // Convert the figurative constancts to lower-case letters.
            If (cpLowFigCons = '*YES');
              spSetFigCons();
            EndIf;

            // Check line to see if it should be suppressed.
            spSuppression();

            // Do miscellaneous changes that are not controlled by a flag.
            spMiscellaneous();

          // Compile-time array data encountered.
          Else;
            pvStopFormat = TRUE;
          EndIf;

        EndSr;
      /end-free

      // Output specifications.
     OOutputSrc E            OutputRec
     O                       outSRCSEQ            6
     O                       outSRCDAT           12
     O                       outSRCDTA          132
     OOutputSrc E            newSrcRec
     O                       outSRCSEQ            6
     O                       newSRCDAT           12
     O                       newSRCDTA          132

      //****************************************************************
      // Subprocedure: Blank out the form type on comment lines.
      //****************************************************************
     P spZapFrmType    B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D isAlpha         C                   0

      /free
        // outSRCDTA = InSRCDTA;
        If (%subst(outSRCDTA:7:1) = '*');
          pvFormType = %subst(outSRCDTA:6:1);

          // Convert to uppercase
          pvFormType = %xlate(lo:up:pvFormType);

          // Don't blank if non-alpha (i.e. keep highlighting)
          If (%check(up:pvFormType) = isAlpha);
            %subst(outSRCDTA:6:1) = ' ';
          EndIf;
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Blank out the first 5 bytes of RPG source,
      //               excluding compile-time arrays of coarse.
      //****************************************************************
     P spZapFirst5     B

      /free
        // outSRCDTA = InSRCDTA;
        If (%subst(outSRCDTA:1:2) <> '**');
          %subst(outSRCDTA:1:5) = '     ';
        Else;
          pvStopFormat = TRUE;
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Replace hilights with blanks.
      //****************************************************************
     P spZapHiLites    B

     D hilites         S             32a   Inz(x'202122232425262728292A2B2C2D2E-
     D                                     2F303132333435363738393A3B3C3D3E3F')
     D char            S              1a

      /free
        For i = 1 to 120;
          char = %subst(outSRCDTA:i:1);
          If (%scan(char:hilites) > 1);
            %subst(outSRCDTA:i:1) = ' ';
          EndIf;
        EndFor;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Convert built-in functions to lower-case.
      //****************************************************************
     P spSetBltIns     B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D char            S              1a
     D isBuiltIn       S               n   Inz(*off)
     D i               S             10i 0

      /free
        For i = 1 to 120;
          char = %subst(outSRCDTA:i:1);
          //If (char = '%' or char = '*');
          If (char = '%');
            isBuiltIn = *on;
          ElseIf (char = '(');
            isBuiltIn = *off;
          ElseIf (isBuiltIn);
            If (%scan(char:up) > 0 or %scan(char:lo) > 0);
              %subst(outSRCDTA:i:1) = %xlate(up:lo:char);
            Else;
              isBuiltIn = *off;
            EndIf;
          EndIf;
        EndFor;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Convert figurative contants to lower-case.
      //****************************************************************
     P spSetFigCons    B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D char            S              1a
     D line            S                   Like(outSRCDTA)
     D conLen          S             10i 0
     D i               S             10i 0
     D posn            S             10i 0

      /free
        // Get an all lower-case version of line.
        line = %xlate(up:lo:outSRCDTA);

        For i = 1 to %elem(figCons);
          conLen = %len(figCons(i));         // length of figurative constant

          posn = %scan(figCons(i):line);     // location of figurative constant in source line
          DoW (posn > 0);
            %subst(outSRCDTA:posn:conLen) = %trim(figCons(i));
            posn = %scan(figCons(i):line:posn+conLen);
          EndDo;
        EndFor;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Convert comment lines that are blank to a
      //               completely blank line.
      //****************************************************************
     P spCvtToBlkLn    B

      /free
        // outSRCDTA = InSRCDTA;
        If (%subst(outSRCDTA:1:7) = '      *');
          If (%subst(outSRCDTA:8:93) = *ALL' ');
            %subst(outSRCDTA:7:1) = ' ';
          EndIf;
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Set Date based on the special value passed in.
      //****************************************************************
     P spSetDate       B

      /free
        // *same is 0400101, so do nothing to the date.

        // *current is 0400102
        If (cpSetDate = '0400102');
          outSRCDAT = %dec(%date():*ymd);
        EndIf;

        // *zeros is 0400103
        If (cpSetDate = '0400103');
          outSRCDAT = 0;
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Replace Opcode with the "prefered" value.
      //****************************************************************
     P spSetOpCode     B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'

      /free
        For i = 1 to iRemaps;
          If (%xlate(lo:up:%subst(outSRCDTA:26:10)) = FromVal(i));
            %subst(outSRCDTA:26:10) = ToVal(i);
          EndIf;
        EndFor;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Move logical comparisons out of the opcode and into
      //               factor2 to the right of the opcode.
      //****************************************************************
     P spUpdCondits    B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D opCode          S             10A
     D factor1         S             14A
     D factor2         S             14A
     D comment         S             20A

      /free
        comment = %subst(outSRCDTA:81:20);
        factor1 = %subst(outSRCDTA:12:14);
        factor2 = %subst(outSRCDTA:36:14);
        opCode = %xlate(lo:up:%subst(outSRCDTA:26:10));

        Select;

          When opCode = 'IFEQ      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'IFNE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'IFLT      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'IFGT      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'IFLE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'IFGE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'If        ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWEQ     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %Subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWNE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWLT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWGT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWLE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOWGE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoW       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOUEQ     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOUNE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOULT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOUGT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOULE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'DOUGE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'DoU       ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDEQ     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDNE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDLT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDGT     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDLE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ANDGE     ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'OREQ      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ORNE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ORLT      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ORGT      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ORLE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'ORGE      ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = '          ';
            %subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENEQ    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENNE    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENLT    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENGT    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENLE    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

          When opCode = 'WHENGE    ';
            %subst(outSRCDTA:12:14) = *ALL' ';
            %subst(outSRCDTA:26:10) = 'When      ';
            %subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
                                                      %trim(factor2);
            %subst(outSRCDTA:81:20) = comment;

        EndSl;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Load arrays of opcodes to be replaced with
      //               standardized case (upper vs. lower vs. mixed).
      //****************************************************************
     P spLoadRemaps    B

     D sourceType      S             10a   Inz('RPGLE     ')

      /free
        //Load the customized from/to values.
        i = 0;
        j = 0;
        Open CspRemap;
        SetLL sourceType CspRemap;
        ReadE sourceType CspRemap;

        DoW (NOT %eof);
          i += 1;
          FromVal(i) = rmapFROMVAL;
          ToVal(i) = rmapTOVAL;

          ReadE sourceType CspRemap;
        EndDo;

        Close CspRemap;
        iRemaps = i;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Perform suppression of deprecated lines.
      //****************************************************************
     P spSuppression   B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'

     D opCode          S             10a
     D factor1         S             14a
     D lineSpec        S              1a

      /free
        // Suppress *LIKE/DEFINES and *DTAARA/DEFINES,
        // they have been moved to the data specs.
        lineSpec = %xlate(lo:up:%subst(outSRCDTA:6:1));
        opCode   = %xlate(lo:up:%subst(outSRCDTA:26:10));
        If (lineSpec = 'C' and opCode = 'DEFINE    ');
          factor1 = %xlate(lo:up:%subst(outSRCDTA:12:14));
          If (factor1 = '*LIKE     ' or factor1 = '*DTAARA   ');
            pvSuppressLine = *on;
          EndIf;
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Perform miscellaneous changes.
      //****************************************************************
     P spMiscellaneous...
     P                 B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'

     D opCode          S             10a
     D lineSpec        S              1a

      /free
        // Remove "SR" following 'C'alculation line type.
        // It is an obsolete way of identifying lines in a
        // "S"ub"R"outine.
        If (%xlate(lo:up:%subst(outSRCDTA:6:3)) = 'CSR');
          %subst(outSRCDTA:6:3) = 'C  ';
        EndIf;

        // Suppress field definition in calculation specs.
        lineSpec = %xlate(lo:up:%subst(outSRCDTA:6:1));
        opCode   = %xlate(lo:up:%subst(outSRCDTA:26:10));
        If (lineSpec = 'C');
          %subst(outSRCDTA:64:7) = '       ';
        EndIf;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Build a workfile of field reference information.
      //     i) Use file specs.
      //    ii) Use data declarations
      //   iii) Use calc spec field declarations
      //****************************************************************
     P spBuildFldRef   B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D lineSpec        S              1a
     D commentCol      S              1a
     D defType         S              2a
     D fileFmt         S              1a
     D fileName        S             10a
     D lengthA         S              7a
     D fromA           S              7a
     D decimalsA       S              2a

     D opCode          S             10a
     D factor1         S             14a
     D factor2         S             14a
     D result          S             14a

      /free
        Open InputSrc;
        Open CspFields;

        Read InputSrc;
        DoW (NOT %eof);
          lineSpec = %xlate(lo:up:%subst(inSRCDTA:6:1));
          WhereDef = lineSpec;
          commentCol  = %subst(inSRCDTA:7:1);

          // Skip lines that are commented out...
          If (commentCol <> '*');
            Select;

              // Process a 'F'ile spec.
              When (lineSpec = 'F');
                // Next month we will add code here to load all the fields
                // from a file in the file specifications.

              // Process an 'I'nput spec.
              When (lineSpec = 'I');
                // Look for a field declaration or rename.

              // Process a 'C'alculation spec.
              When (lineSpec = 'C');
                Clear CSRFIELDS;
                factor1 = %xlate(lo:up:%subst(inSRCDTA:12:14));
                factor2 = %xlate(lo:up:%subst(inSRCDTA:36:14));
                result  = %xlate(lo:up:%subst(inSRCDTA:50:14));
                opCode  = %xlate(lo:up:%subst(inSRCDTA:26:10));
                WhereDef = lineSpec;
                library  = '*NONE';
                file     = '*NONE';
                format   = '*NONE';
                // If a *LIKE DEFINE field definition...
                If (opCode = 'DEFINE    ' and factor1 = '*LIKE     ');
                  fileType = '*LIKEDFN';
                  field    = result;
                  newName  = factor2;
                  dataType = ' ';
                  length   = 0;
                  decimals = 0;
                  Write CSRFIELDS;
                // If a *DTAARA DEFINE definition...
                ElseIf (opCode = 'DEFINE    ' and factor1 = '*DTAARA   ');
                  fileType = '*DTAARA';
                  dataType = ' ';
                  If (factor2 = *blanks);
                    field     = result;
                  Else;
                    field     = factor2;
                    newName   = result;
                  EndIf;
                  lengthA   = %subst(inSRCDTA:64:5);
                  decimalsA = %subst(inSRCDTA:69:2);
                  //           Character field...
                  If (decimalsA = *blanks and lengthA <> *blanks);
                    dataType = 'A';
                    Monitor;
                      length   = %dec(%trim(lengthA):7:0);
                      On-Error;
                        length = 0;
                        decimals = 0;
                    EndMon;
                  //           Packed decimal field...
                  ElseIf (decimalsA <> *blanks and lengthA <> *blanks);
                    dataType = 'P';
                    Monitor;
                      decimals = %dec(%trim(decimalsA):2:0);
                      length   = %dec(%trim(lengthA):7:0);
                      On-Error;
                        length = 0;
                        decimals = 0;
                    EndMon;
                  EndIf;
                  Write CSRFIELDS;
                // Plain 'ol 'C'alculation spec defined field...
                Else;
                  fileType  = '*CALCDFN';
                  field     = %subst(inSRCDTA:50:14);
                  lengthA   = %subst(inSRCDTA:64:5);
                  decimalsA = %subst(inSRCDTA:69:2);
                  //           Character field...
                  If (decimalsA = *blanks and lengthA <> *blanks);
                    dataType = 'A';
                    Monitor;
                      length   = %dec(%trim(lengthA):7:0);
                      Write CSRFIELDS;
                      On-Error;
                      // Definition unreliable; do not save.
                    EndMon;
                  //           Packed decimal field...
                  ElseIf (decimalsA <> *blanks and lengthA <> *blanks);
                    dataType = 'P';
                    Monitor;
                      decimals = %dec(%trim(decimalsA):2:0);
                      length   = %dec(%trim(lengthA):7:0);
                      Write CSRFIELDS;
                      On-Error;
                      // Definition unreliable; do not save.
                    EndMon;
                  EndIf;
                EndIf;

              // Process a 'D'ata spec.
              When (lineSpec = 'D');
                // Next month we will add code here to load all the fields
                // that are defined in the data definition specifications.

            EndSl;
          EndIf; // Skip lines that are commented out...

          Read InputSrc;
        EndDo;

        Close CspFields;
        Close InputSrc;
      /end-free

     P                 E

      //****************************************************************
      // Subprocedure: Add data specs to replace calc spec field defs.
      //****************************************************************
     P spCvtFldDefs    B

     D up              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D lo              C                   'abcdefghijklmnopqrstuvwxyz'
     D lineSpec        S              1a
     D commentCol      S              1a
     D defType         S              2a
     D fileFmt         S              1a
     D fileName        S             10a

     D fldArray        S             15a   Dim(300)
     D fldCount        S             10i 0 Inz(0)

      /free
        Open CspFields;
        Read CspFields;
        DoW (NOT %eof(CspFields));
          // Process Calc Spec field definitions.
          If (fileType = '*CALCDFN' and fldCount < 96);
            // Write out a couple of comment lines before the first definition.
            If (fldCount = 0);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              Except newSrcRec;  // Write a blank source code line...
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              %subst(newSRCDTA:7) = '// Definitions added by REFACTOR command';
                                //  %trim(psProgram);
              Except newSrcRec;  // Write a source code line...
            EndIf;
            // Confirm that the field has not already been added.
            If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
              fldCount += 1;
              fldArray(fldCount) = %xlate(lo:up:Field);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              %subst(newSRCDTA:6) = 'D ' + Field;
              %subst(newSRCDTA:24:1) = 'S';
              %subst(newSRCDTA:33:7) = %editc(Length:'Z');
              %subst(newSRCDTA:40:1) = %xlate(up:lo:DataType);
              If (DataType = 'S' or DataType = 'P');
                If (Decimals = 0);
                  %subst(newSRCDTA:42:1) = '0';
                Else;
                  %subst(newSRCDTA:41:2) = %subst(%editc(Decimals:'Z'):4:2);
                EndIf;
              EndIf;
              Except newSrcRec;  // Write a source code line...
              newSRCDTA = *ALL' ';
            EndIf;

          // Process *LIKE/DEFINE Calc Spec field definitions.
          ElseIf (fileType = '*LIKEDFN' and fldCount < 96);
            // Write out a couple of comment lines before the first definition.
            If (fldCount = 0);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              Except newSrcRec;  // Write a blank source code line...
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              %subst(newSRCDTA:7) = '// Definitions added by REFACTOR command';
                                //  %trim(psProgram);
              Except newSrcRec;  // Write a source code line...
            EndIf;
            // Confirm that the field has not already been added.
            If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
              fldCount += 1;
              fldArray(fldCount) = %xlate(lo:up:Field);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              %subst(newSRCDTA:6) = 'D ' + Field;
              %subst(newSRCDTA:24:1) = 'S';
              %subst(newSRCDTA:44) = 'Like(' + %trim(newName) + ')';
              Except newSrcRec;  // Write a source code line...
              newSRCDTA = *ALL' ';
            EndIf;

          // Process *DTAARA/DEFINE Calc Spec field definitions.
          ElseIf (fileType = '*DTAARA' and fldCount < 96);
            // Write out a couple of comment lines before the first definition.
            If (fldCount = 0);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              Except newSrcRec;  // Write a blank source code line...
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              %subst(newSRCDTA:7) = '// Definitions added by FILTERRPG command';
                                //  %trim(psProgram);
              Except newSrcRec;  // Write a source code line...
            EndIf;
            // Confirm that the field has not already been added.
            If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
              fldCount += 1;
              fldArray(fldCount) = %xlate(lo:up:Field);
              outSRCSEQ += .01;
              newSRCDTA = *ALL' ';
              If (newName <> *blanks);
                %subst(newSRCDTA:6) = 'D ' + newName;
              Else;
                %subst(newSRCDTA:6) = 'D ' + Field;
              ENDIF;
              %subst(newSRCDTA:24:1) = 'S';
              %subst(newSRCDTA:33:7) = %editc(Length:'Z');
              %subst(newSRCDTA:40:1) = %xlate(up:lo:DataType);
              If (DataType = 'S' or DataType = 'P');
                If (Decimals = 0);
                  %subst(newSRCDTA:42:1) = '0';
                Else;
                  %subst(newSRCDTA:41:2) = %subst(%editc(Decimals:'Z'):4:2);
                EndIf;
              EndIf;
              %subst(newSRCDTA:44) = 'DtaAra(' + %trim(field) + ')';
              Except newSrcRec;  // Write a source code line...
              newSRCDTA = *ALL' ';
            EndIf;
          EndIf;

          Read CspFields;
        EndDo;

        // Write a blank line, sequence number permitting...
        If (fldCount > 0 and fldCount < 98);
          outSRCSEQ += .01;
          newSRCDTA = *ALL' ';
          Except newSrcRec;  // Write a source code line...
        EndIf;

        Close CspFields;
      /end-free

     P                 E

** Figurative Constants
*blanks       1
*blank        2
*zeros        3
*zero         4
*off          5
*on           6
*hival        7
*loval        8
*in           9
*lda          10
*dtaara       11
*date         12
*user         13
*year         14
*month        15
*day          16
%abs          17
%addr         18
%alloc        19
%bitand       20
%bitnot       21
%bitor        22
%bitxor       23
%char         24
%checkr       25
%check        26
%date         27
%days         28
%dech         29
%decpos       30
%dec          31
%diff         32
%div          33
%editc        34
%editflt      35
%editw        36
%elem         37
%eof          38
%equal        39
%error        40
%fields       41
%float        42
%found        43
%graph        44
%handler      45
%hours        46
%int          47
%kds          48
%len          49
%lookup       50
%minutes      51
%months       52
%mseconds     53
%nullind      54
%occur        55
%open         56
%paddr        57
%parms        58
%realloc      59
%rem          60
%replace      61
%scan         62
%seconds      63
%shtdn        64
%size         65
%sqrt         66
%status       67
%str          68
%subarr       69
%subdt        70
%subst        71
%this         72
%timestamp    73
%time         74
%tlookup      75
%trim         76
%triml        77
%trimr        78
%ucs2         79
%uns          80
%xfoot        81
%xml          82
%years        83
  



2007 Workware, Inc. All rights reserved.