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.
Vitor Santos Costa d163cadda1 pass regs when constructing long ints and floats.
fix small gcc complaints.
2013-03-26 15:01:52 -05:00

851 lines
17 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
/*
* This file implements unary arithmetic operations in YAP
*
*/
#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;
int off = sizeof(CELL)*4;
if (inp < 0) {
return Yap_ArithError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
"msb/1 received %d", inp);
}
while (off) {
Int limit = ((CELL)1) << (off);
if (inp >= limit) {
out += off;
inp >>= off;
}
off >>= 1;
}
return(out);
}
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_LONG_INT == 8
if (!(inp & 0xffffffffLL)) {inp >>= 32; out += 32;}
#endif
if (!(inp & 0xffffL)) {inp >>= 16; out += 16;}
if (!(inp & 0xffL)) {inp >>= 8; out += 8;}
if (!(inp & 0xfL)) {inp >>= 4; out += 4;}
if (!(inp & 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<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:
return 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 {
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, "log(%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, "acos(%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, "atanh(%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, "atanh(%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, "atanh(%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:
{
Float dbl;
dbl = get_float(t);
#if HAVE_LGAMMA
RFLOAT(lgamma(dbl));
#else
RERROR();
#endif
}
case op_erf:
{
Float dbl = get_float(t), out;
#if HAVE_ERF
out = erf(dbl);
RFLOAT(out);
#else
RERROR();
#endif
}
case op_erfc:
{
Float dbl = get_float(t), out;
#if HAVE_ERF
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 (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* 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();
}
}
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}
};
static Int
p_unary_is( USES_REGS1 )
{ /* X is Y */
Term t = Deref(ARG2);
Term top;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, ARG2, "X is Y");
return FALSE;
}
top = Yap_Eval(Deref(ARG3));
if (!Yap_FoundArithError(top, ARG3)) {
return FALSE;
}
if (IsIntTerm(t)) {
Term tout = Yap_FoundArithError(eval1(IntegerOfTerm(t), top PASS_REGS), Deref(ARG3));
if (!tout)
return FALSE;
return Yap_unify_constant(ARG1,tout);
}
if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
Term out;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntTerm(1);
t = Yap_MkApplTerm(FunctorSlash, 2, ti);
Yap_Error(TYPE_ERROR_EVALUABLE, t,
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,1);
P = FAILCODE;
return(FALSE);
}
if (!(out=Yap_FoundArithError(eval1(p->FOfEE, top PASS_REGS),Deref(ARG3))))
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_Error(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_Error(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;
}