1: \ regexp test
2:
3: \ Copyright (C) 2005,2007,2009 Free Software Foundation, Inc.
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
9: \ as published by the Free Software Foundation, either version 3
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
18: \ along with this program. If not, see http://www.gnu.org/licenses/.
19:
20: : ?depth depth IF ." unbalanced: " .s clearstack cr THEN ;
21:
22: charclass [bl-] blanks +class '-' +char
23: charclass [0-9(] '(' +char '0' '9' ..char
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
31: IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
32: ELSE \0 type ." failed " THEN ;
33:
34: : ?tel-s ( addr u -- ) ?tel ." should succeed" space cr ?depth ;
35: : ?tel-f ( addr u -- ) ?tel ." should fail" space cr ?depth ;
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
52: IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
53: ELSE \0 type ." failed " THEN cr ?depth ;
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:
70: charclass [0-9,./:] '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
71:
72: : ?num
73: (( // \( {++ [0-9,./:] c? ++} \) ))
74: IF \1 type ELSE \0 type ." failed" THEN cr ?depth ;
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" **} \) ))
95: IF \1 type ELSE \0 type ." failed" THEN cr ?depth ;
96:
97: : ?foobars
98: (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) ))
99: IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ?depth ;
100:
101: : ?foos1
102: (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
103: IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ?depth ;
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:
117: s" foobar" ?foos1
118: s" foofoofoobar" ?foos1
119: s" fofoofoofofooofoobarbar" ?foos1
120: s" bla baz bar" ?foos1
121: s" foofoofoo" ?foos1
122:
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:
129: \ buffer overrun test (bug in =")
130:
131: ." --- buffer overrun test ---" cr
132:
133: : ?long-string
134: (( // \( =" abcdefghi" \) ))
135: IF \1 type cr THEN ;
136:
137: 4096 allocate throw 4096 + 8 - constant test-string
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
142: .( done) cr ?depth
143:
144: \ simple replacement test
145:
146: ." --- simple replacement test ---" cr
147:
148: : delnum ( addr u -- addr' u' ) s// \d >> s" " //g ;
149: : test-delnum ( addr u addr' u' -- )
150: 2swap delnum 2over 2over str= 0= IF
151: ." test-delnum: got '" type ." ', expected '" type ." '"
152: ELSE 2drop 2drop ." test-delnum passed" cr THEN ?depth ;
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:
159: : delcomment ( addr u -- addr' u' ) s// ` # {** .? **} >> s" " //g ;
160: s" hello # test " delcomment type cr
161: : delparents ( addr u -- addr' u' ) s// ` ( {* .? *} ` ) >> s" ()" //g ;
162: s" delete (test) and (another test) " delparents type cr
163: ?depth
164:
165: \ replacement tests
166:
167: ." --- replacement tests ---" cr
168:
169: : hms>s ( addr u -- addr' u' )
170: s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
171: \1 s>number drop 60 *
172: \2 s>number drop + 60 *
173: \3 s>number drop + 0 <# 's' hold #s #> //g ;
174:
175: s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
176: ." -> " 2dup type
177: s" bla 45296s fasel 117s blubber" str= [IF] .( ok) [ELSE] .( failed) [THEN] cr
178: ?depth
179:
180: : hms>s,del() ( addr u -- addr' u' )
181: s// {{ ` ( // ` ) >> <<" ()"
182: || \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
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:
188: s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() ." -> " type cr
189:
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: =" /*"
214: \( {** {{ [*] -c? || ` * [*/] -c? }} **} \)
215: {++ ` * ++} ` /
216: )) ;
217:
218: \ this still seems to be too complicated
219: T{ s" /*10203030203030404*/ " underflow3 -> true }T
220: \1 type cr
221:
222: : underflow4 ( -- )
223: (( \( {{ {** \d **} || {** \d **} }} \d \) )) ;
224:
225: T{ s" 0 " underflow4 -> true }T
226:
227: script? [IF] bye [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>