| \ regexp test |
\ regexp test |
| |
|
| charclass [bl-] blanks +class '- +char |
\ Copyright (C) 2005,2007,2009 Free Software Foundation, Inc. |
| charclass [0-9(] '( +char '0 '9 ..char |
|
| |
\ 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 |
| |
\ as published by the Free Software Foundation, either version 3 |
| |
\ 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 |
| |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
| |
|
| |
charclass [bl-] blanks +class '-' +char |
| |
charclass [0-9(] '(' +char '0' '9' ..char |
| |
|
| : telnum ( addr u -- flag ) |
: telnum ( addr u -- flag ) |
| (( {{ ` ( \( \d \d \d \) ` ) || \( \d \d \d \) }} blanks c? |
(( {{ ` ( \( \d \d \d \) ` ) || \( \d \d \d \) }} blanks c? |
| \( \d \d \d \d \) {{ \$ || -\d }} )) ; |
\( \d \d \d \d \) {{ \$ || -\d }} )) ; |
| |
|
| : ?tel ( addr u -- ) telnum |
: ?tel ( addr u -- ) telnum |
| IF '( emit \1 type ." ) " \2 type '- emit \3 type ." succeeded" |
IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded" |
| ELSE \0 type ." failed " THEN ; |
ELSE \0 type ." failed " THEN ; |
| |
|
| : ?tel-s ( addr u -- ) ?tel ." should succeed" space depth . cr ; |
: ?tel-s ( addr u -- ) ?tel ." should succeed" space depth . cr ; |
| \( \d \d \d \d \) {{ \$ || -\d }} )) ; |
\( \d \d \d \d \) {{ \$ || -\d }} )) ; |
| |
|
| : ?tel2 ( addr u -- ) telnum2 |
: ?tel2 ( addr u -- ) telnum2 |
| IF '( emit \1 type ." ) " \2 type '- emit \3 type ." succeeded" |
IF '(' emit \1 type ." ) " \2 type '-' emit \3 type ." succeeded" |
| ELSE \0 type ." failed " THEN cr ; |
ELSE \0 type ." failed " THEN cr ; |
| ." --- Telephone number search ---" cr |
." --- Telephone number search ---" cr |
| s" blabla (123) 456-7890" ?tel2 |
s" blabla (123) 456-7890" ?tel2 |
| |
|
| ." --- Number extraction test ---" cr |
." --- Number extraction test ---" cr |
| |
|
| charclass [0-9,./:] '0 '9 ..char ', +char '. +char '/ +char ': +char |
charclass [0-9,./:] '0' '9' ..char ',' +char '.' +char '/' +char ':' +char |
| |
|
| : ?num |
: ?num |
| (( // \( {++ [0-9,./:] c? ++} \) )) |
(( // \( {++ [0-9,./:] c? ++} \) )) |
| |
|
| : ?foobars |
: ?foobars |
| (( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) )) |
(( // \( {** =" foo" **} \) \( {++ =" bar" ++} \) )) |
| IF \1 type ', emit \2 type ELSE \0 type ." failed" THEN cr ; |
IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ; |
| |
|
| : ?foos1 |
: ?foos1 |
| (( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) )) |
(( // \( {+ =" foo" +} \) \( {++ =" bar" ++} \) )) |
| IF \1 type ', emit \2 type ELSE \0 type ." failed" THEN cr ; |
IF \1 type ',' emit \2 type ELSE \0 type ." failed" THEN cr ; |
| |
|
| s" foobar" ?foos |
s" foobar" ?foos |
| s" foofoofoobar" ?foos |
s" foofoofoobar" ?foos |
| s" bla baz bar" ?foos1 |
s" bla baz bar" ?foos1 |
| s" foofoofoo" ?foos1 |
s" foofoofoo" ?foos1 |
| |
|
| |
\ backtracking on decissions |
| |
|
| |
: ?aab ( addr u -- flag ) |
| |
(( {{ =" aa" || =" a" }} {{ =" ab" || =" a" }} )) ; |
| |
s" aab" ?aab 0= [IF] .( aab failed!) cr [THEN] |
| |
|
| |
\ buffer overrun test (bug in =") |
| |
|
| |
." --- buffer overrun test ---" cr |
| |
|
| |
: ?long-string |
| |
(( // \( =" abcdefghi" \) )) |
| |
IF \1 type cr THEN ; |
| |
|
| |
here 4096 allocate throw 4096 + 8 - constant test-string |
| |
s" abcdefgh" test-string swap cmove> |
| |
.( provoking overflow [i.e. see valgrind output]) cr |
| |
test-string . cr |
| |
test-string 8 ?long-string |
| |
.( done) cr |
| |
|
| |
\ simple replacement test |
| |
|
| |
." --- simple replacement test ---" cr |
| |
|
| |
: delnum ( addr u -- addr' u' ) s// \d >> s" " //g ; |
| |
: test-delnum ( addr u addr' u' -- ) |
| |
2swap delnum 2over 2over str= 0= IF |
| |
." test-delnum: got '" type ." ', expected '" type ." '" |
| |
ELSE 2drop 2drop ." passed" cr THEN ; |
| |
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 |
| |
|
| |
: delcomment ( addr u -- addr' u' ) s// ` # {** .? **} >> s" " //g ; |
| |
s" hello # test " delcomment type cr |
| |
: delparents ( addr u -- addr' u' ) s// ` ( {* .? *} ` ) >> s" ()" //g ; |
| |
s" delete (test) and (another test) " delparents type cr |
| |
|
| |
\ replacement tests |
| |
|
| |
." --- replacement tests ---" cr |
| |
|
| |
: hms>s ( addr u -- addr' u' ) |
| |
s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) >> |
| |
\1 s>number drop 60 * |
| |
\2 s>number drop + 60 * |
| |
\3 s>number drop + 0 <# 's' hold #s #> //g ; |
| |
|
| |
s" bla 12:34:56 fasel 00:01:57 blubber" 2dup type hms>s |
| |
." replaced by " 2dup type |
| |
s" bla 45296s fasel 117s blubber" str= [IF] .( ok) [ELSE] .( failed) [THEN] cr |
| |
|
| |
: hms>s,del() ( addr u -- addr' u' ) |
| |
s// {{ \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) |
| |
>> \1 s>number drop 60 * |
| |
\2 s>number drop + 60 * |
| |
\3 s>number drop + 0 <# 's' hold #s #> << |
| |
|| ` ( // ` ) >> <<" " |
| |
}} LEAVE //s ; |
| |
|
| |
\ doesn't work yet |
| |
\ s" (bla) 12:34:56 (fasel) 00:01:57 (blubber)" 2dup type hms>s,del() space type cr |
| |
|
| script? [IF] bye [THEN] |
script? [IF] bye [THEN] |
