*H**ANAT510120021202129067 WNT-X86                          1CANG       
*C**                                NATGREP ELEMENTS                        P S     
*D01NAT5101P NATGREP ELEMENTS                        ADMINIST                R      
*D02            2002112319100002002112319100000000000564    
*D03WNT-X86 
*D04        
*S****DS          0         1ELEMENTS           
*S****DK          0   I   4 2ELEMENT-CT         
*S****DS I1       0         2ELEMENT                         (1:250)    
*S****DK          0   L     3IS-ANY 
*S****DK          0   L     3NEGATED
*S****DK          0   L     3IS-RANGE           
*S****DK          0   L     3TERMINAL           
*S****DK          0   L     3IS-OPTIONAL        
*S****DK          0   L     3ITEM-CLOSED        
*S****DK          0   I   4 3GROUPL 
*S****DK          0   A  64 3MULTI  
*S****DR          0        R3MULTI                           /* BEGIN REDEFINE: MULTI           
*S****DFRI1       0   A   1 4MULTI-CH                        (1:64)     
*C**                                NATGREP GREPTST1                        F S     
*D01NAT5101F NATGREP GREPTST1                        ADMINIST                S      
*D02            2002120200070002002120200070000000003803    
*D03WNT-X86 
*D04        
*S***********************************************************************           
*S*** Program to test NATGREP       
*S*** Adrian Carter     
*S*** Email: Adrianbc@bigpond.com   
*S***       
*S*** The initial value of #PATTERN is hardwired to a regular           
*S*** expression that means "3 consecutive capitalized words separated  
*S*** by spaces". If you just run the program without making any        
*S*** modifications, it should return "Captain James Cook". 
*S*** If you change the first "[A-Z]" to "[D-Z]", the result should     
*S*** be "South Gippsland Highway". 
*S***       
*S*** Other patterns to try         
*S*** =======================       
*S*** "([a-z; - ]*)"    should return "(adapted to a dry climate)"      
*S*** "[a-z][a-z]* [0-9]* [a-z][a-z]*" should return "of 14 miles"      
*S*** "[0-9][0-9]*[a-z;\--\-][a-z;\--\-]*" should return "80-mile"      
*S***********************************************************************           
*S**DEFINE DATA LOCAL USING METACHAR
*S**LOCAL   
*S**01 #PATTERN    (A50)  INIT <'[A-Z][a-z]* [A-Z][a-z]* [A-Z][a-z]*'>  
*S**01 REDEFINE #PATTERN
*S**  02 #PATTERN-CH  (A1/50)       
*S**01 #TEXT       (A60/19) INIT <  
*S**'Wilson"s Promontory: Southernmost point of the Australian ma',     
*S**'inland, in Victoria, 110 miles (177 km) southeast of Melbour',     
*S**'ne. A granite peninsula, 22 miles long with a maximum width ',     
*S**'of 14 miles, it projects into Bass Strait and is almost an i',     
*S**'sland, being linked to the mainland by beach ridges. From a ',     
*S**'spectacular scenic 80-mile coastline, it rises to a mountain',     
*S**'ous interior; its highest point is Mount Latrobe, at 2,475 f',     
*S**'eet (754 m). There is a lighthouse at its southern tip. The ',     
*S**'vegetative cover, which tends toward the xerophytic (adapted',     
*S**' to a dry climate) on the west, is periodically swept by fir',     
*S**'es. Visited in 1798 by the English explorer George Bass, the',     
*S**' promontory was first called Furneaux Land, after a member o',     
*S**'f Captain James Cook"s second (1772) expedition. It was rena',     
*S**'med for Thomas Wilson, an English merchant. In 1905 the enti',     
*S**'re promontory was made a national park. It is notable for it',     
*S**'s beaches, fern gullies, more than 700 species of plants, an',     
*S**'d a variety of animals, including emus, koalas, and wombats.',     
*S**' Tourist access is gained with some difficulty via the South',     
*S**' Gippsland Highway.'>          
*S**01 REDEFINE #TEXT   
*S**  02 #TEXT-CH     (A1/1140)     
*S**01 #RESULT        (A75/3)       
*S**01 REDEFINE #RESULT 
*S**  02 #RESULT-CH   (A1/225)      
*S**01 #TO    (I4)      
*S**01 #LAST  (I4)      
*S*** NATGREP parameters
*S**01 #PAT-CT    (I4)  
*S**01 #TEXT-CT   (I4)  
*S**01 #INDEX     (I4)  
*S**01 #DISP-L    (I4)  
*S**01 #LENGTH    (I4)  
*S**01 #ERROR     (P2)  
*S**INDEPENDENT         
*S**01 +MAX-LEVEL   (P2)
*S**END-DEFINE          
*S**SET CONTROL 'L'     
*S***       
*S**SET KEY PF3=PGM     
*S**MOVE '^\~*?[-];' TO METACHARS   
*S**REPEAT  
*S**  #INDEX := 0       
*S**  #LENGTH := 0      
*S**  +MAX-LEVEL := 0   
*S**  RESET #RESULT(*)  
*S**  INPUT (IP=OFF) *OUTIN #TEXT(*)
*S**    // 'Metachars:' *OUT METACHARS          
*S**    '(Any, Esc, Not, Closure, Opt, [-], Union)'         
*S**    // 'Search for:' *OUTIN #PATTERN        
*S**  IF *PF-KEY = 'PF3'
*S**    ESCAPE BOTTOM   
*S**  END-IF
*S**  #LAST := *OCCURRENCE(#TEXT)   
*S**  REPEAT WHILE #TEXT(#LAST) = ' '           
*S**    #LAST := #LAST - 1          
*S**    IF #LAST = 0    
*S**      ESCAPE BOTTOM 
*S**    END-IF          
*S**  END-REPEAT        
*S**  IF #LAST = 0      
*S**    ESCAPE TOP      
*S**  END-IF
*S**  EXAMINE #PATTERN FOR #PATTERN GIVING LENGTH #PAT-CT   
*S**  IF #PAT-CT = 0    
*S**    ESCAPE TOP      
*S**  END-IF
*S**  EXAMINE #TEXT(#LAST) FOR ' ' GIVING LENGTH #TEXT-CT   
*S**  #TEXT-CT := #TEXT-CT + (#LAST - 1) * 60   
*S**  CALLNAT 'NATGREP' METACHAR #PATTERN-CH(*) #PAT-CT     
*S**    #TEXT-CH(*) #TEXT-CT #INDEX #LENGTH #ERROR          
*S**  IF #INDEX = 0     
*S**    PRINT '=' #INDEX '=' #LENGTH '=' #ERROR 
*S**    ESCAPE TOP      
*S**  END-IF
*S**  IF #LENGTH < 226  
*S**    #DISP-L := #LENGTH          
*S**   ELSE 
*S**     #DISP-L := 225 
*S**   END-IF           
*S**  #TO := #INDEX + #DISP-L - 1   
*S**  MOVE #TEXT-CH(#INDEX:#TO) TO #RESULT-CH(1:#DISP-L)    
*S**  INPUT (IP=OFF) *OUT #TEXT(*)  
*S**    / 'Index' *OUT #INDEX 'Length' *OUT #LENGTH         
*S**      'Max level' *OUT +MAX-LEVEL           
*S**    / *OUT #RESULT(*)           
*S**END-REPEAT          
*S**END     
*C**                                NATGREP METACHAR                        P S     
*D01NAT5101P NATGREP METACHAR                        ADMINIST                R      
*D02            2002110722270002002110722270000000000496    
*D03WNT-X86 
*D04        
*S****DS          0         1METACHAR           
*S****DK          0   A   9 2METACHARS          
*S****DR          0        R2METACHARS                       /* BEGIN REDEFINE: METACHARS       
*S****DFR         0   A   1 3ANY-ITEM           
*S****DFR         0   A   1 3ESCAPE-ITEM        
*S****DFR         0   A   1 3NOT-ITEM           
*S****DFR         0   A   1 3CLOSURE-ITEM       
*S****DFR         0   A   1 3OPTIONAL-ITEM      
*S****DFR         0   A   1 3START-CLASS        
*S****DFR         0   A   1 3RANGE-DELIM        
*S****DFR         0   A   1 3STOP-CLASS         
*S****DFR         0   A   1 3RANGE-UNION        
*C**                                NATGREP NATGREP                         N S     
*D01NAT5101N NATGREP NATGREP                         ADMINIST                S      
*D02            2002120200170002002120200170000000001342    
*D03WNT-X86 
*D04        
*S********************************************************* 
*S***  Subprogram: NATGREP          
*S***  Regular Expression Matching  
*S***  Port of code from ADA to NATURAL, with extensions.   
*S***       
*S***  ADA code found in
*S***  "Software Components With Ada" by Grady Booch        
*S***  Benjamin/Cummings Publishing Company  1987           
*S***       
*S***  Adrian Carter,  November 2002
*S***  Email: Adrianbc@bigpond.com  
*S***       
*S********************************************************* 
*S**DEFINE DATA         
*S**PARAMETER USING METACHAR        
*S**PARAMETER           
*S**01 THE-PATTERN   (A1/1:V)       
*S**01 PATTERN-CT    (I4)           
*S**01 IN-THE-ITEMS  (A1/1:V)       
*S**01 ITEM-CT       (I4)           
*S**01 #INDEX        (I4)           
*S**01 #LENGTH       (I4)           
*S**01 ERROR-CODE    (P2)           
*S**LOCAL USING ELEMENTS
*S**LOCAL   
*S**01 #I            (I4)           
*S**01 #J            (I4)           
*S**01 #L            (I4)           
*S**01 #1            (I4)   INIT <1>
*S**01 #POS          (I4)           
*S**01 #INDX         (I4)           
*S**END-DEFINE          
*S****      
*S**IF PATTERN-CT = 0 OR PATTERN-CT > *OCCURRENCE(THE-PATTERN)          
*S**  ERROR-CODE := -80 
*S**  ESCAPE ROUTINE    
*S**END-IF  
*S***       
*S*** Do setup          
*S**CALLNAT 'SETGREP' METACHAR ELEMENTS         
*S**  THE-PATTERN(*) PATTERN-CT ERROR-CODE      
*S**IF ERROR-CODE NE 0  
*S**  ESCAPE ROUTINE    
*S**END-IF  
*S***       
*S*** Start recursive match at top level        
*S**FOR #INDX = 1 TO ITEM-CT        
*S**  CALLNAT 'RECURSOR' ELEMENTS #1 IN-THE-ITEMS(*)        
*S**    ITEM-CT #INDX #POS #L       
*S**  IF #POS > 0       /*  success 
*S**    #INDEX := #POS  
*S**    #LENGTH := #L   
*S**    ESCAPE ROUTINE  
*S**  END-IF
*S**END-FOR 
*S***       
*S**END     
*S**        
*C**                                NATGREP RECURSOR                        N S     
*D01NAT5101N NATGREP RECURSOR                        ADMINIST                S      
*D02            2002120200130002002120200130000000004039    
*D03WNT-X86 
*D04        
*S********************************************************* 
*S***  Subprogram: RECURSOR         
*S***  Match a string of characters, starting from a        
*S***  given index, against the internal representation     
*S***  of the pattern.  
*S***  Port of code from ADA to NATURAL, with extensions.   
*S***       
*S***  ADA code found in
*S***  "Software Components With Ada" by Grady Booch        
*S***  Benjamin/Cummings Publishing Company  1987           
*S***       
*S***  Adrian Carter,  November 2002
*S***  Email: Adrianbc@bigpond.com  
*S***       
*S********************************************************* 
*S**DEFINE DATA         
*S**PARAMETER USING ELEMENTS        
*S**PARAMETER           
*S**01 EL-START      (I4)     /* starting at this element   
*S**01 IN-THE-ITEMS  (A1/1:V)       
*S**01 ITEM-CT       (I4)           
*S**01 #START        (I4)     /* starting at this item      
*S**01 #POS          (I4)     /* returns nonzero here if successful     
*S**01 #LENGTH       (I4)     /* returns length of matched text         
*S***       
*S**LOCAL   
*S**01 #I               (I4)        
*S**01 #I1              (I4)        
*S**01 #OK              (L)         
*S**01 #FOUND           (L)         
*S**01 #INDEX           (I4)        
*S**01 #JNDEX           (I4)        
*S**01 #TEMP-POS        (I4)        
*S**01 #TEMP-LOCN       (I4)        
*S**01 #TEMP-INDEX      (I4)        
*S**01 #TEMP-LENGTH     (I4)        
*S**01 #TOTAL-CLOSURES  (I4)        
*S**INDEPENDENT         
*S**01 +MAX-LEVEL    (P2) /* just for reporting max recursion depth     
*S**END-DEFINE          
*S***       
*S**IF *LEVEL > +MAX-LEVEL          
*S**  +MAX-LEVEL := *LEVEL          
*S**END-IF  
*S***       
*S**#POS := 0           
*S**#INDEX := #START    
*S**FOR #I = EL-START TO ELEMENT-CT 
*S**  IF TERMINAL(#I)       /* Last element, search succeeded           
*S**    #POS := #START  
*S**    #LENGTH := #INDEX - #START  
*S**    ESCAPE ROUTINE  
*S**  END-IF
*S***       
*S**  IF ITEM-CLOSED(#I)
*S**    RESET #TOTAL-CLOSURES       
*S**    /* #TOTAL-CLOSURES is the number of items that match
*S**    /* element(#I)  
*S**    FOR #JNDEX = #INDEX TO ITEM-CT          
*S**      /* Check all remaining items against element #I   
*S**      /* until failure or end of items      
*S**      CALLNAT 'TESTCHAR' ELEMENTS #I IN-THE-ITEMS(#JNDEX) #OK       
*S**      IF #OK        
*S**        #TOTAL-CLOSURES := #TOTAL-CLOSURES + 1          
*S**      ELSE          
*S**        ESCAPE BOTTOM           
*S**      END-IF        
*S**    END-FOR         
*S**    /* If TOTAL-CLOSURES > 0, we now attempt to match the           
*S**    /* remaining items with the remainder of the pattern.           
*S**    /* We do this recursively, because the remainder of the         
*S**    /* pattern may itself contain closures. 
*S**    /* However, failure to attain the above match does not          
*S**    /* necessarily imply that the whole process has failed.         
*S**    /* Maybe not everything that matched in the closure 
*S**    /* should have been included there. To address this 
*S**    /* possibility, we back up by progressively removing
*S**    /* matched items from the closure, to give the elements         
*S**    /* that follow the closure a chance.    
*S**    #I1 := #I + 1   
*S**    REPEAT WHILE #TOTAL-CLOSURES > 0        
*S**      #TEMP-INDEX := #INDEX + #TOTAL-CLOSURES           
*S**      CALLNAT 'RECURSOR' ELEMENTS #I1 IN-THE-ITEMS(*) ITEM-CT       
*S**        #TEMP-INDEX #TEMP-POS #TEMP-LENGTH  
*S**      IF #TEMP-POS > 0          
*S**        /* Success! Update index, and continue with next
*S**        /* iteration of outer loop.         
*S**        #INDEX := #TEMP-INDEX   
*S**        ESCAPE BOTTOM           
*S**      ELSE          
*S**        /* Failure. Try the recursive match again, this time        
*S**        /* backing up with one less item.   
*S**        #TOTAL-CLOSURES := #TOTAL-CLOSURES - 1          
*S**      END-IF        
*S**    END-REPEAT      
*S**  ELSE  /* not ITEM-CLOSED(#I)  
*S**    IF #INDEX > ITEM-CT         
*S**      ESCAPE ROUTINE      /*   failure      
*S**    END-IF          
*S**    CALLNAT 'TESTCHAR' ELEMENTS #I IN-THE-ITEMS(#INDEX) #FOUND      
*S**    IF #FOUND       
*S**      IF IS-OPTIONAL(#I) /* "mini-closure", ie max 1 char allowed   
*S**        #I1 := #I + 1           
*S**        #TEMP-INDEX := #INDEX + 1           
*S**        /* No loop needed here, because "#TOTAL-CLOSURES" is only 1.
*S**        CALLNAT 'RECURSOR' ELEMENTS #I1 IN-THE-ITEMS(*) ITEM-CT     
*S**          #TEMP-INDEX #TEMP-POS #TEMP-LENGTH
*S**        IF #TEMP-POS > 0        
*S**          /* Success! Continue with main loop.          
*S**          #INDEX := #TEMP-INDEX 
*S**        END-IF      
*S**      ELSE          
*S**        #INDEX := #INDEX + 1    
*S**        IF #INDEX > ITEM-CT     
*S**          ESCAPE ROUTINE     /*   failure   
*S**        END-IF      
*S**      END-IF        
*S**    ELSE
*S**      IF NOT IS-OPTIONAL(#I)    
*S**        ESCAPE ROUTINE      /*   failure    
*S**      END-IF        
*S**    END-IF          
*S**  END-IF
*S***       
*S**END-FOR 
*S***       
*S**END     
*C**                                NATGREP SETGREP                         N S     
*D01NAT5101N NATGREP SETGREP                         ADMINIST                S      
*D02            2002112322520002002112322520000000011360    
*D03WNT-X86 
*D04        
*S********************************************************* 
*S***  Subprogram: SETGREP          
*S***  Setup internal representation of pattern for         
*S***  regular expression matching. 
*S***  Port of code from ADA to NATURAL, with extensions.   
*S***       
*S***  ADA code found in
*S***  "Software Components With Ada" by Grady Booch        
*S***  Benjamin/Cummings Publishing Company  1987           
*S***       
*S***  Adrian Carter,  November 2002
*S***  Email: Adrianbc@bigpond.com  
*S***       
*S********************************************************* 
*S**DEFINE DATA         
*S**PARAMETER USING METACHAR        
*S**PARAMETER USING ELEMENTS        
*S**PARAMETER           
*S**01 THE-PATTERN   (A1/1:V)       
*S**01 PATTERN-CT    (I4)           
*S**01 ERROR-CODE    (P2)           
*S**LOCAL   
*S**01 #I            (I4)           
*S****  All the possible #STATE values          
*S**01 #BUILDING-PATTERN        (I1)  CONST <1> 
*S**01 #BUILDING-CLASS          (I1)  CONST <2> 
*S**01 #BUILDING-ESCAPE-PATTERN (I1)  CONST <3> 
*S**01 #BUILDING-ESCAPE-CLASS   (I1)  CONST <4> 
*S**01 #BUILDING-RANGE-CLASS    (I1)  CONST <5> 
*S**01 #BUILDING-ESCAPE-RANGE   (I1)  CONST <6> 
*S**        
*S***       
*S**01 #LIMIT       (I4)  INIT <*OCCURRENCE(MULTI)>         
*S**01 #STATE       (I1)  INIT <1>  /* INIT #BUILDING-PATTERN           
*S**01 #PREV-CT     (I4)  INIT <0>  
*S**01 #PAT-ENTRY   (A1)
*S**01 #PREV-CHAR   (A1)
*S**01 #MULTI       (A250)          
*S**01 REDEFINE #MULTI  
*S**  02 #MULTI-CH (A1/250)         
*S**01 #GROUPL      (I4)    /*   Current class length       
*S**01 #PARITY      (I4)    /*   For checking unions of ranges          
*S**01 #MAX-GROUPL  (I4)  INIT <*OCCURRENCE(ELEMENTS.MULTI-CH,2)>       
*S**END-DEFINE          
*S****      
*S**IF PATTERN-CT = 0 OR PATTERN-CT > *OCCURRENCE(THE-PATTERN)          
*S**  ERROR-CODE := -1  
*S**  ESCAPE ROUTINE    
*S**END-IF  
*S**        
*S**ELEMENT-CT := 1     
*S**ASSIGN NEGATED(1) = FALSE       
*S**REPEAT WHILE #I < PATTERN-CT    
*S**  #I := #I + 1      
*S**  MOVE THE-PATTERN(#I) TO #PAT-ENTRY        
*S**  DECIDE ON FIRST VALUE OF #STATE           
*S**    VALUE #BUILDING-PATTERN     
*S**      DECIDE ON FIRST VALUE OF #PAT-ENTRY   
*S**        VALUE ANY-ITEM          
*S**          IF NEGATED(ELEMENT-CT)
*S**            ERROR-CODE := -2    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          GROUPL(ELEMENT-CT) := 0           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = TRUE  
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**          #PREV-CT := ELEMENT-CT
*S**          ELEMENT-CT := ELEMENT-CT + 1      
*S**          GROUPL(ELEMENT-CT) := 0           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = FALSE 
*S**          ASSIGN NEGATED(ELEMENT-CT) = FALSE
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**        VALUE ESCAPE-ITEM       
*S**          #STATE := #BUILDING-ESCAPE-PATTERN
*S**        VALUE NOT-ITEM          
*S**          IF NEGATED(ELEMENT-CT)
*S**            ERROR-CODE := -3    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          ASSIGN NEGATED(ELEMENT-CT) = TRUE 
*S**        VALUE CLOSURE-ITEM      
*S**          IF #PREV-CT = 0       
*S**            ERROR-CODE := -4    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          IF IS-OPTIONAL(#PREV-CT) OR ITEM-CLOSED(#PREV-CT)         
*S**            ERROR-CODE := -5    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          ASSIGN ITEM-CLOSED(#PREV-CT) = TRUE           
*S**        VALUE OPTIONAL-ITEM     
*S**          IF #PREV-CT = 0       
*S**            ERROR-CODE := -6    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          IF IS-OPTIONAL(#PREV-CT) OR ITEM-CLOSED(#PREV-CT)         
*S**            ERROR-CODE := -7    
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          ASSIGN IS-OPTIONAL(#PREV-CT) = TRUE           
*S**        VALUE START-CLASS       
*S**          GROUPL(ELEMENT-CT) := 0           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = FALSE 
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**          #PREV-CT := ELEMENT-CT
*S**          ELEMENT-CT := ELEMENT-CT + 1      
*S**          #STATE := #BUILDING-CLASS         
*S**          #GROUPL:= 0           
*S**          RESET #MULTI          
*S**          GROUPL(ELEMENT-CT) := 0           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = FALSE 
*S**          ASSIGN NEGATED(ELEMENT-CT) = FALSE
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**        VALUE STOP-CLASS        
*S**          ERROR-CODE := -8      
*S**          ESCAPE ROUTINE        
*S**        NONE VALUES 
*S**          /* RANGE-DELIM and RANGE-UNION are ordinary characters, if
*S**          /* not enclosed between a START-CLASS and a STOP-CLASS.   
*S**          GROUPL(ELEMENT-CT) := 1           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = FALSE 
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**          MOVE #PAT-ENTRY TO MULTI(ELEMENT-CT)          
*S**          #PREV-CT := ELEMENT-CT
*S**          ELEMENT-CT := ELEMENT-CT + 1      
*S**          GROUPL(ELEMENT-CT) := 0           
*S**          ASSIGN IS-ANY(ELEMENT-CT) = FALSE 
*S**          ASSIGN NEGATED(ELEMENT-CT) = FALSE
*S**          ASSIGN IS-RANGE(ELEMENT-CT) = FALSE           
*S**          ASSIGN TERMINAL(ELEMENT-CT) = FALSE           
*S**          ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE        
*S**          ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE        
*S**      END-DECIDE    
*S**    VALUE #BUILDING-CLASS       
*S**      DECIDE ON FIRST VALUE OF #PAT-ENTRY   
*S**        VALUE ANY-ITEM          
*S**          ERROR-CODE := -9      
*S**          ESCAPE ROUTINE        
*S**        VALUE ESCAPE-ITEM       
*S**          #STATE := #BUILDING-ESCAPE-CLASS  
*S**        VALUE NOT-ITEM          
*S**          ERROR-CODE := -10     
*S**          ESCAPE ROUTINE        
*S**        VALUE CLOSURE-ITEM      
*S**          ERROR-CODE := -11     
*S**          ESCAPE ROUTINE        
*S**        VALUE OPTIONAL-ITEM     
*S**          ERROR-CODE := -12     
*S**          ESCAPE ROUTINE        
*S**        VALUE START-CLASS       
*S**          ERROR-CODE := -13     
*S**          ESCAPE ROUTINE        
*S**        VALUE RANGE-DELIM       
*S**          IF #GROUPL NE 1       
*S**            ERROR-CODE := -14   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          MOVE RANGE-DELIM TO #PREV-CHAR    
*S**          #STATE := #BUILDING-RANGE-CLASS   
*S**        VALUE STOP-CLASS        
*S**          IF #GROUPL = 0        
*S**            ERROR-CODE := -15   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          GROUPL(#PREV-CT) := #GROUPL       
*S**          MOVE #MULTI TO MULTI(#PREV-CT)    
*S**          RESET #MULTI #GROUPL  
*S**          #STATE := #BUILDING-PATTERN       
*S**        VALUE RANGE-UNION       
*S**          ERROR-CODE := -16     
*S**          ESCAPE ROUTINE        
*S**        NONE VALUES 
*S**          #GROUPL := #GROUPL + 1
*S**          IF #GROUPL > #MAX-GROUPL          
*S**            ERROR-CODE := -17   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          MOVE #PAT-ENTRY TO #MULTI-CH(#GROUPL)         
*S**      END-DECIDE    
*S**    VALUE #BUILDING-ESCAPE-PATTERN          
*S**      GROUPL(ELEMENT-CT) := 1   
*S**      ASSIGN IS-ANY(ELEMENT-CT) = FALSE     
*S**      ASSIGN IS-RANGE(ELEMENT-CT) = FALSE   
*S**      ASSIGN TERMINAL(ELEMENT-CT) = FALSE   
*S**      ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE
*S**      ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE
*S**      MOVE #PAT-ENTRY TO MULTI(ELEMENT-CT)  
*S**      #PREV-CT := ELEMENT-CT    
*S**      ELEMENT-CT := ELEMENT-CT + 1          
*S**      #STATE := #BUILDING-PATTERN           
*S**      GROUPL(ELEMENT-CT) := 0   
*S**      ASSIGN IS-ANY(ELEMENT-CT) = FALSE     
*S**      ASSIGN NEGATED(ELEMENT-CT) = FALSE    
*S**      ASSIGN IS-RANGE(ELEMENT-CT) = FALSE   
*S**      ASSIGN TERMINAL(ELEMENT-CT) = FALSE   
*S**      ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE
*S**      ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE
*S**    VALUE #BUILDING-ESCAPE-CLASS
*S**      #GROUPL := #GROUPL + 1    
*S**      IF #GROUPL > #MAX-GROUPL  
*S**        ERROR-CODE := -18       
*S**        ESCAPE ROUTINE          
*S**      END-IF        
*S**      MOVE #PAT-ENTRY TO #MULTI-CH(#GROUPL) 
*S**      #STATE := #BUILDING-CLASS 
*S**    VALUE #BUILDING-RANGE-CLASS 
*S**      DECIDE ON FIRST VALUE OF #PAT-ENTRY   
*S**        VALUE ANY-ITEM          
*S**          ERROR-CODE := -19     
*S**          ESCAPE ROUTINE        
*S**        VALUE NOT-ITEM          
*S**          ERROR-CODE := -20     
*S**          ESCAPE ROUTINE        
*S**        VALUE CLOSURE-ITEM      
*S**          ERROR-CODE := -21     
*S**          ESCAPE ROUTINE        
*S**        VALUE OPTIONAL-ITEM     
*S**          ERROR-CODE := -22     
*S**          ESCAPE ROUTINE        
*S**        VALUE START-CLASS       
*S**          ERROR-CODE := -23     
*S**          ESCAPE ROUTINE        
*S**        VALUE RANGE-DELIM       
*S**          IF #PREV-CHAR = RANGE-DELIM OR= RANGE-UNION   
*S**            ERROR-CODE := -24   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          MOVE RANGE-DELIM TO #PREV-CHAR    
*S**        VALUE STOP-CLASS        
*S**          /* Must be even number of characters          
*S**          /* If 2, single range 
*S**          /* If more than 2, union of ranges
*S**          COMPUTE #PARITY = #GROUPL - (#GROUPL / 2)*2   
*S**          IF #PARITY = 1        
*S**            ERROR-CODE := -25   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          GROUPL(#PREV-CT) := #GROUPL       
*S**          MOVE #MULTI TO MULTI(#PREV-CT)    
*S**          RESET #MULTI #GROUPL  
*S**          ASSIGN IS-RANGE(#PREV-CT) = TRUE  
*S**          #STATE := #BUILDING-PATTERN       
*S**        VALUE ESCAPE-ITEM       
*S**          #STATE := #BUILDING-ESCAPE-RANGE  
*S**        VALUE RANGE-UNION       
*S**          IF #PREV-CHAR = RANGE-DELIM OR= RANGE-UNION   
*S**            ERROR-CODE := -26   
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          MOVE RANGE-UNION TO #PREV-CHAR    
*S**        NONE VALUES 
*S**          COMPUTE #PARITY = #GROUPL - (#GROUPL / 2)*2   
*S**          DECIDE ON FIRST VALUE OF #PREV-CHAR           
*S**            VALUE RANGE-DELIM   
*S**              IF #PARITY = 0    
*S**                ERROR-CODE := -27  /* RANGE-DELIM in wrong place    
*S**                ESCAPE ROUTINE  
*S**              END-IF
*S**              IF #PAT-ENTRY < #MULTI-CH(#GROUPL)        
*S**                ERROR-CODE := -28  /* End of range less than beginning          
*S**                ESCAPE ROUTINE  
*S**              END-IF
*S**            VALUE RANGE-UNION   
*S**              IF #PARITY = 1    
*S**                ERROR-CODE := -29  /* RANGE-UNION in wrong place    
*S**                ESCAPE ROUTINE  
*S**              END-IF
*S**            NONE VALUES         
*S**              ERROR-CODE := -30   /* Prev entry MUST= DELIM or UNION
*S**              ESCAPE ROUTINE    
*S**          END-DECIDE
*S**          #GROUPL := #GROUPL + 1
*S**          MOVE #PAT-ENTRY TO #PREV-CHAR #MULTI-CH(#GROUPL)          
*S**      END-DECIDE    
*S**    VALUE #BUILDING-ESCAPE-RANGE
*S**      COMPUTE #PARITY = #GROUPL - (#GROUPL / 2)*2       
*S**      DECIDE ON FIRST VALUE OF #PREV-CHAR   
*S**        VALUE RANGE-DELIM       
*S**          IF #PARITY = 0        
*S**            ERROR-CODE := -31  /* RANGE-DELIM in wrong place        
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**          IF #PAT-ENTRY < #MULTI-CH(#GROUPL)
*S**            ERROR-CODE := -32  /* End of range less than beginning  
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**        VALUE RANGE-UNION       
*S**          IF #PARITY = 1        
*S**            ERROR-CODE := -33  /* RANGE-UNION in wrong place        
*S**            ESCAPE ROUTINE      
*S**          END-IF    
*S**        NONE VALUES 
*S**          ERROR-CODE := -34   /* Prev entry MUST= DELIM or UNION    
*S**          ESCAPE ROUTINE        
*S**      END-DECIDE    
*S**      #GROUPL := #GROUPL + 1    
*S**      MOVE #PAT-ENTRY TO #MULTI-CH(#GROUPL) 
*S**      #STATE := #BUILDING-RANGE-CLASS       
*S**      RESET #PREV-CHAR /* #PAT-ENTRY maybe metachar, avoids problem 
*S**    NONE VALUES     
*S**      ERROR-CODE := -35         
*S**      ESCAPE ROUTINE
*S**  END-DECIDE        
*S***       
*S**  IF (ELEMENT-CT GE #LIMIT)     
*S**    ERROR-CODE := -41           
*S**  END-IF
*S***       
*S**END-REPEAT          
*S**        
*S*** Check if pattern has ended in an inconsistent state   
*S**IF #STATE NE #BUILDING-PATTERN  
*S**  ERROR-CODE := -42 
*S**  ESCAPE ROUTINE    
*S**END-IF  
*S**        
*S**IF NEGATED(ELEMENT-CT)          
*S**  ERROR-CODE := -43 
*S**  ESCAPE ROUTINE    
*S**END-IF  
*S**        
*S**ASSIGN TERMINAL(ELEMENT-CT) = TRUE          
*S**ASSIGN IS-OPTIONAL(ELEMENT-CT) = FALSE      
*S**ASSIGN ITEM-CLOSED(ELEMENT-CT) = FALSE      
*S**        
*S*** Return good result
*S**ERROR-CODE := 0     
*S**ESCAPE ROUTINE      
*S***       
*S**END     
*C**                                NATGREP TESTCHAR                        N S     
*D01NAT5101N NATGREP TESTCHAR                        ADMINIST                S      
*D02            2002112322500002002112322500000000001881    
*D03WNT-X86 
*D04        
*S********************************************************* 
*S***  Subprogram: TESTCHAR         
*S***  Match a single item against a single element of      
*S***  the internal representation of the pattern.          
*S***  Port of code from ADA to NATURAL, with extensions.   
*S***       
*S***  ADA code found in
*S***  "Software Components With Ada" by Grady Booch        
*S***  Benjamin/Cummings Publishing Company  1987           
*S***       
*S***  Adrian Carter,  November 2002
*S***  Email: Adrianbc@bigpond.com  
*S***       
*S********************************************************* 
*S**DEFINE DATA         
*S**PARAMETER USING ELEMENTS        
*S**PARAMETER           
*S**01 #INDEX  (I4)     
*S**01 ITEM    (A1)     
*S**01 MATCHES (L)      
*S**LOCAL   
*S**01 #GL     (I4)     
*S**01 #TO     (I4)     
*S**01 #FROM   (I4)     
*S**01 #AGREES (L)    INIT <FALSE>  
*S**END-DEFINE          
*S***       
*S**#GL := GROUPL(#INDEX)           
*S**DECIDE FOR FIRST CONDITION      
*S**    /* Test IS-ANY first. It cannot be negated, and     
*S**    /* is the only condition for which #GL can be zero. 
*S**  WHEN ELEMENTS.IS-ANY(#INDEX)  
*S**    ASSIGN MATCHES = TRUE       
*S**    ESCAPE ROUTINE  
*S**  WHEN ITEM = ' ' AND NOT ELEMENTS.IS-RANGE(#INDEX)     
*S**    IF ELEMENTS.MULTI-CH(#INDEX, 1:#GL) = ' '           
*S**      ASSIGN #AGREES = TRUE     
*S**    END-IF          
*S**  WHEN ELEMENTS.IS-RANGE(#INDEX)
*S**    #TO := 2        
*S**    #FROM := 1      
*S**    REPEAT WHILE #TO LE #GL     
*S**      IF (ITEM < ELEMENTS.MULTI-CH(#INDEX, #FROM))      
*S**          OR (ITEM > ELEMENTS.MULTI-CH(#INDEX, #TO))    
*S**        /* not in range         
*S**        #TO := #TO + 2          
*S**        #FROM := #FROM + 2      
*S**      ELSE          
*S**        /* in range 
*S**        ASSIGN #AGREES = TRUE   
*S**        ESCAPE BOTTOM           
*S**      END-IF        
*S**    END-REPEAT      
*S**  WHEN ELEMENTS.MULTI(#INDEX) = SCAN ITEM /* works for class & literal          
*S**    ASSIGN #AGREES = TRUE       
*S**  WHEN NONE         
*S**    IGNORE  /* #AGREES is already FALSE     
*S**END-DECIDE          
*S***       
*S**** This element might be negated; if so, we have to reverse         
*S**** the result.      
*S***       
*S**IF ELEMENTS.NEGATED(#INDEX)     
*S**  IF #AGREES        
*S**    ASSIGN MATCHES = FALSE      
*S**  ELSE  
*S**    ASSIGN MATCHES = TRUE       
*S**  END-IF
*S**ELSE    
*S**  ASSIGN MATCHES = #AGREES      
*S**END-IF  
*S***       
*S**END     
*E          
