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

3
\ Authors: Bernd Paysan, Anton Ertl, David Kühling
Anton Ertl's avatar
Anton Ertl committed
4
\ Copyright (C) 2005,2007,2009,2010,2018 Free Software Foundation, Inc.
5 6 7 8 9

\ 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
10
\ as published by the Free Software Foundation, either version 3
11 12 13 14 15 16 17 18
\ 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
19
\ along with this program. If not, see http://www.gnu.org/licenses/.
20

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

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

: 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
32
    IF  '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
pazsan's avatar
pazsan committed
33 34
    ELSE \0 type ."  failed " THEN ;

pazsan's avatar
pazsan committed
35 36
: ?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
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

." --- 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
53
    IF   '(' emit \1 type ." ) " \2 type '-' emit \3 type ."  succeeded"
pazsan's avatar
pazsan committed
54
    ELSE \0 type ."  failed " THEN  cr ?depth ;
pazsan's avatar
pazsan committed
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
." --- 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
71
charclass [0-9,./:]  '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
pazsan's avatar
pazsan committed
72 73 74

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

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
96
    IF  \1 type  ELSE  \0 type ."  failed"  THEN  cr ?depth ;
pazsan's avatar
pazsan committed
97 98 99

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

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

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
118 119 120 121 122
s" foobar" ?foos1
s" foofoofoobar" ?foos1
s" fofoofoofofooofoobarbar" ?foos1
s" bla baz bar" ?foos1
s" foofoofoo" ?foos1
pazsan's avatar
pazsan committed
123

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

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

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

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

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

pazsan's avatar
pazsan committed
138
4096 allocate throw 4096 + 8 - constant test-string
139 140 141 142
 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
143
.( done) cr ?depth
144

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

pazsan's avatar
pazsan committed
149
: delnum  ( addr u -- addr' u' )   s// \d >> s" " //g ;
150 151 152
: test-delnum  ( addr u addr' u' -- )
   2swap delnum 2over 2over str= 0= IF
      ." test-delnum: got '" type ." ', expected '" type ." '"
pazsan's avatar
pazsan committed
153
   ELSE  2drop 2drop ." test-delnum passed" cr  THEN  ?depth ;
154 155 156 157 158 159
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
160
: delcomment  ( addr u -- addr' u' )  s// ` # {** .? **} >> s" " //g ;
161
s" hello # test " delcomment type cr
pazsan's avatar
pazsan committed
162 163
: delparents  ( addr u -- addr' u' )  s// ` ( {* .? *} ` ) >> s" ()" //g ;
s" delete (test) and (another test) " delparents type cr
pazsan's avatar
pazsan committed
164
?depth
165

pazsan's avatar
pazsan committed
166 167
\ replacement tests

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

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

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

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

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

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

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

: 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
217
      \( {** {{ [*] -c? || ` * [*/] -c? }} **} \)
pazsan's avatar
pazsan committed
218 219 220 221
      {++ ` * ++} ` /
   )) ;

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

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

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

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