Add the fx to fl conversion functions to Typed Scheme

Add tests for flonum operations to Typed Scheme test suite

Fix the compiler bug tests above uncovered

svn: r18609

collects/tests/typed-scheme/succeed/flonum.ss

@@ -0,0 +1,57 @@
+#lang typed/scheme
+
+(require
+ scheme/flonum
+ scheme/unsafe/ops)
+
+(: check (All (a) ((a a -> Boolean) a a -> Boolean)))
+;; Simple check function as SchemeUnit doesn't work in Typed Scheme (yet)
+(define (check f a b)
+  (if (f a b)
+      #t
+      (error (format "Check (~a ~a ~a) failed" f a b)))) 
+
+(: check-pred (All (a) ((a -> Boolean) a -> Boolean)))
+(define (check-pred pred v)
+  (if (pred v)
+      #t
+      (error (format "Check predicate (~a ~a) failed" pred v))))
+
+(: true? (Any -> Boolean))
+(define (true? x)
+  (if x #t #f))
+
+;; Check that flonum (safe and unsafe) functions work as expected
+
+(check = (flabs 1.45) (unsafe-flabs 1.45))
+(check = (fl+ 1.45 2.36) (unsafe-fl+ 1.45 2.36))
+(check = (fl- 1.45 2.36) (unsafe-fl- 1.45 2.36))
+(check = (fl* 1.45 2.36) (unsafe-fl* 1.45 2.36))
+(check = (fl/ 1.45 2.36) (unsafe-fl/ 1.45 2.36))
+(check-pred true? (fl= 1.45 1.45))
+(check-pred true? (fl<= 1.45 1.45))
+(check-pred true? (fl>= 1.45 1.45))
+(check-pred true? (fl> 1.45 1.36))
+(check-pred true? (fl< 1.36 1.45))
+(check-pred true? (unsafe-fl= 1.45 1.45))
+(check-pred true? (unsafe-fl<= 1.45 1.45))
+(check-pred true? (unsafe-fl>= 1.45 1.45))
+(check-pred true? (unsafe-fl> 1.45 1.36))
+(check-pred true? (unsafe-fl< 1.36 1.45))
+(check = (flmin 1.45 2.36) (unsafe-flmin 1.45 2.36))
+(check = (flmax 1.45 2.36) (unsafe-flmax 1.45 2.36))
+(check = (flround 1.45) (unsafe-flround 1.45))
+(check = (flfloor 1.45) (unsafe-flfloor 1.45))
+(check = (flceiling 1.45) (unsafe-flceiling 1.45))
+(check = (fltruncate 1.45) (unsafe-fltruncate 1.45))
+(check = (flsin 1.45) (unsafe-flsin 1.45))
+(check = (flcos 1.45) (unsafe-flcos 1.45))
+(check = (fltan 1.45) (unsafe-fltan 1.45))
+(check = (flatan 1.45) (unsafe-flatan 1.45))
+(check = (flasin .45) (unsafe-flasin .45))
+(check = (flacos .45) (unsafe-flacos .45))
+(check = (fllog 1.45) (unsafe-fllog 1.45))
+(check = (flexp 1.45) (unsafe-flexp 1.45))
+(check = (flsqrt 1.45) (unsafe-flsqrt 1.45))
+(check = (->fl 1) 1.0)
+(check = (unsafe-fx->fl 1) 1.0)

collects/typed-scheme/private/base-env-numeric.ss

@@ -185,6 +185,7 @@
 [unsafe-fllog fl-unop]
 [unsafe-flexp fl-unop]
 [unsafe-flsqrt fl-unop]
+[unsafe-fx->fl (-Integer . -> . -Flonum)]
 
 [unsafe-fx+ fx-op]
 [unsafe-fx- fx-intop]
@@ -261,6 +262,7 @@
 [fllog fl-unop]
 [flexp fl-unop]
 [flsqrt fl-unop]
+[->fl (-Integer . -> . -Flonum)]
 
 ;; safe flvector ops
 

src/mzscheme/src/numcomp.c

@@ -548,10 +548,22 @@ SAFE_FL(fl_gt_eq, "fl>=", >=)
 SAFE_FL_X(fl_min, "flmin", <, argv[0], argv[1])
 SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1])
 
-#define UNSAFE_FL_X(name, op, fold, T, F, PRE_CHECK)         \
+/* Unsafe FL comparisons. Return boolean */
+#define UNSAFE_FL_COMP(name, op, fold)         \
  static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
  {                                                           \
    if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
+   if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]))   \
+     return scheme_true;                                     \
+   else                                                      \
+     return scheme_false;                                    \
+ }
+
+/* Unsafe FL binary operators. Return flonum */
+#define UNSAFE_FL_BINOP(name, op, fold, T, F, PRE_CHECK)         \
+ static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
+ {                                                           \
+   if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1])); \
    PRE_CHECK                                                 \
    if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]))   \
      return T;                                               \
@@ -559,15 +571,13 @@ SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1])
      return F;                                               \
  }
 
-#define UNSAFE_FL(name, op, fold) UNSAFE_FL_X(name, op, fold, scheme_true, scheme_false, )
+UNSAFE_FL_COMP(unsafe_fl_eq, ==, scheme_bin_eq)
-
+UNSAFE_FL_COMP(unsafe_fl_lt, <, scheme_bin_lt)
-UNSAFE_FL(unsafe_fl_eq, ==, scheme_bin_eq)
+UNSAFE_FL_COMP(unsafe_fl_gt, >, scheme_bin_gt)
-UNSAFE_FL(unsafe_fl_lt, <, scheme_bin_lt)
+UNSAFE_FL_COMP(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq)
-UNSAFE_FL(unsafe_fl_gt, >, scheme_bin_gt)
+UNSAFE_FL_COMP(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq)
-UNSAFE_FL(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq)
-UNSAFE_FL(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq)
 
 #define CHECK_ARGV0_NAN if (MZ_IS_NAN(SCHEME_DBL_VAL(argv[0]))) return argv[0];
 
-UNSAFE_FL_X(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN)
+UNSAFE_FL_BINOP(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN)
-UNSAFE_FL_X(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)
+UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)