[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.5 charclass [bl-] blanks +class '-' +char
21 :     charclass [0-9(] '(' +char '0' '9' ..char
22 : pazsan 1.1
23 :     : telnum ( addr u -- flag )
24 :     (( {{ ` ( \( \d \d \d \) ` ) || \( \d \d \d \) }} blanks c?
25 :     \( \d \d \d \) [bl-] c?
26 :     \( \d \d \d \d \) {{ \$ || -\d }} )) ;
27 :    
28 :     : ?tel ( addr u -- ) telnum
29 : pazsan 1.5 IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
30 : pazsan 1.1 ELSE \0 type ." failed " THEN ;
31 :    
32 :     : ?tel-s ( addr u -- ) ?tel ." should succeed" space depth . cr ;
33 :     : ?tel-f ( addr u -- ) ?tel ." should fail" space depth . cr ;
34 :    
35 :     ." --- Telephone number match ---" cr
36 :     s" (123) 456-7890" ?tel-s
37 :     s" (123) 456-7890 " ?tel-s
38 :     s" (123)-456 7890" ?tel-f
39 :     s" (123) 456 789" ?tel-f
40 :     s" 123 456-7890" ?tel-s
41 :     s" 123 456-78909" ?tel-f
42 :    
43 :     : telnum2 ( addr u -- flag )
44 :     (( // {{ [0-9(] -c? || \^ }}
45 :     {{ ` ( \( \d \d \d \) ` ) || \( \d \d \d \) }} blanks c?
46 :     \( \d \d \d \) [bl-] c?
47 :     \( \d \d \d \d \) {{ \$ || -\d }} )) ;
48 :    
49 :     : ?tel2 ( addr u -- ) telnum2
50 : pazsan 1.5 IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
51 : pazsan 1.1 ELSE \0 type ." failed " THEN cr ;
52 :     ." --- Telephone number search ---" cr
53 :     s" blabla (123) 456-7890" ?tel2
54 :     s" blabla (123) 456-7890 " ?tel2
55 :     s" blabla (123)-456 7890" ?tel2
56 :     s" blabla (123) 456 789" ?tel2
57 :     s" blabla 123 456-7890" ?tel2
58 :     s" blabla 123 456-78909" ?tel2
59 :     s" (123) 456-7890" ?tel2
60 :     s" (123) 456-7890 " ?tel2
61 :     s" a (123)-456 7890" ?tel2
62 :     s" la (123) 456 789" ?tel2
63 :     s" bla 123 456-7890" ?tel2
64 :     s" abla 123 456-78909" ?tel2
65 :    
66 :     ." --- Number extraction test ---" cr
67 :    
68 : pazsan 1.5 charclass [0-9,./:] '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
69 : pazsan 1.1
70 :     : ?num
71 :     (( // \( {++ [0-9,./:] c? ++} \) ))
72 :     IF \1 type ELSE \0 type ." failed" THEN cr ;
73 :    
74 :     s" 1234" ?num
75 :     s" 12,345abc" ?num
76 :     s" foobar12/345:678.9abc" ?num
77 :     s" blafasel" ?num
78 :    
79 :     ." --- String test --- " cr
80 :    
81 :     : ?string
82 :     (( // \( {{ =" foo" || =" bar" || =" test" }} \) ))
83 :     IF \1 type cr THEN ;
84 :     s" dies ist ein test" ?string
85 :     s" foobar" ?string
86 :     s" baz bar foo" ?string
87 :     s" Hier kommt nichts vor" ?string
88 :    
89 :     ." --- longer matches test --- " cr
90 :    
91 :     : ?foos
92 :     (( \( {** =" foo" **} \) ))
93 :     IF \1 type ELSE \0 type ." failed" THEN cr ;
94 :    
95 :     : ?foobars
96 :     (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) ))
97 : pazsan 1.5 IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ;
98 : pazsan 1.1
99 :     : ?foos1
100 :     (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
101 : pazsan 1.5 IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ;
102 : pazsan 1.1
103 :     s" foobar" ?foos
104 :     s" foofoofoobar" ?foos
105 :     s" fofoofoofofooofoobarbar" ?foos
106 :     s" bla baz bar" ?foos
107 :     s" foofoofoo" ?foos
108 :    
109 :     s" foobar" ?foobars
110 :     s" foofoofoobar" ?foobars
111 :     s" fofoofoofofooofoobarbar" ?foobars
112 :     s" bla baz bar" ?foobars
113 :     s" foofoofoo" ?foobars
114 :    
115 :     s" foobar" ?foos1
116 :     s" foofoofoobar" ?foos1
117 :     s" fofoofoofofooofoobarbar" ?foos1
118 :     s" bla baz bar" ?foos1
119 :     s" foofoofoo" ?foos1
120 :    
121 : pazsan 1.14 \ backtracking on decissions
122 :    
123 :     : ?aab ( addr u -- flag )
124 :     (( {{ =" aa" || =" a" }} {{ =" ab" || =" a" }} )) ;
125 :     s" aab" ?aab 0= [IF] .( aab failed!) cr [THEN]
126 :    
127 : dvdkhlng 1.11 \ buffer overrun test (bug in =")
128 :    
129 : pazsan 1.13 ." --- buffer overrun test ---" cr
130 :    
131 : dvdkhlng 1.11 : ?long-string
132 :     (( // \( =" abcdefghi" \) ))
133 :     IF \1 type cr THEN ;
134 :    
135 :     here 4096 allocate throw 4096 + 8 - constant test-string
136 :     s" abcdefgh" test-string swap cmove>
137 :     .( provoking overflow [i.e. see valgrind output]) cr
138 :     test-string . cr
139 :     test-string 8 ?long-string
140 :     .( done) cr
141 :    
142 : dvdkhlng 1.8 \ simple replacement test
143 :    
144 : dvdkhlng 1.11 ." --- simple replacement test ---" cr
145 : pazsan 1.9
146 : pazsan 1.13 : delnum ( addr u -- addr' u' ) s// \d >> s" " //g ;
147 : dvdkhlng 1.8 : test-delnum ( addr u addr' u' -- )
148 :     2swap delnum 2over 2over str= 0= IF
149 :     ." test-delnum: got '" type ." ', expected '" type ." '"
150 : pazsan 1.12 ELSE 2drop 2drop ." passed" cr THEN ;
151 : dvdkhlng 1.8 s" 0" s" " test-delnum
152 :     s" 00" s" " test-delnum
153 :     s" 0a" s" a" test-delnum
154 :     s" a0" s" a" test-delnum
155 :     s" aa" s" aa" test-delnum
156 :    
157 : pazsan 1.12 : delcomment ( addr u -- addr' u' ) s// ` # {** .? **} >> s" " //g ;
158 : dvdkhlng 1.11 s" hello # test " delcomment type cr
159 : pazsan 1.12 : delparents ( addr u -- addr' u' ) s// ` ( {* .? *} ` ) >> s" ()" //g ;
160 :     s" delete (test) and (another test) " delparents type cr
161 : dvdkhlng 1.11
162 : pazsan 1.7 \ replacement tests
163 :    
164 : pazsan 1.9 ." --- replacement tests ---" cr
165 :    
166 : pazsan 1.7 : hms>s ( addr u -- addr' u' )
167 : pazsan 1.12 s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
168 : pazsan 1.7 \1 s>number drop 60 *
169 :     \2 s>number drop + 60 *
170 :     \3 s>number drop + 0 <# 's' hold #s #> //g ;
171 :    
172 : pazsan 1.9 s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
173 : pazsan 1.15 ." -> " 2dup type
174 : pazsan 1.9 s" bla 45296s fasel 117s blubber" str= [IF] .( ok) [ELSE] .( failed) [THEN] cr
175 : pazsan 1.7
176 : pazsan 1.12 : hms>s,del() ( addr u -- addr' u' )
177 :     s// {{ \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
178 :     >> \1 s>number drop 60 *
179 :     \2 s>number drop + 60 *
180 :     \3 s>number drop + 0 <# 's' hold #s #> <<
181 : pazsan 1.14 || ` ( // ` ) >> <<" "
182 : pazsan 1.12 }} LEAVE //s ;
183 :    
184 :     \ doesn't work yet
185 :     \ s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() space type cr
186 :    
187 : pazsan 1.1 script? [IF] bye [THEN]
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help