This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/eval.c
2009-05-22 14:44:32 -05:00

187 lines
4.1 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: eval.c *
* Last rev: *
* mods: *
* comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file implements arithmetic operations
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
#if HAVE_STDARG_H
#include <stdarg.h>
#endif
#include <stdlib.h>
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
yap_error_number Yap_matherror = YAP_NO_ERROR;
static Term
Eval(Term t)
{
if (IsVarTerm(t)) {
return Yap_ArithError(INSTANTIATION_ERROR,t,"in arithmetic");
} else if (IsAtomTerm(t)) {
ExpEntry *p;
Atom name = AtomOfTerm(t);
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 0)))) {
Term ti[2], terror;
/* error */
ti[0] = t;
ti[1] = MkIntegerTerm(0);
/* error */
terror = Yap_MkApplTerm(FunctorSlash, 2, ti);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, terror,
"atom %s for arithmetic expression",
RepAtom(name)->StrOfAE);
}
return Yap_eval_atom(p->FOfEE);
} else if (IsIntTerm(t)) {
return t;
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
switch ((CELL)fun) {
case (CELL)FunctorLongInt:
case (CELL)FunctorDouble:
#ifdef USE_GMP
case (CELL)FunctorBigInt:
#endif
return t;
default:
{
if ((Atom)fun == AtomFoundVar) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil,
"cyclic term in arithmetic expression");
} else {
Int n = ArityOfFunctor(fun);
Atom name = NameOfFunctor(fun);
ExpEntry *p;
Term t1, t2;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, n)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntegerTerm(n);
t = Yap_MkApplTerm(FunctorSlash, 2, ti);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,n);
}
*RepAppl(t) = (CELL)AtomFoundVar;
t1 = Eval(ArgOfTerm(1,t));
if (t1 == 0L) {
*RepAppl(t) = (CELL)fun;
return FALSE;
}
if (n == 1) {
*RepAppl(t) = (CELL)fun;
return Yap_eval_unary(p->FOfEE, t1);
}
t2 = Eval(ArgOfTerm(2,t));
*RepAppl(t) = (CELL)fun;
if (t2 == 0L)
return FALSE;
return Yap_eval_binary(p->FOfEE,t1,t2);
}
}
}
} /* else if (IsPairTerm(t)) */ {
if (TailOfTerm(t) != TermNil) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"string must contain a single character to be evaluated as an arithmetic expression");
}
return Eval(HeadOfTerm(t));
}
}
Term
Yap_Eval(Term t)
{
return Yap_FoundArithError(Eval(t), t);
}
#ifdef BEAM
Int BEAM_is(void);
Int
BEAM_is(void)
{ /* X is Y */
union arith_ret res;
blob_type bt;
bt = Eval(Deref(XREGS[2]), &res);
if (bt==db_ref_e) return (NULL);
return (EvalToTerm(bt,&res));
}
#endif
static Int
p_is(void)
{ /* X is Y */
Term out, t;
t = Deref(ARG2);
out = Yap_FoundArithError(Eval(t), t);
if (!out) return FALSE;
return Yap_unify_constant(ARG1,out);
}
Int
Yap_ArithError(yap_error_number type, Term where, char *format,...)
{
va_list ap;
Yap_Error_TYPE = type;
Yap_Error_Term = where;
if (!Yap_ErrorMessage)
Yap_ErrorMessage = Yap_ErrorSay;
va_start (ap, format);
if (format != NULL) {
#if HAVE_VSNPRINTF
(void) vsnprintf(Yap_ErrorMessage, MAX_ERROR_MSG_SIZE, format, ap);
#else
(void) vsprintf(Yap_ErrorMessage, format, ap);
#endif
} else {
Yap_ErrorMessage[0] = '\0';
}
va_end (ap);
return 0L;
}
void
Yap_InitEval(void)
{
/* here are the arithmetical predicates */
Yap_InitConstExps();
Yap_InitUnaryExps();
Yap_InitBinaryExps();
Yap_InitCPred("is", 2, p_is, SafePredFlag);
}