mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
477 lines
7.8 KiB
Forth
477 lines
7.8 KiB
Forth
~~~
|
|
'Total var
|
|
'WordsTested var
|
|
'Flag var
|
|
'Tests var
|
|
'InTestState var
|
|
|
|
:pad s:length #32 swap - #0 n:max &sp times ;
|
|
:Testing (s-)
|
|
dup 'Test:__ s:put s:put pad #-1 !Flag #0 !Tests &WordsTested v:inc reset ;
|
|
|
|
:passed (-)
|
|
'->_ s:put @Tests n:put '_tests_passed s:put nl ;
|
|
|
|
:exit-on-fail (-)
|
|
@Flag [ '->_FAILED. s:put nl bye ] -if ;
|
|
|
|
:match (n-)
|
|
eq? @InTestState and !InTestState ;
|
|
|
|
:try (qq-)
|
|
#-1 !InTestState
|
|
[ call ] dip call
|
|
depth n:-zero? [ @Flag and !Flag ] if
|
|
@Flag @InTestState and !Flag
|
|
exit-on-fail &Tests v:inc &Total v:inc ;
|
|
|
|
:summary (-)
|
|
@WordsTested n:put '_words_tested s:put nl
|
|
@Total n:put '_tests_passed s:put nl ;
|
|
~~~
|
|
|
|
~~~
|
|
'dup Testing
|
|
[ #1 dup ] [ #1 match #1 match ] try
|
|
[ #4 #3 dup ] [ #3 match #3 match #4 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'drop Testing
|
|
[ #1 #2 drop ] [ #1 eq? ] try
|
|
[ #1 #2 #3 drop ] [ #2 match #1 match ] try
|
|
[ #1 #2 drop drop ] [ #1 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'swap Testing
|
|
[ #1 #2 #3 swap ] [ #2 match #3 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'call Testing
|
|
[ #1 [ ] call #2 ] [ #2 match #1 match ] try
|
|
[ #1 [ #3 ] call #2 ] [ #2 match #3 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'eq? Testing
|
|
[ #1 #2 eq? ] [ FALSE match ] try
|
|
[ #1 #1 eq? ] [ TRUE match ] try
|
|
[ #2 #2 eq? ] [ TRUE match ] try
|
|
[ #2 #1 eq? ] [ FALSE match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'-eq? Testing
|
|
[ #1 #2 -eq? ] [ TRUE match ] try
|
|
[ #1 #1 -eq? ] [ FALSE match ] try
|
|
[ #2 #2 -eq? ] [ FALSE match ] try
|
|
[ #2 #1 -eq? ] [ TRUE match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'lt? Testing
|
|
[ #1 #2 lt? ] [ TRUE match ] try
|
|
[ #3 #2 lt? ] [ FALSE match ] try
|
|
[ #2 #2 lt? ] [ FALSE match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'gt? Testing
|
|
[ #1 #2 gt? ] [ FALSE match ] try
|
|
[ #3 #2 gt? ] [ TRUE match ] try
|
|
[ #2 #2 gt? ] [ FALSE match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'fetch Testing
|
|
'A var
|
|
[ #100 &A store ] [ &A fetch #100 eq? ] try
|
|
[ #200 &A store ] [ &A fetch #200 eq? ] try
|
|
[ #300 &A store ] [ &A fetch #300 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'store Testing
|
|
'A var
|
|
[ #100 &A store ] [ &A fetch #100 eq? ] try
|
|
[ #200 &A store ] [ &A fetch #200 eq? ] try
|
|
[ #300 &A store ] [ &A fetch #300 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'+ Testing
|
|
[ #1 #2 + ] [ #3 eq? ] try
|
|
[ #4 #-2 + ] [ #2 eq? ] try
|
|
[ #0 #1 + ] [ #1 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'- Testing
|
|
[ #2 #1 - ] [ #1 eq? ] try
|
|
[ #2 #4 #3 - - ] [ #1 eq? ] try
|
|
[ #1 #2 #1 #9 - ] [ #-8 match #2 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'* Testing
|
|
[ #1 #2 * ] [ #2 eq? ] try
|
|
[ #2 #3 * ] [ #6 eq? ] try
|
|
[ #-1 #10 * ] [ #-10 eq? ] try
|
|
[ #-1 #2 * #-1 * ] [ #2 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'/mod Testing
|
|
[ #5 #2 /mod ] [ #2 match #1 match ] try
|
|
[ #-5 #2 /mod ] [ #-2 match #-1 match ] try
|
|
[ #-5 #-2 /mod ] [ #2 match #-1 match ] try
|
|
[ #5 #-2 /mod ] [ #-2 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'and Testing
|
|
[ #-1 #-1 and ] [ #-1 match ] try
|
|
[ #0 #-1 and ] [ #0 match ] try
|
|
[ #-1 #0 and ] [ #0 match ] try
|
|
[ #0 #0 and ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'or Testing
|
|
[ #-1 #-1 or ] [ #-1 match ] try
|
|
[ #0 #-1 or ] [ #-1 match ] try
|
|
[ #-1 #0 or ] [ #-1 match ] try
|
|
[ #0 #0 or ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'xor Testing
|
|
[ #-1 #-1 xor ] [ #0 match ] try
|
|
[ #0 #-1 xor ] [ #-1 match ] try
|
|
[ #-1 #0 xor ] [ #-1 match ] try
|
|
[ #0 #0 xor ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'shift Testing
|
|
[ #455 #-3 shift ] [ #3640 match ] try
|
|
[ #3640 #3 shift ] [ #455 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'push Testing
|
|
[ #1 dup push #2 pop ] [ #1 match #2 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'pop Testing
|
|
[ #1 dup push #2 pop ] [ #1 match #2 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'0; Testing
|
|
[ #1 0; #2 0; ] [ #2 eq? swap #1 eq? and ] try
|
|
[ #1 0; #0 0; #2 0; ] [ #1 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'fetch-next Testing
|
|
'A d:create #1 , #2 , #3 ,
|
|
[ &A fetch-next ] [ #1 match &A #1 + match ] try
|
|
[ &A fetch-next drop fetch-next ] [ #2 match &A #2 + match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'store-next Testing
|
|
'A d:create #1 , #2 , #3 ,
|
|
#9 #10 #11 &A store-next store-next store-next drop
|
|
[ &A fetch-next ] [ #11 match &A #1 + match ] try
|
|
[ &A fetch-next drop fetch-next ] [ #10 match &A #2 + match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
's:to-number Testing
|
|
[ '123 s:to-number ] [ #123 match ] try
|
|
[ '-123 s:to-number ] [ #-123 match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
's:eq? Testing
|
|
[ 'egg 'egg s:eq? ] [ #-1 match ] try
|
|
[ 'egg 'shell s:eq? ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
's:length Testing
|
|
[ 'abc s:length ] [ #3 match ] try
|
|
[ 'abcdef s:length ] [ #6 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'choose Testing
|
|
[ TRUE [ #1 ] [ #0 ] choose ] [ #1 match ] try
|
|
[ FALSE [ #1 ] [ #0 ] choose ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'if Testing
|
|
[ #0 TRUE [ #1 ] if ] [ #1 match #0 match ] try
|
|
[ #0 FALSE [ #1 ] if ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'-if Testing
|
|
[ #0 TRUE [ #1 ] -if ] [ #0 match ] try
|
|
[ #0 FALSE [ #1 ] -if ] [ #1 match #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'prefix:( Testing
|
|
[ #1 (#2 #3 ] [ #3 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'Compiler Testing
|
|
[ @Compiler ] [ #0 match ] try
|
|
[ 'Compiler d:lookup d:class fetch ] [ &class:data match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'Heap Testing
|
|
[ Heap ] [ #3 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
', Testing
|
|
[ here #0 , here swap - ] [ #1 eq? ] try
|
|
[ here #12 , fetch ] [ #12 eq? ] try
|
|
here #1 , #2 , #3 ,
|
|
[ fetch-next swap fetch-next swap fetch ]
|
|
[ #3 eq? swap #2 eq? and swap #1 eq? and ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
's, Testing
|
|
[ here 'hello s, ] [ fetch-next $h match
|
|
fetch-next $e match
|
|
fetch-next $l match
|
|
fetch-next $l match
|
|
fetch-next $o match
|
|
drop ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'; Testing
|
|
[ here &; call here swap - ] [ #1 eq? ] try
|
|
[ here &; call fetch ] [ #10 eq? ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'[ Testing
|
|
[ [ ] fetch ] [ #10 match ] try
|
|
[ [ ] #2 - fetch ] [ #1793 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'] Testing
|
|
[ [ ] fetch ] [ #10 match ] try
|
|
[ [ ] #2 - fetch ] [ #1793 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'Dictionary Testing
|
|
[ Dictionary ] [ #2 match ] try
|
|
[ 'Dictionary d:lookup d:class fetch ] [ &class:data match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd:link Testing
|
|
[ #0 d:link ] [ #0 match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'd:xt Testing
|
|
[ #0 d:xt ] [ #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd:class Testing
|
|
[ #0 d:class ] [ #2 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd:name Testing
|
|
[ #0 d:name ] [ #3 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'class:word Testing
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'class:macro Testing
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'class:data Testing
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd:add-header Testing
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'prefix:# Testing
|
|
[ #1 ] [ #1 match ] try
|
|
[ #2 ] [ #2 match ] try
|
|
[ #-1234 ] [ #-1234 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'prefix:: Testing
|
|
:test #1 #2 ;
|
|
[ test ] [ #2 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'prefix:& Testing
|
|
[ &Version ] [ #4 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'prefix:$ Testing
|
|
[ #1 $c #3 ] [ #3 match #99 match #1 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'repeat Testing
|
|
[ #3 repeat dup n:dec 0; again ] [ #1 match #2 match #3 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'again Testing
|
|
[ #3 repeat dup n:dec 0; again ] [ #1 match #2 match #3 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'interpret Testing
|
|
[ '#1 interpret ] [ #1 match ] try
|
|
[ #1 'n:inc interpret ] [ #2 match ] try
|
|
[ #1 #2 'swap interpret ] [ #1 match #2 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd:lookup Testing
|
|
[ 'Compiler d:lookup d:class fetch ] [ &class:data match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'class:primitive Testing
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'Version Testing
|
|
[ Version ] [ #4 match ] try
|
|
[ &Version ] [ #4 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'i Testing
|
|
[ here '........ i ] [ fetch #0 match ] try
|
|
[ here 'li...... i ] [ fetch #1 match ] try
|
|
[ here 'ha...... i ] [ fetch #26 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'd Testing
|
|
[ here #1 d ] [ fetch #1 match ] try
|
|
[ here #2 d ] [ fetch #2 match ] try
|
|
[ here #3 d ] [ fetch #3 match ] try
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
'r Testing
|
|
[ here 'swap r ] [ fetch &swap match ] try
|
|
[ here 'drop r ] [ fetch &drop match ] try
|
|
[ here 'prefix:: r ] [ fetch &prefix:: match ] try
|
|
passed
|
|
~~~
|
|
|
|
|
|
~~~
|
|
'err:notfound Testing
|
|
passed
|
|
~~~
|
|
|
|
~~~
|
|
summary
|
|
~~~
|
|
|