regexp-test.fs 6.31 KB
Newer Older
pazsan's avatar
pazsan committed
1 2
\ regexp test

Anton Ertl's avatar
Anton Ertl committed
3
\ Copyright (C) 2005,2007,2009,2010,2018 Free Software Foundation, Inc.
4 5 6 7 8

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
9
\ as published by the Free Software Foundation, either version 3
10 11 12 13 14 15 16 17
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
18
\ along with this program. If not, see http://www.gnu.org/licenses/.
19

pazsan's avatar
pazsan committed
20 21
: ?depth  depth IF  ." unbalanced: " .s clearstack cr  THEN ;

pazsan's avatar
pazsan committed
22 23
charclass [bl-]   blanks +class '-' +char
charclass [0-9(]  '(' +char '0' '9' ..char
pazsan's avatar
pazsan committed
24 25 26 27 28 29 30

: telnum ( addr u -- flag )
    (( {{ ` (  \( \d \d \d \) ` ) || \( \d \d \d \) }}  blanks c?
    \( \d \d \d \) [bl-] c?
    \( \d \d \d \d \) {{ \$ || -\d }} )) ;

: ?tel ( addr u -- ) telnum
pazsan's avatar
pazsan committed
31
    IF  '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
pazsan's avatar
pazsan committed
32 33
    ELSE \0 type ."  failed " THEN ;

pazsan's avatar
pazsan committed
34 35
: ?tel-s ( addr u -- ) ?tel ."  should succeed" space cr ?depth ;
: ?tel-f ( addr u -- ) ?tel ."  should fail" space cr ?depth ;
pazsan's avatar
pazsan committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51

." --- Telephone number match ---" cr
s" (123) 456-7890" ?tel-s
s" (123) 456-7890 " ?tel-s
s" (123)-456 7890" ?tel-f
s" (123) 456 789" ?tel-f
s" 123 456-7890" ?tel-s
s" 123 456-78909" ?tel-f

: telnum2 ( addr u -- flag )
    (( // {{ [0-9(] -c? || \^ }}
    {{ ` (  \( \d \d \d \) ` ) || \( \d \d \d \) }}  blanks c?
    \( \d \d \d \) [bl-] c?
    \( \d \d \d \d \) {{ \$ || -\d }} )) ;

: ?tel2 ( addr u -- ) telnum2
pazsan's avatar
pazsan committed
52
    IF   '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
pazsan's avatar
pazsan committed
53
    ELSE \0 type ."  failed " THEN  cr ?depth ;
pazsan's avatar
pazsan committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
." --- Telephone number search ---" cr
s" blabla (123) 456-7890" ?tel2
s" blabla (123) 456-7890 " ?tel2
s" blabla (123)-456 7890" ?tel2
s" blabla (123) 456 789" ?tel2
s" blabla 123 456-7890" ?tel2
s" blabla 123 456-78909" ?tel2
s" (123) 456-7890" ?tel2
s"  (123) 456-7890 " ?tel2
s" a (123)-456 7890" ?tel2
s" la (123) 456 789" ?tel2
s" bla 123 456-7890" ?tel2
s" abla 123 456-78909" ?tel2

." --- Number extraction test ---" cr

pazsan's avatar
pazsan committed
70
charclass [0-9,./:]  '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
pazsan's avatar
pazsan committed
71 72 73

: ?num
    (( // \( {++ [0-9,./:] c? ++} \) ))
pazsan's avatar
pazsan committed
74
    IF  \1 type  ELSE  \0 type ."  failed"  THEN   cr ?depth ;
pazsan's avatar
pazsan committed
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94

s" 1234" ?num
s" 12,345abc" ?num
s" foobar12/345:678.9abc" ?num
s" blafasel" ?num

." --- String test --- " cr

: ?string
    (( // \( {{ =" foo" || =" bar" || =" test" }} \) ))
    IF  \1 type  cr THEN ;
s" dies ist ein test" ?string
s" foobar" ?string
s" baz bar foo" ?string
s" Hier kommt nichts vor" ?string

." --- longer matches test --- " cr

: ?foos
    (( \( {** =" foo" **} \) ))
pazsan's avatar
pazsan committed
95
    IF  \1 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
pazsan's avatar
pazsan committed
96 97 98

: ?foobars
    (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) ))
pazsan's avatar
pazsan committed
99
    IF  \1 type ',' emit \2 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
pazsan's avatar
pazsan committed
100 101 102

: ?foos1
    (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
pazsan's avatar
pazsan committed
103
    IF  \1 type ',' emit \2 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
pazsan's avatar
pazsan committed
104 105 106 107 108 109 110 111 112 113 114 115 116

s" foobar" ?foos
s" foofoofoobar" ?foos
s" fofoofoofofooofoobarbar" ?foos
s" bla baz bar" ?foos
s" foofoofoo" ?foos

s" foobar" ?foobars
s" foofoofoobar" ?foobars
s" fofoofoofofooofoobarbar" ?foobars
s" bla baz bar" ?foobars
s" foofoofoo" ?foobars

pazsan's avatar
pazsan committed
117 118 119 120 121
s" foobar" ?foos1
s" foofoofoobar" ?foos1
s" fofoofoofofooofoobarbar" ?foos1
s" bla baz bar" ?foos1
s" foofoofoo" ?foos1
pazsan's avatar
pazsan committed
122

pazsan's avatar
pazsan committed
123 124 125 126 127 128
\ backtracking on decissions

: ?aab ( addr u -- flag )
   (( {{ =" aa" || =" a" }} {{ =" ab" || =" a" }} )) ;
s" aab" ?aab 0= [IF] .( aab failed!) cr [THEN]

129 130
\ buffer overrun test (bug in =")

pazsan's avatar
pazsan committed
131 132
." --- buffer overrun test ---" cr

133 134 135 136
 : ?long-string
    (( // \( =" abcdefghi" \) ))
    IF  \1 type  cr THEN ;

pazsan's avatar
pazsan committed
137
4096 allocate throw 4096 + 8 - constant test-string
138 139 140 141
 s" abcdefgh" test-string swap cmove>
 .( provoking overflow [i.e. see valgrind output]) cr
 test-string . cr
 test-string 8 ?long-string
pazsan's avatar
pazsan committed
142
.( done) cr ?depth
143

144 145
\ simple replacement test
 
146
." --- simple replacement test ---" cr
pazsan's avatar
pazsan committed
147

pazsan's avatar
pazsan committed
148
: delnum  ( addr u -- addr' u' )   s// \d >> s" " //g ;
149 150 151
: test-delnum  ( addr u addr' u' -- )
   2swap delnum 2over 2over str= 0= IF
      ." test-delnum: got '" type ." ', expected '" type ." '"
pazsan's avatar
pazsan committed
152
   ELSE  2drop 2drop ." test-delnum passed" cr  THEN  ?depth ;
153 154 155 156 157 158
s" 0"  s" " test-delnum
s" 00"  s" " test-delnum
s" 0a"  s" a" test-delnum
s" a0"  s" a" test-delnum
s" aa"  s" aa" test-delnum

pazsan's avatar
pazsan committed
159
: delcomment  ( addr u -- addr' u' )  s// ` # {** .? **} >> s" " //g ;
160
s" hello # test " delcomment type cr
pazsan's avatar
pazsan committed
161 162
: delparents  ( addr u -- addr' u' )  s// ` ( {* .? *} ` ) >> s" ()" //g ;
s" delete (test) and (another test) " delparents type cr
pazsan's avatar
pazsan committed
163
?depth
164

pazsan's avatar
pazsan committed
165 166
\ replacement tests

pazsan's avatar
pazsan committed
167 168
." --- replacement tests ---" cr

pazsan's avatar
pazsan committed
169
: hms>s ( addr u -- addr' u' )
pazsan's avatar
pazsan committed
170
  s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
pazsan's avatar
pazsan committed
171 172 173 174
  \1 s>number drop 60 *
  \2 s>number drop + 60 *
  \3 s>number drop + 0 <# 's' hold #s #> //g ;

pazsan's avatar
pazsan committed
175
s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
pazsan's avatar
pazsan committed
176
."  -> " 2dup type
pazsan's avatar
pazsan committed
177
s" bla 45296s fasel 117s blubber" str= [IF] .(  ok) [ELSE] .(  failed) [THEN] cr
pazsan's avatar
pazsan committed
178
?depth
pazsan's avatar
pazsan committed
179

pazsan's avatar
pazsan committed
180
: hms>s,del() ( addr u -- addr' u' )
pazsan's avatar
pazsan committed
181
  s// {{ ` ( // ` ) >> <<" ()"
182
      || \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
pazsan's avatar
pazsan committed
183 184 185 186 187
         >> \1 s>number drop 60 *
            \2 s>number drop + 60 *
            \3 s>number drop + 0 <# 's' hold #s #> <<
      }} LEAVE //s ;

188
s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() ."  -> " type cr
pazsan's avatar
pazsan committed
189

pazsan's avatar
pazsan committed
190 191
\ more tests from David Kühling

Bernd Paysan's avatar
Bernd Paysan committed
192
coverage? false to coverage?
pazsan's avatar
pazsan committed
193
require test/ttester.fs
Bernd Paysan's avatar
Bernd Paysan committed
194
to coverage?
pazsan's avatar
pazsan committed
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215

: underflow1  ( c-addr u -- flag )
   (( {{
         {{ ` - || }} \d
         || \d
      }} )) ;
T{ s" -1dummy" underflow1 -> true }T

: underflow2  ( -- )
   (( \( {{ \s {** \s **} 
	 || =" /*" // =" */"
	 || =" //" {** \d **} }} \) )) ;
T{ s" /*10203030203030404*/   " underflow2 -> true }T
T{ pad 0 underflow2 -> false }T

charclass [*] '* +char
charclass [*/] '* +char '/ +char

: underflow3  ( -- )
   ((
      =" /*"
pazsan's avatar
pazsan committed
216
      \( {** {{ [*] -c? || ` * [*/] -c? }} **} \)
pazsan's avatar
pazsan committed
217 218 219 220
      {++ ` * ++} ` /
   )) ;

\ this still seems to be too complicated
Bernd Paysan's avatar
Bernd Paysan committed
221
T{ s" /*10203030203030404*/   " underflow3 -> true }T
pazsan's avatar
pazsan committed
222 223 224 225 226 227 228
\1 type cr

: underflow4  ( -- )
   (( \( {{ {** \d **} || {** \d **} }} \d \) )) ;

T{ s" 0  " underflow4 -> true }T

Bernd Paysan's avatar
Bernd Paysan committed
229
coverage? [IF] .coverage cov% cr [THEN]
pazsan's avatar
pazsan committed
230
script? [IF] bye [THEN]