OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gfortran.h (GFC_MPC_RND_MODE): New.

Browse Source 
* gfortran.h (GFC_MPC_RND_MODE): New.
	* simplify.c (call_mpc_func): New helper function.
	(gfc_simplify_cos, gfc_simplify_exp, gfc_simplify_log,
	gfc_simplify_sin, gfc_simplify_sqrt): Add MPC support.

From-SVN: r147860
This commit is contained in:
Kaveh R. Ghazi 2009-05-26 06:04:16 +00:00 committed by Kaveh Ghazi
parent a30d7997f3
commit f6b855dfad
3 changed files with 67 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2009-05-26 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gfortran.h (GFC_MPC_RND_MODE): New.
* simplify.c (call_mpc_func): New helper function.
(gfc_simplify_cos, gfc_simplify_exp, gfc_simplify_log,
gfc_simplify_sin, gfc_simplify_sqrt): Add MPC support.
2009-05-25 Janus Weil <janus@gcc.gnu.org>
PR fortran/40176

1
gcc/fortran/gfortran.h
View File

@ -1556,6 +1556,7 @@ gfc_intrinsic_sym;
#include <gmp.h>
#include <mpfr.h>
#define GFC_RND_MODE GMP_RNDN
#define GFC_MPC_RND_MODE MPC_RNDNN
typedef struct gfc_expr
{

67
gcc/fortran/simplify.c
View File

@ -210,6 +210,24 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
}
}
/* Helper function to convert to/from mpfr_t & mpc_t and call the
supplied mpc function on the respective values. */
#ifdef HAVE_mpc
static void
call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
mpfr_srcptr input_re, mpfr_srcptr input_im,
int (*func)(mpc_ptr, mpc_srcptr, mpc_rnd_t))
{
mpc_t c;
mpc_init2 (c, mpfr_get_default_prec());
mpc_set_fr_fr (c, input_re, input_im, GFC_MPC_RND_MODE);
func (c, c, GFC_MPC_RND_MODE);
mpfr_set (result_re, MPC_RE (c), GFC_RND_MODE);
mpfr_set (result_im, MPC_IM (c), GFC_RND_MODE);
mpc_clear (c);
}
#endif
/********************** Simplification functions *****************************/
@ -985,7 +1003,6 @@ gfc_expr *
gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
@ -999,6 +1016,12 @@ gfc_simplify_cos (gfc_expr *x)
break;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
call_mpc_func (result->value.complex.r, result->value.complex.i,
x->value.complex.r, x->value.complex.i, mpc_cos);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
@ -1012,6 +1035,8 @@ gfc_simplify_cos (gfc_expr *x)
mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
mpfr_clears (xp, xq, NULL);
}
#endif
break;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
@ -1370,7 +1395,6 @@ gfc_expr *
gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
@ -1385,6 +1409,12 @@ gfc_simplify_exp (gfc_expr *x)
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
call_mpc_func (result->value.complex.r, result->value.complex.i,
x->value.complex.r, x->value.complex.i, mpc_exp);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
@ -1393,6 +1423,8 @@ gfc_simplify_exp (gfc_expr *x)
mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
mpfr_clears (xp, xq, NULL);
}
#endif
break;
default:
@ -2688,7 +2720,6 @@ gfc_expr *
gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xr, xi;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
@ -2721,6 +2752,12 @@ gfc_simplify_log (gfc_expr *x)
}
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
call_mpc_func (result->value.complex.r, result->value.complex.i,
x->value.complex.r, x->value.complex.i, mpc_log);
#else
{
mpfr_t xr, xi;
mpfr_init (xr);
mpfr_init (xi);
@ -2734,7 +2771,8 @@ gfc_simplify_log (gfc_expr *x)
mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
mpfr_clears (xr, xi, NULL);
}
#endif
break;
default:
@ -4314,7 +4352,6 @@ gfc_expr *
gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
@ -4329,6 +4366,12 @@ gfc_simplify_sin (gfc_expr *x)
case BT_COMPLEX:
gfc_set_model (x->value.real);
#ifdef HAVE_mpc
call_mpc_func (result->value.complex.r, result->value.complex.i,
x->value.complex.r, x->value.complex.i, mpc_sin);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
@ -4341,6 +4384,8 @@ gfc_simplify_sin (gfc_expr *x)
mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
mpfr_clears (xp, xq, NULL);
}
#endif
break;
default:
@ -4425,7 +4470,6 @@ gfc_expr *
gfc_simplify_sqrt (gfc_expr *e)
{
gfc_expr *result;
mpfr_t ac, ad, s, t, w;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -4442,10 +4486,16 @@ gfc_simplify_sqrt (gfc_expr *e)
break;
case BT_COMPLEX:
gfc_set_model (e->value.real);
#ifdef HAVE_mpc
call_mpc_func (result->value.complex.r, result->value.complex.i,
e->value.complex.r, e->value.complex.i, mpc_sqrt);
#else
{
/* Formula taken from Numerical Recipes to avoid over- and
underflow. */
gfc_set_model (e->value.real);
mpfr_t ac, ad, s, t, w;
mpfr_init (ac);
mpfr_init (ad);
mpfr_init (s);
@ -4517,7 +4567,8 @@ gfc_simplify_sqrt (gfc_expr *e)
&e->where);
mpfr_clears (s, t, ac, ad, w, NULL);
}
#endif
break;
default: