163 lines
2.7 KiB
C
163 lines
2.7 KiB
C
/* { dg-do compile } */
|
|
/* { dg-options "-O3 -std=c99 -mexplicit-relocs" } */
|
|
|
|
typedef int R_len_t;
|
|
typedef unsigned int SEXPTYPE;
|
|
struct sxpinfo_struct
|
|
{
|
|
SEXPTYPE type:5;
|
|
};
|
|
|
|
struct vecsxp_struct
|
|
{
|
|
R_len_t length;
|
|
R_len_t truelength;
|
|
};
|
|
|
|
struct listsxp_struct
|
|
{
|
|
struct SEXPREC *carval;
|
|
struct SEXPREC *cdrval;
|
|
struct SEXPREC *tagval;
|
|
};
|
|
|
|
typedef struct SEXPREC
|
|
{
|
|
struct sxpinfo_struct sxpinfo;
|
|
union
|
|
{
|
|
struct listsxp_struct listsxp;
|
|
} u;
|
|
} SEXPREC, *SEXP;
|
|
|
|
typedef struct VECTOR_SEXPREC
|
|
{
|
|
struct vecsxp_struct vecsxp;
|
|
} VECTOR_SEXPREC, *VECSEXP;
|
|
|
|
typedef union
|
|
{
|
|
VECTOR_SEXPREC s;
|
|
double align;
|
|
} SEXPREC_ALIGN;
|
|
|
|
extern SEXP R_NilValue;
|
|
extern SEXP R_MissingArg;
|
|
|
|
int Rf_envlength (SEXP rho);
|
|
SEXP Rf_protect (SEXP);
|
|
const char *Rf_translateChar (SEXP);
|
|
|
|
inline R_len_t
|
|
Rf_length (SEXP s)
|
|
{
|
|
int i;
|
|
switch (((s)->sxpinfo.type))
|
|
{
|
|
case 0:
|
|
return 0;
|
|
case 24:
|
|
return (((VECSEXP) (s))->vecsxp.length);
|
|
case 6:
|
|
case 17:
|
|
i = 0;
|
|
while (s != ((void *) 0) && s != R_NilValue)
|
|
{
|
|
i++;
|
|
s = ((s)->u.listsxp.cdrval);
|
|
}
|
|
return i;
|
|
case 4:
|
|
return Rf_envlength (s);
|
|
default:
|
|
return 1;
|
|
}
|
|
}
|
|
|
|
inline SEXP
|
|
Rf_lang3 (SEXP s, SEXP t, SEXP u)
|
|
{
|
|
return s;
|
|
}
|
|
|
|
typedef SEXP (*CCODE) (SEXP, SEXP, SEXP, SEXP);
|
|
|
|
static SEXP PlusSymbol;
|
|
static SEXP MinusSymbol;
|
|
static SEXP DivideSymbol;
|
|
|
|
int isZero (SEXP s);
|
|
SEXP PP (SEXP s);
|
|
SEXP AddParens (SEXP expr);
|
|
SEXP Rf_install ();
|
|
|
|
static int
|
|
isUminus (SEXP s)
|
|
{
|
|
if (((s)->sxpinfo.type) == 6 && ((s)->u.listsxp.carval) == MinusSymbol)
|
|
{
|
|
switch (Rf_length (s))
|
|
{
|
|
case 2:
|
|
return 1;
|
|
case 3:
|
|
if (((((((s)->u.listsxp.cdrval))->u.listsxp.cdrval))->u.listsxp.
|
|
carval) == R_MissingArg)
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
}
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
static SEXP
|
|
simplify (SEXP fun, SEXP arg1, SEXP arg2)
|
|
{
|
|
SEXP ans;
|
|
if (fun == PlusSymbol)
|
|
{
|
|
if (isZero (arg1))
|
|
ans = arg2;
|
|
else if (isUminus (arg1))
|
|
ans =
|
|
simplify (MinusSymbol, arg2,
|
|
((((arg1)->u.listsxp.cdrval))->u.listsxp.carval));
|
|
else if (isUminus (arg2))
|
|
ans =
|
|
simplify (MinusSymbol, arg1,
|
|
((((arg2)->u.listsxp.cdrval))->u.listsxp.carval));
|
|
}
|
|
else if (fun == DivideSymbol)
|
|
{
|
|
ans = Rf_lang3 (DivideSymbol, arg1, arg2);
|
|
}
|
|
|
|
return ans;
|
|
}
|
|
|
|
|
|
static SEXP
|
|
D (SEXP expr, SEXP var)
|
|
{
|
|
return simplify (PlusSymbol,
|
|
PP (D
|
|
(((((expr)->u.listsxp.cdrval))->u.listsxp.carval),
|
|
var)),
|
|
PP (D
|
|
(((((((expr)->u.listsxp.cdrval))->u.listsxp.cdrval))->
|
|
u.listsxp.carval), var)));
|
|
}
|
|
|
|
SEXP
|
|
do_D (SEXP call, SEXP op, SEXP args, SEXP env)
|
|
{
|
|
SEXP expr, var;
|
|
var = Rf_install ();
|
|
expr = ((args)->u.listsxp.carval);
|
|
Rf_protect (expr = D (expr, var));
|
|
expr = AddParens (expr);
|
|
return expr;
|
|
}
|