1065 lines
24 KiB
C
1065 lines
24 KiB
C
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: arith1.c * Last rev:
|
|
** mods: * comments: arithmetical expression evaluation *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
#endif
|
|
|
|
/**
|
|
@file arith1.c
|
|
|
|
@addtogroup arithmetic_operators
|
|
|
|
- <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
|
|
|
|
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_.
|
|
|
|
- <b>float( _X_) [ISO]</b><p> @anchor float_1_op
|
|
|
|
If _X_ evaluates to an integer, the corresponding float, else the float
|
|
itself.
|
|
|
|
- <b>float_fractional_part( _X_) [ISO]</b><p> @anchor float_fractional_part_1
|
|
|
|
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.
|
|
|
|
- <b>float_integer_part( _X_) [ISO]</b><p> @anchor float_integer_part_1
|
|
|
|
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.
|
|
|
|
- <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_.
|
|
|
|
In `iso` language mode the argument must be a floating point-number and the
|
|
result is an integer.
|
|
|
|
- <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
|
|
|
|
The nearest integral value to _X_. If _X_ is equidistant to two integers,
|
|
it will be rounded to the closest even integral value.
|
|
|
|
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>sign( _X_) [ISO]</b><p> @anchor sign_1
|
|
|
|
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.
|
|
|
|
- <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
|
|
|
|
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.
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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
|
|
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.
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~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
|
|
|
|
The number of bits set to `1` in the binary representation of the
|
|
non-negative integer _X_.
|
|
|
|
- <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"
|
|
#include "YapEval.h"
|
|
#include "YapHeap.h"
|
|
#include "Yatom.h"
|
|
|
|
static Term float_to_int(Float v USES_REGS) {
|
|
#if USE_GMP
|
|
Int i = (Int)v;
|
|
|
|
if (i - v == 0.0) {
|
|
return MkIntegerTerm(i);
|
|
} else {
|
|
return Yap_gmp_float_to_big(v);
|
|
}
|
|
#else
|
|
return MkIntegerTerm(v);
|
|
#endif
|
|
}
|
|
|
|
#define RBIG_FL(v) return (float_to_int(v PASS_REGS))
|
|
|
|
typedef struct init_un_eval {
|
|
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
|
|
#define asinh(F) (log((F) + sqrt((F) * (F) + 1)))
|
|
#endif
|
|
#if !HAVE_ACOSH
|
|
#define acosh(F) (log((F) + sqrt((F) * (F)-1)))
|
|
#endif
|
|
#if !HAVE_ATANH
|
|
#define atanh(F) (log((1 + (F)) / (1 - (F))) / 2)
|
|
#endif
|
|
|
|
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
|
|
static double my_rint(double x) {
|
|
double y, z;
|
|
Int n;
|
|
|
|
if (x >= 0) {
|
|
y = x + 0.5;
|
|
z = floor(y);
|
|
n = (Int)z;
|
|
if (y == z && n % 2)
|
|
return (z - 1);
|
|
} else {
|
|
y = x - 0.5;
|
|
z = ceil(y);
|
|
n = (Int)z;
|
|
if (y == z && n % 2)
|
|
return (z + 1);
|
|
}
|
|
return (z);
|
|
}
|
|
#endif
|
|
|
|
static Int
|
|
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) {
|
|
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
|
|
"msb/1 received %d", inp);
|
|
}
|
|
|
|
#if HAVE__BUILTIN_FFSLL
|
|
out = __builtin_ffsll(inp);
|
|
#elif HAVE_FFSLL
|
|
out = ffsll(inp);
|
|
#else
|
|
if (inp == 0)
|
|
return 0L;
|
|
#if SIZEOF_INT_P == 8
|
|
if (inp & ((CELL)0xffffffffLL << 32)) {
|
|
inp >>= 32;
|
|
out += 32;
|
|
}
|
|
#endif
|
|
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;
|
|
}
|
|
|
|
Int Yap_msb(
|
|
Int inp USES_REGS) /* calculate the most significant bit for an integer */
|
|
{
|
|
return msb(inp PASS_REGS);
|
|
}
|
|
|
|
static Int
|
|
lsb(Int inp USES_REGS) /* calculate the least significant bit for an integer */
|
|
{
|
|
/* the obvious solution: do it by using binary search */
|
|
Int out = 0;
|
|
|
|
if (inp < 0) {
|
|
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
|
|
"msb/1 received %d", inp);
|
|
}
|
|
if (inp == 0)
|
|
return 0L;
|
|
#if SIZEOF_INT_P == 8
|
|
if (!(inp & (CELL)0xffffffffLL)) {
|
|
inp >>= 32;
|
|
out += 32;
|
|
}
|
|
#endif
|
|
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++;
|
|
|
|
return out;
|
|
}
|
|
|
|
static Int popcount(
|
|
Int inp USES_REGS) /* calculate the least significant bit for an integer */
|
|
{
|
|
/* the obvious solution: do it by using binary search */
|
|
Int c = 0, j = 0, m = ((CELL)1);
|
|
|
|
if (inp < 0) {
|
|
Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
|
|
"popcount/1 received %d", inp);
|
|
}
|
|
if (inp == 0)
|
|
return 0L;
|
|
for (j = 0, c = 0; j < sizeof(inp) * 8; j++, m <<= 1) {
|
|
if (inp & m)
|
|
c++;
|
|
}
|
|
|
|
return c;
|
|
}
|
|
|
|
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)) {
|
|
case long_int_e: {
|
|
#ifdef USE_GMP
|
|
Int i = IntegerOfTerm(t);
|
|
|
|
if (i == Int_MIN) {
|
|
return Yap_gmp_neg_int(i);
|
|
} else
|
|
#endif
|
|
RINT(-IntegerOfTerm(t));
|
|
}
|
|
case double_e:
|
|
RFLOAT(-FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_neg_big(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_unot:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
RINT(~IntegerOfTerm(t));
|
|
case double_e:
|
|
Yap_ArithError(TYPE_ERROR_INTEGER, t, "\\(%f)", FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_unot_big(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_exp:
|
|
RFLOAT(exp(get_float(t)));
|
|
case op_log: {
|
|
Float dbl = get_float(t);
|
|
if (dbl >= 0) {
|
|
RFLOAT(log(dbl));
|
|
} else {
|
|
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "log(%f)", dbl);
|
|
}
|
|
}
|
|
case op_log10: {
|
|
Float dbl = get_float(t);
|
|
if (dbl >= 0) {
|
|
RFLOAT(log10(dbl));
|
|
} else {
|
|
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "log10(%f)", dbl);
|
|
}
|
|
}
|
|
case op_sqrt: {
|
|
Float dbl = get_float(t), out;
|
|
out = sqrt(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "sqrt(%f)", dbl);
|
|
}
|
|
#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;
|
|
|
|
dbl = get_float(t);
|
|
out = asin(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "asin(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_acos: {
|
|
Float dbl, out;
|
|
|
|
dbl = get_float(t);
|
|
out = acos(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(EVALUATION_ERROR_UNDEFINED, t, "acos(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_atan: {
|
|
Float dbl, out;
|
|
|
|
dbl = get_float(t);
|
|
out = atan(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "atan(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_asinh: {
|
|
Float dbl, out;
|
|
|
|
dbl = get_float(t);
|
|
out = asinh(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "asinh(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_acosh: {
|
|
Float dbl, out;
|
|
|
|
dbl = get_float(t);
|
|
out = acosh(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "acosh(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_atanh: {
|
|
Float dbl, out;
|
|
|
|
dbl = get_float(t);
|
|
out = atanh(dbl);
|
|
#if HAVE_ISNAN
|
|
if (isnan(out)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "atanh(%f)", dbl);
|
|
}
|
|
#endif
|
|
RFLOAT(out);
|
|
}
|
|
case op_lgamma: {
|
|
#if HAVE_LGAMMA
|
|
Float dbl;
|
|
|
|
dbl = get_float(t);
|
|
RFLOAT(lgamma(dbl));
|
|
#else
|
|
RERROR();
|
|
#endif
|
|
}
|
|
case op_erf: {
|
|
#if HAVE_ERF
|
|
Float dbl = get_float(t), out;
|
|
out = erf(dbl);
|
|
RFLOAT(out);
|
|
#else
|
|
RERROR();
|
|
#endif
|
|
}
|
|
case op_erfc: {
|
|
#if HAVE_ERF
|
|
Float dbl = get_float(t), out;
|
|
out = erfc(dbl);
|
|
RFLOAT(out);
|
|
#else
|
|
RERROR();
|
|
#endif
|
|
}
|
|
/*
|
|
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
|
|
|
|
*/
|
|
case op_floor: {
|
|
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
|
|
return Yap_gmp_floor(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
#if HAVE_ISNAN
|
|
if (isnan(dbl)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
|
|
}
|
|
#endif
|
|
#if HAVE_ISINF
|
|
if (isinf(dbl)) {
|
|
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
|
|
(%f)",
|
|
dbl);
|
|
}
|
|
#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
|
|
return Yap_gmp_ceiling(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
#if HAVE_ISNAN
|
|
if (isnan(dbl)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
|
|
}
|
|
#endif
|
|
#if HAVE_ISINF
|
|
if (isinf(dbl)) {
|
|
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
|
|
(%f)",
|
|
dbl);
|
|
}
|
|
#endif
|
|
RBIG_FL(ceil(dbl));
|
|
}
|
|
case op_round: {
|
|
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
|
|
return Yap_gmp_round(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
#if HAVE_ISNAN
|
|
if (isnan(dbl)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
|
|
}
|
|
#endif
|
|
#if HAVE_ISINF
|
|
if (isinf(dbl)) {
|
|
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer\
|
|
(%f)",
|
|
dbl);
|
|
}
|
|
#endif
|
|
RBIG_FL(my_rint(dbl));
|
|
}
|
|
case op_truncate:
|
|
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:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_trunc(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
#if HAVE_ISNAN
|
|
if (isnan(dbl)) {
|
|
Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
|
|
}
|
|
#endif
|
|
#if HAVE_ISINF
|
|
if (isinf(dbl)) {
|
|
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl),
|
|
"integer (%f)", dbl);
|
|
}
|
|
#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:
|
|
return t;
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
RFLOAT(Yap_gmp_to_float(t));
|
|
#endif
|
|
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
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_msb:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
RINT(msb(IntegerOfTerm(t) PASS_REGS));
|
|
case double_e:
|
|
Yap_ArithError(TYPE_ERROR_INTEGER, t, "msb(%f)", FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_msb(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_lsb:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
RINT(lsb(IntegerOfTerm(t) PASS_REGS));
|
|
case double_e:
|
|
Yap_ArithError(TYPE_ERROR_INTEGER, t, "lsb(%f)", FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_lsb(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_popcount:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
RINT(popcount(IntegerOfTerm(t) PASS_REGS));
|
|
case double_e:
|
|
Yap_ArithError(TYPE_ERROR_INTEGER, t, "popcount(%f)", FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_popcount(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_ffracp:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
if (isoLanguageFlag()) { /* iso */
|
|
Yap_ArithError(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%f)",
|
|
IntegerOfTerm(t));
|
|
} else {
|
|
RFLOAT(0.0);
|
|
}
|
|
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
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_fintp:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
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
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_sign:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e: {
|
|
Int x = IntegerOfTerm(t);
|
|
|
|
RINT((x > 0 ? 1 : (x < 0 ? -1 : 0)));
|
|
}
|
|
case double_e: {
|
|
|
|
Float dbl = FloatOfTerm(t);
|
|
|
|
RINT((dbl > 0.0 ? 1 : (dbl < 0.0 ? -1 : 0)));
|
|
}
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_sign(t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
case op_random1:
|
|
switch (ETypeOfTerm(t)) {
|
|
case long_int_e:
|
|
RINT(Yap_random() * IntegerOfTerm(t));
|
|
case double_e:
|
|
Yap_ArithError(TYPE_ERROR_INTEGER, t, "random(%f)", FloatOfTerm(t));
|
|
case big_int_e:
|
|
#ifdef USE_GMP
|
|
return Yap_gmp_mul_float_big(Yap_random(), t);
|
|
#endif
|
|
default:
|
|
RERROR();
|
|
}
|
|
}
|
|
/// end of switch
|
|
RERROR();
|
|
}
|
|
|
|
Term Yap_eval_unary(Int f, Term t) {
|
|
CACHE_REGS
|
|
return eval1(f, t PASS_REGS);
|
|
}
|
|
|
|
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;
|
|
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);
|
|
return Yap_unify_constant(ARG1, tout);
|
|
} else if (IsAtomTerm(t)) {
|
|
Atom name = AtomOfTerm(t);
|
|
ExpEntry *p;
|
|
Term out;
|
|
|
|
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
|
|
Yap_EvalError(TYPE_ERROR_EVALUABLE, takeIndicator(t),
|
|
"functor %s/1 for arithmetic expression",
|
|
RepAtom(name)->StrOfAE);
|
|
return FALSE;
|
|
}
|
|
do {
|
|
out = eval1(p->FOfEE, top PASS_REGS);
|
|
go = Yap_CheckArithError();
|
|
} while (go);
|
|
return Yap_unify_constant(ARG1, out);
|
|
}
|
|
return false;
|
|
}
|
|
|
|
static Int p_unary_op_as_integer(USES_REGS1) { /* X is Y */
|
|
Term t = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t)) {
|
|
Yap_EvalError(INSTANTIATION_ERROR, t, "X is _Y");
|
|
return (FALSE);
|
|
}
|
|
if (IsIntTerm(t)) {
|
|
return Yap_unify_constant(ARG2, t);
|
|
}
|
|
if (IsAtomTerm(t)) {
|
|
Atom name = AtomOfTerm(t);
|
|
ExpEntry *p;
|
|
|
|
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
|
|
return Yap_unify(ARG1, ARG2);
|
|
}
|
|
return Yap_unify_constant(ARG2, MkIntTerm(p->FOfEE));
|
|
}
|
|
return (FALSE);
|
|
}
|
|
|
|
void Yap_InitUnaryExps(void) {
|
|
unsigned int i;
|
|
ExpEntry *p;
|
|
|
|
for (i = 0; i < sizeof(InitUnTab) / sizeof(InitUnEntry); ++i) {
|
|
AtomEntry *ae = RepAtom(Yap_LookupAtom(InitUnTab[i].OpName));
|
|
if (ae == NULL) {
|
|
Yap_EvalError(RESOURCE_ERROR_HEAP, TermNil, "at InitUnaryExps");
|
|
return;
|
|
}
|
|
WRITE_LOCK(ae->ARWLock);
|
|
if (Yap_GetExpPropHavingLock(ae, 1)) {
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
break;
|
|
}
|
|
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);
|
|
Yap_InitCPred("$unary_op_as_integer", 2, p_unary_op_as_integer,
|
|
TestPredFlag | SafePredFlag);
|
|
}
|
|
|
|
/* This routine is called from Restore to make sure we have the same arithmetic
|
|
* operators */
|
|
int Yap_ReInitUnaryExps(void) { return TRUE; }
|