\     File:  mstrings-test.fs
\    Title:  Tests for measured string words
\   Author:  David N. Williams
\  License:  Public Domain
\  Version:  0.8.4
\  Revised:  November 20, 2008

s" ttester.fs" included  \ gforth cvs revision 1.13 known to work
true VERBOSE !

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 ;

\ Uncomment to test with pfe parsing module:
\ true value PARSING-EXT  \ default in mstrings.fs is FALSE

s" mstrings-0end.fs"   required
s" mstrings-linput.fs" required  \ all sublibs now loaded

decimal

PARSING-EXT [IF]
  COMMENT Using pfe parsing module.
[ELSE]
  PFE-HOST 0= [IF] cr [THEN]
  COMMENT Using parsing.fs.
[THEN]

[UNDEFINED] cell [IF] 1 cells constant cell [THEN]

\ WARNING:  In pfe, PAD moves when HERE changes and can get
\ unaligned.  Use MPAD instead.

256 constant #mpad-chars
create mpad #mpad-chars chars cell+ allot

\ Useful for inspecting dumps:
: 0mpad  ( -- )  0 mpad ! mpad cell+  #mpad-chars 0 fill ; 

\ Uncomment to check the result of 0MPAD:
0 [IF]
0mpad mpad #mpad-chars chars cell+ dump \\
[THEN]

create m"hello" 5 ,
  char h c, char e c, char l c, char l c, char o c,
m"hello" cell+ 5 2constant "hello"

create m"" 0 ,
m"" cell+ 0 2constant ""

: s=      ( s1 s2 -- flag )  compare 0= ;
: mpad=   ( s -- n )     mpad mcount s= ;
: c>/buf  ( #chars -- c[#chars]+cell )  chars cell+ ;
: s>/buf  ( s -- c[s.len]+cell )        nip c>/buf ;

t{ "hello" s" hello" s= -> true }t
t{ "hello" s" hell"  s= -> false }t
t{ "hello" ""        s= -> false }t
t{ "" s" "           s= -> true }t

TESTING  MCOUNT -MCOUNT (M+) (M!) /M MROOM? M+ROOM? M+ M!

t{ m"hello" mcount -> "hello" }t
t{ "hello" mpad (m!) mpad mcount -> mpad cell+ "hello" nip }t
t{ s" hello" mpad= -> true }t \ uses MCOUNT
t{ s" " mpad (m!) mpad mcount -> mpad cell+ 0 }t

t{ "hello" -mcount -> m"hello" }t

\ (m!)  ( s a-addr -- )
\ (m+)  ( s m -- )

t{ s" Hello," 2dup mpad (m!) mpad= -> true }t
t{ s"  world!" mpad (m+) s" Hello, world!" mpad= -> true }t
t{ s" " mpad (m+) s" Hello, world!" mpad= -> true }t
t{ s" " mpad (m!) s" " mpad= -> true }t
t{ s" Hello, world!" 2dup nip mpad ! mpad= -> true }t
t{ s" " mpad (m!) s" testing" 2dup mpad (m+) mpad= -> true }t

\ /m  ( len -- c[len]+cell )

t{ 0 /m -> 1 cells }t
t{ 1 /m -> 1 chars cell+ }t

\ mroom?  ( len mbuf /mbuf -- len mbuf flag )

0 mpad !
t{ 0 mpad cell 1-  mroom? -> 0 mpad false }t
t{ 0 mpad cell     mroom? -> 0 mpad true }t
t{ 1 mpad cell     mroom? -> 1 mpad false }t
t{ 1 mpad 1 c>/buf mroom? -> 1 mpad true }t
t{ 2 mpad 2 c>/buf mroom? -> 2 mpad true }t
t{ 3 mpad 2 c>/buf mroom? -> 3 mpad false }t
t{ s" " mpad= -> true }t

\ m+room?  ( len mbuf /mbuf -- len mbuf flag )

t{ 0 mpad cell 1- m+room? -> 0 mpad false }t
t{ 0 mpad cell    m+room? -> 0 mpad true }t
t{ 1 mpad cell    m+room? -> 1 mpad false }t

"hello" mpad (m!)
t{ 0 mpad cell 1-           m+room? -> 0 mpad false }t
t{ 0 mpad "hello" s>/buf    m+room? -> 0 mpad true }t
t{ 1 mpad "hello" s>/buf    m+room? -> 1 mpad false }t
t{ 1 mpad "hello" 1+ s>/buf m+room? -> 1 mpad true }t
t{ 2 mpad "hello" 1+ s>/buf m+room? -> 2 mpad false }t

\ m!  ( s mbuf /mbuf -- flag )

t{ s" testing" mpad over c>/buf    m! -> true }t
t{ s" testing" mpad over 1- c>/buf m! -> false }t
t{ s" " mpad cell                  m! -> true }t
t{ mpad mcount -> mpad cell+ 0 }t

\ m+  ( s mbuf /mbuf -- flag )

s" Hello," mpad (m!)
t{ s"  world!" mpad s" Hello, world!" s>/buf m+ -> true }t
t{ s" Hello, world!" mpad= -> true }t
t{ s" " mpad        s" Hello, world!" s>/buf m+ -> true }t
t{ s" Hello, world!" mpad= -> true }t

s" Hello," mpad (m!)
t{ s"  world!" mpad s" Hello, world!" 1- s>/buf m+ -> false }t
t{ s" Hello," mpad= -> true }t

TESTING  M, M,S (M+,) ?MCONTIG-DATA M+,

0 value mhere

: m=      ( s m -- flag ) mcount s= ;
: mhere=  ( s -- flag )   mhere mcount s= ;
: mafter  ( m -- m' )     mcount chars + ;

\ m,  ( s -- )

align  \ just in case
here to mhere
t{ s" testing" 2dup m, mhere= -> true }t
t{ mhere mafter -> here }t 

t{ here 1 and -> 1 }t
here to mhere  \ unaligned unless trivally aligned
t{ s" 1" 2dup m, mhere aligned m= -> true }t
t{ mhere aligned mafter -> here }t

1 allot
here to mhere
t{ s" " 2dup m, mhere aligned m= -> true }t
t{ mhere aligned mafter -> here }t

\ (m+,)  ( s m -- )

align here to mhere
s" Hello," m,
t{ s"  world!" mhere (m+,) -> }t
t{ mhere mafter -> here }t 
t{ s" Hello, world!" mhere= -> true }t
t{ mhere mafter -> here }t 
t{ here s" " mhere   (m+,) -> here }t
t{ mhere mafter -> here }t 
t{ s" Hello, world!" mhere= -> true }t
align

\ m+,  ( s m -- )

\ Same tests as for (M+,).
align here to mhere
s" Hello," m,
t{ s"  world!" mhere m+, -> }t
t{ mhere mafter -> here }t 
t{ s" Hello, world!" mhere= -> true }t
t{ mhere mafter -> here }t 
t{ here s" " mhere   m+, -> here }t
t{ mhere mafter -> here }t 
t{ s" Hello, world!" mhere= -> true }t
align

\ Uncomment to test noncontiguity abort, ?MCONTIG-DATA:
\ here to mhere s" 1234" m, 1 chars allot s" x" mhere m+,

\ m,s  ( s -- s' )

here to mhere
t{ s" testing" 2dup m,s s= -> true }t
t{ mhere mafter -> here }t 

align here to mhere
t{ s" " 2dup m,s s= -> true }t
t{ mhere mafter -> here }t

align 1 chars allot here to mhere
t{ s" 1" m,s -> mhere aligned mcount }t
t{ mhere aligned mafter -> here }t
t{ s" 1" mhere aligned m= -> true }t

TESTING  (NULL-M+) NULL-M+ NULL-M+,

\ (null-m+)  ( m -- )

t{ s" testing" mpad (m!) mpad (null-m+) -> }t
t{ mpad mafter c@ -> 0 }t
t{ s" " mpad (m!)        mpad (null-m+) -> }t
t{ mpad mafter c@ -> 0 }t

\ null-m+  ( mbuf /mbuf -- flag )

t{ s" testing" 2dup mpad (m!) s>/buf mpad swap    null-m+ -> false }t
t{ s" testing" 2dup mpad (m!) 1+ s>/buf mpad swap null-m+ -> true }t
t{ mpad mafter c@ -> 0 }t

\ null-m+,  ( -- )

s" testing" m,s -mcount to mhere
t{ null-m+, -> }t
t{ mhere mcount 1+ chars + -> here }t
t{ s" testing" mhere m= -> true }t

\ INPUT WORDS

TESTING  EOL-S

s" ANSForth-eol-tempfile" m,s 2constant name

name r/w open-file nip ( ior) 0=
[IF]
red-text .( Can't test EOL-S, file already exists: )
blue-text name type cr normal-text
[ELSE]
name r/w bin create-file throw value id
s" " id write-line throw
id file-size throw 2drop
0 0 id reposition-file throw
t{ mpad 4 id read-file throw ( #chars)
   mpad swap eol-s s= -> true }t
name delete-file throw
[THEN]

[UNDEFINED] cell [IF] 1 cells constant cell [THEN]

eol-s chars constant /eol ( addr) drop

\ single line strings

s" "          m,s 2constant empty-s
s" 1"         m,s 2constant s1
s" 12"        m,s 2constant s2
s" 12345678"  m,s 2constant s8
s" 123456789" m,s 2constant s9

\ multiline strings (MPAD has at least 252 chars)

: mpad-m,s  ( -- )  mpad mcount m,s ;

0 mpad !
s9 mpad (m+)   eol-s mpad (m+)   s2 mpad (m+)
mpad-m,s 2constant ml1

0 mpad !
s8 mpad (m+)   eol-s mpad (m+)   s1 mpad (m+)
mpad-m,s 2constant ml2

0 mpad !
s9 mpad (m+)   eol-s mpad (m+)
mpad-m,s 2constant ml3

0 mpad !
eol-s mpad (m+)   s8 mpad (m+)
mpad-m,s 2constant ml4

0 mpad !
eol-s mpad (m+)   ml4 mpad (m+)
mpad-m,s 2constant ml5

TESTING  UPTO-M! UPTO-M+ M!" M!` M+" M+`

\ Note that input resumes immediately after the delimiting character.
\ DO NOT CHANGE SPACING OR LINE BREAKS FOR INPUT STRINGS!

\ upto-m!  ( "<lines><char>" mbuf /mbuf char  -- room? found? )
\ upto-m+  ( "<lines><char>" mbuf /mbuf char  -- room? found? )

t{ mpad s9 s>/buf char # upto-m! 123456789#-> true true }t
t{ s9 mpad= -> true }t

t{ mpad ml1 1- s>/buf char 3 upto-m+
123 -> false true 123 }t

s9 mpad (m!)
t{ mpad ml1 s>/buf char # upto-m+
12#-> true true }t
t{ ml1 mpad= -> true }t

0 mpad !
t{ mpad ml1 s>/buf char # upto-m+ 123456789
12# -> true true }t
t{ ml1 mpad= -> true }t

t{ mpad ml1 s>/buf char # upto-m+ # -> true true }t
t{ ml1 mpad= -> true }t

t{ mpad 8 chars cell+ char 9 upto-m! 0123456789
  -> false true 0123456789 }t
t{ mpad mcount s" " s= -> true }t

t{ mpad ml1 s>/buf char # upto-m! 123456789
12#-> true true }t
t{ ml1 mpad= -> true }t

t{ mpad ml2 s>/buf char # upto-m! 12345678
1#-> true true }t
t{ ml2 mpad= -> true }t

t{ mpad ml3 s>/buf char # upto-m! 123456789
#-> true true }t
t{ ml3 mpad= -> true }t

t{ mpad ml4 s>/buf char # upto-m!
12345678#-> true true }t
t{ ml4 mpad= -> true }t

0 mpad !
t{ mpad cell char # upto-m+ # -> true true }t
t{ empty-s mpad= -> true }t

t{ mpad cell char # upto-m! # -> true true }t
t{ empty-s mpad= -> true }t

t{ mpad 8 chars cell+ char 9 upto-m! 12345678
19 -> false false 19 }t
t{ mpad mcount s" 12345678" s= -> true }t

t{ mpad 8 chars cell+ /eol + char 9 upto-m! 12345678
19 -> false true 19 }t
t{ mpad mcount ml2 1 cut-last s= -> true }t

\ Uncomment the following to test for the delimiter not found
\ before the end of the file.  Note that pfe clears the data
\ stack after this test, while gforth leaves the expected output
\ of UPTO-M!, ( true false).
0 [IF]
5000 constant /mbuf  \ enough to include the rest of this file
create mbuf /mbuf allot
COMMENT Execute "mbuf mcount type" to see the rest of the file.
mbuf /mbuf 0 upto-m!  \ null char not in this file
[THEN]

\ m!" m+" m!` m+` ( "<lines><char>" mbuf /mbuf -- flag )

t{ mpad s8 s>/buf m!" 12345678" s8 mpad= -> true true }t
t{ mpad cell m!" " empty-s         mpad= -> true true }t
t{ mpad s2 s>/buf cell+ m!` 12` s2 mpad= -> true true }t
t{ mpad cell m!` ` empty-s         mpad= -> true true }t

t{ mpad ml2 s>/buf m!" 12345678
1" ml2 mpad= -> true true }t

t{ mpad ml3 s>/buf m!` 123456789
` ml3 mpad= -> true true }t

t{ mpad ml4 s>/buf m!"
12345678" ml4 mpad= -> true true }t

t{ mpad ml5 s>/buf m!"

12345678"ml5 mpad= -> true true }t

s8 mpad (m!)
t{ mpad s8 s>/buf /eol + m+`
` -> true }t
t{ mpad dup mcount s>/buf m+` ` -> true }t
t{ mpad ml2 s>/buf m+" 1" ml2 mpad= -> true true }t

0 mpad !
t{ mpad cell m+" " -> true }t
t{ mpad s9 s>/buf m+" 123456789" -> true }t
t{ s9 mpad= -> true }t

TESTING  UPTO-M,S M,S" M,S` M" M`

\ DO NOT CHANGE SPACING OR LINE BREAKS FOR INPUT STRINGS!

\ upto-m,s  ( "<lines><char>" char -- s )

t{ char # upto-m,s 123456789#s9 s= -> true }t
t{ char # upto-m,s # empty-s    s= -> true }t

t{ char # upto-m,s 123456789
12#ml1 s= -> true }t

t{ char # upto-m,s 12345678
1#ml2 s= -> true }t

t{ char # upto-m,s 123456789
#  ml3 s= -> true }t

t{ char # upto-m,s
12345678# ml4 s= -> true }t

\ Uncomment to test delimiter not found:
0 [IF]  \ assume data space can contain the rest of this file
0 upto-m,s \ null char not in this file
[THEN]


\ m,s"  ( "<lines><">" -- s )
\ m,s`  ( "<lines><`>" -- s )

\ interpret

t{ m,s" 12345678" s8 s= -> true }t
t{ m,s" "empty-s     s= -> true }t
t{ m,s` 12` s2       s= -> true }t
t{ m,s` `  empty-s   s= -> true }t

t{ m,s" 12345678
1"ml2 s= -> true }t

t{ m,s` 123456789
` ml3 s= -> true }t

t{ m,s"
12345678"  ml4 s= -> true }t

\ use in a definition

: dfn-m,s"  ( "<lines><">" -- s )  m,s" ;
: dfn-m,s`  ( "<lines><`>" -- s )  m,s` ;

t{ dfn-m,s" 12345678" s8 s= -> true }t
t{ dfn-m,s" "empty-s     s= -> true }t
t{ dfn-m,s` 12` s2       s= -> true }t
t{ dfn-m,s` `  empty-s   s= -> true }t

t{ dfn-m,s" 12345678
1"ml2 s= -> true }t

t{ dfn-m,s` 123456789
` ml3 s= -> true }t

t{ dfn-m,s"
12345678"  ml4 s= -> true }t

\ The following is tested implicity through M" and M`:
\ m"<lines><char>"  \ compile:  ( "<lines><char>" char -- )
\                   \ run:      ( -- s )

: [empty]  m" " ;
t{ [empty] s" " s= -> true }t

: [123]  m` 123` ;
t{ [123] s" 123" s= -> true }t

: [ml1]  m" 123456789
12" ;
t{ [ml1] ml1 s= -> true }t

: [ml2]  m` 12345678
1` ;
t{ [ml2] ml2 s= -> true }t

: [ml3]  m" 123456789
" ;
t{ [ml3] ml3 s= -> true }t

: [ml4]  m`
12345678` ;
t{ [ml4] ml4 s= -> true }t

: [ml5]  m"

12345678" ;
t{ [ml5] ml5 s= -> true }t

\ Uncomment to test interpret mode exception:
\ m" 123"

TESTING  S-UPTO-M,+ S-UPTO-M,S |S|-UPTO-M,S

\ s-upto-m+,  ( "<lines><pat.body>" pat.s m -- )
\ Across line tests are implicit, through S-UPTO-M,S.

here aligned to mhere s" 123" m,
t{ s" 123" mhere= -> true }t
t{ s" END" mhere s-upto-m+, 45ENDs" 12345" mhere= -> true }t
t{ here dup aligned = -> false }t

\ Uncomment to test noncontiguity abort:
0 [IF]
here to mhere s" 1234" m, 1 chars allot
s" END" mhere s-upto-m+, 56END
[THEN]

\ s-upto-m,s  ( "<lines><pat.body>" pat.s -- lines.s )

t{ s" END" s-upto-m,s 123456789ENDs9 s= -> true }t
t{ s" END" s-upto-m,s END empty-s    s= -> true }t
t{ s" END" s-upto-m,s
END eol-s s= -> true }t

t{ s" END" s-upto-m,s 123456789
12END ml1 s= -> true }t

t{ s" END" s-upto-m,s 12345678
1ENDml2 s= -> true }t

t{ s" END" s-upto-m,s 123456789
END  ml3 s= -> true }t

t{ s" END" s-upto-m,s
12345678END ml4 s= -> true }t

\ Uncomment to test string not found:
0 [IF]  \ assume data space can contain the rest of this file
s" nowhere to be found" s-upto-m,s \ should not be in this file
[THEN]

\ |s|-upto-m,s  ( "<lines><ws><pat.body><ws>" pat.s -- lines.s )

t{ s" END" |s|-upto-m,s 123456789 END s9 s= -> true }t
t{ s" END" |s|-upto-m,s END empty-s s= -> true }t
t{ s" END" |s|-upto-m,s
END eol-s s= -> true }t

t{ s" END" |s|-upto-m,s 123456789
12 END ml1 s= -> true }t

t{ s" END" |s|-upto-m,s 12345678
1 END  ml2 s= -> true }t

t{ s" END" |s|-upto-m,s 123456789
END
ml3 s= -> true }t  \ "END" starts text buffer with empty parse area

t{ s" END" |s|-upto-m,s 123456789
END ml3 s= -> true }t \ "END" starts text buffer with nonempty parse area

t{ s" END" |s|-upto-m,s
12345678 END ml4 s= -> true }t

t{ s" END" |s|-upto-m,s 12END3 END s" 12END3" s= -> true }t
t{ s" END" |s|-upto-m,s 12 END3  END s" 12 END3 " s= -> true }t
t{ s" END" |s|-upto-m,s 12END 3   END s" 12END 3  " s= -> true }t

\ Uncomment to test string not found:
0 [IF]  \ assume data space can contain the rest of this file
s" NTBF" |s|-upto-m,s  NTBFis not white delimitedNTBF
[THEN]

VERBOSE @ [IF]
blue-text .( #ERRORS: ) #errors . normal-text cr
[THEN]