From fe46e8c697bb87d6f56a30f3807f77b9274890c2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 1 May 2018 23:27:57 -0700 Subject: [PATCH] Add support for C99 floating-point predicates. Also expose those predicates in Scheme, and implement flo:eqv? properly. --- src/microcode/artutl.c | 11 +---- src/microcode/extern.h | 1 - src/microcode/flonum.c | 74 ++++++++++++++++++++++++++++ src/runtime/arith.scm | 5 -- src/runtime/primitive-arithmetic.scm | 32 ++++++------ src/runtime/runtime.pkg | 11 ++++- 6 files changed, 102 insertions(+), 32 deletions(-) diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c index dcb6a0cfe..0c4291706 100644 --- a/src/microcode/artutl.c +++ b/src/microcode/artutl.c @@ -223,16 +223,7 @@ finite_flonum_p (SCHEME_OBJECT x) bool flonum_is_finite_p (SCHEME_OBJECT x) { - return double_is_finite_p (FLONUM_TO_DOUBLE (x)); -} - -bool -double_is_finite_p (double x) -{ - return - (((x > 1.0) || (x < -1.0)) - ? (x != (x / 2.0)) - : ((x <= 1.0) && (x >= -1.0))); + return (isfinite (FLONUM_TO_DOUBLE (x))); } bool diff --git a/src/microcode/extern.h b/src/microcode/extern.h index bedf025d2..1f1fa877b 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -271,7 +271,6 @@ extern SCHEME_OBJECT integer_negative_zero_bits (unsigned long, unsigned long); extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long); extern SCHEME_OBJECT integer_shift_right (SCHEME_OBJECT, unsigned long); -extern bool double_is_finite_p (double); extern SCHEME_OBJECT double_to_flonum (double); extern bool real_number_to_double_p (SCHEME_OBJECT); extern double real_number_to_double (SCHEME_OBJECT); diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c index 40d4f5f74..1b66da4c9 100644 --- a/src/microcode/flonum.c +++ b/src/microcode/flonum.c @@ -476,6 +476,80 @@ DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-SINGLE", Prim_cast_integer_to_ieee754 } } +/* C99 flonum predicates */ + +DEFINE_PRIMITIVE ("FLONUM-IS-FINITE?", Prim_flonum_is_finite_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isfinite (arg_flonum (1)))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-INFINITE?", Prim_flonum_is_infinite_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isinf (arg_flonum (1)))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-NAN?", Prim_flonum_is_nan_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isnan (arg_flonum (1)))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-NORMAL?", Prim_flonum_is_normal_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isnormal (arg_flonum (1)))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-NEGATIVE?", Prim_flonum_is_negative_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (signbit (arg_flonum (1)))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-GREATER?", Prim_flonum_is_greater_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (isgreater ((arg_flonum (1)), (arg_flonum (2))))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-GREATER-OR-EQUAL?", Prim_flonum_is_greater_or_equal_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (isgreaterequal ((arg_flonum (1)), (arg_flonum (2))))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-LESS-OR-EQUAL?", Prim_flonum_is_less_or_equal_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (islessequal ((arg_flonum (1)), (arg_flonum (2))))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-LESS?", Prim_flonum_is_less_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (isless ((arg_flonum (1)), (arg_flonum (2))))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-LESS-OR-GREATER?", Prim_flonum_is_less_or_greater_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (islessgreater ((arg_flonum (1)), (arg_flonum (2))))); +} + +DEFINE_PRIMITIVE ("FLONUM-IS-UNORDERED?", Prim_flonum_is_unordered_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (isunordered ((arg_flonum (1)), (arg_flonum (2))))); +} + /* Miscellaneous floating-point operations */ DEFINE_PRIMITIVE ("FLONUM-COPYSIGN", Prim_flonum_copysign, 2, 2, 0) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 01dd548d9..5fd209f29 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -912,11 +912,6 @@ USA. (let ((p flo:significand-digits-base-2)) (rat:* (flo:->integer (flo:denormalize f p)) (rat:expt 2 (int:- e-p p))))))) - -(define (flo:nan? x) - (not (or (flo:positive? x) - (flo:negative? x) - (flo:zero? x)))) (define (real:real? object) (or (flonum? object) diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm index 971beef6a..9b1b386e0 100644 --- a/src/runtime/primitive-arithmetic.scm +++ b/src/runtime/primitive-arithmetic.scm @@ -158,9 +158,20 @@ USA. (flo:zero? flonum-zero? 1) (flo:positive? flonum-positive? 1) (flo:negative? flonum-negative? 1) + (flo:finite? flonum-is-finite? 1) + (flo:infinite? flonum-is-infinite? 1) + (flo:nan? flonum-is-nan? 1) + (flo:normal? flonum-is-normal? 1) + (flo:safe-negative? flonum-is-negative? 1) (flo:= flonum-equal? 2) (flo:< flonum-less? 2) (flo:> flonum-greater? 2) + (flo:safe> flonum-is-greater? 2) + (flo:safe>= flonum-is-greater-or-equal? 2) + (flo:safe< flonum-is-less? 2) + (flo:safe<= flonum-is-less-or-equal? 2) + (flo:safe<> flonum-is-less-or-greater? 2) + (flo:unordered? flonum-is-unordered? 2) (flo:+ flonum-add 2) (flo:- flonum-subtract 2) (flo:* flonum-multiply 2) @@ -229,22 +240,13 @@ USA. ((flo:= x y) y) (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:max)))) -;;; XXX FLO:FINITE?, FLO:NAN?, FLO:EQV?, &c., are cute, but should be -;;; replaced by primitives. - -(define (flo:finite? x) - (if (or (flo:> x 1.) (flo:< x -1.)) - (not (flo:= x (flo:/ x 2.))) - (and (flo:<= x 1.) (flo:>= x -1.)))) - (define (flo:eqv? x y) - ;; (bit-string=? (flo:->bit-string x) (flo:->bit-string y)) - (if (flo:= x y) - (or (not (flo:zero? x)) - ;; XXX Kludgey but expedient test for zero sign. - (flo:= (flo:atan2 x -1.) (flo:atan2 y -1.))) - ;; XXX (and (flo:nan? x) (flo:nan? y) ...) - #f)) + (and (not (flo:nan? x)) + (not (flo:nan? y)) + (flo:= x y) + (or (not (flo:zero? x)) + (eq? (flo:safe-negative? x) + (flo:safe-negative? y))))) (define (int:->flonum n) ((ucode-primitive integer->flonum 2) n #b10)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index d60ba44a5..378feabb2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -299,6 +299,7 @@ USA. flo:floor->exact flo:gamma flo:hypot + flo:infinite? flo:j0 flo:j1 flo:jn @@ -308,12 +309,20 @@ USA. flo:max flo:min flo:modulo + flo:nan? flo:negate flo:negative? flo:nextafter + flo:normal? flo:positive? flo:round flo:round->exact + flo:safe-negative? + flo:safe< + flo:safe<= + flo:safe<> + flo:safe> + flo:safe>= flo:sin flo:sinh flo:sqrt @@ -321,6 +330,7 @@ USA. flo:tanh flo:truncate flo:truncate->exact + flo:unordered? flo:vector-cons flo:vector-length flo:vector-ref @@ -3311,7 +3321,6 @@ USA. cube exact-nonnegative-integer? exact-positive-integer? - flo:nan? flo:significand-digits-base-10 flo:significand-digits-base-2 flonum-unparser-cutoff -- 2.25.1