yap-6.3/H/arith2.h

/*************************************************************************
 *									 *
 *	 YAP Prolog 							 *
 *									 *
 *	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
 *									 *
 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
 *									 *
 **************************************************************************
 *									 *
 * File:		arithi2.c						 *
 * Last rev:								 *
 * mods:									 *
 * comments:	arithmetical expression evaluation			 *
 *									 *
 *************************************************************************/

/* This file implements fast binary math operations for YAP
 *
 */

inline static int
add_overflow(Int x, Int i, Int j)
{
  return (i & j & ~x) | (~i & ~j & x);
}

inline static Term
add_int(Int i, Int j)
{
  Int x = i+j;
#if USE_GMP
  /* Integer overflow, we need to use big integers */
  Int overflow = (i & j & ~x) | (~i & ~j & x);
  if (overflow) {
    return(Yap_gmp_add_ints(i, j));
  }
#endif
#ifdef BEAM
  RINT(x);
  return( MkIntegerTerm (x));
#else
  RINT(x);
#endif
}

inline static int
sub_overflow(Int x, Int i, Int j)
{
  return (i & ~j & ~x) | (~i & j & x);
}

inline static Term
sub_int(Int i, Int j)
{
  Int x = i-j;
#if USE_GMP
  Int overflow = (i & ~j & ~x) | (~i & j & x);
  /* Integer overflow, we need to use big integers */
  if (overflow) {
    return(Yap_gmp_sub_ints(i, j));
  }
#endif
#ifdef BEAM
  RINT(x);
  return( MkIntegerTerm (x));
#else
  RINT(x);
#endif
}

#ifdef __GNUC__
#ifdef __i386__
#define DO_MULTI() { Int tmp1;						\
    __asm__ ("imull  %3\n\t movl   $0,%1\n\t jno    0f\n\t movl   $1,%1\n\t 0:"	\
	     : "=a" (z),						\
	       "=d" (tmp1)						\
	     : "a" (i1),						\
	       "rm" (i2)						\
	     : "cc" );							\
    if (tmp1) goto overflow;						\
  }
#define OPTIMIZE_MULTIPLI 1
#endif
#endif


inline static int
mul_overflow(Int z, Int i1, Int i2)
{
  return (i2 &&  z/i2 != i1);
}

#ifndef OPTIMIZE_MULTIPLI
#define DO_MULTI() z = i1*i2;			\
  if (i2 &&  z/i2 != i1) goto overflow
#endif

inline static Term
times_int(Int i1, Int i2) {
#ifdef USE_GMP
  Int z;
  DO_MULTI();
  RINT(z);
 overflow:
  {
    return(Yap_gmp_mul_ints(i1, i2));
  }
#else
  RINT(i1*i2);
#endif
}


#if USE_GMP
static inline int
sl_overflow(Int x,Int i)
{
  CELL t = (1<<x)-1;
  return (t & i) != i;
}

static inline int
sr_overflow(Int x,Int i)
{
  CELL t = (1>>x)-1;
  return (t & i) != i;
}
#else
static inline Int
sl_overflow(Int x,Int i)
{
  return FALSE; 
}

static inline Int
sr_overflow(Int x,Int i)
{
  return FALSE;
}
#endif

inline static Term
do_sll(Int i, Int j)
{
#if USE_GMP
  Int x = (8*sizeof(CELL)-2)-j;
  
  if (x < 0||
      sl_overflow(x,i)) {
    return(Yap_gmp_sll_ints(i, j));
  }
#endif
  RINT(i << j);
}


static inline Term
p_plus(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      return add_int(IntegerOfTerm(t1),IntegerOfTerm(t2));
    case double_e:
      {
	/* integer, double */
	Float fl1 = (Float)IntegerOfTerm(t1);
	Float fl2 = FloatOfTerm(t2);
	RFLOAT(fl1+fl2);
      }
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_add_int_big(IntegerOfTerm(t1), Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
  case double_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* float * integer */
      RFLOAT(FloatOfTerm(t1)+IntegerOfTerm(t2));
    case double_e:
      RFLOAT(FloatOfTerm(t1)+FloatOfTerm(t2));
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_add_float_big(FloatOfTerm(t1),Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      return(Yap_gmp_add_int_big(IntegerOfTerm(t2), Yap_BigIntOfTerm(t1)));
    case big_int_e:
      /* two bignums */
      return(Yap_gmp_add_big_big(Yap_BigIntOfTerm(t1), Yap_BigIntOfTerm(t2)));
    case double_e:
      return(Yap_gmp_add_float_big(FloatOfTerm(t2),Yap_BigIntOfTerm(t1)));
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}

static Term
p_minus(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      return sub_int(IntegerOfTerm(t1), IntegerOfTerm(t2));
    case double_e:
      {
	/* integer, double */
	Float fl1 = (Float)IntegerOfTerm(t1);
	Float fl2 = FloatOfTerm(t2);
	RFLOAT(fl1-fl2);
      }
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_sub_int_big(IntegerOfTerm(t1), Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* float * integer */
      RFLOAT(FloatOfTerm(t1)-IntegerOfTerm(t2));
    case double_e:
      {
	RFLOAT(FloatOfTerm(t1)-FloatOfTerm(t2));
      }
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_sub_float_big(FloatOfTerm(t1),Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      return(Yap_gmp_sub_big_int(Yap_BigIntOfTerm(t1), IntegerOfTerm(t2)));
    case big_int_e:
      return(Yap_gmp_sub_big_big(Yap_BigIntOfTerm(t1), Yap_BigIntOfTerm(t2)));
    case double_e:
      return(Yap_gmp_sub_big_float(Yap_BigIntOfTerm(t1),FloatOfTerm(t2)));
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}


static Term
p_times(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      return(times_int(IntegerOfTerm(t1),IntegerOfTerm(t2)));
    case double_e:
      {
	/* integer, double */
	Float fl1 = (Float)IntegerOfTerm(t1);
	Float fl2 = FloatOfTerm(t2);
	RFLOAT(fl1*fl2);
      }
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_mul_int_big(IntegerOfTerm(t1), Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* float * integer */
      RFLOAT(FloatOfTerm(t1)*IntegerOfTerm(t2));
    case double_e:
      RFLOAT(FloatOfTerm(t1)*FloatOfTerm(t2));
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_mul_float_big(FloatOfTerm(t1),Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      return(Yap_gmp_mul_int_big(IntegerOfTerm(t2), Yap_BigIntOfTerm(t1)));
    case big_int_e:
      /* two bignums */
      return(Yap_gmp_mul_big_big(Yap_BigIntOfTerm(t1), Yap_BigIntOfTerm(t2)));
    case double_e:
      return(Yap_gmp_mul_float_big(FloatOfTerm(t2),Yap_BigIntOfTerm(t1)));
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}

static Term
p_div(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      {
	Int i2 = IntegerOfTerm(t2);
      
	if (i2 == 0) {
	  Yap_Error(EVALUATION_ERROR_ZERO_DIVISOR, t2, "// /2");
	  /* make GCC happy */
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	RINT(IntegerOfTerm(t1) / i2);
      }
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "// /2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case big_int_e:
#ifdef USE_GMP
      /* Cool */
      RINT(0);
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    Yap_Error(TYPE_ERROR_INTEGER, t1, "// /2");
    P = (yamop *)FAILCODE;
    RERROR();
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* dividing a bignum by an integer */
      {
	Term t= Yap_gmp_div_big_int(Yap_BigIntOfTerm(t1), IntegerOfTerm(t2));
	if (t==0L) {
	  /* make GCC happy */
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	return(t);
      }
    case big_int_e:
      /* two bignums */
      {
	Term t;

	t = Yap_gmp_div_big_big(Yap_BigIntOfTerm(t1), Yap_BigIntOfTerm(t2));
	if (t==0L) {
	  /* make GCC happy */
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	return(t);
      }
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "// /2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case db_ref_e:
      RERROR();
    }
  case db_ref_e:
    RERROR();
#endif
  }
  RERROR();
}

static Term
p_and(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      RINT(IntegerOfTerm(t1) & IntegerOfTerm(t2));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "/\\ /2");
      P = (yamop *)FAILCODE;
      RERROR();
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_and_int_big(IntegerOfTerm(t1),Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    Yap_Error(TYPE_ERROR_INTEGER, t1, "/\\ /2");
    P = (yamop *)FAILCODE;
    RERROR();
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* anding a bignum with an integer is easy */
      return(Yap_gmp_and_int_big(IntegerOfTerm(t2),Yap_BigIntOfTerm(t1)));
    case big_int_e:
      /* two bignums */
      return(Yap_gmp_and_big_big(Yap_BigIntOfTerm(t2), Yap_BigIntOfTerm(t1)));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "/\\ /2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}

static Term
p_or(Term t1, Term t2) {
  switch(ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      RINT(IntegerOfTerm(t1) | IntegerOfTerm(t2));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "\\/ /2");
      P = (yamop *)FAILCODE;
      RERROR();
    case big_int_e:
#ifdef USE_GMP
      return(Yap_gmp_ior_int_big(IntegerOfTerm(t1),Yap_BigIntOfTerm(t2)));
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    Yap_Error(TYPE_ERROR_INTEGER, t1, "\\/ /2");
    P = (yamop *)FAILCODE;
    RERROR();
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* anding a bignum with an integer is easy */
      return(Yap_gmp_ior_int_big(IntegerOfTerm(t2),Yap_BigIntOfTerm(t1)));
    case big_int_e:
      /* two bignums */
      return(Yap_gmp_ior_big_big(Yap_BigIntOfTerm(t2), Yap_BigIntOfTerm(t1)));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "\\/ /2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}

static Term
p_sll(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      if (IntegerOfTerm(t2) < 0) {
	Int i2 = IntegerOfTerm(t2);
	if (i2 == Int_MIN) {
	  Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	RINT(IntegerOfTerm(t1) >> -i2);
      }
      return do_sll(IntegerOfTerm(t1),IntegerOfTerm(t2));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "<</2");
      P = (yamop *)FAILCODE;
      RERROR();
    case big_int_e:
#ifdef USE_GMP
      Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, "<</2");
      P = (yamop *)FAILCODE;
      RERROR();
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    Yap_Error(TYPE_ERROR_INTEGER, t1, "<< /2");
    P = (yamop *)FAILCODE;
    RERROR();
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      {
	Term t = Yap_gmp_sll_big_int(Yap_BigIntOfTerm(t1),  IntegerOfTerm(t2));
	if (t == 0L) {
	  Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	return(t);
      }
    case big_int_e:
      Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, "<</2");
      P = (yamop *)FAILCODE;
      RERROR();
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, "<</2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}

static Term
p_slr(Term t1, Term t2) {
  switch (ETypeOfTerm(t1)) {
  case long_int_e:
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      /* two integers */
      if (IntegerOfTerm(t2) < 0) {
	Int i2 = IntegerOfTerm(t2);
	if (i2 == Int_MIN) {
	  Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	return do_sll(IntegerOfTerm(t1), -i2);
      }
      RINT(IntegerOfTerm(t1) >> IntegerOfTerm(t2));
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, ">>/2");
      P = (yamop *)FAILCODE;
      RERROR();
    case big_int_e:
#ifdef USE_GMP
      Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
      P = (yamop *)FAILCODE;
      RERROR();
#endif
    case db_ref_e:
      RERROR();
    }
    break;
  case double_e:
    Yap_Error(TYPE_ERROR_INTEGER, t1, ">>/2");
    P = (yamop *)FAILCODE;
    RERROR();
  case big_int_e:
#ifdef USE_GMP
    switch (ETypeOfTerm(t2)) {
    case long_int_e:
      {
	Term t;

	t = Yap_gmp_sll_big_int(Yap_BigIntOfTerm(t1),  -IntegerOfTerm(t2));
	if (t == 0L) {
	  Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
	  P = (yamop *)FAILCODE;
	  RERROR();
	}
	return(t);
      }
    case big_int_e:
      Yap_Error(DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, t2, ">>/2");
      P = (yamop *)FAILCODE;
      RERROR();
    case double_e:
      Yap_Error(TYPE_ERROR_INTEGER, t2, ">>/2");
      /* make GCC happy */
      P = (yamop *)FAILCODE;
      RERROR();
    case db_ref_e:
      RERROR();
    }
#endif
  case db_ref_e:
    RERROR();
  }
  RERROR();
}