Annotation of gforth/regexp-test.fs, revision 1.23

1.1       pazsan      1: \ regexp test
                      2: 
1.23    ! anton       3: \ Copyright (C) 2005,2007,2009,2010 Free Software Foundation, Inc.
1.2       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.3       anton       9: \ as published by the Free Software Foundation, either version 3
1.2       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.3       anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.2       anton      19: 
1.16      pazsan     20: : ?depth  depth IF  ." unbalanced: " .s clearstack cr  THEN ;
                     21: 
1.5       pazsan     22: charclass [bl-]   blanks +class '-' +char
                     23: charclass [0-9(]  '(' +char '0' '9' ..char
1.1       pazsan     24: 
                     25: : telnum ( addr u -- flag )
                     26:     (( {{ ` (  \( \d \d \d \) ` ) || \( \d \d \d \) }}  blanks c?
                     27:     \( \d \d \d \) [bl-] c?
                     28:     \( \d \d \d \d \) {{ \$ || -\d }} )) ;
                     29: 
                     30: : ?tel ( addr u -- ) telnum
1.5       pazsan     31:     IF  '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
1.1       pazsan     32:     ELSE \0 type ."  failed " THEN ;
                     33: 
1.16      pazsan     34: : ?tel-s ( addr u -- ) ?tel ."  should succeed" space cr ?depth ;
                     35: : ?tel-f ( addr u -- ) ?tel ."  should fail" space cr ?depth ;
1.1       pazsan     36: 
                     37: ." --- Telephone number match ---" cr
                     38: s" (123) 456-7890" ?tel-s
                     39: s" (123) 456-7890 " ?tel-s
                     40: s" (123)-456 7890" ?tel-f
                     41: s" (123) 456 789" ?tel-f
                     42: s" 123 456-7890" ?tel-s
                     43: s" 123 456-78909" ?tel-f
                     44: 
                     45: : telnum2 ( addr u -- flag )
                     46:     (( // {{ [0-9(] -c? || \^ }}
                     47:     {{ ` (  \( \d \d \d \) ` ) || \( \d \d \d \) }}  blanks c?
                     48:     \( \d \d \d \) [bl-] c?
                     49:     \( \d \d \d \d \) {{ \$ || -\d }} )) ;
                     50: 
                     51: : ?tel2 ( addr u -- ) telnum2
1.5       pazsan     52:     IF   '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
1.16      pazsan     53:     ELSE \0 type ."  failed " THEN  cr ?depth ;
1.1       pazsan     54: ." --- Telephone number search ---" cr
                     55: s" blabla (123) 456-7890" ?tel2
                     56: s" blabla (123) 456-7890 " ?tel2
                     57: s" blabla (123)-456 7890" ?tel2
                     58: s" blabla (123) 456 789" ?tel2
                     59: s" blabla 123 456-7890" ?tel2
                     60: s" blabla 123 456-78909" ?tel2
                     61: s" (123) 456-7890" ?tel2
                     62: s"  (123) 456-7890 " ?tel2
                     63: s" a (123)-456 7890" ?tel2
                     64: s" la (123) 456 789" ?tel2
                     65: s" bla 123 456-7890" ?tel2
                     66: s" abla 123 456-78909" ?tel2
                     67: 
                     68: ." --- Number extraction test ---" cr
                     69: 
1.5       pazsan     70: charclass [0-9,./:]  '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
1.1       pazsan     71: 
                     72: : ?num
                     73:     (( // \( {++ [0-9,./:] c? ++} \) ))
1.16      pazsan     74:     IF  \1 type  ELSE  \0 type ."  failed"  THEN   cr ?depth ;
1.1       pazsan     75: 
                     76: s" 1234" ?num
                     77: s" 12,345abc" ?num
                     78: s" foobar12/345:678.9abc" ?num
                     79: s" blafasel" ?num
                     80: 
                     81: ." --- String test --- " cr
                     82: 
                     83: : ?string
                     84:     (( // \( {{ =" foo" || =" bar" || =" test" }} \) ))
                     85:     IF  \1 type  cr THEN ;
                     86: s" dies ist ein test" ?string
                     87: s" foobar" ?string
                     88: s" baz bar foo" ?string
                     89: s" Hier kommt nichts vor" ?string
                     90: 
                     91: ." --- longer matches test --- " cr
                     92: 
                     93: : ?foos
                     94:     (( \( {** =" foo" **} \) ))
1.16      pazsan     95:     IF  \1 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
1.1       pazsan     96: 
                     97: : ?foobars
                     98:     (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) ))
1.16      pazsan     99:     IF  \1 type ',' emit \2 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
1.1       pazsan    100: 
                    101: : ?foos1
                    102:     (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
1.16      pazsan    103:     IF  \1 type ',' emit \2 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
1.1       pazsan    104: 
                    105: s" foobar" ?foos
                    106: s" foofoofoobar" ?foos
                    107: s" fofoofoofofooofoobarbar" ?foos
                    108: s" bla baz bar" ?foos
                    109: s" foofoofoo" ?foos
                    110: 
                    111: s" foobar" ?foobars
                    112: s" foofoofoobar" ?foobars
                    113: s" fofoofoofofooofoobarbar" ?foobars
                    114: s" bla baz bar" ?foobars
                    115: s" foofoofoo" ?foobars
                    116: 
1.17      pazsan    117: s" foobar" ?foos1
                    118: s" foofoofoobar" ?foos1
                    119: s" fofoofoofofooofoobarbar" ?foos1
                    120: s" bla baz bar" ?foos1
                    121: s" foofoofoo" ?foos1
1.1       pazsan    122: 
1.14      pazsan    123: \ backtracking on decissions
                    124: 
                    125: : ?aab ( addr u -- flag )
                    126:    (( {{ =" aa" || =" a" }} {{ =" ab" || =" a" }} )) ;
                    127: s" aab" ?aab 0= [IF] .( aab failed!) cr [THEN]
                    128: 
1.11      dvdkhlng  129: \ buffer overrun test (bug in =")
                    130: 
1.13      pazsan    131: ." --- buffer overrun test ---" cr
                    132: 
1.11      dvdkhlng  133:  : ?long-string
                    134:     (( // \( =" abcdefghi" \) ))
                    135:     IF  \1 type  cr THEN ;
                    136: 
1.17      pazsan    137: 4096 allocate throw 4096 + 8 - constant test-string
1.11      dvdkhlng  138:  s" abcdefgh" test-string swap cmove>
                    139:  .( provoking overflow [i.e. see valgrind output]) cr
                    140:  test-string . cr
                    141:  test-string 8 ?long-string
1.17      pazsan    142: .( done) cr ?depth
1.11      dvdkhlng  143: 
1.8       dvdkhlng  144: \ simple replacement test
                    145:  
1.11      dvdkhlng  146: ." --- simple replacement test ---" cr
1.9       pazsan    147: 
1.13      pazsan    148: : delnum  ( addr u -- addr' u' )   s// \d >> s" " //g ;
1.8       dvdkhlng  149: : test-delnum  ( addr u addr' u' -- )
                    150:    2swap delnum 2over 2over str= 0= IF
                    151:       ." test-delnum: got '" type ." ', expected '" type ." '"
1.17      pazsan    152:    ELSE  2drop 2drop ." test-delnum passed" cr  THEN  ?depth ;
1.8       dvdkhlng  153: s" 0"  s" " test-delnum
                    154: s" 00"  s" " test-delnum
                    155: s" 0a"  s" a" test-delnum
                    156: s" a0"  s" a" test-delnum
                    157: s" aa"  s" aa" test-delnum
                    158: 
1.12      pazsan    159: : delcomment  ( addr u -- addr' u' )  s// ` # {** .? **} >> s" " //g ;
1.11      dvdkhlng  160: s" hello # test " delcomment type cr
1.12      pazsan    161: : delparents  ( addr u -- addr' u' )  s// ` ( {* .? *} ` ) >> s" ()" //g ;
                    162: s" delete (test) and (another test) " delparents type cr
1.17      pazsan    163: ?depth
1.11      dvdkhlng  164: 
1.7       pazsan    165: \ replacement tests
                    166: 
1.9       pazsan    167: ." --- replacement tests ---" cr
                    168: 
1.7       pazsan    169: : hms>s ( addr u -- addr' u' )
1.12      pazsan    170:   s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
1.7       pazsan    171:   \1 s>number drop 60 *
                    172:   \2 s>number drop + 60 *
                    173:   \3 s>number drop + 0 <# 's' hold #s #> //g ;
                    174: 
1.9       pazsan    175: s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
1.15      pazsan    176: ."  -> " 2dup type
1.9       pazsan    177: s" bla 45296s fasel 117s blubber" str= [IF] .(  ok) [ELSE] .(  failed) [THEN] cr
1.17      pazsan    178: ?depth
1.7       pazsan    179: 
1.12      pazsan    180: : hms>s,del() ( addr u -- addr' u' )
1.19      pazsan    181:   s// {{ ` ( // ` ) >> <<" ()"
1.18      pazsan    182:       || \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
1.12      pazsan    183:          >> \1 s>number drop 60 *
                    184:             \2 s>number drop + 60 *
                    185:             \3 s>number drop + 0 <# 's' hold #s #> <<
                    186:       }} LEAVE //s ;
                    187: 
1.18      pazsan    188: s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() ."  -> " type cr
1.12      pazsan    189: 
1.21      pazsan    190: \ more tests from David K├╝hling
                    191: 
                    192: require test/ttester.fs
                    193: 
                    194: : underflow1  ( c-addr u -- flag )
                    195:    (( {{
                    196:          {{ ` - || }} \d
                    197:          || \d
                    198:       }} )) ;
                    199: T{ s" -1dummy" underflow1 -> true }T
                    200: 
                    201: : underflow2  ( -- )
                    202:    (( \( {{ \s {** \s **} 
                    203:         || =" /*" // =" */"
                    204:         || =" //" {** \d **} }} \) )) ;
                    205: T{ s" /*10203030203030404*/   " underflow2 -> true }T
                    206: T{ pad 0 underflow2 -> false }T
                    207: 
                    208: charclass [*] '* +char
                    209: charclass [*/] '* +char '/ +char
                    210: 
                    211: : underflow3  ( -- )
                    212:    ((
                    213:       =" /*"
1.22      pazsan    214:       \( {** {{ [*] -c? || ` * [*/] -c? }} **} \)
1.21      pazsan    215:       {++ ` * ++} ` /
                    216:    )) ;
                    217: 
                    218: \ this still seems to be too complicated
1.22      pazsan    219: T{ s" /*10203030203030404*/   " underflow3 .s -> true }T
1.21      pazsan    220: \1 type cr
                    221: 
                    222: : underflow4  ( -- )
                    223:    (( \( {{ {** \d **} || {** \d **} }} \d \) )) ;
                    224: 
                    225: T{ s" 0  " underflow4 -> true }T
                    226: 
1.1       pazsan    227: script? [IF] bye [THEN]

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>