From 62129ffea4dc0b3fbe44d5f5d21bb14ef4b16d2d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Jul 2017 18:47:59 -0500
Subject: [PATCH] basis: Add unit-test~ and unit-test-v~ for testing floats.

Use unit-test~ in math.functions in some places to make sure we like it.
---
 basis/math/functions/functions-tests.factor | 21 ++++++++---------
 basis/math/functions/functions.factor       |  4 ++--
 basis/tools/test/test.factor                | 25 ++++++++++++++++-----
 3 files changed, 33 insertions(+), 17 deletions(-)

diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index f0f3930c83..3cb2febf54 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -82,11 +82,11 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
 { 4.0 } [ 10000.0 log10 ] unit-test
 { $ log10-factorial-1000 t } [ 1000 factorial [ log10 ] [ bignum? ] bi ] unit-test
 
-{ t } [ 1 e^ e 1.e-10 ~ ] unit-test
-{ f } [ 1 e^ 0/0. 1.e-10 ~ ] unit-test
-{ f } [ 0/0. 1 e^ 1.e-10 ~ ] unit-test
-{ t } [ 1.0 e^ e 1.e-10 ~ ] unit-test
-{ t } [ -1 e^ e * 1.0 1.e-10 ~ ] unit-test
+{ e 1.e-10 } [ 1 e^ ] unit-test~
+{ 0/0. 1.e-10 } [ 1 e^ ] unit-test~
+{ 1.e-10 } [ 0/0. 1 e^ ] unit-test~
+{ e 1.e-10 } [ 1.0 e^ ] unit-test~
+{ 1.0 1.e-10 } [ -1 e^ e * ] unit-test~
 { f } [ 1/0. 1/0. 1.e-10 ~ ] unit-test
 { f } [ 1/0. -1/0. 1.e-10 ~ ] unit-test
 { f } [ 1/0. 0/0. 1.e-10 ~ ] unit-test
@@ -120,12 +120,13 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
 { f } [ 10 atanh real? ] unit-test
 { f } [ 10.0 atanh real? ] unit-test
 
-{ t } [ 10 asin sin 10 1.e-10 ~ ] unit-test
+{ 10 1.e-10 } [ 10 asin sin ] unit-test~
+{ -100 1.e-10 } [ -100 atan tan ] unit-test~
+{ 10 1.e-10 } [ 10 asinh sinh ] unit-test~
+{ 10 1.e-10 } [ 10 atanh tanh ] unit-test~
+{ 0.5 1.e-10 } [ 0.5 atanh tanh ] unit-test~
+
 { t } [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
-{ t } [ -100 atan tan -100 1.e-10 ~ ] unit-test
-{ t } [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
-{ t } [ 10 atanh tanh 10 1.e-10 ~ ] unit-test
-{ t } [ 0.5 atanh tanh 0.5 1.e-10 ~ ] unit-test
 
 { t } [ 0 42 divisor? ] unit-test
 { t } [ 42 7 divisor? ] unit-test
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index ec19c5a54e..ab19faf078 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel math.constants math.private math.bits
-math.libm combinators fry math.order sequences ;
+USING: combinators fry kernel math math.bits math.constants
+math.libm math.order math.private sequences ;
 IN: math.functions
 
 GENERIC: sqrt ( x -- y ) foldable
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index ee5ef0de05..8473b2d70f 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -3,11 +3,11 @@
 USING: accessors arrays assocs combinators command-line
 compiler.units continuations debugger effects fry
 generalizations io io.files.temp io.files.unique kernel lexer
-locals macros namespaces parser prettyprint quotations sequences
-sequences.generalizations source-files source-files.errors
-source-files.errors.debugger splitting stack-checker summary
-system tools.errors unicode vocabs vocabs.files vocabs.metadata
-vocabs.parser words ;
+locals macros math.functions math.vectors namespaces parser
+prettyprint quotations sequences sequences.generalizations
+source-files source-files.errors source-files.errors.debugger
+splitting stack-checker summary system tools.errors unicode
+vocabs vocabs.files vocabs.metadata vocabs.parser words ;
 FROM: vocabs.hierarchy => load ;
 IN: tools.test
 
@@ -64,6 +64,18 @@ SYMBOL: current-test-file
 : (long-unit-test) ( output input -- error/f failed? tested? )
     long-unit-tests-enabled? get [ (unit-test) ] [ 2drop f f f ] if ;
 
+: (unit-test-comparator) ( output input comparator -- error/f failed? tested? )
+    swapd '[
+        { } _ with-datastack
+        _ >quotation _ compose with-datastack f
+    ] [ t ] recover t ; inline
+
+: (unit-test~) ( output input -- error/f failed? tested? )
+    [ ~ ] (unit-test-comparator) ;
+
+: (unit-test-v~) ( output input -- error/f failed? tested? )
+    [ v~ ] (unit-test-comparator) ;
+
 : short-effect ( effect -- pair )
     [ in>> length ] [ out>> length ] bi 2array ;
 
@@ -172,6 +184,9 @@ PRIVATE>
     [ cleanup-unique-directory ] with-temp-directory ; inline
 
 TEST: unit-test
+TEST: unit-test~
+TEST: unit-test-v~
+TEST: unit-test-comparator
 TEST: long-unit-test
 TEST: must-infer-as
 TEST: must-infer