\ File: parsing-test.fs \ Title: Tests for parsing strings and the input stream \ Author: David N. Williams \ License: Public Domain \ Version: 0.8.3 \ Revised: November 22, 2009 s" ttester.fs" included \ gforth cvs revision 1.13 known to work true VERBOSE ! decimal 0 value #errors :noname ( s -- ) #errors 1+ to #errors ERROR1 ; ERROR-XT ! \ Change this to false for terminals without ANSI color modes: true [IF] \ ANSI color \ Borrowed from Krishna Myneni: : normal-text ( -- ) 27 EMIT [CHAR] [ EMIT [CHAR] 0 EMIT [CHAR] m EMIT ; : red-text ( -- ) 27 EMIT [CHAR] [ EMIT ." 31m" ; : green-text ( -- ) 27 EMIT [CHAR] [ EMIT ." 32m" ; : blue-text ( -- ) 27 EMIT [CHAR] [ EMIT ." 34m" ; [ELSE] \ no color : normal-text ; : red-text ; : green-text ; : blue-text ; [THEN] : COMMENT ( -- ) \ also borrowed from Krisnha Myneni blue-text source >in @ /string verbose @ if type cr else 2drop then source >in ! drop normal-text ; \ Change this to true to test our pfe parsing module instead of \ parsing.fs with pfe: false constant PARSING-EXT [UNDEFINED] s= [IF] : s= ( s1 s2 -- flag ) compare 0= ; [THEN] \ Works with pfe and gforth: s" FORTH-NAME" environment? [IF] s" pfe" s= [ELSE] false [THEN] ( pfe?) constant PFE-HOST 0 [IF] To test CR echoing for terminal input, copy and paste this entire file into a terminal window. The point of the following conditional is that, in terminal mode, gforth 0.6.2 inserts a tab into the input buffer without autocompleting if further input is pending, while pfe 0.33.61 does not. [THEN] source-id 0= ( terminal?) PFE-HOST and constant DISALLOW-TAB-TEST PFE-HOST PARSING-EXT and [IF] loadm parsing [ELSE] s" parsing.fs" included [THEN] PFE-HOST 0= [IF] cr [THEN] blue-text .( Loaded ) PARSING-LIB-S type .( .) cr normal-text \ \\ uncomment this very line to test \\ COMMENT File \\ test commented out. here 0 2constant "" \ empty string with arbitrary addr : "hello!" ( -- s ) s" hello!" ; : "h" ( -- s ) s" h" ; decimal 8 constant BS 9 constant HT 10 constant LF 13 constant CRET \ Convert a string to its right or left empty string. : >"" ( addr len -- addr+c[len] 0 ) chars + 0 ; : <"" ( addr len -- addr 0 ) drop 0 ; PFE-HOST [IF] "hello!" 4 /string -4 /string nip 0= [IF] \ avoid pfe /STRING negative index bug \ Assume that len >= 0 and (len -i) >= 0: : cut-first ( addr len i -- addr+c[i] len-i ) >r r@ - swap r> chars + swap ; cr [THEN] [THEN] TESTING CUT-FIRST CUT-LAST KEEP-FIRST KEEP-LAST ( addr len i -- addr+i len-i ) t{ "hello!" 6 cut-first -> "hello!" >"" }t t{ "hello!" 3 cut-first -> "hello!" 3 /string }t t{ "hello!" 0 cut-first -> "hello!" }t t{ "hello!" 6 cut-first s" " compare -> 0 }t t{ "hello!" 3 cut-first s" lo!" compare -> 0 }t t{ "hello!" 0 cut-first s" hello!" compare -> 0 }t ( addr len i -- addr len-i ) t{ "hello!" 6 cut-last -> "hello!" <"" }t t{ "hello!" 3 cut-last -> "hello!" 3 - }t t{ "hello!" 0 cut-last -> "hello!" }t t{ "hello!" 6 cut-last s" " compare -> 0 }t t{ "hello!" 3 cut-last s" hel" compare -> 0 }t t{ "hello!" 0 cut-last s" hello!" compare -> 0 }t ( addr len i -- addr i ) t{ "hello!" 6 keep-first -> "hello!" }t t{ "hello!" 3 keep-first -> "hello!" 3 nip }t t{ "hello!" 0 keep-first -> "hello!" <"" }t t{ "hello!" 6 keep-first s" hello!" compare -> 0 }t t{ "hello!" 3 keep-first s" hel" compare -> 0 }t t{ "hello!" 0 keep-first s" " compare -> 0 }t ( addr len i -- addr+len-i i ) t{ "hello!" 6 keep-last -> "hello!" }t t{ "hello!" 3 keep-last -> "hello!" 3 /string }t t{ "hello!" 0 keep-last -> "hello!" >"" }t t{ "hello!" 6 keep-last s" hello!" compare -> 0 }t t{ "hello!" 3 keep-last s" lo!" compare -> 0 }t t{ "hello!" 0 keep-last s" " compare -> 0 }t \ These two allow negative i: t{ "hello!" 4 cut-first -4 cut-first -> "hello!" }t t{ "hello!" 4 cut-last -4 cut-last -> "hello!" }t TESTING STRING/ END-C@ SKIP /SPLIT SCAN WHITE? t{ "hello!" 6 string/ -> "hello!" }t t{ "hello!" 3 string/ -> "hello!" 3 cut-first }t t{ "hello!" 0 string/ -> "hello!" >"" }t t{ "hello!" end-c@ -> char ! }t t{ "h" end-c@ -> char h }t : "ccchello!" ( -- s ) s" ccchello!" ; : "hello!ccc" ( -- s ) s" hello!ccc" ; : "xyz" ( -- s ) s" xyz" ; here lf c, bl c, cret c, ( addr) 3 chars 2constant "___" here lf c, bl c, cret c, char x c, char y c, char z c, ( addr) 6 chars 2constant "___xyz" here char x c, char y c, char z c, lf c, bl c, cret c, ( addr) 6 chars 2constant "xyz___" here ht c, bl c, cret c, char x c, char y c, char z c, cret c, bl c, ht c, ( addr) 9 chars 2constant "___xyz___" t{ "" char c skip -> "" }t t{ "ccchello!" char c skip -> "ccchello!" 3 cut-first }t t{ "ccchello!" char d skip -> "ccchello!" }t t{ "" bl skip -> "" }t t{ "ccchello!" bl skip -> "ccchello!" }t t{ "___" bl skip -> "___" >"" }t t{ "___xyz" bl skip -> "___xyz" 3 cut-first }t t{ "ccchello!" 2dup char c skip /split -> "ccchello!" 3 cut-first "ccchello!" 3 keep-first }t t{ "" "" /split -> "" "" }t t{ "hello!" 2dup >"" /split -> "hello!" >"" "hello!" }t t{ "" char c scan -> "" }t t{ "ccchello!" char c scan -> "ccchello!" }t t{ "ccchello!" char h scan -> "ccchello!" 3 cut-first }t t{ "ccchello!" char d scan -> "ccchello!" >"" }t t{ "" bl scan -> "" }t t{ "ccchello!" bl scan -> "ccchello!" >"" }t t{ "___xyz" bl scan -> "___xyz" }t t{ "xyz___" bl scan -> "xyz___" 3 cut-first }t : all-white? ( -- flag ) true >r 33 0 DO i white? r> and >r LOOP r> ; t{ all-white? -> true }t t{ bl 1+ white? -> false }t s" MAX-U" environment? [IF] constant MAX-U t{ MAX-U white? -> false }t [ELSE] COMMENT System doesn't know MAX-U environment query. [THEN] TESTING SKIP-BACK TRIM| |TRIM |TRIM| SCAN-BACK SEEK t{ "" char c skip-back -> "" }t t{ "hello!ccc" char c skip-back -> "hello!ccc" 3 cut-last }t t{ "hello!ccc" char d skip-back -> "hello!ccc" }t t{ "" bl skip-back -> "" }t t{ "hello!ccc" bl skip-back -> "hello!ccc" }t t{ "___" bl skip-back -> "___" <"" }t t{ "xyz___" bl skip-back -> "xyz___" 3 keep-first }t t{ "" trim| -> "" }t t{ "hello!ccc" trim| -> "hello!ccc" }t t{ "___" trim| -> "___" <"" }t t{ "xyz___" trim| -> "xyz___" 3 keep-first }t t{ "" |trim -> "" }t t{ "___" |trim -> "___" >"" }t t{ "___xyz" |trim -> "___xyz" 3 cut-first }t t{ "" |trim| -> "" }t t{ "___" |trim| -> "___" >"" }t t{ "xyz___" |trim| -> "xyz___" 3 keep-first }t t{ "___xyz" |trim| -> "___xyz" 3 cut-first }t t{ "___xyz___" |trim| -> "___xyz___" 3 cut-first 3 cut-last }t 0 [IF] TESTING BACK (Tool Belt 2000) : BACK ( str len char -- str len-i ) >R BEGIN DUP WHILE 1- 2DUP CHARS + C@ R@ = UNTIL 1+ THEN R> DROP ; t{ "" char c BACK -> "" }t t{ "hello!ccc" char c BACK -> "hello!ccc" }t t{ "hello!ccc" char d BACK -> "hello!ccc" <"" }t t{ "" bl BACK -> "" }t t{ "hello!ccc" bl BACK -> "hello!ccc" <"" }t \ BL is literal, not whitespace in ToolBelt 2000. t{ "___" bl BACK -> "___" 1- }t t{ "xyz___" bl BACK -> "xyz___" 1- }t [THEN] 0 [IF] TESTING BACK (Tool Belt 2002) : COND 0 ; IMMEDIATE : THENS BEGIN DUP WHILE postpone THEN REPEAT DROP ; IMMEDIATE : BACK[ S" BEGIN dup WHILE 2dup end-c@ COND " EVALUATE ; IMMEDIATE : ]BACK S" THENS 0= WHILE 1- REPEAT THEN " EVALUATE ; IMMEDIATE : Is-White ( char -- flag ) 33 - 0< ; : BACK ( str /str char -- str /str-i ) dup BL = IF DROP BACK[ Is-White ]BACK ELSE >R BACK[ R@ = ]BACK R> DROP THEN ; t{ "" char c BACK -> "" }t t{ "hello!ccc" char c BACK -> "hello!ccc" }t t{ "hello!ccc" char d BACK -> "hello!ccc" <"" }t t{ "" bl BACK -> "" }t t{ "hello!ccc" bl BACK -> "hello!ccc" <"" }t t{ "___" bl BACK -> "___" }t t{ "xyz___" bl BACK -> "xyz___" }t [THEN] t{ "" char c scan-back -> "" }t t{ "hello!ccc" char c scan-back -> "hello!ccc" }t t{ "hello!ccc" char d scan-back -> "hello!ccc" <"" }t t{ "" bl scan-back -> "" }t t{ "hello!ccc" bl scan-back -> "hello!ccc" <"" }t t{ "___" bl scan-back -> "___" }t t{ "xyz___" bl scan-back -> "xyz___" }t t{ "" char c seek -> "" false }t t{ "ccchello!" char c seek -> "ccchello!" 1 cut-first true }t t{ "ccchello!" char h seek -> "ccchello!" 4 cut-first true }t t{ "ccchello!" char d seek -> "ccchello!" >"" false }t t{ "" bl seek -> "" false }t t{ "ccchello!" bl seek -> "ccchello!" >"" false }t t{ "___xyz" bl seek -> "___xyz" 1 cut-first true }t t{ "xyz___" bl seek -> "xyz___" 4 cut-first true }t TESTING S-STARTS S-ENDS t{ "hello!ccc" s" hel" s-starts -> "hello!ccc" true }t t{ "hello!ccc" s" hem" s-starts -> "hello!ccc" false }t t{ "hello!ccc" s" HEL" s-starts -> "hello!ccc" false }t t{ "h" "h" s-starts -> "h" true }t t{ "h" s" he" s-starts -> "h" false }t t{ "" "" s-starts -> "" true }t t{ "" "h" s-starts -> "" false }t t{ "h" "" s-starts -> "h" true }t t{ "hello!ccc" s" !ccc" s-ends -> "hello!ccc" true }t t{ "hello!ccc" s" ccd" s-ends -> "hello!ccc" false }t t{ "hello!ccc" s" CCC" s-ends -> "hello!ccc" false }t t{ "h" "h" s-ends -> "h" true }t t{ "h" s" he" s-ends -> "h" false }t t{ "" "" s-ends -> "" true }t t{ "" "h" s-ends -> "" false }t t{ "h" "" s-ends -> "h" true }t TESTING {}IN {}SCAN {}SEEK {}STARTS {}ENDS SEPARATE {}SEPARATE S-SEPARATE \ Strings with one HT whitespace char: here char a c, char b c, char c c, HT c, char e c, char f c, char g c, ( addr) 7 chars 2constant "abc\tefg" here char r c, char s c, char t c, HT c, ( addr) 4 chars 2constant "rst\t" here HT c, char u c, char v c, char w c, ( addr) 4 chars 2constant "\tuvw" \ True substrings: "abc\tefg" 3 keep-first 2constant "abc" "abc\tefg" 3 string/ 2constant "efg" "rst\t" 3 keep-first 2constant "rst" "\tuvw" 3 string/ 2constant "uvw" t{ "abc\tefg" BL separate -> "efg" "abc" true }t t{ "abc\tefg" HT separate -> "efg" "abc" true }t t{ "abc\tefg" char d separate -> "abc\tefg" false }t t{ "hello!" char h separate -> "hello!" 1 cut-first "hello!" <"" true }t t{ "hello!" char ! separate -> "hello!" >"" "hello!" 1 cut-last true }t t{ "rst\t" BL separate -> "rst\t" >"" "rst" true }t t{ "rst\t" HT separate -> "rst\t" >"" "rst" true }t t{ "\tuvw" BL separate -> "uvw" "\tuvw" <"" true }t t{ "\tuvw" HT separate -> "uvw" "\tuvw" <"" true }t t{ "" char d separate -> "" false }t t{ "" BL separate -> "" false }t t{ "h" char h separate -> "h" >"" "h" <"" true }t create {\tabc} ht c, char a c, char b c, char c c, 0 c, create {_xyz} bl c, char x c, char y c, char z c, 0 c, create {bw} char b c, char w c, 0 c, create {hg} char h c, char g c, 0 c, create {} 0 c, t{ bl {\tabc} {}in -> 0 }t t{ ht {\tabc} {}in -> ht }t t{ char c {\tabc} {}in -> char c }t t{ 0 {\tabc} {}in -> 0 }t t{ char c {} {}in -> 0 }t t{ 0 {} {}in -> 0 }t t{ "abc\tefg" {\tabc} {}scan -> "abc\tefg" }t t{ "abc\tefg" {_xyz} {}scan -> "abc\tefg" >"" }t t{ "abc\tefg" {bw} {}scan -> "abc\tefg" 1 cut-first }t t{ "abc\tefg" {hg} {}scan -> "abc\tefg" 1 keep-last }t t{ "rst" {\tabc} {}scan -> "rst" >"" }t t{ "" {bw} {}scan -> "" }t t{ "abc\tefg" {\tabc} {}seek -> "abc\tefg" 1 cut-first char a }t t{ "abc\tefg" {_xyz} {}seek -> "abc\tefg" >"" 0 }t t{ "abc\tefg" {bw} {}seek -> "abc\tefg" 2 cut-first char b }t t{ "abc\tefg" {hg} {}seek -> "abc\tefg" >"" char g }t t{ "rst" {\tabc} {}seek -> "rst" >"" 0 }t t{ "" {bw} {}seek -> "" 0 }t t{ "abc\tefg" {\tabc} {}starts -> "abc\tefg" char a }t t{ "abc\tefg" {_xyz} {}starts -> "abc\tefg" 0 }t t{ "abc\tefg" {bw} {}starts -> "abc\tefg" 0 }t t{ "abc\tefg" {hg} {}starts -> "abc\tefg" 0 }t t{ "abc\tefg" {} {}starts -> "abc\tefg" 0 }t t{ "" {bw} {}starts -> "" 0 }t t{ "" {} {}starts -> "" 0 }t t{ "abc\tefg" {\tabc} {}ends -> "abc\tefg" 0 }t t{ "abc\tefg" {_xyz} {}ends -> "abc\tefg" 0 }t t{ "abc\tefg" {bw} {}ends -> "abc\tefg" 0 }t t{ "abc\tefg" {hg} {}ends -> "abc\tefg" char g }t t{ "abc\tefg" {} {}ends -> "abc\tefg" 0 }t t{ "" {bw} {}ends -> "" 0 }t t{ "" {} {}ends -> "" 0 }t t{ "abc\tefg" {\tabc} {}separate -> "abc\tefg" 1 cut-first "abc\tefg" <"" char a }t t{ "abc\tefg" {bw} {}separate -> "abc\tefg" 2 cut-first "abc\tefg" 1 keep-first char b }t t{ "abc\tefg" {hg} {}separate -> "abc\tefg" >"" "abc\tefg" 1 cut-last char g }t t{ "abc\tefg" {_xyz} {}separate -> "abc\tefg" 0 }t t{ "h" {hg} {}separate -> "h" >"" "h" <"" char h }t t{ "rst" {\tabc} {}separate -> "rst" 0 }t t{ "" {bw} {}separate -> "" 0 }t t{ "hello!" s" ll" s-separate -> "hello!" 2 keep-last "hello!" 2 keep-first true }t t{ "hello!" s" h" s-separate -> "hello!" 1 cut-first "hello!" <"" true }t t{ "hello!" s" !" s-separate -> "hello!" >"" "hello!" 1 cut-last true }t t{ "hello!" "hello!" s-separate -> "hello!" >"" "hello!" <"" true }t t{ "hello!" "" s-separate -> "hello!" "hello!" <"" true }t t{ "hello!" "hello!ccc" s-separate -> "hello!" false }t t{ "hello!" s" hello!c" s-separate -> "hello!" false }t t{ "hello!" s" hl" s-separate -> "hello!" false }t t{ "" s" " s-separate -> "" "" true }t t{ "" "h" s-separate -> "" false }t TESTING S-AFTER FIRST-WORD SEPARATE-WORD t{ "" "" s-after -> "" }t t{ "abc\tefg" "abc" s-after -> "abc\tefg" 3 cut-first }t t{ "abc\tefg" "efg" s-after -> "abc\tefg" >"" }t t{ "abc" "abc" s-after -> "abc" >"" }t t{ "abc" "abc" <"" s-after -> "abc" }t t{ "abc" "abc" >"" s-after -> "abc" >"" }t t{ "abc" "abc" 1 cut-first 1 cut-last s-after -> "abc" 1 keep-last }t t{ "" first-word -> "" }t t{ "abc" first-word -> "abc" }t t{ "___" first-word -> "___" >"" }t t{ "___xyz" first-word -> "___xyz" 3 keep-last }t t{ "xyz___" first-word -> "xyz___" 3 keep-first }t t{ "___xyz___" first-word -> "___xyz___" 3 cut-first 3 cut-last }t t{ "" separate-word -> "" "" }t t{ "abc" separate-word -> "abc" >"" "abc" }t t{ "___" separate-word -> "___" >"" 2dup }t t{ "___xyz" separate-word -> "___xyz" >"" "___xyz" 3 keep-last }t t{ "xyz___" separate-word -> "xyz___" 2 keep-last "xyz___" 3 keep-first }t t{ "___xyz___" separate-word -> "___xyz___" 2 keep-last "___xyz___" 3 cut-first 3 cut-last }t TESTING WHITE-DELIMITED? : "ab" s" ab" ; : "ab_c" s" ab c" ; : "c_ab" s" c ab" ; : "_ab_" s" ab " ; t{ "ab" "ab" white-delimited? -> true }t t{ "ab_c" 2 keep-first "ab_c" white-delimited? -> true }t t{ "c_ab" 2 keep-last "c_ab" white-delimited? -> true }t t{ "_ab_" 1 cut-first 1 cut-last "_ab_" white-delimited? -> true }t t{ "ab" 1 cut-first "ab" white-delimited? -> false }t t{ "ab" 1 cut-last "ab" white-delimited? -> false }t t{ "ab_c" 1 cut-first 1 cut-last "ab_c" white-delimited? -> false }t t{ "ab_c" 1 cut-first 2 cut-last "ab_c" white-delimited? -> false }t t{ "ab" <"" 2dup white-delimited? -> true }t t{ "ab" <"" "ab" white-delimited? -> false }t t{ "_ab_" <"" "_ab_" white-delimited? -> true }t t{ "ab" >"" 2dup white-delimited? -> true }t t{ "ab" >"" "ab" white-delimited? -> false }t t{ "_ab_" >"" "_ab_" white-delimited? -> true }t TESTING PARSE-AREA-EMPTY? EMPTY-PARSE-AREA PARSE-NAME PREPARSE-NAME t{ s" parse-area-empty?" evaluate -> true }t \ Testing the position of the input stream after words that move \ in it is tricky. We make special versions of those words that \ record the input stream position, and use a vector so we can \ EVALUATE the same strings for both nonrecording and recording \ tests, to save writing. The vector is of course dangerous, so \ we check its value following each set of those tests. variable vector : vexec vector @ execute ; : "" s" vexec harry" ; : "" s" vexec harry" ; : "" s" vexec harry " ; : "" s" vexec harry " ; : "" s" vexec harry empty-parse-area" ; : "" s" vexec" ; : "" s" vexec " ; : "" s" vexec " ; ' parse-name vector ! t{ "" evaluate -> "" 5 keep-last }t t{ "" evaluate -> "" 5 keep-last }t t{ "" evaluate -> "" 1 cut-last 5 keep-last }t t{ "" evaluate -> "" 2 cut-last 5 keep-last }t t{ "" evaluate -> "" 17 cut-last 5 keep-last }t t{ "" evaluate -> "" >"" }t t{ "" evaluate -> "" >"" }t t{ "" evaluate -> "" >"" }t t{ ' parse-name -> vector @ }t : parse-name-rec parse-name >in @ ; : eval-snip ( s -- >in ) evaluate -rot 2drop ; \ abbreviation ' parse-name-rec vector ! t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" 1 cut-last nip }t t{ "" eval-snip -> "" s" empty-parse-area" nip cut-last nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ ' parse-name-rec -> vector @ }t : "" s" preparse-name 123" ; : "" s" preparse-name 123 " ; : "" s" preparse-name" ; : "" s" preparse-name " ; : "" s" preparse-name " ; t{ "" evaluate -> "" 3 keep-last 123 }t t{ "" evaluate -> "" 4 keep-last 3 keep-first 123 }t t{ "" evaluate -> "" >"" }t t{ "" evaluate -> "" >"" }t t{ "" evaluate -> "" >"" }t TESTING \\ PARSE-AREA@ PARSE-AREA! PARSE-NAME-AWAY >IN++ >IN-- t{ s" true \\ false" evaluate -> true }t \ do not change the spacing in the line below: t{ s" >in++ parse-area@ 0 drop" 2dup evaluate 2swap 19 cut-first d= -> true }t \ also tests >IN++ t{ s" source 5 keep-last parse-area! 4 2 1 +" evaluate -> 3 }t t{ s" source 37 cut-first 2dup parse-area! parse-area@ -12 cut-first d=" evaluate -> true }t \ right boundary t{ 3 2 s" >in--" evaluate -> 1 }t t{ 3 2 s" >in-- " evaluate -> 3 2 }t t{ 3 2 s" >in++" evaluate -> 3 2 }t t{ 3 2 s" >in++ +" evaluate -> 3 2 }t t{ 3 2 s" >in++ ++" evaluate -> 5 }t : >in+ ( u -- ) 0 ?DO >in++ LOOP ; : >in- ( u -- ) 0 ?DO >in-- LOOP ; \ left boundary t{ 1 -1 5 1 s" + >in-" evaluate -> }t \ back 6 t{ 1 -1 5 2 s" + >in-" evaluate -> }t \ back 7 t{ 1 -1 5 20 s" + >in-" evaluate -> }t \ back infinity t{ 1 0 4 1 s" + >in-" evaluate -> 1 }t \ back 5 \ left to right boundary t{ 3 2 19 0 s" >in+ source parse-area! +" evaluate -> 5 }t t{ 3 2 20 0 s" >in+ source parse-area! +" evaluate -> 3 2 }t t{ 3 2 30 0 s" >in+ source parse-area! +" evaluate -> 3 2 }t : "" s" vexec harry 123" ; : "" s" vexec harry 123" ; : "" s" vexec harry" ; : "" s" vexec harry " ; \ normal PARSE-NAME-AWAY ' parse-name-away vector ! t{ "" evaluate -> 123 }t t{ "" evaluate -> 123 }t t{ "" evaluate -> }t t{ "" evaluate -> }t t{ ' parse-name-away -> vector @ }t : parse-name-away-rec parse-name-away >in @ ; ' parse-name-away-rec vector ! t{ "" evaluate drop -> "" 3 cut-last nip }t t{ "" evaluate drop -> "" 4 cut-last nip }t t{ "" evaluate -> "" nip }t t{ "" evaluate -> "" 1 cut-last nip }t t{ ' parse-name-away-rec -> vector @ }t TESTING ?EMIT-CR NEXT-INSTREAM-NAME \ DON'T rearrange the across-line tests! source-id [IF] COMMENT You should see "1" and "2" on the same line: [ELSE] COMMENT You should see "1" and 2" on separate lines: [THEN] ?emit-cr .( 1) ?emit-cr .( 2) cr t{ next-instream-name 123 evaluate -> 123 }t t{ next-instream-name 123 evaluate -> 123 }t t{ next-instream-name 123 evaluate -> 123 }t t{ next-instream-name 123 s" 123" s= -> true }t t{ next-instream-name 123 s" 123" s= -> true }t t{ next-instream-name 123 s" 123" s= -> true }t t{ next-instream-name 123 s" 123" s= -> true }t : nin1 s" next-instream-name" ; : nin2 s" next-instream-name " ; t{ nin1 evaluate -> nin1 >"" }t t{ nin2 evaluate -> nin2 >"" }t : next-instream-name-rec next-instream-name >in @ ; \ We assume the line-crossing action is okay from above. ' next-instream-name-rec vector ! t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" 1 cut-last nip }t t{ "" eval-snip -> "" s" empty-parse-area" nip cut-last nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ "" eval-snip -> "" nip }t t{ ' next-instream-name-rec -> vector @ }t TESTING S-SEEK-INSTREAM |S|-SEEK-INSTREAM \ DON'T rearrange the across-line tests! t{ s" 123" s-seek-instream g123456 -> true 456 }t t{ s" 123" s-seek-instream g123456 -> true 456 }t t{ s" 123" s-seek-instream g123456 -> true 456 }t t{ s" 1 2 3" s-seek-instream 456g1 2 31 2 34 -> true 4 }t t{ s" 1 2 3" s-seek-instream 456g1 2 3 1 2 34 -> true 4 }t t{ s" 1 2 3" s-seek-instream g 1 2 3456 -> true 456 }t \ The input stream position for S-SEEK-INSTREAM is already \ tested by the above. We'll need extra tests for \ |S|-SEEK-INSTREAM to be sure it doesn't skip a trailing \ whitespace character. t{ s" 123" |s|-seek-instream g 123 456 -> true 456 }t t{ s" 123" |s|-seek-instream g 123 456 -> true 456 }t t{ s" 123" |s|-seek-instream g 123 456 -> true 456 }t t{ s" 123" |s|-seek-instream 123 456 -> true 456 }t t{ s" 123" |s|-seek-instream 123 456 -> true 456 }t t{ s" 1 2 3" |s|-seek-instream g 1 2 3 456 -> true 456 }t t{ s" 123" |s|-seek-instream 123 456 -> true 456 }t t{ s" 123 " |s|-seek-instream g 123 456 -> true 456 }t t{ s" " |s|-seek-instream 456 -> true 456 }t t{ s" 123" |s|-seek-instream 12344 123 456 -> true 456 }t t{ s" 123" |s|-seek-instream gg123 123 456 -> true 456 }t t{ s" 111" |s|-seek-instream 1111 111 456 -> true 456 }t t{ s" 1 23" |s|-seek-instream g 1 23 456 -> true 456 }t \ The following input stream position tests for \ |S|-SEEK-INSTREAM do not go across lines. We assume the \ line-crossing action is okay from above. 0 [IF] \ repeated for convenience : "" s" vexec harry 123" ; : "" s" vexec harry 123" ; : "" s" vexec harry" ; : "" s" vexec harry " ; [THEN] : |s|-seek-instream-rec |s|-seek-instream >in @ ; ' |s|-seek-instream-rec vector ! t{ s" harry" "" evaluate -> true "" 4 cut-last nip 123 }t t{ s" harry" "" evaluate -> true "" 5 cut-last nip 123 }t t{ s" harry " "" evaluate -> true "" 4 cut-last nip 123 }t t{ s" harry" "" evaluate -> true "" nip }t t{ s" harry" "" evaluate -> true "" 2 cut-last nip }t t{ ' |s|-seek-instream-rec -> vector @ }t COMMENT Empty string not tested: S-SEEK-INSTREAM |S|-SEEK-INSTREAM : nwtbf ( xt -- ) >r s" nowhere to be found" r> execute ." parse area length: " parse-area@ . drop 0= ABORT" ***string not found across lines" ; \ Uncomment one of the following to test the false case for \ S-SEEK-INSTREAM, or |S|-SEEK-INSTREAM. The parse area length \ should be zero. \ ' s-seek-instream nwtbf \ ' |s|-seek-instream nwtbf DISALLOW-TAB-TEST [IF] COMMENT Using spaces as whitespace in |S|-SEEK-INSTREAM test. t{ s" 1 23" |s|-seek-instream g 1 23 456 -> true 456 }t [ELSE] COMMENT Using tabs as whitespace in |S|-SEEK-INSTREAM test. \ Do not remove the tabs in the following line: t{ s" 1 23" |s|-seek-instream g 1 23 456 -> true 456 }t [THEN] (* This comment should be ignored, and the input stream should resume after its "*)" terminator. *) COMMENT "(*" white-delimited interpretation comment ignored : pa@-1 ( -- flag ) (* This comment tests the immediacy of (*. *) s" parse-area@" 2dup + >r evaluate r> 0 d= ; t{ pa@-1 -> true }t \ tests (* COMMENT "(*" white-delimited compilation comment ignored [DEFINED] --- [IF] --- Here's another comment to be ignored. --- COMMENT "---" white-delimited interpretation comment ignored [THEN] [DEFINED] (( [IF] (( Here's another comment to be ignored. )) COMMENT "((" white-delimited interpretation comment ignored [THEN] \ Uncomment the following to test nontermination of (*: \ (* This is an unterminated comment. VERBOSE @ [IF] blue-text .( #ERRORS: ) #errors . normal-text cr [THEN]