path: root/test.fs

\ tests
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ ↑ some of the tests are lifted from the test suite and the standard
\ no point in coming up with my own when this is here

\ commented out ones are for words that do not currently exist but Should

true verbose !

hex

testing basic assumptions

t{ -> }t
t{ : bitsset?  if 0 0 else 0 then ; -> }t
t{ 0 bitsset? -> 0 }t
t{ 1 bitsset? -> 0 0 }t
t{ -1 bitsset? -> 0 0 }t

testing booleans

t{ 0 0 and -> 0 }t
t{ 0 1 and -> 0 }t
t{ 1 0 and -> 0 }t
t{ 1 1 and -> 1 }t

t{ 0 invert 1 and -> 1 }t
t{ 1 invert 1 and -> 0 }t

0 constant 0s
0 invert constant 1s

t{ 0s invert -> 1s }t
t{ 1s invert -> 0s }t

t{ 0s 0s and -> 0s }t
t{ 0s 1s and -> 0s }t
t{ 1s 0s and -> 0s }t
t{ 1s 1s and -> 1s }t

t{ 0s 0s or -> 0s }t
t{ 0s 1s or -> 1s }t
t{ 1s 0s or -> 1s }t
t{ 1s 1s or -> 1s }t

t{ 0s 0s xor -> 0s }t
t{ 0s 1s xor -> 1s }t
t{ 1s 0s xor -> 1s }t
t{ 1s 1s xor -> 0s }t

t{ 123 constant x123 -> }t
t{ x123 -> 123 }t
t{ : equ constant ; -> }t
t{ x123 equ y123 -> }t
t{ y123 -> 123 }t

testing bit shifting

1s 1 rshift invert constant msb
t{ msb bitsset? -> 0 0 }t

t{ 1 0 lshift -> 1 }t
t{ 1 1 lshift -> 2 }t
t{ 1 2 lshift -> 4 }t
t{ 1 f lshift -> 8000 }t
t{ 1s 1 lshift 1 xor -> 1s }t
t{ msb 1 lshift -> 0 }t

t{    1 0 rshift -> 1 }t
t{    1 1 rshift -> 0 }t
t{    2 1 rshift -> 1 }t
t{    4 2 rshift -> 1 }t
t{ 8000 f rshift -> 1 }t
t{  msb 1 rshift msb and -> 0 }t

testing comparison

0 invert			constant max-uint
0 invert 1 rshift		constant max-int
0 invert 1 rshift invert	constant min-int
0 invert 1 rshift		constant mid-uint
0 invert 1 rshift invert	constant mid-uint+1

0s constant <false>
1s constant <true>

t{ 0 0= -> <true> }t
t{ 1 0= -> <false> }t
t{ 2 0= -> <false> }t
t{ -1 0= -> <false> }t
t{ max-uint 0= -> <false> }t
t{ min-int 0= -> <false> }t
t{ max-int 0= -> <false> }t

t{ 0 0 = -> <true> }t
t{ 1 1 = -> <true> }t
t{ -1 -1 = -> <true> }t
t{ 1 0 = -> <false> }t
t{ -1 0 = -> <false> }t
t{ 0 1 = -> <false> }t
t{ 0 -1 = -> <false> }t

t{ 0 0< -> <false> }t
t{ -1 0< -> <true> }t
t{ min-int 0< -> <true> }t
t{ 1 0< -> <false> }t
t{ max-int 0< -> <false> }t

t{ 0 1 < -> <true> }t
t{ 1 2 < -> <true> }t
t{ -1 0 < -> <true> }t
t{ -1 1 < -> <true> }t
t{ min-int 0 < -> <true> }t
t{ min-int max-int < -> <true> }t
t{ 0 max-int < -> <true> }t
t{ 0 0 < -> <false> }t
t{ 1 1 < -> <false> }t
t{ 1 0 < -> <false> }t
t{ 2 1 < -> <false> }t
t{ 0 -1 < -> <false> }t
t{ 1 -1 < -> <false> }t
t{ 0 min-int < -> <false> }t
t{ max-int min-int < -> <false> }t
t{ max-int 0 < -> <false> }t

t{ 0 1 > -> <false> }t
t{ 1 2 > -> <false> }t
t{ -1 0 > -> <false> }t
t{ -1 1 > -> <false> }t
t{ min-int 0 > -> <false> }t
t{ min-int max-int > -> <false> }t
t{ 0 max-int > -> <false> }t
t{ 0 0 > -> <false> }t
t{ 1 1 > -> <false> }t
t{ 1 0 > -> <true> }t
t{ 2 1 > -> <true> }t
t{ 0 -1 > -> <true> }t
t{ 1 -1 > -> <true> }t
t{ 0 min-int > -> <true> }t
t{ max-int min-int > -> <true> }t
t{ max-int 0 > -> <true> }t

t{ 0 1 u< -> <true> }t
t{ 1 2 u< -> <true> }t
t{ 0 mid-uint u< -> <true> }t
t{ 0 max-uint u< -> <true> }t
t{ mid-uint max-uint u< -> <true> }t
t{ 0 0 u< -> <false> }t
t{ 1 1 u< -> <false> }t
t{ 1 0 u< -> <false> }t
t{ 2 1 u< -> <false> }t
t{ mid-uint 0 u< -> <false> }t
t{ max-uint 0 u< -> <false> }t
t{ max-uint mid-uint u< -> <false> }t

\ t{ 0 1 min -> 0 }t
\ t{ 1 2 min -> 1 }t
\ t{ -1 0 min -> -1 }t
\ t{ -1 1 min -> -1 }t
\ t{ min-int 0 min -> min-int }t
\ t{ min-int max-int min -> min-int }t
\ t{ 0 max-int min -> 0 }t
\ t{ 0 0 min -> 0 }t
\ t{ 1 1 min -> 1 }t
\ t{ 1 0 min -> 0 }t
\ t{ 2 1 min -> 1 }t
\ t{ 0 -1 min -> -1 }t
\ t{ 1 -1 min -> -1 }t
\ t{ 0 min-int min -> min-int }t
\ t{ max-int min-int min -> min-int }t
\ t{ max-int 0 min -> 0 }t
\
\ t{ 0 1 max -> 1 }t
\ t{ 1 2 max -> 2 }t
\ t{ -1 0 max -> 0 }t
\ t{ -1 1 max -> 1 }t
\ t{ min-int 0 max -> 0 }t
\ t{ min-int max-int max -> max-int }t
\ t{ 0 max-int max -> max-int }t
\ t{ 0 0 max -> 0 }t
\ t{ 1 1 max -> 1 }t
\ t{ 1 0 max -> 1 }t
\ t{ 2 1 max -> 2 }t
\ t{ 0 -1 max -> 0 }t
\ t{ 1 -1 max -> 1 }t
\ t{ 0 min-int max -> 0 }t
\ t{ max-int min-int max -> max-int }t
\ t{ max-int 0 max -> max-int }t

testing stack manipulation

t{ 1 2 2drop -> }t
t{ 1 2 2dup -> 1 2 1 2 }t
\ t{ 1 2 3 4 2over -> 1 2 3 4 1 2 }t
t{ 1 2 3 4 2swap -> 3 4 1 2 }t
t{ 0 ?dup -> 0 }t
t{ 1 ?dup -> 1 1 }t
t{ -1 ?dup -> -1 -1 }t
t{ depth -> 0 }t
t{ 0 depth -> 0 1 }t
t{ 0 1 depth -> 0 1 2 }t
t{ 0 drop -> }t
t{ 1 2 drop -> 1 }t
t{ 1 dup -> 1 1 }t
t{ 1 2 over -> 1 2 1 }t
t{ 1 2 3 rot -> 2 3 1 }t
t{ 1 2 swap -> 2 1 }t

testing return stack manipulation

t{ : gr1 >r r> ; -> }t
t{ : gr2 >r r@ r> drop ; -> }t
t{ 123 gr1 -> 123 }t
t{ 123 gr2 -> 123 }t
t{ 1s gr1 -> 1s }t   ( return stack holds cells )

testing basic math

t{ 0 5 + -> 5 }t
t{ 5 0 + -> 5 }t
t{ 0 -5 + -> -5 }t
t{ -5 0 + -> -5 }t
t{ 1 2 + -> 3 }t
t{ 1 -2 + -> -1 }t
t{ -1 2 + -> 1 }t
t{ -1 -2 + -> -3 }t
t{ -1 1 + -> 0 }t
t{ mid-uint 1 + -> mid-uint+1 }t

t{ 0 5 - -> -5 }t
t{ 5 0 - -> 5 }t
t{ 0 -5 - -> 5 }t
t{ -5 0 - -> -5 }t
t{ 1 2 - -> -1 }t
t{ 1 -2 - -> 3 }t
t{ -1 2 - -> -3 }t
t{ -1 -2 - -> 1 }t
t{ 0 1 - -> -1 }t
t{ mid-uint+1 1 - -> mid-uint }t

t{ 0 1+ -> 1 }t
t{ -1 1+ -> 0 }t
t{ 1 1+ -> 2 }t
t{ mid-uint 1+ -> mid-uint+1 }t

t{ 2 1- -> 1 }t
t{ 1 1- -> 0 }t
t{ 0 1- -> -1 }t
t{ mid-uint+1 1- -> mid-uint }t

t{ 0 negate -> 0 }t
t{ 1 negate -> -1 }t
t{ -1 negate -> 1 }t
t{ 2 negate -> -2 }t
t{ -2 negate -> 2 }t

t{ 0 abs -> 0 }t
t{ 1 abs -> 1 }t
t{ -1 abs -> 1 }t
t{ min-int abs -> mid-uint+1 }t

testing multiplication

t{ 0 0 * -> 0 }t				\ test identities
t{ 0 1 * -> 0 }t
t{ 1 0 * -> 0 }t
t{ 1 2 * -> 2 }t
t{ 2 1 * -> 2 }t
t{ 3 3 * -> 9 }t
t{ -3 3 * -> -9 }t
t{ 3 -3 * -> -9 }t
t{ -3 -3 * -> 9 }t

t{ mid-uint+1 1 rshift 2 * -> mid-uint+1 }t
t{ mid-uint+1 2 rshift 4 * -> mid-uint+1 }t
t{ mid-uint+1 1 rshift mid-uint+1 or 2 * -> mid-uint+1 }t

testing memory stuff

here 1 allot
here
constant 2nda
constant 1sta
t{ 1sta 2nda u< -> <true> }t		\ here must grow with allot
t{ 1sta 1+ -> 2nda }t			\ ... by one address unit

here 1 ,
here 2 ,
constant 2nd
constant 1st
t{ 1st 2nd u< -> <true> }t			\ here must grow with allot
t{ 1st cell+ -> 2nd }t			\ ... by one cell
t{ 1st 1 cells + -> 2nd }t
t{ 1st @ 2nd @ -> 1 2 }t
t{ 5 1st ! -> }t
t{ 1st @ 2nd @ -> 5 2 }t
t{ 6 2nd ! -> }t
t{ 1st @ 2nd @ -> 5 6 }t
t{ 1s 1st !  1st @ -> 1s }t		\ can store cell-wide value

here 1 c,
here 2 c,
constant 2ndc
constant 1stc
t{ 1stc 2ndc u< -> <true> }t		\ here must grow with allot
t{ 1stc char+ -> 2ndc }t			\ ... by one char
t{ 1stc 1 chars + -> 2ndc }t
t{ 1stc c@ 2ndc c@ -> 1 2 }t
t{ 3 1stc c! -> }t
t{ 1stc c@ 2ndc c@ -> 3 2 }t
t{ 4 2ndc c! -> }t
t{ 1stc c@ 2ndc c@ -> 3 4 }t

t{ 1 chars 1 < -> <false> }t
t{ 1 chars 1 cells > -> <false> }t

t{ 1 cells 1 < -> <false> }t
t{ 1 cells 1 chars mod -> 0 }t

testing characters and strings

t{ char X     -> 58 }t
t{ char Hello -> 48 }t
t{ bl -> 20 }t

t{ : gc4 s" XY" ; ->   }t
t{ gc4 swap drop  -> 2 }t
t{ gc4 drop dup c@ swap char+ c@ -> 58 59 }t
: gc5 s" A String"2drop ; \ There is no space between the " and 2drop
t{ gc5 -> }t

testing dictionary

t{ : gt1 123 ;   ->     }t
t{ ' gt1 execute -> 123 }t
t{ : gt2 ['] gt1 ; immediate -> }t
t{ gt2 execute -> 123 }t

here 3 c, char g c, char t c, char 1 c, constant gt1string
here 3 c, char g c, char t c, char 2 c, constant gt2string
t{ gt1string count find -> 'h gt1 -1 }t
t{ gt2string count find -> 'h gt2 -1 }t

t{ : gt3 gt2 literal ; -> }t
t{ gt3 -> ' gt1 }t

t{ gt1string count -> gt1string char+ 3 }t

t{ : gt4 postpone gt1 ; immediate -> }t
t{ : gt5 gt4 ; -> }t
t{ gt5 -> 123 }t
t{ : gt6 345 ; immediate -> }t
t{ : gt7 postpone gt6 ; -> }t
t{ gt7 -> 345 }t

t{ : gt8 state @ ; immediate -> }t
t{ gt8 -> 0 }t
t{ : gt9 gt8 literal ; -> }t
t{ gt9 0= -> <false> }t

testing flow control

t{ : gi1 if 123 then ; -> }t
t{ : gi2 if 123 else 234 then ; -> }t
t{  0 gi1 ->     }t
t{  1 gi1 -> 123 }t
t{ -1 gi1 -> 123 }t
t{  0 gi2 -> 234 }t
t{  1 gi2 -> 123 }t
t{ -1 gi1 -> 123 }t
\ Multiple ELSEs in an IF statement
: melse if 1 else 2 else 3 else 4 else 5 then ;
t{ <false> melse -> 2 4 }t
t{ <true>  melse -> 1 3 5 }t

: CS1 case 1 of 111 endof
   2 of 222 endof
   3 of 333 endof
   >r 999 r>
   endcase
;
t{ 1 CS1 -> 111 }t
t{ 2 CS1 -> 222 }t
t{ 3 CS1 -> 333 }t
t{ 4 CS1 -> 999 }t
: CS2 >r case
   -1 of case r@ 1 of 100 endof
                2 of 200 endof
                >r -300 r>
        endcase
     endof
   -2 of case r@ 1 of -99 endof
                >r -199 r>
        endcase
     endof
     >r 299 r>
   endcase r> drop ;

t{ -1 1 CS2 ->  100 }t
t{ -1 2 CS2 ->  200 }t
t{ -1 3 CS2 -> -300 }t
t{ -2 1 CS2 ->  -99 }t
t{ -2 2 CS2 -> -199 }t
t{  0 2 CS2 ->  299 }t

t{ : gi3 begin dup 5 < while dup 1+ repeat ; -> }t
t{ 0 gi3 -> 0 1 2 3 4 5 }t
t{ 4 gi3 -> 4 5 }t
t{ 5 gi3 -> 5 }t
t{ 6 gi3 -> 6 }t

t{ : gi4 begin dup 1+ dup 5 > until ; -> }t
t{ 3 gi4 -> 3 4 5 6 }t
t{ 5 gi4 -> 5 6 }t
t{ 6 gi4 -> 6 7 }t

t{ : gi6 ( n -- 0,1,..n )
     dup if dup >r 1- recurse r> then ; -> }t
t{ 0 gi6 -> 0 }t
t{ 1 gi6 -> 0 1 }t
t{ 2 gi6 -> 0 1 2 }t
t{ 3 gi6 -> 0 1 2 3 }t
t{ 4 gi6 -> 0 1 2 3 4 }t
decimal
t{ :noname ( N -- 0, 1, .., N )
     dup if dup >r 1- recurse r> then
   ;
   constant RN1 -> }t
t{ 0 RN1 execute -> 0 }t
t{ 4 RN1 execute -> 0 1 2 3 4 }t

\ todo broken
\ i think the case is splunging up the recurse
\ i dont know why, because recurse takes no arguments
:noname ( N -- N1 )
   1- dup
   case 0 of exit endof
     1 of 11 swap recurse endof
     2 of 22 swap recurse endof
     3 of 33 swap recurse endof
     drop abs recurse exit
   endcase
; constant RN2

t{  1 RN2 execute -> 0 }t
t{  2 RN2 execute -> 11 0 }t
t{  4 RN2 execute -> 33 22 11 0 }t
t{ 25 RN2 execute -> 33 22 11 0 }t
hex

t{ : gd1 do i loop ; -> }t
t{          4        1 gd1 ->  1 2 3   }t
t{          2       -1 gd1 -> -1 0 1   }t
t{ mid-uint+1 mid-uint gd1 -> mid-uint }t

\ todo +loop tests
\ should make -loop first and deal with negatives

t{ : gd5 123 swap 0 do 
     i 4 > if drop 234 leave then 
   loop ; -> }t
t{ 1 gd5 -> 123 }t
t{ 5 gd5 -> 123 }t
t{ 6 gd5 -> 234 }t

\ todo unloop tests

testing define words

t{ : nop : postpone ; ; -> }t
t{ nop nop1 nop nop2 -> }t
t{ nop1 -> }t
t{ nop2 -> }t
t{ : gdx   123 ;    : gdx   gdx 234 ; -> }t
t{ gdx -> 123 234 }t

t{ variable v1 ->     }t
t{    123 v1 ! ->     }t
t{        v1 @ -> 123 }t

t{ : does1 does> @ 1 + ; -> }t
t{ : does2 does> @ 2 + ; -> }t
t{ create cr1 -> }t
t{ cr1   -> here }t
t{ 1 ,   ->   }t
t{ cr1 @ -> 1 }t
t{ does1 ->   }t
t{ cr1   -> 2 }t
t{ does2 ->   }t
t{ cr1   -> 3 }t

testing evaluate

: ge1 s" 123" ; immediate
: ge2 s" 123 1+" ; immediate
: ge3 s" : ge4 345 ;" ;
: ge5 evaluate ; immediate
t{ ge1 evaluate -> 123 }t ( test evaluate in interp. state )
t{ ge2 evaluate -> 124 }t
t{ ge3 evaluate ->     }t
t{ ge4          -> 345 }t

t{ : ge6 ge1 ge5 ; -> }t ( test evaluate in compile state )
t{ ge6 -> 123 }t
t{ : ge7 ge2 ge5 ; -> }t
t{ ge7 -> 124 }t

: gs4 source >in ! drop ;
t{ gs4 123 456
    -> }t

testing vocabularies

t{ vocabulary testvoc -> }t
t{ also testvoc definitions -> }t
t{ get-current empty-wordlist? -> <true> }t
t{ : testicle  67 ; -> }t
t{ get-current empty-wordlist? -> <false> }t
t{ testicle -> 67 }t

decimal