sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'fpe-without-sigfpe2' into 'develop'

Browse source 
ieee_fp: move fetestexcept checks directly after floating point calculations

See merge request embeddable-common-lisp/ecl!186
This commit is contained in:
Daniel Kochmański 2020-02-17 21:44:35 +00:00
commit db3079f8a0
15 changed files with 352 additions and 153 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/c/number.d
View file

@ -38,13 +38,11 @@
# define DO_DETECT_FPE2(f1,f2) DO_DETECT_FPE(f1)
# else
/*
* We need explicit checks for floating point exception bits being set
* We need explicit checks for floating point exception bits being
* set; ECL_MATHERR_TEST handles this for us, so nothing to do here.
*/
# define DO_DETECT_FPE(f) do { \
int status = fetestexcept(ecl_process_env()->trap_fpe_bits); \
unlikely_if (status) ecl_deliver_fpe(status); \
} while (0)
# define DO_DETECT_FPE2(f1,f2) DO_DETECT_FPE(f1)
# define DO_DETECT_FPE(f)
# define DO_DETECT_FPE2(f1,f2)
# endif
#else
/*

32
src/c/numbers/atan.d
View file

@ -24,23 +24,27 @@ cl_object
ecl_atan2(cl_object y, cl_object x)
{
cl_object output;
int tx = ecl_t_of(x);
int ty = ecl_t_of(y);
if (tx < ty)
tx = ty;
if (tx == t_longfloat) {
long double d = atan2l(ecl_to_long_double(y), ecl_to_long_double(x));
output = ecl_make_long_float(d);
} else {
double dx = ecl_to_double(x);
double dy = ecl_to_double(y);
double dz = atan2(dy, dx);
if (tx == t_doublefloat) {
output = ecl_make_double_float(dz);
ECL_MATHERR_CLEAR;
{
int tx = ecl_t_of(x);
int ty = ecl_t_of(y);
if (tx < ty)
tx = ty;
if (tx == t_longfloat) {
long double d = atan2l(ecl_to_long_double(y), ecl_to_long_double(x));
output = ecl_make_long_float(d);
} else {
output = ecl_make_single_float(dz);
double dx = ecl_to_double(x);
double dy = ecl_to_double(y);
double dz = atan2(dy, dx);
if (tx == t_doublefloat) {
output = ecl_make_double_float(dz);
} else {
output = ecl_make_single_float(dz);
}
}
}
ECL_MATHERR_TEST;
return output;
}

10
src/c/numbers/ceiling.d
View file

@ -18,6 +18,8 @@
#endif
#include <ecl/internal.h>
#pragma STDC FENV_ACCESS ON
@(defun ceiling (x &optional (y OBJNULL))
@
if (narg == 1)
@ -30,6 +32,8 @@ cl_object
ecl_ceiling1(cl_object x)
{
cl_object v0, v1;
ECL_MATHERR_CLEAR;
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
@ -66,6 +70,8 @@ ecl_ceiling1(cl_object x)
default:
FEwrong_type_nth_arg(@[ceiling],1,x,@[real]);
}
ECL_MATHERR_TEST;
@(return v0 v1);
}
@ -75,6 +81,8 @@ ecl_ceiling2(cl_object x, cl_object y)
const cl_env_ptr the_env = ecl_process_env();
cl_object v0, v1;
cl_type ty;
ECL_MATHERR_CLEAR;
v0 = v1 = ECL_NIL;
ty = ecl_t_of(y);
if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) {
@ -221,5 +229,7 @@ ecl_ceiling2(cl_object x, cl_object y)
default:
FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]);
}
ECL_MATHERR_TEST;
ecl_return2(the_env, v0, v1);
}

90
src/c/numbers/divide.d
View file

@ -12,9 +12,12 @@
*
*/
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
#pragma STDC FENV_ACCESS ON
@(defun / (num &rest nums)
@
/* INV: type check is in ecl_divide() */
@ -41,6 +44,9 @@ complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi)
cl_object
ecl_divide(cl_object x, cl_object y)
{
cl_object ret;
ECL_MATHERR_CLEAR;
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM;
@ -58,18 +64,22 @@ ecl_divide(cl_object x, cl_object y)
y->ratio.num);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y));
ret = ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y));
break;
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y));
ret = ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y));
break;
}
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y));
ret = ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y));
break;
}
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y));
ret = ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y));
break;
}
CASE_RATIO_FIXNUM {
if (y == ecl_make_fixnum(0)) {
@ -86,59 +96,76 @@ ecl_divide(cl_object x, cl_object y)
return ecl_make_ratio(num, den);
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y));
ret = ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y));
break;
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y));
ret = ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y));
break;
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y));
ret = ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y));
break;
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y));
ret = ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y));
break;
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y));
ret = ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y));
break;
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y));
ret = ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y));
break;
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y));
ret = ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y));
break;
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y));
ret = ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y));
break;
}
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y));
ret = ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y));
break;
}
CASE_BIGNUM_LONG_FLOAT;
CASE_RATIO_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y));
break;
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y));
ret = ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y));
break;
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y));
ret = ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y));
ret = ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y));
break;
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y));
ret = ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y));
break;
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y));
ret = ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y));
break;
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y));
ret = ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y));
break;
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y));
ret = ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
@ -180,9 +207,9 @@ ecl_divide(cl_object x, cl_object y)
CASE_SINGLE_FLOAT_CSFLOAT;
CASE_COMPLEX_CSFLOAT;
CASE_CSFLOAT_CSFLOAT {
cl_object aux = ecl_alloc_object(t_csfloat);
ecl_csfloat(aux) = ecl_to_csfloat(x) / ecl_to_csfloat(y);
return aux;
ret = ecl_alloc_object(t_csfloat);
ecl_csfloat(ret) = ecl_to_csfloat(x) / ecl_to_csfloat(y);
break;
}
/* upgraded type cdfloat */
CASE_CSFLOAT_DOUBLE_FLOAT;
@ -204,9 +231,9 @@ ecl_divide(cl_object x, cl_object y)
CASE_COMPLEX_CDFLOAT;
CASE_CSFLOAT_CDFLOAT;
CASE_CDFLOAT_CDFLOAT {
cl_object aux = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(aux) = ecl_to_cdfloat(x) / ecl_to_cdfloat(y);
return aux;
ret = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(ret) = ecl_to_cdfloat(x) / ecl_to_cdfloat(y);
break;
}
/* upgraded type clfloat */
CASE_CSFLOAT_LONG_FLOAT;
@ -234,12 +261,15 @@ ecl_divide(cl_object x, cl_object y)
CASE_CSFLOAT_CLFLOAT;
CASE_CDFLOAT_CLFLOAT;
CASE_CLFLOAT_CLFLOAT {
cl_object aux = ecl_alloc_object(t_clfloat);
ecl_clfloat(aux) = ecl_to_clfloat(x) / ecl_to_clfloat(y);
return aux;
ret = ecl_alloc_object(t_clfloat);
ecl_clfloat(ret) = ecl_to_clfloat(x) / ecl_to_clfloat(y);
break;
}
#endif
CASE_UNKNOWN(@[/],x,y,@[number]);
}
MATH_DISPATCH2_END;
ECL_MATHERR_TEST;
return ret;
}

28
src/c/numbers/expt.d
View file

@ -119,17 +119,25 @@ ecl_expt_float(cl_object x, cl_object y) {
cl_type
tx = ecl_t_of(x),
ty = ecl_t_of(y);
cl_object ret;
ECL_MATHERR_CLEAR;
switch((ty > tx) ? ty : tx) {
case t_longfloat:
return ecl_make_long_float
ret = ecl_make_long_float
(powl(ecl_to_long_double(x), ecl_to_long_double(y)));
break;
case t_doublefloat:
return ecl_make_double_float
ret = ecl_make_double_float
(pow(ecl_to_double(x), ecl_to_double(y)));
break;
default:
return ecl_make_single_float
ret = ecl_make_single_float
(powf(ecl_to_float(x), ecl_to_float(y)));
break;
}
ECL_MATHERR_TEST;
return ret;
}
#ifdef ECL_COMPLEX_FLOAT
@ -138,19 +146,27 @@ ecl_expt_complex_float(cl_object x, cl_object y) {
cl_type
tx = ecl_t_of(x),
ty = ecl_t_of(y);
cl_object ret;
ECL_MATHERR_CLEAR;
switch ((ty > tx)? ty : tx) {
case t_clfloat:
case t_longfloat:
return ecl_make_clfloat
ret = ecl_make_clfloat
(cpowl(ecl_to_clfloat(x), ecl_to_clfloat(y)));
break;
case t_cdfloat:
case t_doublefloat:
return ecl_make_cdfloat
ret = ecl_make_cdfloat
(cpow (ecl_to_cdfloat(x), ecl_to_cdfloat(y)));
break;
default:
return ecl_make_csfloat
ret = ecl_make_csfloat
(cpowf(ecl_to_csfloat(x), ecl_to_csfloat(y)));
break;
}
ECL_MATHERR_TEST;
return ret;
}
#endif

10
src/c/numbers/floor.d
View file

@ -21,6 +21,8 @@
#include <ecl/impl/math_dispatch2.h>
#include <ecl/internal.h>
#pragma STDC FENV_ACCESS ON
@(defun floor (x &optional (y OBJNULL))
@
if (narg == 1)
@ -34,6 +36,8 @@ ecl_floor1(cl_object x)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object v0, v1;
ECL_MATHERR_CLEAR;
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
@ -68,6 +72,8 @@ ecl_floor1(cl_object x)
default:
FEwrong_type_nth_arg(@[floor],1,x,@[real]);
}
ECL_MATHERR_TEST;
ecl_return2(the_env, v0, v1);
}
@ -76,6 +82,8 @@ ecl_floor2(cl_object x, cl_object y)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object v0, v1;
ECL_MATHERR_CLEAR;
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
@ -235,6 +243,8 @@ ecl_floor2(cl_object x, cl_object y)
}
}
MATH_DISPATCH2_END;
ECL_MATHERR_TEST;
ecl_return2(the_env, v0, v1);
}

94
src/c/numbers/minus.d
View file

@ -12,10 +12,12 @@
*
*/
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
#pragma STDC FENV_ACCESS ON
@(defun - (num &rest nums)
cl_object diff;
@
@ -31,6 +33,9 @@
cl_object
ecl_minus(cl_object x, cl_object y)
{
cl_object ret;
ECL_MATHERR_CLEAR;
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
@ -46,10 +51,12 @@ ecl_minus(cl_object x, cl_object y)
return ecl_make_ratio(z, y->ratio.den);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y));
ret = ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y));
break;
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y));
ret = ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y));
break;
}
CASE_BIGNUM_FIXNUM {
return _ecl_big_plus_fix(x, -ecl_fixnum(y));
@ -59,11 +66,13 @@ ecl_minus(cl_object x, cl_object y)
}
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y));
ret = ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y));
break;
}
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y));
ret = ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y));
break;
}
CASE_RATIO_FIXNUM;
/* fallthrough */
@ -80,61 +89,79 @@ ecl_minus(cl_object x, cl_object y)
return ecl_make_ratio(z, z1);
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y));
ret = ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y));
break;
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y));
ret = ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y));
break;
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y));
ret = ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y));
break;
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y));
ret = ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y));
break;
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y));
ret = ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y));
break;
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y));
ret = ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y));
break;
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y));
ret = ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y));
break;
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y));
ret = ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y));
break;
}
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y));
break;
}
CASE_BIGNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y));
break;
}
CASE_RATIO_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y));
break;
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y));
break;
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y));
ret = ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y));
break;
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y));
ret = ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y));
break;
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y));
ret = ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y));
break;
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y));
ret = ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y));
break;
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y));
ret = ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
@ -179,9 +206,9 @@ ecl_minus(cl_object x, cl_object y)
CASE_SINGLE_FLOAT_CSFLOAT;
CASE_COMPLEX_CSFLOAT;
CASE_CSFLOAT_CSFLOAT {
cl_object aux = ecl_alloc_object(t_csfloat);
ecl_csfloat(aux) = ecl_to_csfloat(x) - ecl_to_csfloat(y);
return aux;
ret = ecl_alloc_object(t_csfloat);
ecl_csfloat(ret) = ecl_to_csfloat(x) - ecl_to_csfloat(y);
break;
}
/* upgraded type cdfloat */
CASE_CSFLOAT_DOUBLE_FLOAT;
@ -203,9 +230,9 @@ ecl_minus(cl_object x, cl_object y)
CASE_COMPLEX_CDFLOAT;
CASE_CSFLOAT_CDFLOAT;
CASE_CDFLOAT_CDFLOAT {
cl_object aux = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(aux) = ecl_to_cdfloat(x) - ecl_to_cdfloat(y);
return aux;
ret = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(ret) = ecl_to_cdfloat(x) - ecl_to_cdfloat(y);
break;
}
/* upgraded type clfloat */
CASE_CSFLOAT_LONG_FLOAT;
@ -234,12 +261,15 @@ ecl_minus(cl_object x, cl_object y)
CASE_CDFLOAT_CLFLOAT;
CASE_CLFLOAT_CLFLOAT
{
cl_object aux = ecl_alloc_object(t_clfloat);
ecl_clfloat(aux) = ecl_to_clfloat(x) - ecl_to_clfloat(y);
return aux;
ret = ecl_alloc_object(t_clfloat);
ecl_clfloat(ret) = ecl_to_clfloat(x) - ecl_to_clfloat(y);
break;
}
#endif
CASE_UNKNOWN(@[-],x,y,@[number]);
}
MATH_DISPATCH2_END;
ECL_MATHERR_TEST;
return ret;
}

5
src/c/numbers/one_minus.d
View file

@ -16,6 +16,11 @@
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch.h>
/* INV: FLT_MIN - 1 == FLT_MIN
* DBL_MIN - 1 == DBL_MIN
* LDBL_MIN - 1 == LDBL_MIN
* (no ECL_MATHERR_TEST needed) */
static cl_object
ecl_one_minus_fix(cl_object x)
{

5
src/c/numbers/one_plus.d
View file

@ -16,6 +16,11 @@
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch.h>
/* INV: FLT_MAX + 1 == FLT_MAX
* DBL_MAX + 1 == DBL_MAX
* LDBL_MAX + 1 == LDBL_MAX
* (no ECL_MATHERR_TEST needed) */
static cl_object
ecl_one_plus_fix(cl_object x)
{

94
src/c/numbers/plus.d
View file

@ -12,10 +12,12 @@
*
*/
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
#pragma STDC FENV_ACCESS ON
@(defun + (&rest nums)
cl_object sum = ecl_make_fixnum(0);
@
@ -27,6 +29,9 @@
cl_object
ecl_plus(cl_object x, cl_object y) {
cl_object ret;
ECL_MATHERR_CLEAR;
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
@ -42,10 +47,12 @@ ecl_plus(cl_object x, cl_object y) {
return ecl_make_ratio(z, y->ratio.den);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y));
ret = ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y));
break;
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y));
ret = ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y));
break;
}
CASE_BIGNUM_FIXNUM {
return _ecl_big_plus_fix(x, ecl_fixnum(y));
@ -55,11 +62,13 @@ ecl_plus(cl_object x, cl_object y) {
}
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y));
ret = ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y));
break;
}
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y));
ret = ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y));
break;
}
CASE_RATIO_FIXNUM;
CASE_RATIO_BIGNUM {
@ -75,61 +84,79 @@ ecl_plus(cl_object x, cl_object y) {
return ecl_make_ratio(z, z1);
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y));
ret = ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y));
break;
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y));
ret = ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y));
break;
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y));
ret = ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y));
break;
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y));
ret = ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y));
break;
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y));
ret = ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y));
break;
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y));
ret = ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y));
break;
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y));
ret = ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y));
break;
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y));
ret = ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y));
break;
}
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y));
break;
}
CASE_BIGNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y));
break;
}
CASE_RATIO_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y));
break;
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y));
break;
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y));
ret = ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y));
break;
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y));
ret = ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y));
break;
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y));
ret = ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y));
break;
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y));
ret = ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y));
break;
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y));
ret = ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
@ -174,9 +201,9 @@ ecl_plus(cl_object x, cl_object y) {
CASE_SINGLE_FLOAT_CSFLOAT;
CASE_COMPLEX_CSFLOAT;
CASE_CSFLOAT_CSFLOAT {
cl_object aux = ecl_alloc_object(t_csfloat);
ecl_csfloat(aux) = ecl_to_csfloat(x) + ecl_to_csfloat(y);
return aux;
ret = ecl_alloc_object(t_csfloat);
ecl_csfloat(ret) = ecl_to_csfloat(x) + ecl_to_csfloat(y);
break;
}
/* upgraded type cdfloat */
CASE_CSFLOAT_DOUBLE_FLOAT;
@ -198,9 +225,9 @@ ecl_plus(cl_object x, cl_object y) {
CASE_COMPLEX_CDFLOAT;
CASE_CSFLOAT_CDFLOAT;
CASE_CDFLOAT_CDFLOAT {
cl_object aux = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(aux) = ecl_to_cdfloat(x) + ecl_to_cdfloat(y);
return aux;
ret = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(ret) = ecl_to_cdfloat(x) + ecl_to_cdfloat(y);
break;
}
/* upgraded type clfloat */
CASE_CSFLOAT_LONG_FLOAT;
@ -229,12 +256,15 @@ ecl_plus(cl_object x, cl_object y) {
CASE_CDFLOAT_CLFLOAT;
CASE_CLFLOAT_CLFLOAT
{
cl_object aux = ecl_alloc_object(t_clfloat);
ecl_clfloat(aux) = ecl_to_clfloat(x) + ecl_to_clfloat(y);
return aux;
ret = ecl_alloc_object(t_clfloat);
ecl_clfloat(ret) = ecl_to_clfloat(x) + ecl_to_clfloat(y);
break;
}
#endif
CASE_UNKNOWN(@[+],x,y,@[number]);
}
MATH_DISPATCH2_END;
ECL_MATHERR_TEST;
return ret;
}

6
src/c/numbers/round.d
View file

@ -23,6 +23,8 @@
#endif
#include <ecl/internal.h>
#pragma STDC FENV_ACCESS ON
@(defun round (x &optional (y OBJNULL))
@
if (narg == 1)
@ -104,6 +106,8 @@ ecl_round1(cl_object x)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object v0, v1;
ECL_MATHERR_CLEAR;
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
@ -138,6 +142,8 @@ ecl_round1(cl_object x)
default:
FEwrong_type_nth_arg(@[round],1,x,@[real]);
}
ECL_MATHERR_TEST;
ecl_return2(the_env, v0, v1);
}

97
src/c/numbers/times.d
View file

@ -12,10 +12,12 @@
*
*/
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <ecl/impl/math_dispatch2.h>
#pragma STDC FENV_ACCESS ON
@(defun * (&rest nums)
cl_object prod = ecl_make_fixnum(1);
@
@ -28,6 +30,9 @@
cl_object
ecl_times(cl_object x, cl_object y)
{
cl_object ret;
ECL_MATHERR_CLEAR;
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM {
@ -42,10 +47,12 @@ ecl_times(cl_object x, cl_object y)
y->ratio.den);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y));
ret = ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y));
break;
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y));
ret = ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y));
break;
}
CASE_BIGNUM_FIXNUM {
return _ecl_big_times_fix(x, ecl_fixnum(y));
@ -54,10 +61,12 @@ ecl_times(cl_object x, cl_object y)
return _ecl_big_times_big(x, y);
}
CASE_BIGNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y));
ret = ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y));
break;
}
CASE_BIGNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y));
ret = ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y));
break;
}
CASE_RATIO_FIXNUM;
CASE_RATIO_BIGNUM {
@ -70,65 +79,84 @@ ecl_times(cl_object x, cl_object y)
return ecl_make_ratio(num, den);
}
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y));
ret = ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y));
break;
}
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y));
ret = ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y));
break;
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y));
ret = ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y));
break;
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y));
ret = ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y));
break;
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y));
ret = ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y));
break;
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y));
ret = ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y));
break;
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y));
ret = ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y));
break;
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y));
ret = ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y));
break;
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y));
ret = ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y));
break;
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y));
ret = ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y));
break;
}
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y));
ret = ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y));
break;
}
CASE_BIGNUM_LONG_FLOAT;
CASE_RATIO_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y));
ret = ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y));
break;
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y));
ret = ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y));
break;
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y));
ret = ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y));
ret = ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y));
break;
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y));
ret = ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y));
break;
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y));
ret = ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y));
break;
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y));
ret = ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y));
break;
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y));
ret = ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y));
break;
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
@ -179,9 +207,9 @@ ecl_times(cl_object x, cl_object y)
CASE_SINGLE_FLOAT_CSFLOAT;
CASE_COMPLEX_CSFLOAT;
CASE_CSFLOAT_CSFLOAT {
cl_object aux = ecl_alloc_object(t_csfloat);
ecl_csfloat(aux) = ecl_to_csfloat(x) * ecl_to_csfloat(y);
return aux;
ret = ecl_alloc_object(t_csfloat);
ecl_csfloat(ret) = ecl_to_csfloat(x) * ecl_to_csfloat(y);
break;
}
/* upgraded type cdfloat */
CASE_CSFLOAT_DOUBLE_FLOAT;
@ -203,9 +231,9 @@ ecl_times(cl_object x, cl_object y)
CASE_COMPLEX_CDFLOAT;
CASE_CSFLOAT_CDFLOAT;
CASE_CDFLOAT_CDFLOAT {
cl_object aux = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(aux) = ecl_to_cdfloat(x) * ecl_to_cdfloat(y);
return aux;
ret = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(ret) = ecl_to_cdfloat(x) * ecl_to_cdfloat(y);
break;
}
/* upgraded type clfloat */
CASE_CSFLOAT_LONG_FLOAT;
@ -234,12 +262,15 @@ ecl_times(cl_object x, cl_object y)
CASE_CDFLOAT_CLFLOAT;
CASE_CLFLOAT_CLFLOAT
{
cl_object aux = ecl_alloc_object(t_clfloat);
ecl_clfloat(aux) = ecl_to_clfloat(x) * ecl_to_clfloat(y);
return aux;
ret = ecl_alloc_object(t_clfloat);
ecl_clfloat(ret) = ecl_to_clfloat(x) * ecl_to_clfloat(y);
break;
}
#endif
CASE_UNKNOWN(@[*],x,y,@[number]);
}
MATH_DISPATCH2_END;
ECL_MATHERR_TEST;
return ret;
}

5
src/c/numbers/truncate.d
View file

@ -22,10 +22,14 @@
#endif
#include <ecl/internal.h>
#pragma STDC FENV_ACCESS ON
cl_object
ecl_truncate1(cl_object x)
{
cl_object v0, v1;
ECL_MATHERR_CLEAR;
switch (ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
@ -61,6 +65,7 @@ ecl_truncate1(cl_object x)
default:
FEwrong_type_nth_arg(@[truncate],1,x,@[real]);
}
ECL_MATHERR_TEST;
{
const cl_env_ptr the_env = ecl_process_env();
ecl_return2(the_env, v0, v1);

2
src/h/impl/math_dispatch.h
View file

@ -63,7 +63,9 @@ typedef cl_object (*math_one_arg_fn)(cl_object);
cl_object ecl_##name(cl_object arg) \
{ \
cl_object out; \
ECL_MATHERR_CLEAR; \
out = ecl_##name##_ne(arg); \
ECL_MATHERR_TEST; \
return out; \
}

17
src/h/impl/math_fenv.h
View file

@ -95,4 +95,21 @@
# define ECL_WITH_LISP_FPE_END } while (0)
#endif
#if defined(HAVE_FENV_H) && defined(ECL_IEEE_FP) && !defined(HAVE_FEENABLEEXCEPT) && !defined(ECL_AVOID_FPE_H)
# define ECL_USED_EXCEPTIONS (FE_DIVBYZERO|FE_INVALID|FE_OVERFLOW|FE_UNDERFLOW)
# define ECL_MATHERR_CLEAR feclearexcept(FE_ALL_EXCEPT)
# define ECL_MATHERR_TEST do { \
int bits = fetestexcept(ECL_USED_EXCEPTIONS); \
unlikely_if (bits) { \
bits &= ecl_process_env()->trap_fpe_bits; \
if (bits) ecl_deliver_fpe(bits); \
} \
} while(0)
#else
# define ECL_MATHERR_CLEAR
# define ECL_MATHERR_TEST
#endif
extern void ecl_deliver_fpe(int flags);
#endif /* !ECL_MATH_FENV_H */