EXTOL RPG Program: EXPARSER

EXTOL RPG - External Call EXPARSER - Parse Input String on Word Breaks

     H/TITLE Parse input string on word breaks; call repeatedly
     H            Y
     Z* CRTRPGPGM
     Z* OPTION(*NOXREF) GENOPT(*OPTIMIZE)
      *
     W* Warning: This program does not set on the LR indicator
      *
      *
     E                    DI         80  1               param string
     E                    DO         80  1               param string
      *
     I            DS
      * Parameter strings as arrays
     I                                        1  80 DI
     I                                        1  80 DIF
     I            DS
     I                                        1  80 DO
     I                                        1  80 DOF
     I            DS
     I                                        1   1 DQ1CH
     I                                        2   2 DQ2CH
     I                                        1   10DQ1
     I                                        1   20DQ2
     I                                        1  12 DQF
     I                                        3  12 TESTIN
      *
     I            DS
      * Default string for testing for break points:
     I I            ' ,;-()/\!?'              1  10 TESTDF
      * Parameter declarations
     I            DS
      * I :  Code trans directions    1
     I                                        1   1 P1CDTT
      * I :  Code table reference    10
     I                                        2  11 P2TABL
      * B :  Code in standard form   80
     I                                       12  91 P3CDST
      * B :  Code qualifier data     80
     I                                       92 171 P4CDQD
      * B :  Code in local form      80
     I                                      172 251 P5CDLC
      *
      /EJECT
      *****************************************************************
      * Entry parameters
     C           *ENTRY    PLIST
     C                     PARM           P0RTN   7
     C           P1CDTT    PARM           WP0001  1        Code trans dire
     C           P2TABL    PARM           WP0002 10        Code table refe
     C           P3CDST    PARM P3CDST    WP0003 80        Code in standar
     C           P4CDQD    PARM P4CDQD    WP0004 80        Code qualifier
     C           P5CDLC    PARM P5CDLC    WP0005 80        Code in local f
      *****************************************************************
      *
      * Reset output to blanks
     C                     MOVE *BLANKS   P5CDLC
      * CASE: PAR.Code trans directions is Inward translation
     C           P1CDTT    IFEQ 'I'
      *
      * The qualifier specifies what kind of parsing is to be done.
      * It should be a left-justified one- or two-digit number on the
      * first call for a given input string, and blanks for each repeat
      * call for the same input string.
      *
      * On the first call:
      *  Initialize the "desired output length" to the qualifier value.
      *  Save the input string & (if specified) the "break" characters.
      *  Return the characters starting in position 1 up to the maximum
      *  length possible within the "desired output length" without
      *  breaking up words.
      * On the repeat calls:
      *  Use the saved value of the "desired output length", and the
      *  saved position where the last output string ended.
      *  Return the characters starting from the last ending position +1
      *  up to the "desired output length" without breaking up words.
      *
      * Check qualifier value:
     C                     MOVELP4CDQD    DQF
     C           DQ1CH     IFGE '0'
      * Numeric qualifier - re-initialize for new input string
     C                     Z-ADD1         IS      30       start position
      * Use Code in standard form as input
     C                     MOVELP3CDST    DIF
      * Use qual characters 3-12 as test characters, use defaults if blank
     C           TESTIN    IFNE *BLANK
     C                     MOVELTESTIN    TEST   10        use qual input
     C                     ELSE
     C                     MOVELTESTDF    TEST             use defaults
     C                     END
      *
      * Convert 1 or 2-digit string to ID = "desired output length"
     C           DQ2CH     IFGE '0'
     C                     Z-ADDDQ2       ID      30       if 2-digit
     C                     ELSE
     C                     Z-ADDDQ1       ID               if 1-digit
     C                     END
     C           ID        IFLT 1                          limit to min=1
     C                     Z-ADD1         ID
     C                     END
     C           ID        IFGT 80                         limit to max=80
     C                     Z-ADD80        ID
     C                     END
      *
      * End of initialization on new string:
     C                     END
      * Initialize output work variable:
     C                     MOVE *BLANKS   DOF
      * Skip with no error if start position IS is > 80 (past end)
      * (It will be >80 if called after entire string has been parsed)
     C           IS        IFGT 80                         skip
      * A "Return code" of blank means there is no error
     C                     MOVEL*BLANK    P0RTN            *Return code
     C                     ELSE
      *
      * Find desired end position:
     C           IS        ADD  ID        IE      30       end position +1
     C                     SUB  1         IE               end position
      * Save original length:
     C                     Z-ADDID        IL      30       actual length
      * Adjust if over limit:
     C           IE        IFGE 80                         limit to max=80
     C                     Z-ADD80        IE
     C           IE        SUB  IS        IL               length -1
     C                     ADD  1         IL               length
     C                     END
      * Save original end point:
     C                     Z-ADDIE        IE1     30
      *
      * Get substring from IS through IE constrained by word
      * breaks, if possible. (If not possible, just break words.)
     C           IS        IFGT 0                          skip
     C           IL        ANDGT0                          pathological
     C           IE        ANDGEIS                         cases...
      * Determine last blank character position (or other breakpoint):
     C                     MOVELDI,IE     DIIE    1        (performance)
      * The CHECK will set NOT to 1 if DIEE is NOT found in TEST:
     C           TEST      CHECKDIIE      NOT     10
      * (NOT will be zero if the character IS in TEST)
     C           IE        DOWGEIS
     C           NOT       ANDNE0
     C                     SUB  1         IE
     C                     SUB  1         IL
     C           IE        IFGE 1
     C                     MOVELDI,IE     DIIE
     C           TEST      CHECKDIIE      NOT
     C                     END
     C                     END
      * Check whether a breakpoint was found:
     C           IE        IFLT IS
      * If no breaks found, cannot break. Use original ID (br eak words):
     C                     Z-ADDID        IL               actual length
     C                     Z-ADDIE1       IE               actual end
     C                     ELSE
      * Otherwise, break before '('; break on others:
     C           DI,IE     IFEQ '('
     C           IE        ANDGTIS
     C                     SUB  1         IE
     C                     SUB  1         IL
     C                     END
      *
     C                     END
      * Extract substring of length IL starting at IS:
     C           IL        SUBSTDIF:IS    DOF       P
      * A "Return code" of blank means there is no error
     C                     MOVEL*BLANK    P0RTN            *Return code
      * Set up for next call - end point + 1 => next start point
     C           IE        ADD  1         IS
      *
     C                     ELSE
      * If here, "pathological" case (probably invalid qualifier constant)
      * A "Return code" of non-blank will be logged as a translation error:
     C                     MOVEL'PARSER'  P0RTN            *Return code
     C                     END
      *
     C                     END
      * Move to output parm:
     C                     MOVELDOF       P5CDLC
      *
     C                     ELSE
      * CASE: PAR.Code trans directions is Outward translation
     C           P1CDTT    IFEQ 'O'
      * (not intended for outward; just pass local to standard...)
     C                     MOVELP5CDLC    P3CDST
      * A "Return code" of blank means there is no error
     C                     MOVEL*BLANK    P0RTN            *Return code
     C                     END
      *
     C                     END
      *
      * Exit program - leave active (*INLR is off)
     C                     RETRN



By: on