diff --git a/collects/tests/typed-scheme/succeed/flonum.ss b/collects/tests/typed-scheme/succeed/flonum.ss new file mode 100644 index 0000000000..d6c70ff3c3 --- /dev/null +++ b/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) diff --git a/collects/typed-scheme/private/base-env-numeric.ss b/collects/typed-scheme/private/base-env-numeric.ss index 5d2b05edf1..a7eb9b6326 100644 --- a/collects/typed-scheme/private/base-env-numeric.ss +++ b/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 diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 24c47968d1..001f9481d0 100644 --- a/src/mzscheme/src/numcomp.c +++ b/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(unsafe_fl_eq, ==, scheme_bin_eq) -UNSAFE_FL(unsafe_fl_lt, <, scheme_bin_lt) -UNSAFE_FL(unsafe_fl_gt, >, scheme_bin_gt) -UNSAFE_FL(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq) -UNSAFE_FL(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq) +UNSAFE_FL_COMP(unsafe_fl_eq, ==, scheme_bin_eq) +UNSAFE_FL_COMP(unsafe_fl_lt, <, scheme_bin_lt) +UNSAFE_FL_COMP(unsafe_fl_gt, >, scheme_bin_gt) +UNSAFE_FL_COMP(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq) +UNSAFE_FL_COMP(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_X(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN) +UNSAFE_FL_BINOP(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN) +UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)