Annotation of gforth/regexp-test.fs, revision 1.14
1.1 pazsan 1: \ regexp test
2:
1.6 anton 3: \ Copyright (C) 2005,2007,2009 Free Software Foundation, Inc.
1.2 anton 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
1.3 anton 9: \ as published by the Free Software Foundation, either version 3
1.2 anton 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
1.3 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.2 anton 19:
1.5 pazsan 20: charclass [bl-] blanks +class '-' +char
21: charclass [0-9(] '(' +char '0' '9' ..char
1.1 pazsan 22:
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
1.5 pazsan 29: IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
1.1 pazsan 30: 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
1.5 pazsan 50: IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded"
1.1 pazsan 51: 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:
1.5 pazsan 68: charclass [0-9,./:] '0' '9' ..char ',' +char '.' +char '/' +char ':' +char
1.1 pazsan 69:
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" ++} \) ))
1.5 pazsan 97: IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ;
1.1 pazsan 98:
99: : ?foos1
100: (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) ))
1.5 pazsan 101: IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ;
1.1 pazsan 102:
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:
1.14 ! pazsan 121: \ 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:
1.11 dvdkhlng 127: \ buffer overrun test (bug in =")
128:
1.13 pazsan 129: ." --- buffer overrun test ---" cr
130:
1.11 dvdkhlng 131: : ?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:
1.8 dvdkhlng 142: \ simple replacement test
143:
1.11 dvdkhlng 144: ." --- simple replacement test ---" cr
1.9 pazsan 145:
1.13 pazsan 146: : delnum ( addr u -- addr' u' ) s// \d >> s" " //g ;
1.8 dvdkhlng 147: : test-delnum ( addr u addr' u' -- )
148: 2swap delnum 2over 2over str= 0= IF
149: ." test-delnum: got '" type ." ', expected '" type ." '"
1.12 pazsan 150: ELSE 2drop 2drop ." passed" cr THEN ;
1.8 dvdkhlng 151: 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:
1.12 pazsan 157: : delcomment ( addr u -- addr' u' ) s// ` # {** .? **} >> s" " //g ;
1.11 dvdkhlng 158: s" hello # test " delcomment type cr
1.12 pazsan 159: : delparents ( addr u -- addr' u' ) s// ` ( {* .? *} ` ) >> s" ()" //g ;
160: s" delete (test) and (another test) " delparents type cr
1.11 dvdkhlng 161:
1.7 pazsan 162: \ replacement tests
163:
1.9 pazsan 164: ." --- replacement tests ---" cr
165:
1.7 pazsan 166: : hms>s ( addr u -- addr' u' )
1.12 pazsan 167: s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >>
1.7 pazsan 168: \1 s>number drop 60 *
169: \2 s>number drop + 60 *
170: \3 s>number drop + 0 <# 's' hold #s #> //g ;
171:
1.9 pazsan 172: s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s
173: ." replaced by " 2dup type
174: s" bla 45296s fasel 117s blubber" str= [IF] .( ok) [ELSE] .( failed) [THEN] cr
1.7 pazsan 175:
1.12 pazsan 176: : 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 #> <<
1.14 ! pazsan 181: || ` ( // ` ) >> <<" "
1.12 pazsan 182: }} 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:
1.1 pazsan 187: script? [IF] bye [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to regexp-test.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth