diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
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.
703d948559
yap-6.3/C/arith1.c
vsc 46f90fc6aa fix register recovery after ^c on Macs 
fix 64 bit complaints.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1542 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2006-02-13 16:58:55 +00:00

2075 lines
40 KiB
C
Raw Blame History

/*************************************************************************
* *
* 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 "Heap.h"
#include "eval.h"
#define E_FUNC blob_type
#define E_ARGS , arith_retptr o
#define TMP_BIG() ((o)->big)
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RBIG(v) return(big_int_e)
#define RERROR() return(db_ref_e)
#if USE_GMP
static blob_type
float_to_int(Float v, union arith_ret *o)
{
Int i = (Int)v;
if (i-v == 0.0) {
o->Int = i;
return(long_int_e);
} else {
mpz_init_set_d(o->big, v);
return big_int_e;
}
}
#define RBIG_FL(v) return(float_to_int(v,o))
#else
#define RBIG_FL(v) (o)->Int = (Int)(v); return long_int_e
#endif
#if USE_GMP
static void
process_iso_error(MP_INT *big, Term t, char *operation)
{ /* iso */
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is %s(%s)", operation, s);
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is %s(t)",operation);
P = (yamop *)FAILCODE;
}
}
#endif
inline static Functor
AritFunctorOfTerm(Term t) {
if (IsVarTerm(t)) {
return(FunctorDBRef);
}
if (IsApplTerm(t)) {
return(FunctorOfTerm(t));
} else {
if (IsIntTerm(t))
return(FunctorLongInt);
else
return(FunctorDBRef);
}
}
static Term
EvalToTerm(blob_type f, union arith_ret *res)
{
switch (f) {
case long_int_e:
return(MkIntegerTerm(res->Int));
case double_e:
return(MkFloatTerm(res->dbl));
#ifdef USE_GMP
case big_int_e:
{
Term t = Yap_MkBigIntTerm(res->big);
mpz_clear(res->big);
return t;
}
#endif
default:
return TermNil;
}
}
typedef blob_type (*f_unexp)(Term, arith_retptr);
typedef struct init_un_eval {
char *OpName;
f_unexp 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
/*
do nothing...
*/
static E_FUNC
p_uplus(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
blob_type bt;
union arith_ret v;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(IntegerOfTerm(t));
case double_e:
RFLOAT(FloatOfTerm(t));
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(v.Int);
case double_e:
RFLOAT(v.dbl);
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
MPZ_SET(new, v.big);
RBIG(new);
}
#endif
default:
/* Error */
RERROR();
}
}
}
/*
unary minus: -
*/
static E_FUNC
p_uminus(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(-IntegerOfTerm(t));
case double_e:
RFLOAT(-FloatOfTerm(t));
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
MPZ_SET(new, Yap_BigIntOfTerm(t));
mpz_neg(new, new);
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(-v.Int);
case double_e:
RFLOAT(-v.dbl);
#ifdef USE_GMP
case big_int_e:
mpz_neg(v.big, v.big);
RBIG(v.big);
#endif
default:
/* Error */
RERROR();
}
}
}
/*
unary negation is \
*/
static E_FUNC
p_unot(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(~IntegerOfTerm(t));
case double_e:
Yap_Error(TYPE_ERROR_INTEGER, t, "\\(f)", FloatOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
mpz_com(new, new);
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(~v.Int);
case double_e:
Yap_Error(TYPE_ERROR_INTEGER, t, "\\(%f)", v.dbl);
P = (yamop *)FAILCODE;
RERROR();
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
MPZ_SET(new, v.big);
mpz_com(new, new);
RBIG(new);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
/*
exponentiation exp(x)
*/
static E_FUNC
p_exp(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RFLOAT(exp(IntegerOfTerm(t)));
case double_e:
RFLOAT(exp(FloatOfTerm(t)));
#ifdef USE_GMP
case big_int_e:
RFLOAT(exp(mpz_get_d(Yap_BigIntOfTerm(t))));
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RFLOAT(exp(v.Int));
case double_e:
RFLOAT(exp(v.dbl));
#ifdef USE_GMP
case big_int_e:
{
double dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(exp(dbl));
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
/*
natural logarithm log(x)
*/
static E_FUNC
p_log(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (dbl >= 0) {
RFLOAT(log(dbl));
} else {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
}
/*
base 10 logarithm log10(x)
*/
static E_FUNC
p_log10(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (dbl >= 0) {
RFLOAT(log10(dbl));
} else {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log10(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
}
/*
square root sqrt(x)
*/
static E_FUNC
p_sqrt(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl, out;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
out = sqrt(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t, "acos(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
#endif
RFLOAT(out);
}
/*
sine sin(x) ? why did they take the e
*/
static E_FUNC
p_sin(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(sin(dbl));
}
/*
cosine cos(x)
*/
static E_FUNC
p_cos(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(cos(dbl));
}
/*
tangent tan(x)
*/
static E_FUNC
p_tan(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(tan(dbl));
}
/*
hyperbolic sine sinh(x) = (exp(x) - exp(-x)) / 2.
*/
static E_FUNC
p_sinh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(sinh(dbl));
}
/*
hyperbolic cosine cosh(x) = (exp(x) + exp(-x)) / 2.
*/
static E_FUNC
p_cosh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(cosh(dbl));
}
/*
hyperbolic tangent tanh(x)
*/
static E_FUNC
p_tanh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(tanh(dbl));
}
/*
asin(x) arc sine function
*/
static E_FUNC
p_asin(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl, out;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
out = asin(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t, "asin(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
#endif
RFLOAT(out);
}
/*
acos(x) arc cosine function
*/
static E_FUNC
p_acos(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl, out;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
out = acos(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t, "acos(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
#endif
RFLOAT(out);
}
/*
atan(x) arc tangent function
*/
static E_FUNC
p_atan(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(atan(dbl));
}
/*
asinh(x) arc hyperbolic sine
*/
static E_FUNC
p_asinh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(asinh(dbl));
}
/*
acosh(x) arc hyperbolic cosine
*/
static E_FUNC
p_acosh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl, out;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
out = acosh(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t, "acosh(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
#endif
RFLOAT(out);
}
/*
atanh(x) arc hyperbolic tangent
*/
static E_FUNC
p_atanh(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl, out;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
out = atanh(dbl);
#if HAVE_ISNAN
if (isnan(out)) {
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t, "atanh(%f)", dbl);
P = (yamop *)FAILCODE;
RERROR();
}
#endif
RFLOAT(out);
}
/*
lgamma(x) is the logarithm of the gamma function.
*/
static E_FUNC
p_lgamma(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
dbl = IntegerOfTerm(t);
break;
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
break;
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
dbl = v.Int;
break;
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
/* Yap_Error */
RERROR();
}
}
#if HAVE_LGAMMA
{
Float out;
out = lgamma(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
*/
static E_FUNC
p_floor(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(IntegerOfTerm(t));
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", s);
P = (yamop *)FAILCODE;
Yap_FreeCodeSpace(s);
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(t)");
P = (yamop *)FAILCODE;
RERROR();
}
} else {
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(v.Int);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Int sz = 2+mpz_sizeinbase(v.big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, v.big);
mpz_clear(v.big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", s);
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
mpz_clear(v.big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(t)");
P = (yamop *)FAILCODE;
RERROR();
}
} else {
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
RBIG_FL(floor(dbl));
} else {
RFLOAT(floor(dbl));
}
}
/*
ceiling(x) minimum integer smallest or equal to X
*/
static E_FUNC
p_ceiling(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(IntegerOfTerm(t));
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(Yap_BigIntOfTerm(t), t, "ceiling");
RERROR();
} else {
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(v.Int);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(v.big, t, "ceiling");
mpz_clear(v.big);
RERROR();
} else {
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
RBIG_FL(ceil(dbl));
} else {
RFLOAT(ceil(dbl));
}
}
/* 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
/*
round(x) integer closest to 0
*/
static E_FUNC
p_round(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(IntegerOfTerm(t));
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
process_iso_error(Yap_BigIntOfTerm(t), t, "round");
RERROR();
} else {
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(v.Int);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(v.big, t, "round");
mpz_clear(v.big);
RERROR();
} else {
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
double vl = my_rint(dbl);
RBIG_FL(vl);
} else {
double vl = my_rint(dbl);
RFLOAT(vl);
}
}
/*
truncate(x) integer closest to 0
*/
static E_FUNC
p_truncate(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(IntegerOfTerm(t));
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(Yap_BigIntOfTerm(t), t, "truncate");
RERROR();
} else {
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(v.Int);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(v.big, t, "truncate");
mpz_clear(v.big);
RERROR();
} else {
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (dbl >= 0 ) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
RBIG_FL(floor(dbl));
} else {
RFLOAT(floor(dbl));
}
} else {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
RBIG_FL(ceil(dbl));
} else {
RFLOAT(ceil(dbl));
}
}
}
/*
integer(x) SICStus integer closest to 0, similar to truncate
*/
static E_FUNC
p_integer(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(IntegerOfTerm(t));
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(v.Int);
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
MPZ_SET(new,v.big);
RBIG(new);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
if (dbl <= (Float)Int_MAX && dbl >= (Float)Int_MIN) {
RINT((Int) dbl);
} else {
#ifdef USE_GMP
MP_INT *new = TMP_BIG();
fprintf(stderr,"dbl is %g\n",dbl);
mpz_init_set_d(new, dbl);
RBIG(new);
#else
Yap_Error(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer/1");
P = (yamop *)FAILCODE;
RERROR();
#endif
}
}
/*
float(x) SICStus float
*/
static E_FUNC
p_float(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RFLOAT(IntegerOfTerm(t));
case double_e:
RFLOAT(FloatOfTerm(t));
#ifdef USE_GMP
case big_int_e:
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RFLOAT(v.Int);
case double_e:
RFLOAT(v.dbl);
#ifdef USE_GMP
case big_int_e:
{
Float dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(dbl);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
static Int
msb(Int inp) /* 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) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, MkIntegerTerm(inp),
"msb/1 received %d", inp);
P = (yamop *)FAILCODE;
return(0);
}
while (off) {
Int limit = 1L << (off);
if (inp >= limit) {
out += off;
inp >>= off;
}
off >>= 1;
}
return(out);
}
/*
abs(x): absolute value of a number
*/
static E_FUNC
p_abs(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(labs(IntegerOfTerm(t)));
case double_e:
RFLOAT(fabs(FloatOfTerm(t)));
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
mpz_abs(new, new);
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(labs(v.Int));
case double_e:
RFLOAT(fabs(v.dbl));
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = TMP_BIG();
MPZ_SET(new, v.big);
mpz_abs(new, new);
RBIG(new);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
/*
msb(x) most significant bit
*/
static E_FUNC
p_msb(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
switch (BlobOfFunctor(f)) {
case long_int_e:
RINT(msb(IntegerOfTerm(t)));
case double_e:
Yap_Error(TYPE_ERROR_INTEGER, t, "msb(%f)", FloatOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
#ifdef USE_GMP
case big_int_e:
RINT(mpz_sizeinbase(Yap_BigIntOfTerm(t),2));
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT(v.Int);
case double_e:
Yap_Error(TYPE_ERROR_INTEGER, t, "msb(%f)", v.dbl);
P = (yamop *)FAILCODE;
RERROR();
#ifdef USE_GMP
case big_int_e:
{
int sz = mpz_sizeinbase(v.big,2);
mpz_clear(v.big);
RINT(sz);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
/*
float_fractional_part(x) fraction for a float.
*/
static E_FUNC
p_ffracp(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(0.0);
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(Yap_BigIntOfTerm(t), t, "float_fractional_part");
RERROR();
} else {
RFLOAT(0.0);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(0.0);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(v.big, t, "float_fractional_part");
mpz_clear(v.big);
RERROR();
} else {
mpz_clear(v.big);
RFLOAT(0.0);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(dbl-ceil(dbl));
}
/*
float_integer_part(x) integer for a float.
*/
static E_FUNC
p_fintp(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(%f)", IntegerOfTerm(t));
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(IntegerOfTerm(t));
}
case double_e:
dbl = FloatOfTerm(t);
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(Yap_BigIntOfTerm(t), t, "float_integer_part");
RERROR();
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
}
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(%f)", v.Int);
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(v.Int);
}
case double_e:
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
process_iso_error(Yap_BigIntOfTerm(t), t, "float_integer_part");
RERROR();
} else {
Float dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(dbl);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
RFLOAT(rint(dbl));
}
/*
sign(x) sign of a number.
*/
static E_FUNC
p_sign(Term t E_ARGS)
{
Functor f = AritFunctorOfTerm(t);
union arith_ret v;
blob_type bt;
Float dbl;
switch (BlobOfFunctor(f)) {
case long_int_e:
{
Int x = IntegerOfTerm(t);
RINT((x > 0 ? 1 : (x < 0 ? -1 : 0)));
}
case double_e:
dbl = FloatOfTerm(t);
RINT((dbl > 0.0 ? 1 : (dbl < 0.0 ? -1 : 0)));
#ifdef USE_GMP
case big_int_e:
RINT(mpz_sgn(Yap_BigIntOfTerm(t)));
#endif
default:
/* we've got a full term, need to evaluate it first */
bt = Yap_Eval(t, &v);
/* second case, no need no evaluation */
switch (bt) {
case long_int_e:
RINT((v.Int > 0 ? 1 : (v.Int < 0 ? -1 : 0)));
case double_e:
RINT((v.dbl > 0.0 ? 1 : (v.dbl < 0.0 ? -1 : 0)));
#ifdef USE_GMP
case big_int_e:
{
int sgn = mpz_sgn(v.big);
mpz_clear(v.big);
RINT(sgn);
}
#endif
default:
/* Yap_Error */
RERROR();
}
}
}
static InitUnEntry InitUnTab[] = {
{"+", p_uplus},
{"-", p_uminus},
{"\\", p_unot},
{"exp", p_exp},
{"log", p_log},
{"log10", p_log10},
{"sqrt", p_sqrt},
{"sin", p_sin},
{"cos", p_cos},
{"tan", p_tan},
{"sinh", p_sinh},
{"cosh", p_cosh},
{"tanh", p_tanh},
{"asin", p_asin},
{"acos", p_acos},
{"atan", p_atan},
{"asinh", p_asinh},
{"acosh", p_acosh},
{"atanh", p_atanh},
{"floor", p_floor},
{"ceiling", p_ceiling},
{"round", p_round},
{"truncate", p_truncate},
{"integer", p_integer},
{"float", p_float},
{"abs", p_abs},
{"msb", p_msb},
{"float_fractional_part", p_ffracp},
{"float_integer_part", p_fintp},
{"sign", p_sign},
{"lgamma", p_lgamma},
};
static Int
p_unary_is(void)
{ /* X is Y */
Term t = Deref(ARG2);
union arith_ret res;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, ARG2, "X is Y");
return(FALSE);
}
if (IsIntTerm(t)) {
blob_type f = InitUnTab[IntOfTerm(t)].f(Deref(ARG3),&res);
return (Yap_unify_constant(ARG1,EvalToTerm(f,&res)));
}
if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
blob_type f;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 1)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntTerm(1);
t = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("/"),2), 2, ti);
Yap_Error(TYPE_ERROR_EVALUABLE, t,
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,1);
P = (yamop *)FAILCODE;
return(FALSE);
}
f = p->FOfEE.unary(Deref(ARG3),&res);
return (Yap_unify_constant(ARG1,EvalToTerm(f,&res)));
}
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.unary = InitUnTab[i].f;
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
Yap_InitCPred("is", 3, p_unary_is, TestPredFlag | SafePredFlag);
}
/* This routine is called from Restore to make sure we have the same arithmetic operators */
int
Yap_ReInitUnaryExps(void)
{
unsigned int i;
Prop p;
for (i = 0; i < sizeof(InitUnTab)/sizeof(InitUnEntry); ++i) {
AtomEntry *ae = RepAtom(Yap_FullLookupAtom(InitUnTab[i].OpName));
if (ae == NULL) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"at ReInitUnaryExps");
return FALSE;
}
WRITE_LOCK(ae->ARWLock);
if ((p = Yap_GetExpPropHavingLock(ae, 1)) == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return FALSE;
}
RepExpProp(p)->FOfEE.unary = InitUnTab[i].f;
WRITE_UNLOCK(ae->ARWLock);
}
return TRUE;
}
Reference in New Issue View Git Blame Copy Permalink