This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/arith1.c

1065 lines
24 KiB
C
Raw Normal View History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
2018-04-23 14:34:52 +01:00
* File: arith1.c * Last rev:
** mods: * comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
2018-04-23 14:34:52 +01:00
static char SccsId[] = "%W% %G%";
#endif
2014-04-21 11:14:18 +01:00
/**
@file arith1.c
2014-04-21 11:14:18 +01:00
@addtogroup arithmetic_operators
2014-04-21 11:14:18 +01:00
- <b>exp( _X_) [ISO]</b><p> @anchor exp_1
Natural exponential.
- <b>log( _X_) [ISO]</b><p> @anchor log_1
Natural logarithm.
- <b>log10( _X_)</b><p> @anchor log10_1
Decimal logarithm.
- <b>sqrt( _X_) [ISO]</b><p> @anchor sqrt_1
Square root.
- <b>sin( _X_) [ISO]</b><p> @anchor sin_1
Sine.
- <b>cos( _X_) [ISO]</b><p> @anchor cos_1
Cosine.
- <b>tan( _X_) [ISO]</b><p> @anchor tan_1
Tangent.
- <b>asin( _X_) [ISO]</b><p> @anchor asin_1
Arc sine.
- <b>acos( _X_) [ISO]</b><p> @anchor acos_1
Arc cosine.
- <b>atan( _X_) [ISO]</b><p> @anchor atan_1
Arc tangent.
- <b>sinh( _X_)</b><p> @anchor sinh_1
Hyperbolic sine.
- <b>cosh( _X_)</b><p> @anchor cosh_1
Hyperbolic cosine.
- <b>tanh( _X_)</b><p> @anchor tanh_1
Hyperbolic tangent.
- <b>asinh( _X_)</b><p> @anchor asinh_1
Hyperbolic arc sine.
- <b>acosh( _X_)</b><p> @anchor acosh_1
Hyperbolic arc cosine.
- <b>atanh( _X_)</b><p> @anchor atanh_1
Hyperbolic arc tangent.
- <b>lgamma( _X_)</b><p> @anchor lgamma_1
Logarithm of gamma function.
- <b>erf( _X_)</b><p> @anchor erf_1
Gaussian error function.
- <b>erfc( _X_)</b><p> @anchor erfc_1
Complementary gaussian error function.
- <b>random( _X_) [ISO]</b><p> @anchor random_1_op
An integer random number between 0 and _X_.
In `iso` language mode the argument must be a floating
point-number, the result is an integer and it the float is equidistant
it is rounded up, that is, to the least integer greater than _X_.
- <b>integer( _X_)</b><p> @anchor integer_1_op
2018-04-23 14:34:52 +01:00
If _X_ evaluates to a float, the integer between the value of _X_ and 0
closest to the value of _X_, else if _X_ evaluates to an integer, the value of
_X_.
2014-04-21 11:14:18 +01:00
- <b>float( _X_) [ISO]</b><p> @anchor float_1_op
2018-04-23 14:34:52 +01:00
If _X_ evaluates to an integer, the corresponding float, else the float
itself.
2014-04-21 11:14:18 +01:00
- <b>float_fractional_part( _X_) [ISO]</b><p> @anchor float_fractional_part_1
2018-04-23 14:34:52 +01:00
The fractional part of the floating point number _X_, or `0.0` if _X_ is
an integer. In the `iso` language mode, _X_ must be an integer.
2014-04-21 11:14:18 +01:00
- <b>float_integer_part( _X_) [ISO]</b><p> @anchor float_integer_part_1
2018-04-23 14:34:52 +01:00
The float giving the integer part of the floating point number _X_, or _X_
if _X_ is an integer. In the `iso` language mode, _X_ must be an integer.
2014-04-21 11:14:18 +01:00
- <b>abs( _X_) [ISO]</b><p> @anchor abs_1
The absolute value of _X_.
- <b>ceiling( _X_) [ISO]</b><p> @anchor ceiling_1
The integer that is the smallest integral value not smaller than _X_.
2018-04-23 14:34:52 +01:00
In `iso` language mode the argument must be a floating point-number and the
result is an integer.
2014-04-21 11:14:18 +01:00
- <b>floor( _X_) [ISO]</b><p> @anchor floor_1
The integer that is the greatest integral value not greater than _X_.
In `iso` language mode the argument must be a floating
point-number and the result is an integer.
- <b>round( _X_) [ISO]</b><p> @anchor round_1
2018-04-23 14:34:52 +01:00
The nearest integral value to _X_. If _X_ is equidistant to two integers,
it will be rounded to the closest even integral value.
2014-04-21 11:14:18 +01:00
2018-04-23 14:34:52 +01:00
In `iso` language mode the argument must be a floating point-number, the
result is an integer and it the float is equidistant it is rounded up, that is,
to the least integer greater than _X_.
2014-04-21 11:14:18 +01:00
- <b>sign( _X_) [ISO]</b><p> @anchor sign_1
2018-04-23 14:34:52 +01:00
Return 1 if the _X_ evaluates to a positive integer, 0 it if evaluates to
0, and -1 if it evaluates to a negative integer. If _X_ evaluates to a
floating-point number return 1.0 for a positive _X_, 0.0 for 0.0, and -1.0
otherwise.
2014-04-21 11:14:18 +01:00
- <b>truncate( _X_) [ISO]</b><p> @anchor truncate_1
The integral value between _X_ and 0 closest to _X_.
- <b>rational( _X_)</b><p> @anchor rational_1_op
2018-04-23 14:34:52 +01:00
Convert the expression _X_ to a rational number or integer. The function
returns the input on integers and rational numbers. For floating point numbers,
the returned rational number exactly represents the float. As floats cannot
exactly represent all decimal numbers the results may be surprising. In the
examples below, doubles can represent `0.25` and the result is as expected, in
contrast to the result of `rational(0.1)`. The function `rationalize/1` gives a
more intuitive result.
2014-04-21 11:14:18 +01:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~prolog
?- A is rational(0.25).
A is 1 rdiv 4
?- A is rational(0.1).
A = 3602879701896397 rdiv 36028797018963968
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- <b>rationalize( _X_)</b><p> @anchor rationalize_1
Convert the expression _X_ to a rational number or integer. The function is
2018-04-23 14:34:52 +01:00
similar to [rational/1](@ref rational_1), but the result is only accurate
within the rounding error of floating point numbers, generally producing a much
smaller denominator.
2014-04-21 11:14:18 +01:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~prolog
?- A is rationalize(0.25).
A = 1 rdiv 4
?- A is rationalize(0.1).
A = 1 rdiv 10
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- <b>\\ _X_ [ISO]</b><p>
Integer bitwise negation.
- <b>msb( _X_)</b><p> @anchor msb_1
The most significant bit of the non-negative integer _X_.
- <b>lsb( _X_)</b><p> @anchor lsb_1
The least significant bit of the non-negative integer _X_.
- <b>popcount( _X_)</b><p> @anchor popcount_1
2018-04-23 14:34:52 +01:00
The number of bits set to `1` in the binary representation of the
non-negative integer _X_.
2014-04-21 11:14:18 +01:00
- <b>[ _X_]</b><p>
Evaluates to _X_ for expression _X_. Useful because character
strings in Prolog are lists of character codes.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.prolog}
X is Y*10+C-"0"
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
is the same as
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.prolog}
X is Y*10+C-[48].
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
which would be evaluated as:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.prolog}
X is Y*10+C-48.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*/
#include "Yap.h"
2017-02-20 14:21:46 +00:00
#include "YapEval.h"
2018-04-23 14:34:52 +01:00
#include "YapHeap.h"
#include "Yatom.h"
2018-04-23 14:34:52 +01:00
static Term float_to_int(Float v USES_REGS) {
#if USE_GMP
Int i = (Int)v;
2018-04-23 14:34:52 +01:00
if (i - v == 0.0) {
return MkIntegerTerm(i);
} else {
return Yap_gmp_float_to_big(v);
}
#else
return MkIntegerTerm(v);
#endif
}
2018-04-23 14:34:52 +01:00
#define RBIG_FL(v) return (float_to_int(v PASS_REGS))
typedef struct init_un_eval {
2018-04-23 14:34:52 +01:00
char *OpName;
arith1_op f;
} InitUnEntry;
/* Some compilers just don't get it */
#ifdef __MINGW32__
#undef HAVE_ASINH
#undef HAVE_ACOSH
#undef HAVE_ATANH
#undef HAVE_FINITE
#endif
#if !HAVE_ASINH
2018-04-23 14:34:52 +01:00
#define asinh(F) (log((F) + sqrt((F) * (F) + 1)))
#endif
#if !HAVE_ACOSH
2018-04-23 14:34:52 +01:00
#define acosh(F) (log((F) + sqrt((F) * (F)-1)))
#endif
#if !HAVE_ATANH
2018-04-23 14:34:52 +01:00
#define atanh(F) (log((1 + (F)) / (1 - (F))) / 2)
#endif
2018-04-23 14:34:52 +01:00
static inline Float get_float(Term t) {
if (IsFloatTerm(t)) {
return FloatOfTerm(t);
}
if (IsIntTerm(t)) {
return IntOfTerm(t);
}
if (IsLongIntTerm(t)) {
return LongIntOfTerm(t);
}
#ifdef USE_GMP
if (IsBigIntTerm(t)) {
return Yap_gmp_to_float(t);
}
#endif
return 0.0;
}
/* WIN32 machines do not necessarily have rint. This will do for now */
#if HAVE_RINT
#define my_rint(X) rint(X)
#else
2018-04-23 14:34:52 +01:00
static double my_rint(double x) {
double y, z;
Int n;
if (x >= 0) {
y = x + 0.5;
z = floor(y);
2018-04-23 14:34:52 +01:00
n = (Int)z;
if (y == z && n % 2)
2018-04-23 14:34:52 +01:00
return (z - 1);
} else {
y = x - 0.5;
z = ceil(y);
2018-04-23 14:34:52 +01:00
n = (Int)z;
if (y == z && n % 2)
2018-04-23 14:34:52 +01:00
return (z + 1);
}
2018-04-23 14:34:52 +01:00
return (z);
}
#endif
static Int
2018-04-23 14:34:52 +01:00
msb(Int inp USES_REGS) /* calculate the most significant bit for an integer */
{
/* the obvious solution: do it by using binary search */
Int out = 0;
if (inp < 0) {
2016-11-08 07:37:36 +00:00
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
2018-04-23 14:34:52 +01:00
"msb/1 received %d", inp);
}
#if HAVE__BUILTIN_FFSLL
2018-04-23 14:34:52 +01:00
out = __builtin_ffsll(inp);
#elif HAVE_FFSLL
2018-04-23 14:34:52 +01:00
out = ffsll(inp);
#else
2018-04-23 14:34:52 +01:00
if (inp == 0)
return 0L;
#if SIZEOF_INT_P == 8
2018-04-23 14:34:52 +01:00
if (inp & ((CELL)0xffffffffLL << 32)) {
inp >>= 32;
out += 32;
}
#endif
2018-04-23 14:34:52 +01:00
if (inp & ((CELL)0xffffL << 16)) {
inp >>= 16;
out += 16;
}
if (inp & ((CELL)0xffL << 8)) {
inp >>= 8;
out += 8;
}
if (inp & ((CELL)0xfL << 4)) {
inp >>= 4;
out += 4;
}
if (inp & ((CELL)0x3L << 2)) {
inp >>= 2;
out += 2;
}
if (inp & ((CELL)0x1 << 1))
out++;
#endif
return out;
}
2018-04-23 14:34:52 +01:00
Int Yap_msb(
Int inp USES_REGS) /* calculate the most significant bit for an integer */
{
return msb(inp PASS_REGS);
}
2009-10-20 09:50:51 +01:00
static Int
2018-04-23 14:34:52 +01:00
lsb(Int inp USES_REGS) /* calculate the least significant bit for an integer */
2009-10-20 09:50:51 +01:00
{
/* the obvious solution: do it by using binary search */
Int out = 0;
if (inp < 0) {
2016-11-08 07:37:36 +00:00
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
2018-04-23 14:34:52 +01:00
"msb/1 received %d", inp);
2009-10-20 09:50:51 +01:00
}
2018-04-23 14:34:52 +01:00
if (inp == 0)
2009-10-20 09:50:51 +01:00
return 0L;
2014-01-19 21:15:05 +00:00
#if SIZEOF_INT_P == 8
2018-04-23 14:34:52 +01:00
if (!(inp & (CELL)0xffffffffLL)) {
inp >>= 32;
out += 32;
}
2009-10-20 09:50:51 +01:00
#endif
2018-04-23 14:34:52 +01:00
if (!(inp & (CELL)0xffffL)) {
inp >>= 16;
out += 16;
}
if (!(inp & (CELL)0xffL)) {
inp >>= 8;
out += 8;
}
if (!(inp & (CELL)0xfL)) {
inp >>= 4;
out += 4;
}
if (!(inp & (CELL)0x3L)) {
inp >>= 2;
out += 2;
}
if (!(inp & ((CELL)0x1)))
out++;
2009-10-20 09:50:51 +01:00
return out;
}
2018-04-23 14:34:52 +01:00
static Int popcount(
Int inp USES_REGS) /* calculate the least significant bit for an integer */
2009-10-20 10:03:10 +01:00
{
/* the obvious solution: do it by using binary search */
2010-05-11 00:18:12 +01:00
Int c = 0, j = 0, m = ((CELL)1);
2009-10-20 10:03:10 +01:00
if (inp < 0) {
2018-04-23 14:34:52 +01:00
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
"popcount/1 received %d", inp);
2009-10-20 10:03:10 +01:00
}
2018-04-23 14:34:52 +01:00
if (inp == 0)
2009-10-20 10:03:10 +01:00
return 0L;
2018-04-23 14:34:52 +01:00
for (j = 0, c = 0; j < sizeof(inp) * 8; j++, m <<= 1) {
if (inp & m)
c++;
}
2009-10-20 10:03:10 +01:00
return c;
}
2018-04-23 14:34:52 +01:00
static Term eval1(Int fi, Term t USES_REGS) {
arith1_op f = fi;
switch (f) {
case op_uplus:
return t;
case op_uminus:
switch (ETypeOfTerm(t)) {
2018-04-23 14:34:52 +01:00
case long_int_e: {
#ifdef USE_GMP
2018-04-23 14:34:52 +01:00
Int i = IntegerOfTerm(t);
2018-04-23 14:34:52 +01:00
if (i == Int_MIN) {
return Yap_gmp_neg_int(i);
} else
#endif
2018-04-23 14:34:52 +01:00
RINT(-IntegerOfTerm(t));
}
case double_e:
RFLOAT(-FloatOfTerm(t));
case big_int_e:
2010-06-01 01:07:36 +01:00
#ifdef USE_GMP
2010-05-27 12:24:15 +01:00
return Yap_gmp_neg_big(t);
2010-06-01 01:07:36 +01:00
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_unot:
switch (ETypeOfTerm(t)) {
case long_int_e:
RINT(~IntegerOfTerm(t));
case double_e:
2018-04-23 14:34:52 +01:00
Yap_ArithError(TYPE_ERROR_INTEGER, t, "\\(%f)", FloatOfTerm(t));
case big_int_e:
#ifdef USE_GMP
2010-05-27 12:24:15 +01:00
return Yap_gmp_unot_big(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_exp:
RFLOAT(exp(get_float(t)));
2018-04-23 14:34:52 +01:00
case op_log: {
Float dbl = get_float(t);
if (dbl >= 0) {
RFLOAT(log(dbl));
} else {
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "log(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
}
case op_log10: {
Float dbl = get_float(t);
if (dbl >= 0) {
RFLOAT(log10(dbl));
} else {
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "log10(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
}
case op_sqrt: {
Float dbl = get_float(t), out;
out = sqrt(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "sqrt(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_sin: {
Float dbl = get_float(t), out;
out = sin(dbl);
RFLOAT(out);
}
case op_cos: {
Float dbl = get_float(t), out;
out = cos(dbl);
RFLOAT(out);
}
case op_tan: {
Float dbl = get_float(t), out;
out = tan(dbl);
RFLOAT(out);
}
case op_sinh: {
Float dbl = get_float(t), out;
out = sinh(dbl);
RFLOAT(out);
}
case op_cosh: {
Float dbl = get_float(t), out;
out = cosh(dbl);
RFLOAT(out);
}
case op_tanh: {
Float dbl = get_float(t), out;
out = tanh(dbl);
RFLOAT(out);
}
case op_asin: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = asin(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "asin(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_acos: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = acos(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "acos(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_atan: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = atan(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "atan(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_asinh: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = asinh(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "asinh(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_acosh: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = acosh(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "acosh(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_atanh: {
Float dbl, out;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
out = atanh(dbl);
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(out)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "atanh(%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RFLOAT(out);
}
case op_lgamma: {
2014-01-19 21:15:05 +00:00
#if HAVE_LGAMMA
2018-04-23 14:34:52 +01:00
Float dbl;
2018-04-23 14:34:52 +01:00
dbl = get_float(t);
RFLOAT(lgamma(dbl));
#else
2018-04-23 14:34:52 +01:00
RERROR();
#endif
2018-04-23 14:34:52 +01:00
}
case op_erf: {
#if HAVE_ERF
2018-04-23 14:34:52 +01:00
Float dbl = get_float(t), out;
out = erf(dbl);
RFLOAT(out);
#else
2018-04-23 14:34:52 +01:00
RERROR();
#endif
2018-04-23 14:34:52 +01:00
}
case op_erfc: {
#if HAVE_ERF
2018-04-23 14:34:52 +01:00
Float dbl = get_float(t), out;
out = erfc(dbl);
RFLOAT(out);
#else
2018-04-23 14:34:52 +01:00
RERROR();
#endif
2018-04-23 14:34:52 +01:00
}
/*
floor(x) maximum integer greatest or equal to X
There are really two built-ins:
SICStus converts from int/big/float -> float
ISO only converts from float -> int/big
*/
2018-04-23 14:34:52 +01:00
case op_floor: {
Float dbl;
2018-04-23 14:34:52 +01:00
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
case double_e:
dbl = FloatOfTerm(t);
break;
case big_int_e:
#ifdef USE_GMP
2018-04-23 14:34:52 +01:00
return Yap_gmp_floor(t);
#endif
2018-04-23 14:34:52 +01:00
default:
RERROR();
}
2010-02-26 09:12:20 +00:00
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(dbl)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
2010-02-26 09:12:20 +00:00
#endif
2010-04-14 19:49:22 +01:00
#if HAVE_ISINF
2018-04-23 14:34:52 +01:00
if (isinf(dbl)) {
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
(%f)",
dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RBIG_FL(floor(dbl));
}
case op_ceiling: {
Float dbl;
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
case double_e:
dbl = FloatOfTerm(t);
break;
case big_int_e:
#ifdef USE_GMP
2018-04-23 14:34:52 +01:00
return Yap_gmp_ceiling(t);
#endif
2018-04-23 14:34:52 +01:00
default:
RERROR();
}
2010-02-26 09:12:20 +00:00
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(dbl)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
2010-02-26 09:12:20 +00:00
#endif
2010-04-14 19:49:22 +01:00
#if HAVE_ISINF
2018-04-23 14:34:52 +01:00
if (isinf(dbl)) {
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
(%f)",
dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RBIG_FL(ceil(dbl));
}
case op_round: {
Float dbl;
2018-04-23 14:34:52 +01:00
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
case double_e:
dbl = FloatOfTerm(t);
break;
case big_int_e:
#ifdef USE_GMP
2018-04-23 14:34:52 +01:00
return Yap_gmp_round(t);
#endif
2018-04-23 14:34:52 +01:00
default:
RERROR();
}
2010-02-26 09:12:20 +00:00
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(dbl)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
2010-02-26 09:12:20 +00:00
#endif
2010-04-14 19:49:22 +01:00
#if HAVE_ISINF
2018-04-23 14:34:52 +01:00
if (isinf(dbl)) {
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
(%f)",
dbl);
}
2018-04-23 14:34:52 +01:00
#endif
RBIG_FL(my_rint(dbl));
}
case op_truncate:
2018-04-23 14:34:52 +01:00
case op_integer: {
Float dbl;
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
case double_e:
dbl = FloatOfTerm(t);
break;
case big_int_e:
2010-04-14 19:49:22 +01:00
#ifdef USE_GMP
2018-04-23 14:34:52 +01:00
return Yap_gmp_trunc(t);
#endif
2018-04-23 14:34:52 +01:00
default:
RERROR();
}
#if HAVE_ISNAN
2018-04-23 14:34:52 +01:00
if (isnan(dbl)) {
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
#endif
2010-04-14 19:49:22 +01:00
#if HAVE_ISINF
2018-04-23 14:34:52 +01:00
if (isinf(dbl)) {
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl),
"integer (%f)", dbl);
}
2018-04-23 14:34:52 +01:00
#endif
if (dbl < 0.0)
RBIG_FL(ceil(dbl));
else
RBIG_FL(floor(dbl));
}
case op_float:
switch (ETypeOfTerm(t)) {
case long_int_e:
RFLOAT(IntegerOfTerm(t));
case double_e:
2010-03-09 22:03:00 +00:00
return t;
case big_int_e:
#ifdef USE_GMP
RFLOAT(Yap_gmp_to_float(t));
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_rational:
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
#ifdef USE_GMP
case double_e:
return Yap_gmp_float_to_rational(FloatOfTerm(t));
#endif
case big_int_e:
return t;
default:
RERROR();
}
case op_rationalize:
switch (ETypeOfTerm(t)) {
case long_int_e:
return t;
#ifdef USE_GMP
case double_e:
return Yap_gmp_float_rationalize(FloatOfTerm(t));
#endif
case big_int_e:
return t;
default:
RERROR();
}
case op_abs:
switch (ETypeOfTerm(t)) {
case long_int_e:
RINT(labs(IntegerOfTerm(t)));
case double_e:
RFLOAT(fabs(FloatOfTerm(t)));
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_abs_big(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_msb:
switch (ETypeOfTerm(t)) {
case long_int_e:
RINT(msb(IntegerOfTerm(t) PASS_REGS));
case double_e:
2016-11-08 07:37:36 +00:00
Yap_ArithError(TYPE_ERROR_INTEGER, t, "msb(%f)", FloatOfTerm(t));
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_msb(t);
2009-10-20 09:50:51 +01:00
#endif
2010-03-06 22:43:21 +00:00
default:
2009-10-20 09:50:51 +01:00
RERROR();
}
case op_lsb:
switch (ETypeOfTerm(t)) {
case long_int_e:
RINT(lsb(IntegerOfTerm(t) PASS_REGS));
2009-10-20 09:50:51 +01:00
case double_e:
2016-11-08 07:37:36 +00:00
Yap_ArithError(TYPE_ERROR_INTEGER, t, "lsb(%f)", FloatOfTerm(t));
2009-10-20 09:50:51 +01:00
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_lsb(t);
2009-10-20 10:03:10 +01:00
#endif
2010-03-06 22:43:21 +00:00
default:
2009-10-20 10:03:10 +01:00
RERROR();
}
case op_popcount:
switch (ETypeOfTerm(t)) {
case long_int_e:
RINT(popcount(IntegerOfTerm(t) PASS_REGS));
2009-10-20 10:03:10 +01:00
case double_e:
2016-11-08 07:37:36 +00:00
Yap_ArithError(TYPE_ERROR_INTEGER, t, "popcount(%f)", FloatOfTerm(t));
2009-10-20 10:03:10 +01:00
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_popcount(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_ffracp:
switch (ETypeOfTerm(t)) {
case long_int_e:
2015-06-18 00:18:28 +01:00
if (isoLanguageFlag()) { /* iso */
2018-04-23 14:34:52 +01:00
Yap_ArithError(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%f)",
IntegerOfTerm(t));
} else {
2018-04-23 14:34:52 +01:00
RFLOAT(0.0);
}
2018-04-23 14:34:52 +01:00
case double_e: {
Float dbl;
dbl = FloatOfTerm(t);
RFLOAT(dbl - ceil(dbl));
} break;
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_float_fractional_part(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_fintp:
switch (ETypeOfTerm(t)) {
case long_int_e:
2018-04-23 14:34:52 +01:00
Yap_ArithError(TYPE_ERROR_FLOAT, t, "X is float_integer_part(%f)",
IntegerOfTerm(t));
case double_e:
RFLOAT(rint(FloatOfTerm(t)));
break;
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_float_integer_part(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_sign:
switch (ETypeOfTerm(t)) {
2018-04-23 14:34:52 +01:00
case long_int_e: {
Int x = IntegerOfTerm(t);
2018-04-23 14:34:52 +01:00
RINT((x > 0 ? 1 : (x < 0 ? -1 : 0)));
}
case double_e: {
2018-04-23 14:34:52 +01:00
Float dbl = FloatOfTerm(t);
2018-04-23 14:34:52 +01:00
RINT((dbl > 0.0 ? 1 : (dbl < 0.0 ? -1 : 0)));
}
case big_int_e:
#ifdef USE_GMP
return Yap_gmp_sign(t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
case op_random1:
switch (ETypeOfTerm(t)) {
case long_int_e:
2018-04-23 14:34:52 +01:00
RINT(Yap_random() * IntegerOfTerm(t));
case double_e:
2016-11-08 07:37:36 +00:00
Yap_ArithError(TYPE_ERROR_INTEGER, t, "random(%f)", FloatOfTerm(t));
case big_int_e:
#ifdef USE_GMP
2013-01-14 09:56:25 +00:00
return Yap_gmp_mul_float_big(Yap_random(), t);
#endif
2010-03-06 22:43:21 +00:00
default:
RERROR();
}
}
2014-04-21 11:14:18 +01:00
/// end of switch
RERROR();
}
2018-04-23 14:34:52 +01:00
Term Yap_eval_unary(Int f, Term t) {
CACHE_REGS
2018-04-23 14:34:52 +01:00
return eval1(f, t PASS_REGS);
}
2018-04-23 14:34:52 +01:00
static InitUnEntry InitUnTab[] = {{"+", op_uplus},
{"-", op_uminus},
{"\\", op_unot},
{"exp", op_exp},
{"log", op_log},
{"log10", op_log10},
{"sqrt", op_sqrt},
{"sin", op_sin},
{"cos", op_cos},
{"tan", op_tan},
{"sinh", op_sinh},
{"cosh", op_cosh},
{"tanh", op_tanh},
{"asin", op_asin},
{"acos", op_acos},
{"atan", op_atan},
{"asinh", op_asinh},
{"acosh", op_acosh},
{"atanh", op_atanh},
{"floor", op_floor},
{"ceiling", op_ceiling},
{"round", op_round},
{"truncate", op_truncate},
{"integer", op_integer},
{"float", op_float},
{"abs", op_abs},
{"msb", op_msb},
{"lsb", op_lsb},
{"popcount", op_popcount},
{"float_fractional_part", op_ffracp},
{"float_integer_part", op_fintp},
{"sign", op_sign},
{"lgamma", op_lgamma},
{"erf", op_erf},
{"erfc", op_erfc},
{"rational", op_rational},
{"rationalize", op_rationalize},
{"random", op_random1}};
Atom Yap_NameOfUnaryOp(int i) { return Yap_LookupAtom(InitUnTab[i].OpName); }
static Int p_unary_is(USES_REGS1) { /* X is Y */
Term t = Deref(ARG2);
Term top;
2018-04-16 14:54:53 +01:00
bool go;
if (IsVarTerm(t)) {
Yap_EvalError(INSTANTIATION_ERROR, t, "unbound unary operator");
return FALSE;
}
Yap_ClearExs();
top = Yap_Eval(Deref(ARG3));
if (IsIntTerm(t)) {
Term tout;
Int i;
i = IntegerOfTerm(t);
tout = eval1(i, top PASS_REGS);
2018-04-23 14:34:52 +01:00
return Yap_unify_constant(ARG1, tout);
2014-10-19 01:50:11 +01:00
} else if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
2009-05-10 04:30:08 +01:00
Term out;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
2015-08-07 22:57:53 +01:00
Yap_EvalError(TYPE_ERROR_EVALUABLE, takeIndicator(t),
2018-04-23 14:34:52 +01:00
"functor %s/1 for arithmetic expression",
RepAtom(name)->StrOfAE);
return FALSE;
}
2018-04-16 14:54:53 +01:00
do {
2018-04-23 14:34:52 +01:00
out = eval1(p->FOfEE, top PASS_REGS);
go = Yap_CheckArithError();
} while (go);
return Yap_unify_constant(ARG1, out);
}
2018-04-16 14:54:53 +01:00
return false;
}
2018-04-23 14:34:52 +01:00
static Int p_unary_op_as_integer(USES_REGS1) { /* X is Y */
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
2018-04-23 14:34:52 +01:00
Yap_EvalError(INSTANTIATION_ERROR, t, "X is _Y");
return (FALSE);
}
if (IsIntTerm(t)) {
2018-04-23 14:34:52 +01:00
return Yap_unify_constant(ARG2, t);
}
if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
2018-04-23 14:34:52 +01:00
return Yap_unify(ARG1, ARG2);
}
2018-04-23 14:34:52 +01:00
return Yap_unify_constant(ARG2, MkIntTerm(p->FOfEE));
}
2018-04-23 14:34:52 +01:00
return (FALSE);
}
2018-04-23 14:34:52 +01:00
void Yap_InitUnaryExps(void) {
unsigned int i;
ExpEntry *p;
2018-04-23 14:34:52 +01:00
for (i = 0; i < sizeof(InitUnTab) / sizeof(InitUnEntry); ++i) {
AtomEntry *ae = RepAtom(Yap_LookupAtom(InitUnTab[i].OpName));
if (ae == NULL) {
2018-04-23 14:34:52 +01:00
Yap_EvalError(RESOURCE_ERROR_HEAP, TermNil, "at InitUnaryExps");
return;
}
WRITE_LOCK(ae->ARWLock);
if (Yap_GetExpPropHavingLock(ae, 1)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
2018-04-23 14:34:52 +01:00
p = (ExpEntry *)Yap_AllocAtomSpace(sizeof(ExpEntry));
p->KindOfPE = ExpProperty;
p->ArityOfEE = 1;
p->ENoOfEE = 1;
p->FOfEE = InitUnTab[i].f;
AddPropToAtom(ae, (PropEntry *)p);
WRITE_UNLOCK(ae->ARWLock);
}
Yap_InitCPred("is", 3, p_unary_is, TestPredFlag | SafePredFlag);
2018-04-23 14:34:52 +01:00
Yap_InitCPred("$unary_op_as_integer", 2, p_unary_op_as_integer,
TestPredFlag | SafePredFlag);
}
2018-04-23 14:34:52 +01:00
/* This routine is called from Restore to make sure we have the same arithmetic
* operators */
int Yap_ReInitUnaryExps(void) { return TRUE; }