/*************************************************************************
* *
* 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
- exp( _X_) [ISO] @anchor exp_1
Natural exponential.
- log( _X_) [ISO]
@anchor log_1
Natural logarithm.
- log10( _X_)
@anchor log10_1
Decimal logarithm.
- sqrt( _X_) [ISO]
@anchor sqrt_1
Square root.
- sin( _X_) [ISO]
@anchor sin_1
Sine.
- cos( _X_) [ISO]
@anchor cos_1
Cosine.
- tan( _X_) [ISO]
@anchor tan_1
Tangent.
- asin( _X_) [ISO]
@anchor asin_1
Arc sine.
- acos( _X_) [ISO]
@anchor acos_1
Arc cosine.
- atan( _X_) [ISO]
@anchor atan_1
Arc tangent.
- sinh( _X_)
@anchor sinh_1
Hyperbolic sine.
- cosh( _X_)
@anchor cosh_1
Hyperbolic cosine.
- tanh( _X_)
@anchor tanh_1
Hyperbolic tangent.
- asinh( _X_)
@anchor asinh_1
Hyperbolic arc sine.
- acosh( _X_)
@anchor acosh_1
Hyperbolic arc cosine.
- atanh( _X_)
@anchor atanh_1
Hyperbolic arc tangent.
- lgamma( _X_)
@anchor lgamma_1
Logarithm of gamma function.
- erf( _X_)
@anchor erf_1
Gaussian error function.
- erfc( _X_)
@anchor erfc_1
Complementary gaussian error function.
- random( _X_) [ISO]
@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_.
- integer( _X_)
@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_.
- float( _X_) [ISO]
@anchor float_1_op
If _X_ evaluates to an integer, the corresponding float, else the float itself.
- float_fractional_part( _X_) [ISO]
@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.
- float_integer_part( _X_) [ISO]
@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.
- abs( _X_) [ISO]
@anchor abs_1
The absolute value of _X_.
- ceiling( _X_) [ISO]
@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.
- floor( _X_) [ISO]
@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.
- round( _X_) [ISO]
@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_.
- sign( _X_) [ISO]
@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.
- truncate( _X_) [ISO]
@anchor truncate_1
The integral value between _X_ and 0 closest to _X_.
- rational( _X_)
@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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- rationalize( _X_)
@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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- \\ _X_ [ISO]
Integer bitwise negation.
- msb( _X_)
@anchor msb_1
The most significant bit of the non-negative integer _X_.
- lsb( _X_)
@anchor lsb_1
The least significant bit of the non-negative integer _X_.
- popcount( _X_)
@anchor popcount_1
The number of bits set to `1` in the binary representation of the non-negative integer _X_.
- [ _X_]
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 "Yatom.h"
#include "YapHeap.h"
#include "eval.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) {
return 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) {
return 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) {
return 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= 0) {
RFLOAT(log(dbl));
} else {
return Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log(%f)", dbl);
}
}
case op_log10:
{
Float dbl = get_float(t);
if (dbl >= 0) {
RFLOAT(log10(dbl));
} else {
return Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log10(%f)", dbl);
}
}
case op_sqrt:
{
Float dbl = get_float(t), out;
out = sqrt(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
return Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, 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)) {
return 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)) {
return 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)) {
return 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)) {
return 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)) {
return 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)) {
return 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)) {
return Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
#endif
#if HAVE_ISINF
if (isinf(dbl)) {
return 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)) {
return Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
#endif
#if HAVE_ISINF
if (isinf(dbl)) {
return 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)) {
return Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
#endif
#if HAVE_ISINF
if (isinf(dbl)) {
return 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)) {
return Yap_ArithError(DOMAIN_ERROR_OUT_OF_RANGE, t, "integer(%f)", dbl);
}
#endif
#if HAVE_ISINF
if (isinf(dbl)) {
return 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:
return 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:
return 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:
return 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 */
return 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:
return 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:
return 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;
yap_error_number err;
if (IsVarTerm(t)) {
Yap_EvalError(INSTANTIATION_ERROR, t, "unbound unary operator");
return FALSE;
}
Yap_ClearExs();
top = Yap_Eval(Deref(ARG3));
if ((err=Yap_FoundArithError())) {
Yap_EvalError(err,ARG3,"X is op(Y): error in Y ");
return FALSE;
}
if (IsIntTerm(t)) {
Term tout;
Int i;
i = IntegerOfTerm(t);
tout = eval1(i, top PASS_REGS);
if ((err=Yap_FoundArithError())) {
Functor f = Yap_MkFunctor( Yap_NameOfUnaryOp(i), 1 );
Term t = Yap_MkApplTerm( f, 1, &top );
Yap_EvalError(err, t ,"error in %s/1 ", RepAtom(NameOfFunctor(f))->StrOfAE);
return FALSE;
}
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, takeName(t),
"functor %s/1 for arithmetic expression",
RepAtom(name)->StrOfAE);
return FALSE;
}
out= eval1(p->FOfEE, top PASS_REGS);
if ((err=Yap_FoundArithError())) {
return FALSE;
}
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(OUT_OF_HEAP_ERROR,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;
}