diff --git a/src/c/num_co.d b/src/c/num_co.d index 3f1c120b5..1a88fc970 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -115,51 +115,47 @@ cl_object cl_decode_float(cl_object x) { const cl_env_ptr the_env = ecl_process_env(); - int e, s; - cl_type tx = ecl_t_of(x); - float f; + int e, s = 1; + cl_object y = ECL_NIL; - switch (tx) { - case t_singlefloat: { - f = ecl_single_float(x); - if (f >= 0.0) { - s = 1; - } else { - f = -f; - s = 0; + switch (ecl_t_of(x)) { + case t_longfloat: { + long double d = ecl_long_float(x); + if (signbit(d)) { + s = -1; + d = -d; } - f = frexpf(f, &e); - x = ecl_make_single_float(f); + d = frexpl(d, &e); + x = ecl_make_long_float(d); + y = ecl_make_long_float(s); break; } case t_doublefloat: { double d = ecl_double_float(x); - if (d >= 0.0) { - s = 1; - } else { + if (signbit(d)) { + s = -1; d = -d; - s = 0; } d = frexp(d, &e); x = ecl_make_double_float(d); + y = ecl_make_double_float(s); break; } - case t_longfloat: { - long double d = ecl_long_float(x); - if (d >= 0.0) - s = 1; - else { + case t_singlefloat: { + float d = ecl_single_float(x); + if (signbit(d)) { + s = -1; d = -d; - s = 0; } - d = frexpl(d, &e); - x = ecl_make_long_float(d); + d = frexpf(d, &e); + x = ecl_make_single_float(d); + y = ecl_make_single_float(s); break; } default: FEwrong_type_only_arg(@[decode-float],x,@[float]); } - ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s)); + ecl_return3(the_env, x, ecl_make_fixnum(e), y); } cl_object diff --git a/src/tests/normal-tests/ieee-fp.lsp b/src/tests/normal-tests/ieee-fp.lsp index 0f3adf18a..503e20b25 100644 --- a/src/tests/normal-tests/ieee-fp.lsp +++ b/src/tests/normal-tests/ieee-fp.lsp @@ -813,3 +813,18 @@ Common Lisp type contagion rules." :floating-point-inexact) do (signals error (si:trap-fpe sym flag) "~s should be an invalid EXT:FPE-TRAP condition." sym))) (si:trap-fpe bits t)))) + +(test ieee-fp.0034.decode-float + (labels ((test-float (proto num res exp sign) + (equal (multiple-value-list (decode-float (float num proto))) + (list (float res proto) exp (float sign proto)))) + (test-float* (num res exp sign) + (is (test-float 1.0f0 num res exp sign)) + (is (test-float 1.0d0 num res exp sign)) + (is (test-float 1.0l0 num res exp sign)))) + (test-float* -10.0 0.625 4 -1.0) + (test-float* -1.0 0.5 1 -1.0) + (test-float* -0.0 0.0 0 -1.0) + (test-float* +0.0 0.0 0 +1.0) + (test-float* +1.0 0.5 1 +1.0) + (test-float* +10.0 0.625 4 +1.0)))