(    Title:  Tests for pfe gmp-ext module
      File:  libgmp-test.fs
    Author:  David N. Williams
   Version:  0.8.0
   License:  public domain
   Revised:  March 26, 2011

Version 0.8.0
26Mar11 * Renamed file from gmplib-test.fs to libgmp-test.fs.
	* Replaced input file name prefix "gmplib" by "libgmp".

Version 0.7.0
24Mar11 * Sync'd version number.
	* Added multiple definition warning turnoffs, which can
	  be commented out
	* Removed restriction to pfe for printout of libgmp
	  parameters.

Version 0.6.0
 6Mar11 * Sync'd version number.
 	* Replaced lib string by gmp_version, renamed
	  MP-BITS/LIMB as mp_bits_per_limb
 7Mar11 * Added mpz_get_d.

Version 0.5.2
 9Feb11 * Tests:  MPZ-SET MPZ-SET-UI MPZ-SET-SI
10Feb11	* Remaining arithmetic section tests. 
13Feb11 * Division tests.
15Feb11 * Adjusted for new stack effect in MPZ-SET-STR,
	  MPZ-INIT-SET-STR, MPZ-GET-STR.
17Feb11 * New C names.
18Feb11 * Adjustments for new BASE args.
19Feb11 * Added MZ".
25Feb11 * Inverted pseudoflag for mpz_set_str and
	  mpz_init_set_str.
	* Added conditional for running with gforth.
27Feb11 * Renamed file as gmplib-test.fs
	* Added conditional for running with iForth. 

Version 0.5.1
 7Feb11 * Revised for new argument order.
	* Explicit test for MPZ-GET-STR.
	* BASE tests for MPZ-SET-STR and MPZ-GET-STR

Version 0.5.0
16Jan11 * Started as gmp-test.fs.
 2Feb11 * Renamed as gmp-ext-test.fs.
 4Feb11 * Tests up to date with gmp-ext.c.

These tests aim to check that the gmp library functions are
correctly bound.  They do not particulary aim to check the
correctness of gmp itself.  They work with gforth, iForth, and
pfe.
)

s" ttester-xf.fs" INCLUDED
true VERBOSE !
s" tester-display.fs" INCLUDED
s" xtester-errors.fs" INCLUDED

[UNDEFINED] bits/cell [IF]
s" ADDRESS-UNIT-BITS" environment?
  0= [IF] cr .( ***Can't determine BITS/CELL) ABORT [THEN]
  1 cells * constant BITS/CELL [THEN]

BITS/CELL 32 = BITS/CELL 64 = or
0= [IF] cr .( *** BITS/CELL must be 32 or 64) ABORT [THEN]

s" MAX-N" environment?
0= [IF] cr .( ***Can't determine MAX-N) ABORT [THEN]
constant MAXN

s" MAX-U" environment?
0= [IF] cr .( ***Can't determine MAX-U) ABORT [THEN]
constant MAXU

BITS/CELL 32 =    \ assume 2's complement
[IF]   : "MAXN"  s" 2147483647" ;
       : "MAXU"  s" 4294967295" ;
       : hex-"MAXN"     s" 7fffffff" ;
       : hex-"MAXU"     s" ffffffff" ;
       : hex-"2*MAXU"  s" 1fffffffe" ;
[ELSE] : "MAXN"  s" 9223372036854775807" ;
       : "MAXU"  s" 18446744073709551615" ;
       : hex-"MAXN"     s" 7fffffffffffffff" ;
       : hex-"MAXU"     s" ffffffffffffffff" ;
       : hex-"2*MAXU"  s" 1fffffffffffffffe" ; [THEN]

PFE-HOST    [IF]  0 REDEFINED-MSG !
  LOADM libgmp-pfe  LOADM zchar [THEN]   \ gmp bindings and zchar-ext
GFORTH-HOST [IF]  0 WARNINGS !
  s" libgmp-gforth.fs"  REQUIRED [THEN]
IFORTH-HOST [IF]    0 WARNING !
  s" libgmp-iforth.frt" INCLUDED [THEN]

1024 CONSTANT /STRBUF

\ before first displayed line
PFE-HOST IFORTH-HOST or [IF] ?.cr [THEN]
?." zstring buffer size: " /STRBUF ?. ?.cr

s" mstrings.fs" INCLUDED

[UNDEFINED] ZCOUNT [IF]
: zcount  ( 'zstr -- 'zstr len )
  dup 0 2>r
  BEGIN
    dup c@ 0<>
  WHILE
    1+ r> 1+ >r
  REPEAT drop 2r> ;
[THEN]

?." GMP version: " gmp_version zcount ?type ?.cr
?." bits/limb:   "  mp_bits_per_limb ?. ?.cr
?." mpz size:    "  /MPZ ?. ?.cr

\ *** GENERAL USE

[UNDEFINED] S= [IF] : S=  ( s -- flag)  compare 0= ; [THEN] 

\ debugging
[UNDEFINED] \\ [IF]
  : \\  ( -- )  -1 parse 2drop BEGIN refill 0= UNTIL ;
[THEN]
: .#  ( n -- )  cr ." #" . cr ;

\ *** FOR TESTING

[UNDEFINED] MZ" [IF]
0 VALUE MZBUF   0 VALUE /MZBUF
: MZ"  ( "<chars><">" -- 'zstr )
  MZBUF 0= ABORT" no string buffer"
  MZBUF /MZBUF m!"     0= ABORT" string buffer overflow"
  MZBUF /MZBUF null-m+ 0= ABORT" string buffer overflow"
  MZBUF cell+ ;
[THEN]

[UNDEFINED] ZSTRLEN [IF] : zstrlen ( 'zstr -- len ) zcount nip ; [THEN]

: MZSTR-s= ( s -- flag ) MZBUF cell+ zcount s= ;

: >MZSTR   ( 'b --  )
  MZBUF cell+ BASE @ rot mpz_get_str
  zstrlen MZBUF ! ;

: MZSTR. ( -- )	   MZBUF mcount type ;
: b.     ( 'b -- ) >MZSTR MZSTR. ;

align here /STRBUF allot to MZBUF    /STRBUF to /MZBUF

[UNDEFINED] /MPZ [IF] 12 constant /MPZ [THEN]
CREATE b /MPZ allot  \ usually for results
t{ b mpz_init -> }t

\ Error reports will be less informative than with a true
\ bnstack tester:
: ={  t{ ;    : =>  b >MZSTR true -> ;    : }=  MZSTR-s= }t ;

[UNDEFINED] MZ" [IF]
TESTING  mz"
t{ mz" xxxxx" dup 5 s" xxxxx" s= swap 5 + c@ -> true 0 }t
t{ s" xxxxx" MZSTR-s= -> true }t
[THEN]


\ *** 1 Integers

\ *** 1.1 Initialization

TESTING  /MPZ mpz_init mpz_clear

CREATE b1 /MPZ allot   CREATE b2 /MPZ allot
t{ b1 mpz_init b2 mpz_init -> }t

={ b mpz_clear b mpz_init => s" 0" }=

\ *** 1.2 Assignment

TESTING  mpz_set mpz_set_ui mpz_set_si mz" mpz_set_str

t{ b1 1 mpz_set_si b2 2 mpz_set_si -> }t

={ b b2   mpz_set    => S" 2" }=
={ b -15  mpz_set_si => S" -15" }=
={ b MAXU mpz_set_ui => "MAXU" }=
hex
={ b MAXU mpz_set_ui => hex-"MAXU" }=
decimal

t{ b mz" 1024" BASE @ mpz_set_str 0= -> true }t
t{ mz" zzzzz" drop -> }t

hex
t{ b mz" 800" BASE @ mpz_set_str 0= -> true }t
={ => s" 800" }=
decimal
={ => s" 2048" }=
t{ b mz" A00" BASE @ mpz_set_str 0= -> false }t

\ *** 1.3 Combined Initialization and Assignment

TESTING  mpz_init_set mpz_init_set_ui mpz_init_set_si mpz_init_set_str

={ b mpz_clear b b2 mpz_init_set => s" 2" }=
={ b mpz_clear b MAXU mpz_init_set_ui => "MAXU" }=
={ b mpz_clear b -11 mpz_init_set_si => s" -11" }=
hex
={ b mpz_clear b mz" -A" BASE @ mpz_init_set_str 0= => true s" -a" }=
decimal
={ => s" -10" }=

\ for defining test constants
: BVAL  ( "name" n -- )
  create here /MPZ allot swap mpz_init_set_si
DOES>   ( -- 'mpz ) ;

t{ 10 BVAL b10 -> }t
={ b b10 mpz_set => s" 10" }=

\ *** 1.4 Conversion

TESTING  mz" mpz_get_str mpz_get_d

t{ mz" yyyyyy" -> MZBUF cell+ }t
t{ mz" xxxxx" dup 5 s" xxxxx" s= swap 5 + c@ -> true 0 }t 

t{ b mz" 1024" BASE @ mpz_set_str 0= -> true }t
t{ mz" zzzzz" drop -> }t

t{ MZBUF cell+ BASE @ b mpz_get_str -> MZBUF cell+ }t
t{ s" 1024" MZSTR-s= -> true }t
={ => s" 1024" }=

t{ b10 mpz_get_d -> 10e }t

\ *** 1.5 Arithmetic

TESTING  mpz_add mpz_add_ui mpz_sub mpz_sub_ui mpz_ui_sub

={ b b1 b2  mpz_add    =>   s" 3" }=
={ b b1 b   mpz_add    =>   s" 4" }=
={ b b1 15  mpz_add_ui =>  s" 16" }=
={ b b1 b2  mpz_sub    =>  s" -1" }=
={ b b1 15  mpz_sub_ui => s" -14" }=
={ b 15  b1 mpz_ui_sub =>  s" 14" }=

TESTING  mpz_mul mpz_mul_si mpz_mul_ui

={ b b2 b2  mpz_mul    =>  s" 4" }=
={ b b2 -1  mpz_mul_si => s" -2" }=
hex
={ b b2 MAXU mpz_mul_ui => hex-"2*MAXU" }=
decimal

TESTING  mpz_addmul mpz_addmul_ui mpz_submul mpz_submul_ui mpz_mul_2exp

={ b 15 mpz_set_si => s" 15" }=
={ b b1 b2 mpz_addmul    => s" 17" }=
={ b b2 13 mpz_addmul_ui => s" 43" }=
={ b b2 b1 mpz_submul    => s" 41" }=
={ b b2 3  mpz_submul_ui => s" 35" }=
={ b b2 5  mpz_mul_2exp  => s" 64" }=

TESTING  mpz_neg mpz_abs

CREATE -b1 /MPZ allot   CREATE -b2 /MPZ allot
t{ -b1 mpz_init -b2 mpz_init -> }t

t{ -b1 mz" -1" BASE @ mpz_set_str 0= -> true }t
t{ -b2 mz" -2" BASE @ mpz_set_str 0= -> true }t
t{ -b1 >MZSTR s" -1" MZSTR-s= -> true }t
t{ -b2 >MZSTR s" -2" MZSTR-s= -> true }t

={ b  b1 mpz_neg => s" -1" }=
={ b -b1 mpz_abs =>  s" 1" }=

\ *** 1.6 Division
(
The floored and symmetric division examples in the table below
are taken from DPANS94 3.2.2.1:

  Ceiling             Floored             Symmetric         
  num  den quo rem    num  den quo rem    num  den quo rem  
   10   7   2  -4      10   7   1   3      10   7   1   3   
  -10   7  -1  -3     -10   7  -2   4     -10   7  -1  -3   
   10  -7  -1   3      10  -7  -2  -4      10  -7  -1   3   
  -10  -7   2   4     -10  -7   1  -3     -10  -7   1  -3   

Note that we only need the first two rows to distinguish calls
among the c [ceiling], f [floored], and t [symmetric] functions.
)

-10 bval -b10    7 bval b7   \ b10 already defined

\ for quotient and remainder results
: bq b ;  \ so ={...=>...}= still works
 0 bval br

TESTING  mpz_cdiv_q mpz_cdiv_r mpzl_cdiv_qr

={ bq     b10 b7 mpz_cdiv_q  =>  s" 2" }=
={ bq     b10 b7 mpz_cdiv_r  => s" -4" }=
={ bq br  b10 b7 mpz_cdiv_qr =>  s" 2" }=
={ b  br         mpz_set     => s" -4" }=

={ bq    -b10 b7 mpz_cdiv_q  => s" -1" }=
={ bq    -b10 b7 mpz_cdiv_r  => s" -3" }=
={ bq br -b10 b7 mpz_cdiv_qr => s" -1" }=
={ b  br         mpz_set     => s" -3" }=

TESTING  mpz_cdiv_q_ui mpz_cdiv_r_ui mpz_cdiv_qrt_ui mpz_cdiv_ui

={ bq     b10 7 mpz_cdiv_q_ui  => 4  s" 2" }=
={ bq     b10 7 mpz_cdiv_r_ui  => 4 s" -4" }=
={ bq br  b10 7 mpz_cdiv_qr_ui => 4  s" 2" }=
={ b  br        mpz_set        =>   s" -4" }=
t{        b10 7 mpz_cdiv_ui    -> 4 }t

={ bq    -b10 7 mpz_cdiv_q_ui  => 3 s" -1" }=
={ bq    -b10 7 mpz_cdiv_r_ui  => 3 s" -3" }=
={ bq br -b10 7 mpz_cdiv_qr_ui => 3 s" -1" }=
={ b  br        mpz_set        =>   s" -3" }=
t{       -b10 7 mpz_cdiv_ui    -> 3 }t

TESTING  mpz_cdiv_q_2exp mpz_cdiv_r_2exp

\ denom = 2^3 = 8
={ bq  b10 3 mpz_cdiv_q_2exp =>  s" 2" }=
={ b   b10 3 mpz_cdiv_r_2exp => s" -6" }=
={ bq -b10 3 mpz_cdiv_q_2exp => s" -1" }=
={ b  -b10 3 mpz_cdiv_r_2exp => s" -2" }=

TESTING  mpz_fdiv_q mpz_fdiv_r mpzl_fdiv_qr

={ bq     b10 b7 mpz_fdiv_q  =>  s" 1" }=
={ bq     b10 b7 mpz_fdiv_r  =>  s" 3" }=
={ bq br  b10 b7 mpz_fdiv_qr =>  s" 1" }=
={ b  br         mpz_set     =>  s" 3" }=

={ bq    -b10 b7 mpz_fdiv_q  => s" -2" }=
={ bq    -b10 b7 mpz_fdiv_r  =>  s" 4" }=
={ bq br -b10 b7 mpz_fdiv_qr => s" -2" }=
={ b  br         mpz_set     =>  s" 4" }=

TESTING  mpz_fdiv_q_ui mpz_fdiv_r_ui mpz_fdiv_qrt_ui mpz_fdiv_ui

={ bq     b10 7 mpz_fdiv_q_ui  => 3  s" 1" }=
={ bq     b10 7 mpz_fdiv_r_ui  => 3  s" 3" }=
={ bq br  b10 7 mpz_fdiv_qr_ui => 3  s" 1" }=
={ b  br        mpz_set        =>    s" 3" }=
t{        b10 7 mpz_fdiv_ui    -> 3 }t

={ bq    -b10 7 mpz_fdiv_q_ui  => 4 s" -2" }=
={ bq    -b10 7 mpz_fdiv_r_ui  => 4  s" 4" }=
={ bq br -b10 7 mpz_fdiv_qr_ui => 4 s" -2" }=
={ b  br        mpz_set        =>    s" 4" }=
t{       -b10 7 mpz_fdiv_ui    -> 4 }t

TESTING  mpz_fdiv_q_2exp mpz_fdiv_r_2exp

\ denom = 2^3 = 8
={ bq  b10 3 mpz_fdiv_q_2exp =>  s" 1" }=
={ b   b10 3 mpz_fdiv_r_2exp =>  s" 2" }=
={ bq -b10 3 mpz_fdiv_q_2exp => s" -2" }=
={ b  -b10 3 mpz_fdiv_r_2exp =>  s" 6" }=

TESTING  mpz_tdiv_q mpz_tdiv_r mpzl_tdiv_qr

={ bq     b10 b7 mpz_tdiv_q  =>  s" 1" }=
={ bq     b10 b7 mpz_tdiv_r  =>  s" 3" }=
={ bq br  b10 b7 mpz_tdiv_qr =>  s" 1" }=
={ bq br        mpz_set      =>  s" 3" }=

={ bq    -b10 b7 mpz_tdiv_q  => s" -1" }=
={ bq    -b10 b7 mpz_tdiv_r  => s" -3" }=
={ bq br -b10 b7 mpz_tdiv_qr => s" -1" }=
={ bq br         mpz_set     => s" -3" }=

TESTING  mpz_tdiv_q_ui mpz_tdiv_r_ui mpz_tdiv_qrt_ui mpz_tdiv_ui

={ bq     b10 7 mpz_tdiv_q_ui  => 3  s" 1" }=
={ bq     b10 7 mpz_tdiv_r_ui  => 3  s" 3" }=
={ bq br  b10 7 mpz_tdiv_qr_ui => 3  s" 1" }=
={ b  br        mpz_set        =>    s" 3" }=
t{        b10 7 mpz_tdiv_ui    -> 3 }t

={ bq    -b10 7 mpz_tdiv_q_ui  => 3 s" -1" }=
={ bq    -b10 7 mpz_tdiv_r_ui  => 3 s" -3" }=
={ bq br -b10 7 mpz_tdiv_qr_ui => 3 s" -1" }=
={ b  br        mpz_set        =>   s" -3" }=
t{       -b10 7 mpz_tdiv_ui    -> 3 }t

TESTING  mpz_tdiv_q_2exp mpz_tdiv_r_2exp

\ denom = 2^3 = 8
={ bq  b10 3 mpz_tdiv_q_2exp =>  s" 1" }=
={ b   b10 3 mpz_tdiv_r_2exp =>  s" 2" }=
={ bq -b10 3 mpz_tdiv_q_2exp => s" -1" }=
={ b  -b10 3 mpz_tdiv_r_2exp => s" -2" }=

TESTING  mpz_mod mpz_mod_ui mpz_divexact mpz_divexact_ui

={ b  b10 b7 mpz_mod => s" 3" }=
={ b -b10 b7 mpz_mod => s" 4" }=
={ b  b10  7 mpz_mod_ui => 3 s" 3" }=
={ b -b10  7 mpz_mod_ui => 4 s" 4" }=

={ b  b10  b2 mpz_divexact    =>  s" 5" }=
={ b -b10  b2 mpz_divexact    => s" -5" }=
={ b  b10 -b2 mpz_divexact    => s" -5" }=
={ b  b10   2 mpz_divexact_ui =>  s" 5" }=
={ b -b10   2 mpz_divexact_ui => s" -5" }=

TESTING  mpz_divisible_p  mpz_divisible_ui_p  mpz_divisible_2exp_p 

: wff  0= 0= ;

4 bval b4
t{ b10 b2 mpz_divisible_p wff      -> true }t
t{ b7  b2 mpz_divisible_p wff      -> false }t
t{ b10  2 mpz_divisible_ui_p wff   -> true }t
t{ b7   2 mpz_divisible_ui_p wff   -> false }t
t{ b4   2 mpz_divisible_2exp_p wff -> true }t
t{ b7   2 mpz_divisible_2exp_p wff -> false }t

TESTING  mpz_congruent_p mpz_congruent_ui_p mpz_congruent_2exp_p

3 bval b3
t{ b7  b3 b4 mpz_congruent_p wff    -> true }t
t{ b10 b3 b4 mpz_congruent_p wff    -> false }t
t{ b7  3  4  mpz_congruent_ui_p wff -> true }t
t{ b10 3  4  mpz_congruent_ui_p wff -> false }t
\ 2^2 = 4
t{ b7  b3 2  mpz_congruent_2exp_p wff -> true }t
t{ b10 b3 2  mpz_congruent_2exp_p wff -> false }t

\ *** 1.10 Comparison

TESTING  mpz_cmp mpz_cmp_si mpz_cmp_ui mpz_cmpabs mpz_cmp_abs_ui

t{ b1 b2 mpz_cmp 0< -> true }t
t{ b2 b1 mpz_cmp 0> -> true }t
t{ b1 b1 mpz_cmp 0= -> true }t

t{ b2 1 mpz_cmp_si 0> -> true }t
t{ b1 2 mpz_cmp_si 0< -> true }t
t{ b1 1 mpz_cmp_si 0= -> true }t

t{ b2 -1 mpz_cmp_ui 0> -> false }t
t{ b1  2 mpz_cmp_ui 0< -> true }t
t{ b1  1 mpz_cmp_ui 0= -> true }t

t{  b1 -b2 mpz_cmpabs 0< -> true }t
t{ -b2  b1 mpz_cmpabs 0> -> true }t
t{  b1 -b1 mpz_cmpabs 0= -> true }t

t{ -b2  1 mpz_cmpabs_ui 0> -> true }t
t{  b2 -1 mpz_cmpabs_ui 0> -> false }t
t{  b1 -2 mpz_cmpabs_ui 0< -> true }t
t{ -b1  2 mpz_cmpabs_ui 0< -> true }t
t{  b1 -1 mpz_cmpabs_ui 0= -> false }t
t{  b1  1 mpz_cmpabs_ui 0= -> true }t

\ b mpz_clear   b1 mpz_clear   b2 mpz_clear


\ *** Floating point

\ General use

variable MFEXP

: >MFSTR  ( 'f -- )
  >r MZBUF cell+ MFEXP base @ 0 r> mpf_get_str zstrlen MZBUF ! ;

: MFSTR.  ( -- )
  MZBUF mcount
  over c@ [char] - =
  IF ." -0." 1 cut-first ELSE ." +0." THEN
  type ."  E" MFEXP @ . ;

: mf.  ( 'f -- ) >MFSTR MFSTR. ;

\ *** 4.1 Initialization

TESTING  /MPF mpf_init mpf_clear

\ mpf_set_si mpf_set-ui mpf_get_str  \ FIXME!!

create f /MPF allot   create f1 /MPF allot   create f2 /MPF allot

t{ f mpf_init -> }t
t{ 15 MFEXP ! f >MFSTR -> }t
\ 0 doesn't produce any digits
t{ s" " MZSTR-s= MFEXP @ -> true 0 }t

t{ f1 mpf_init f2 mpf_init -> }t

t{ f -15 mpf_set_si -> }t
t{ f >MFSTR -> }t
t{ s" -15" MZSTR-s= MFEXP @ -> true 2 }t
t{ f 15 mpf_set_ui -> }t
t{ f >MFSTR -> }t
t{ s" 15" MZSTR-s= MFEXP @ -> true 2 }t
t{ f mpf_clear -> }t

?.xt-errors GFORTH-HOST [IF] ?.cr [THEN]