suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add the fx to fl conversion functions to Typed Scheme

Browse Source 
Add tests for flonum operations to Typed Scheme test suite

Fix the compiler bug tests above uncovered

svn: r18609
This commit is contained in:
Noel Welsh 2010-03-24 13:18:37 +00:00
parent 4c547721dd
commit af84b331a1
3 changed files with 79 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/tests/typed-scheme/succeed/flonum.ss Normal file
View File

@ -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)

2
collects/typed-scheme/private/base-env-numeric.ss
View File

@ -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

30
src/mzscheme/src/numcomp.c
View File

@ -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)