\ fpio-test.4th
\
\ Evaluate the floating point input/output number conversion of a 
\ Forth system which uses IEEE floating point format.
\
\ Copyright (c) 2010, Krishna Myneni
\
\ Permission is granted to use this code for any purpose, 
\ provided the copyright notice above is preserved.
\
\ Revisions:
\    2010-11-28  km  created.
\    2010-11-30  km  revised comments; added rounding tests provided
\                    by Andrew P. Haley, and others [1].
\    2010-12-01  km  added further examples from [1--3]; separated
\                    section 2 tests based on system fp precision
\                    to avoid double rounding.
\
\ Notes:
\   0. The "tests" performed by this module are intended to assess
\      the behavior of fp number conversion for a Forth system.
\      Failure of certain tests by a given Forth system does NOT 
\      imply that the system does not conform to any present Forth
\      standard, e.g. Forth-94. 

\   1. Tests are valid only for systems which use IEEE floating point 
\      formats to represent fp numbers. "Round to nearest" mode
\      is assumed (IEEE 754 "nearest ties to even" rounding mode).
\
\   2. The Forth system's floating point number conversion
\      should be capable of processing at least 55 digits
\      excluding the exponent field, in order to run all of these
\      tests.
\
\   3. Currently, only tests for floating point number input 
\      at single and and double precision are performed; need
\      to add extended precision tests for those systems which
\      support the 10 byte format. Also need to test >FLOAT
\      and REPRESENT.
\
\   4. Uses the enhanced ttester-xf test harness by David N.
\      Williams; however, the older ttester.fs may also be
\      used.
\
\ References:
\   1. http://sourceware.org/bugzilla/show_bug.cgi?id=3479
\
\   2. R. Regan, "Incorrectly Rounded Conversions in GCC and GLIBC",
\      http://www.exploringbinary.com/incorrectly-rounded-conversions-in-gcc-and-glibc/
\      June 3, 2010.
\
\   3. R. Regan, "Incorrectly Rounded Conversions in Visual C++",
\      http://www.exploringbinary.com/incorrectly-rounded-conversions-in-visual-c-plus-plus/
\      May 28, 2010.

CR .( FPIO-TEST         V1.3      21 Sep     2026 )
BASE @
s" ans-words" included
[undefined] T{ [if] s" ttester" included [then]

variable e_s1
variable e_s2
variable fpio-test-errors  0 fpio-test-errors !

:noname  ( c-addr u -- | Keep a cumulative error count )
  1 fpio-test-errors +! error1 ;  error-xt !

HEX
  4  constant  SINGLE_PREC
  8  constant  DOUBLE_PREC
  A  constant  EXT_PREC
 10  constant  QUAD_PREC

1 FLOATS constant SYSTEM_PREC

\ The following definitions are taken from the reference implementation 
\ of the memory access words Rfd (v. 20100621), for Forth 200x.

: B!    ( x addr --    ) SWAP FF AND SWAP C! ;
: B@    (   addr -- x  ) C@ FF AND ;
: BYTES CHARS ( n1 -- n2 ) ;

: b@+ ( x1 addr1 -- x2 addr2 )  SWAP 8 LSHIFT OVER B@ + SWAP 1 BYTES + ;
: b@- ( x1 addr1 -- x2 addr2 )  1 BYTES - DUP B@ ROT 8 LSHIFT + SWAP ;

: BE-L@ ( addr -- x )  0 SWAP  b@+ b@+ b@+ b@+    DROP ;
: LE-L@ ( addr -- x )  0 SWAP 4 BYTES + b@- b@- b@- b@- DROP ;

1234 PAD !
PAD B@ 34 = [IF]
\ Little-endian systems
: L@   ( a -- u ) LE-L@ ;
: lDF@ ( a -- u ) L@ ;
: uDF@ ( a -- u ) 4 BYTES + L@ ;
[ELSE]
\ Big-endian systems
: L@   ( a -- u ) BE-L@ ;
: lDF@ ( a -- u ) 4 BYTES + L@ ;
: uDF@ ( a -- u ) L@ ;
[THEN] 

: 2L@ dup uDF@ swap lDF@ ;

create r4   4 bytes allot
create r8   8 bytes allot

: !r ( a -- ) ( F: r -- ) fdup r4 sf! r8 df! ;

: dec_t{  decimal t{ ;
: hex_t{  hex     t{ ;


cr
0 e_s1 !
COMMENT Section I
TESTING Conversion of Exactly Representable Numbers
\ I.1
dec_t{  0.000000000000000000000000e0 !r -> }t
hex_t{  r4 L@  ->  00000000 }t 
hex_t{  r8 2L@ ->  00000000 00000000 }t

\ I.2
dec_t{  9.99999935045640392457461415399766451285519391957298315801212e-39 !r -> }t
hex_t{  r4 L@  ->  006ce3ee }t
hex_t{  r8 2L@ ->  380b38fb 80000000 }t

\ I.3
dec_t{ -1.00000001335143196001808973960578441619873046875e-10 !r -> }t
hex_t{  r4 L@  ->  aedbe6ff }t
hex_t{  r8 2L@ ->  bddb7cdf e0000000 }t

\ I.4
dec_t{  9.99999974737875163555145263671875e-05 !r -> }t
hex_t{  r4 L@  ->  38d1b717 }t
hex_t{  r8 2L@ ->  3f1a36e2 e0000000 }t

\ I.5
dec_t{  0.100000001490116119384765625e0 !r -> }t
hex_t{  r4 L@  ->  3dcccccd }t
hex_t{  r8 2L@ ->  3fb99999 a0000000 }t

\ I.6
dec_t{  1.0e0 !r -> }t
hex_t{  r4 L@  ->  3f800000 }t
hex_t{  r8 2L@ ->  3ff00000 00000000 }t

\ I.7
dec_t{ -1.0e0 !r -> }t
hex_t{  r4 L@  ->  bf800000 }t
hex_t{  r8 2L@ ->  bff00000 00000000 }t

\ I.8
dec_t{  3.926990926265716552734375e-1 !r -> }t
hex_t{  r4 L@  ->  3ec90fdb  }t
hex_t{  r8 2L@ ->  3fd921fb 60000000 }t

\ I.9
dec_t{  5.235987901687622070312500e-1 !r -> }t
hex_t{  r4 L@  ->  3f060a92 }t
hex_t{  r8 2L@ ->  3fe0c152 40000000 }t

\ I.10
dec_t{  7.853981852531433105468750e-1 !r -> }t
hex_t{  r4 L@  ->  3f490fdb }t
hex_t{  r8 2L@ ->  3fe921fb 60000000 }t

\ I.11
dec_t{  1.047197580337524414062500e0 !r -> }t
hex_t{  r4 L@  ->  3f860a92 }t
hex_t{  r8 2L@ ->  3ff0c152 40000000 }t

\ I.12
dec_t{  1.178097248077392578125000e0 !r -> }t
hex_t{  r4 L@  ->  3f96cbe4 }t
hex_t{  r8 2L@ ->  3ff2d97c 80000000 }t

\ I.13
dec_t{  1.570796370506286621093750e0 !r -> }t
hex_t{  r4 L@  ->  3fc90fdb }t
hex_t{  r8 2L@ ->  3ff921fb 60000000 }t

\ I.14
dec_t{  1.963495373725891113281250e0 !r -> }t
hex_t{  r4 L@  ->  3ffb53d1 }t
hex_t{  r8 2L@ ->  3fff6a7a 20000000 }t

\ I.15
dec_t{  2.094395160675048828125000e0 !r -> }t
hex_t{  r4 L@  ->  40060a92 }t
hex_t{  r8 2L@ ->  4000c152 40000000 }t

\ I.16
dec_t{  2.356194496154785156250000e0 !r -> }t
hex_t{  r4 L@  ->  4016cbe4 }t
hex_t{  r8 2L@ ->  4002d97c 80000000 }t

\ I.17
dec_t{  2.617993831634521484375000e0 !r -> }t
hex_t{  r4 L@  ->  40278d36 }t
hex_t{  r8 2L@ ->  4004f1a6 c0000000 }t

\ I.18
dec_t{  2.748893499374389648437500e0 !r -> }t
hex_t{  r4 L@  ->  402feddf }t
hex_t{  r8 2L@ ->  4005fdbb e0000000 }t

\ I.19
dec_t{  3.141592741012573242187500e0 !r -> }t
hex_t{  r4 L@  ->  40490fdb }t
hex_t{  r8 2L@ ->  400921fb 60000000 }t

\ I.20
dec_t{  10e0 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.21
dec_t{  1.0e1 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.22
dec_t{  0.10e2 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.23
dec_t{  0.010e3 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.24
dec_t{  0.0000010e7 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.25
dec_t{  0.000000000000010e15 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.26
dec_t{  0.0000000000000000000000000000000000010e37 !r -> }t
hex_t{  r4 L@  ->  41200000 }t
hex_t{  r8 2L@ ->  40240000 00000000 }t

\ I.27
dec_t{  1.0e10  !r -> }t
hex_t{  r4 L@  ->  501502f9 }t
hex_t{  r8 2L@ ->  4202a05f 20000000 }t

\ I.28
dec_t{  9999999933815812510711506376257961984e0 !r -> }t
hex_t{  r4 L@  ->  7cf0bdc2  }t
hex_t{  r8 2L@ ->  479e17b8 40000000 }t

fpio-test-errors @ e_s1 !
cr

0 e_s2 !
SYSTEM_PREC DOUBLE_PREC > [IF]
.( System FP precision is not supported for the rounding tests. ) cr
[ELSE]
COMMENT SECTION II
TESTING Rounding of Numbers

SYSTEM_PREC SINGLE_PREC = [IF]
COMMENT SFLOAT TESTS
\ II.1
dec_t{  1.0e-10 !r -> }t
hex_t{  r4 L@  -> 2edbe6ff }t

\ II.2
dec_t{  2.71828182845904523536e0 !r -> }t
hex_t{  r4 L@  -> 402df854 }t

\ II.3
dec_t{  3.14159265358979323846e0 !r -> }t
hex_t{  r4 L@  -> 40490fdb }t

\ II.4
dec_t{  3.518437208883201171875E+013 !r -> }t
hex_t{  r4 L@  -> 56000000 }t

\ II.5
dec_t{  1.00000005960464477550e0 !r -> }t
hex_t{  r4 L@  -> 3f800001 }t

\ II.6
dec_t{  5.00000000000000166533453693773481063544750213623046875e-1 !r -> }t
hex_t{  r4 L@  -> 3f000000 }t

\ II.7
dec_t{  62.5364939768271845828e0 !r -> }t
hex_t{  r4 L@  -> 427a255f }t

\ II.8
dec_t{  8.10109172351e-10 !r ->  }t
hex_t{  r4 L@  -> 305eae5d }t

\ II.9
dec_t{  9214843084008499e0 !r -> }t
hex_t{  r4 L@ -> 0 }t

\ II.10
dec_t{  1.50000000000000011102230246251565404236316680908203125e0 !r ->  }t
hex_t{  r4 L@  -> 3fc00000 }t

\ II.11
dec_t{  9007199254740991.4999999999999999999999999999999995e0 !r ->  }t
hex_t{  r4 L@  -> 5a000000 }t

\ II.12
dec_t{  1.000000000000000111022302462515654042363166809082031250e+00 !r -> }t
hex_t{  r4 L@  -> 3f800000 }t

\ II.13
dec_t{  1.000000000000000111022302462515654042363166809082031251e+00 !r -> }t
hex_t{  r4 L@  -> 3f800000 }t

[ELSE]
COMMENT DFLOAT TESTS
\ II.1
dec_t{  1.0e-10 !r -> }t
hex_t{  r8 2L@ -> 3ddb7cdf d9d7bdbb }t

\ II.2
dec_t{  2.71828182845904523536e0 !r -> }t
hex_t{  r8 2L@ -> 4005bf0a 8b145769 }t

\ II.3
dec_t{  3.14159265358979323846e0 !r -> }t
hex_t{  r8 2L@ -> 400921fb 54442d18 }t

\ II.4
dec_t{  3.518437208883201171875E+013 !r -> }t
hex_t{  r8 2L@ -> 42c00000 00000002 }t

\ II.5
dec_t{  1.00000005960464477550e0 !r -> }t
hex_t{  r8 2L@ -> 3ff00000 10000000 }t

\ II.6
dec_t{  5.00000000000000166533453693773481063544750213623046875e-1 !r -> }t
hex_t{  r8 2L@ -> 3fe00000 00000002 }t

\ II.7
dec_t{  62.5364939768271845828e0 !r -> }t
hex_t{  r8 2L@ -> 404f44ab d5aa7ca4 }t

\ II.8
dec_t{  8.10109172351e-10 !r ->  }t
hex_t{  r8 2L@ -> 3e0bd5cb aef0fd0c }t

\ II.9
dec_t{  9214843084008499e0 !r -> }t
hex_t{  r8 2L@ -> 43405e6c ec57761a }t

\ II.10
dec_t{  1.50000000000000011102230246251565404236316680908203125e0 !r ->  }t
hex_t{  r8 2L@ ->  3ff80000 0 }t

\ II.11
dec_t{  9007199254740991.4999999999999999999999999999999995e0 !r ->  }t
hex_t{  r8 2L@ -> 433fffff ffffffff }t

\ II.12
dec_t{  1.000000000000000111022302462515654042363166809082031250e+00 !r -> }t
hex_t{  r8 2L@ -> 3ff00000 00000000 }t

\ II.13
dec_t{  1.000000000000000111022302462515654042363166809082031251e+00 !r -> }t
hex_t{  r8 2L@ -> 3ff00000 00000001 }t

[THEN]
fpio-test-errors @ e_s1 @ - e_s2 !

[THEN]
BASE !

CR .( Section  I Error Count: ) e_s1 ?
CR .( Section II Error Count: ) e_s2 ?
CR .( Total      Error Count: ) FPIO-TEST-ERRORS ? CR
CR .( End of Floating Point I/O tests) CR