/*-------------------------------------*\
| basis module for compiled R programs  |
|---------------------------------------|
   
   (C)Copyright 2007 Simon Urbanek
   License: GPL v2

   Parts are based on R 2.5.1 
\*-------------------------------------*/
  
/* for efficiency we enable R internals to get macros */
#define USE_RINTERNALS 1

#include <R.h>
#include <Rinternals.h>

extern double  lgammafn(double);
extern double  digamma(double);
extern double  trigamma(double);
extern double gamma_cody(double);

/* we don't use gettext, so fake it */
#define _(X) (X)

/*-- from Defn.h --*/

/* structure for caching machine accuracy values */
typedef struct {
  int ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp;
  double eps, epsneg, xmin, xmax;
} AccuracyInfo;

LibExtern AccuracyInfo R_AccuracyInfo;
/* we could replace those with static definitions ...  */
double R_pow(double x, double y);
double R_pow_di(double x, int n);

/* Arithmetic and Relation Operators */
typedef enum {
  PLUSOP = 1,
  MINUSOP,
  TIMESOP,
  DIVOP,
  POWOP,
  MODOP,
    IDIVOP
} ARITHOP_TYPE;

typedef enum {
  EQOP = 1,
  NEOP,
  LTOP,
  LEOP,
  GEOP,
    GTOP
} RELOP_TYPE;

/*-- from arithmetics.c --*/

#define R_INTEGER(robj, i) (double) (INTEGER(robj)[i] == NA_INTEGER ? NA_REAL : INTEGER(robj)[i])

/* i1 = i % n1; i2 = i % n2;
 * this macro is quite a bit faster than having real modulo calls
 * in the loop (tested on Intel and Sparc)
 */
#define mod_iterate(n1,n2,i1,i2) for (i=i1=i2=0; i<n; \
				      i1 = (++i1 == n1) ? 0 : i1,\
					i2 = (++i2 == n2) ? 0 : i2,\
					++i)

/* Keep these two in step */
static inline double myfmod(double x1, double x2)
{
  double q = x1 / x2, tmp;

  if (x2 == 0.0) return R_NaN;
  tmp = x1 - floor(q) * x2;
  if(R_FINITE(q) && (fabs(q) > 1/R_AccuracyInfo.eps))
    warning(_("probable complete loss of accuracy in modulus"));
  q = floor(tmp/x2);
  return tmp - q * x2;
}

static inline double myfloor(double x1, double x2)
{
  double q = x1 / x2, tmp;

  if (x2 == 0.0) return q;
  tmp = x1 - floor(q) * x2;
  return floor(q) + floor(tmp/x2);
}

/* some systems get this wrong, possibly depend on what libs are loaded */
static R_INLINE double R_log(double x) { 
  return x > 0 ? log(x) : x < 0 ? R_NaN : R_NegInf; 
}

static inline SEXP real_binary(ARITHOP_TYPE code, SEXP s1, SEXP s2)
{
  int i, i1, i2, n, n1, n2;
  SEXP ans;
  
  /* Note: "s1" and "s2" are protected above. */
  n1 = LENGTH(s1);
  n2 = LENGTH(s2);
  
  /* S4-compatibility change: if n1 or n2 is 0, result is of length 0 */
  if (n1 == 0 || n2 == 0) return(allocVector(REALSXP, 0));

  n = (n1 > n2) ? n1 : n2;
  PROTECT(ans = allocVector(REALSXP, n));
  switch (code) {
  case PLUSOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] + REAL(s2)[i2];
      }
    } else  if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_INTEGER(s1, i1) + REAL(s2)[i2];
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] + R_INTEGER(s2, i2);
      }
    }

    break;
  case MINUSOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] - REAL(s2)[i2];
      }
    } else  if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_INTEGER(s1, i1) - REAL(s2)[i2];
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] - R_INTEGER(s2, i2);
      }
    }
    break;
  case TIMESOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] * REAL(s2)[i2];
      }
    } else if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_INTEGER(s1, i1) * REAL(s2)[i2];
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] * R_INTEGER(s2, i2);
      }
    }
    break;
  case DIVOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] / REAL(s2)[i2];
      }
    } else if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_INTEGER(s1, i1) / REAL(s2)[i2];
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = REAL(s1)[i1] / R_INTEGER(s2, i2);
      }
    }
    break;
  case POWOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_pow(REAL(s1)[i1], REAL(s2)[i2]);
      }
    } else if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_pow( R_INTEGER(s1, i1), REAL(s2)[i2]);
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = R_pow(REAL(s1)[i1], R_INTEGER(s2, i2));
      }
    }
    break;
  case MODOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfmod(REAL(s1)[i1], REAL(s2)[i2]);
      }
    } else if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfmod( R_INTEGER(s1, i1), REAL(s2)[i2]);
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfmod(REAL(s1)[i1], R_INTEGER(s2, i2));
      }
    }
    break;
  case IDIVOP:
    if(TYPEOF(s1) == REALSXP && TYPEOF(s2) == REALSXP) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfloor(REAL(s1)[i1], REAL(s2)[i2]);
      }
    } else if(TYPEOF(s1) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfloor(R_INTEGER(s1, i1), REAL(s2)[i2]);
      }
    } else  if(TYPEOF(s2) == INTSXP ) {
      mod_iterate(n1, n2, i1, i2) {
	REAL(ans)[i] = myfloor(REAL(s1)[i1], R_INTEGER(s2,i2));
      }
    }
    break;
  }

  /* quick return if there are no attributes */
  if (ATTRIB(s1) == R_NilValue && ATTRIB(s2) == R_NilValue) {
    UNPROTECT(1);
    return ans;
  }
  /* Copy attributes from longer argument. */

  if (n1 > n2)
    copyMostAttrib(s1, ans);
  else if (n1 == n2) {
    copyMostAttrib(s2, ans);
    copyMostAttrib(s1, ans);
  }
  else
    copyMostAttrib(s2, ans);

  UNPROTECT(1);
  return ans;
}

/*--- from seq.c ---*/

static inline SEXP seq_colon(double n1, double n2, SEXP call)
{
  int i, n, in1;
  double r;
  SEXP ans;
  Rboolean useInt;

  in1 = (int)(n1);
  useInt = (n1 == in1);
  if (n1 <= INT_MIN || n2 <= INT_MIN || n1 > INT_MAX || n2 > INT_MAX)
    useInt = FALSE;
  r = fabs(n2 - n1);
  if(r >= INT_MAX) errorcall(call,_("result would be too long a vector"));

  n = r + 1 + FLT_EPSILON;
  if (useInt) {
    ans = allocVector(INTSXP, n);
    if (n1 <= n2)
      for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 + i;
    else
      for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 - i;
  } else {
    ans = allocVector(REALSXP, n);
    if (n1 <= n2)
      for (i = 0; i < n; i++) REAL(ans)[i] = n1 + i;
    else
      for (i = 0; i < n; i++) REAL(ans)[i] = n1 - i;
  }
  return ans;
}

static inline SEXP real_unary(ARITHOP_TYPE code, SEXP s1)
{
  int i, n;
  SEXP ans;

  switch (code) {
  case PLUSOP: return s1;
  case MINUSOP:
    ans = duplicate(s1);
    n = LENGTH(s1);
    for (i = 0; i < n; i++)
      REAL(ans)[i] = -REAL(s1)[i];
    return ans;
  default:
    error("invalid unary operator");
  }
  return s1;                  /* never used; to keep -Wall happy */
}

#define R_MSG_NA "NaNs produced"

#define MAKE_MATH1_NAME(fn) RC_ ## fn
#define MAKE_MATH1_FN(fn) static inline SEXP MAKE_MATH1_NAME(fn)(SEXP sa) \
{ \
  SEXP sy; \
  double *y, *a; \
  int i, n; \
  int naflag; \
 \
  if (!isNumeric(sa)) \
    error("parameter not numeric"); \
 \
  n = length(sa); \
  PROTECT(sa = coerceVector(sa, REALSXP)); \
  PROTECT(sy = allocVector(REALSXP, n)); \
  a = REAL(sa); \
  y = REAL(sy); \
  naflag = 0; \
  for (i = 0; i < n; i++) { \
    if (ISNAN(a[i])) \
      y[i] = a[i]; \
    else { \
      y[i] = fn(a[i]); \
      if (ISNAN(y[i])) naflag = 1; \
    } \
  } \
  if(naflag) \
    warningcall(R_NilValue, R_MSG_NA); \
 \
  DUPLICATE_ATTRIB(sy, sa); \
  UNPROTECT(2); \
  return sy; \
}

/* compatibility macros that map names generated by the compiler to corresponding R functions */

#define RC__ar2(X,Y,Z) real_binary(X,Y,Z)
#define RC__ar1(X,Y) real_unary(X,Y)

/* noops */
#define RC_expression(X) (X)
#define RC_quote(X) (X)

/* --- native function code --- */
#define NC_GETOP(S,O) S=CAR(O)
/* eval(LCONS(install("str"),CONS(S,R_NilValue)),_rho) */
#define ENC_GETOP(S,O) S=CAR(O); if (TYPEOF(S)==SYMSXP) S=findVar(S, _rho); else if (TYPEOF(S)==LANGSXP) S=eval(S, _rho);

/*--- "compiled" code ---*/
  
