[gforth] / gforth / regexp-test.fs  

gforth: gforth/regexp-test.fs

1 : pazsan 1.1 \ regexp test
2 :    
3 : anton 1.6 \ Copyright (C) 2005,2007,2009 Free Software Foundation, Inc.
4 : anton 1.2
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 : anton 1.3 \ as published by the Free Software Foundation, either version 3
10 : anton 1.2 \ 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 : anton 1.3 \ along with this program. If not, see http://www.gnu.org/licenses/.
19 : anton 1.2
20 : pazsan 1.16 : ?depth depth IF ." unbalanced: " .s clearstack cr THEN ;
21 :    
22 : pazsan 1.5 charclass [bl-] blanks +class '-' +char
23 :     charclass [0-9(] '(' +char '0' '9' ..char
24 : pazsan 1.1
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 : pazsan 1.5 IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
32 : pazsan 1.1 ELSE \0 type ." failed " THEN ;
33 :    
34 : pazsan 1.16 : ?tel-s ( addr u -- ) ?tel ." should succeed" space cr ?depth ;
35 :     : ?tel-f ( addr u -- ) ?tel ." should fail" space cr ?depth ;
36 : pazsan 1.1
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 : pazsan 1.5 IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
53 : pazsan 1.16 ELSE \0 type ." failed " THEN cr ?depth ;
54 : pazsan 1.1 ." --- 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 : pazsan 1.5 charclass [0-9,./:] '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
71 : pazsan 1.1
72 :     : ?num
73 :     (( // \( {++ [0-9,./:] c? ++} \) ))
74 : pazsan 1.16 IF \1 type ELSE \0 type ." failed" THEN cr ?depth ;
75 : pazsan 1.1
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 : pazsan 1.16 IF \1 type ELSE \0 type ." failed" THEN cr ?depth ;
96 : pazsan 1.1
97 :     : ?foobars
98 :     (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) ))
99 : pazsan 1.16 IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ?depth ;
100 : pazsan 1.1
101 :     : ?foos1
102 :     (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
103 : pazsan 1.16 IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ?depth ;
104 : pazsan 1.1
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 : pazsan 1.17 s" foobar" ?foos1
118 :     s" foofoofoobar" ?foos1
119 :     s" fofoofoofofooofoobarbar" ?foos1
120 :     s" bla baz bar" ?foos1
121 :     s" foofoofoo" ?foos1
122 : pazsan 1.1
123 : pazsan 1.14 \ 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 : dvdkhlng 1.11 \ buffer overrun test (bug in =")
130 :    
131 : pazsan 1.13 ." --- buffer overrun test ---" cr
132 :    
133 : dvdkhlng 1.11 : ?long-string
134 :     (( // \( =" abcdefghi" \) ))
135 :     IF \1 type cr THEN ;
136 :    
137 : pazsan 1.17 4096 allocate throw 4096 + 8 - constant test-string
138 : dvdkhlng 1.11 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 : pazsan 1.17 .( done) cr ?depth
143 : dvdkhlng 1.11
144 : dvdkhlng 1.8 \ simple replacement test
145 :    
146 : dvdkhlng 1.11 ." --- simple replacement test ---" cr
147 : pazsan 1.9
148 : pazsan 1.13 : delnum ( addr u -- addr' u' ) s// \d >> s" " //g ;
149 : dvdkhlng 1.8 : test-delnum ( addr u addr' u' -- )
150 :     2swap delnum 2over 2over str= 0= IF
151 :     ." test-delnum: got '" type ." ', expected '" type ." '"
152 : pazsan 1.17 ELSE 2drop 2drop ." test-delnum passed" cr THEN ?depth ;
153 : dvdkhlng 1.8 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 : pazsan 1.12 : delcomment ( addr u -- addr' u' ) s// ` # {** .? **} >> s" " //g ;
160 : dvdkhlng 1.11 s" hello # test " delcomment type cr
161 : pazsan 1.12 : delparents ( addr u -- addr' u' ) s// ` ( {* .? *} ` ) >> s" ()" //g ;
162 :     s" delete (test) and (another test) " delparents type cr
163 : pazsan 1.17 ?depth
164 : dvdkhlng 1.11
165 : pazsan 1.7 \ replacement tests
166 :    
167 : pazsan 1.9 ." --- replacement tests ---" cr
168 :    
169 : pazsan 1.7 : hms>s ( addr u -- addr' u' )
170 : pazsan 1.12 s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
171 : pazsan 1.7 \1 s>number drop 60 *
172 :     \2 s>number drop + 60 *
173 :     \3 s>number drop + 0 <# 's' hold #s #> //g ;
174 :    
175 : pazsan 1.9 s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
176 : pazsan 1.15 ." -> " 2dup type
177 : pazsan 1.9 s" bla 45296s fasel 117s blubber" str= [IF] .( ok) [ELSE] .( failed) [THEN] cr
178 : pazsan 1.17 ?depth
179 : pazsan 1.7
180 : pazsan 1.12 : hms>s,del() ( addr u -- addr' u' )
181 :     s// {{ \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
182 :     >> \1 s>number drop 60 *
183 :     \2 s>number drop + 60 *
184 :     \3 s>number drop + 0 <# 's' hold #s #> <<
185 : pazsan 1.14 || ` ( // ` ) >> <<" "
186 : pazsan 1.12 }} LEAVE //s ;
187 :    
188 :     \ doesn't work yet
189 :     \ s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() space type cr
190 :    
191 : pazsan 1.1 script? [IF] bye [THEN]
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help