From be262ab5cc288412e8b120dd407cf545bfaa8943 Mon Sep 17 00:00:00 2001 From: ghazi Date: Sun, 28 Jun 2009 06:06:28 +0000 Subject: gcc/fortran: * gfortran.h: Define HAVE_mpc_pow. * arith.c (complex_reciprocal, complex_pow): If HAVE_mpc_pow, don't define these functions. (arith_power): If HAVE_mpc_pow, use mpc_pow. gcc/testsuite: * gfortran.dg/integer_exponentiation_4.f90: Temporarily comment out some values and add some cases. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149023 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 2aa3c40fd40..dddf7e003ce 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -896,6 +896,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) /* Compute the reciprocal of a complex number (guaranteed nonzero). */ +#if ! defined(HAVE_mpc_pow) static void complex_reciprocal (gfc_expr *op) { @@ -922,6 +923,7 @@ complex_reciprocal (gfc_expr *op) } #endif } +#endif /* ! HAVE_mpc_pow */ /* Raise a complex number to positive power (power > 0). @@ -932,6 +934,7 @@ complex_reciprocal (gfc_expr *op) "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if ! defined(HAVE_mpc_pow) static void complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power) { @@ -988,6 +991,7 @@ complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power) mpfr_clears (x_r, x_i, tmp, re, im, NULL); } +#endif /* ! HAVE_mpc_pow */ /* Raise a number to a power. */ @@ -1107,6 +1111,15 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_COMPLEX: { +#ifdef HAVE_mpc_pow + mpc_t apower; + gfc_set_model (mpc_realref (op1->value.complex)); + mpc_init2 (apower, mpfr_get_default_prec()); + mpc_set_z (apower, op2->value.integer, GFC_MPC_RND_MODE); + mpc_pow(result->value.complex, op1->value.complex, apower, + GFC_MPC_RND_MODE); + mpc_clear (apower); +#else mpz_t apower; /* Compute op1**abs(op2) */ @@ -1118,6 +1131,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) /* If (op2 < 0), compute the inverse. */ if (power_sign < 0) complex_reciprocal (result); +#endif /* HAVE_mpc_pow */ } break; @@ -1159,6 +1173,10 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) return ARITH_PROHIBIT; } +#ifdef HAVE_mpc_pow + mpc_pow (result->value.complex, op1->value.complex, + op2->value.complex, GFC_MPC_RND_MODE); +#else { mpfr_t x, y, r, t; @@ -1211,6 +1229,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) mpfr_mul (mpc_imagref (result->value.complex), x, y, GFC_RND_MODE); mpfr_clears (r, t, x, y, NULL); } +#endif /* HAVE_mpc_pow */ } break; default: -- cgit v1.2.1 From a414690d9fc74fb66266ef8e37926a672163ebf9 Mon Sep 17 00:00:00 2001 From: ghazi Date: Wed, 7 Oct 2009 23:40:25 +0000 Subject: * arith.c (arith_power): Use mpc_pow_z. * gfortran.h (HAVE_mpc_pow_z): Define. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152544 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index dddf7e003ce..82a43ad7178 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1111,7 +1111,10 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_COMPLEX: { -#ifdef HAVE_mpc_pow +#ifdef HAVE_mpc_pow_z + mpc_pow_z (result->value.complex, op1->value.complex, + op2->value.integer, GFC_MPC_RND_MODE); +#elif defined(HAVE_mpc_pow) mpc_t apower; gfc_set_model (mpc_realref (op1->value.complex)); mpc_init2 (apower, mpfr_get_default_prec()); -- cgit v1.2.1 From 66a56860076243903465dadec8482f55d32144dc Mon Sep 17 00:00:00 2001 From: jakub Date: Sat, 28 Nov 2009 12:13:21 +0000 Subject: * trans-common.c (create_common): Remove unused offset variable. * io.c (gfc_match_wait): Remove unused loc variable. * trans-openmp.c (gfc_trans_omp_clauses): Remove unused old_clauses variable. (gfc_trans_omp_do): Remove unused outermost variable. * iresolve.c (gfc_resolve_alarm_sub, gfc_resolve_fseek_sub): Remove unused status variable. * module.c (number_use_names): Remove unused c variable. (load_derived_extensions): Remove unused nuse variable. * trans-expr.c (gfc_conv_substring): Remove unused var variable. * trans-types.c (gfc_get_array_descr_info): Remove unused offset_off variable. * matchexp.c (match_primary): Remove unused where variable. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Remove unused cond2 variable. (gfc_conv_intrinsic_sizeof): Remove unused source variable. (gfc_conv_intrinsic_transfer): Remove unused stride variable. (gfc_conv_intrinsic_function): Remove unused isym variable. * arith.c (gfc_hollerith2real, gfc_hollerith2complex, gfc_hollerith2logical): Remove unused len variable. * parse.c (parse_derived): Remove unused derived_sym variable. * decl.c (variable_decl): Remove unused old_locus variable. * resolve.c (check_class_members): Remove unused tbp_sym variable. (resolve_ordinary_assign): Remove unused assign_proc variable. (resolve_equivalence): Remove unused value_name variable. * data.c (get_array_index): Remove unused re variable. * trans-array.c (gfc_conv_array_transpose): Remove unused src_info variable. (gfc_conv_resolve_dependencies): Remove unused aref and temp_dim variables. (gfc_conv_loop_setup): Remove unused dim and len variables. (gfc_walk_variable_expr): Remove unused head variable. * match.c (match_typebound_call): Remove unused var variable. * intrinsic.c (gfc_convert_chartype): Remove unused from_ts variable. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154722 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 82a43ad7178..bd0ca6122cf 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1,5 +1,5 @@ /* Compiler arithmetic - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -2668,9 +2668,6 @@ gfc_expr * gfc_hollerith2real (gfc_expr *src, int kind) { gfc_expr *result; - int len; - - len = src->value.character.length; result = gfc_get_expr (); result->expr_type = EXPR_CONSTANT; @@ -2692,9 +2689,6 @@ gfc_expr * gfc_hollerith2complex (gfc_expr *src, int kind) { gfc_expr *result; - int len; - - len = src->value.character.length; result = gfc_get_expr (); result->expr_type = EXPR_CONSTANT; @@ -2741,9 +2735,6 @@ gfc_expr * gfc_hollerith2logical (gfc_expr *src, int kind) { gfc_expr *result; - int len; - - len = src->value.character.length; result = gfc_get_expr (); result->expr_type = EXPR_CONSTANT; -- cgit v1.2.1 From 0f77e4b8530980a42d981b38f6295a71ae02bc74 Mon Sep 17 00:00:00 2001 From: ghazi Date: Mon, 7 Dec 2009 15:32:43 +0000 Subject: PR other/40302 * arith.c: Remove HAVE_mpc* checks throughout. * expr.c: Likewise. * gfortran.h: Likewise. * resolve.c: Likewise. * simplify.c: Likewise. * target-memory.c: Likewise. * target-memory.h: Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155043 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 306 +--------------------------------------------------- 1 file changed, 4 insertions(+), 302 deletions(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index bd0ca6122cf..d119d1231f9 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -429,12 +429,7 @@ gfc_constant_result (bt type, int kind, locus *where) case BT_COMPLEX: gfc_set_model_kind (kind); -#ifdef HAVE_mpc mpc_init2 (result->value.complex, mpfr_get_default_prec()); -#else - mpfr_init (result->value.complex.r); - mpfr_init (result->value.complex.i); -#endif break; default: @@ -639,12 +634,7 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_neg (result->value.complex.r, op1->value.complex.r, GFC_RND_MODE); - mpfr_neg (result->value.complex.i, op1->value.complex.i, GFC_RND_MODE); -#endif break; default: @@ -677,16 +667,8 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_add (result->value.complex, op1->value.complex, op2->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_add (result->value.complex.r, op1->value.complex.r, - op2->value.complex.r, GFC_RND_MODE); - - mpfr_add (result->value.complex.i, op1->value.complex.i, - op2->value.complex.i, GFC_RND_MODE); -#endif break; default: @@ -719,16 +701,8 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_sub (result->value.complex, op1->value.complex, op2->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_sub (result->value.complex.r, op1->value.complex.r, - op2->value.complex.r, GFC_RND_MODE); - - mpfr_sub (result->value.complex.i, op1->value.complex.i, - op2->value.complex.i, GFC_RND_MODE); -#endif break; default: @@ -762,26 +736,8 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_COMPLEX: gfc_set_model (mpc_realref (op1->value.complex)); -#ifdef HAVE_mpc mpc_mul (result->value.complex, op1->value.complex, op2->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t x, y; - mpfr_init (x); - mpfr_init (y); - - mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE); - mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE); - mpfr_sub (result->value.complex.r, x, y, GFC_RND_MODE); - - mpfr_mul (x, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE); - mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE); - mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE); - - mpfr_clears (x, y, NULL); - } -#endif break; default: @@ -829,13 +785,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; case BT_COMPLEX: - if ( -#ifdef HAVE_mpc - mpc_cmp_si_si (op2->value.complex, 0, 0) == 0 -#else - mpfr_sgn (op2->value.complex.r) == 0 - && mpfr_sgn (op2->value.complex.i) == 0 -#endif + if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0 && gfc_option.flag_range_check == 1) { rc = ARITH_DIV0; @@ -843,8 +793,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) } gfc_set_model (mpc_realref (op1->value.complex)); - -#ifdef HAVE_mpc if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0) { /* In Fortran, return (NaN + NaN I) for any zero divisor. See @@ -855,32 +803,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) else mpc_div (result->value.complex, op1->value.complex, op2->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t x, y, div; - mpfr_init (x); - mpfr_init (y); - mpfr_init (div); - - mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE); - mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE); - mpfr_add (div, x, y, GFC_RND_MODE); - - mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE); - mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE); - mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE); - mpfr_div (result->value.complex.r, result->value.complex.r, div, - GFC_RND_MODE); - - mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE); - mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE); - mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE); - mpfr_div (result->value.complex.i, result->value.complex.i, div, - GFC_RND_MODE); - - mpfr_clears (x, y, div, NULL); - } -#endif break; default: @@ -893,107 +815,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) return check_result (rc, op1, result, resultp); } - -/* Compute the reciprocal of a complex number (guaranteed nonzero). */ - -#if ! defined(HAVE_mpc_pow) -static void -complex_reciprocal (gfc_expr *op) -{ - gfc_set_model (mpc_realref (op->value.complex)); -#ifdef HAVE_mpc - mpc_ui_div (op->value.complex, 1, op->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t mod, tmp; - - mpfr_init (mod); - mpfr_init (tmp); - - mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE); - mpfr_mul (tmp, op->value.complex.i, op->value.complex.i, GFC_RND_MODE); - mpfr_add (mod, mod, tmp, GFC_RND_MODE); - - mpfr_div (op->value.complex.r, op->value.complex.r, mod, GFC_RND_MODE); - - mpfr_neg (op->value.complex.i, op->value.complex.i, GFC_RND_MODE); - mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE); - - mpfr_clears (tmp, mod, NULL); - } -#endif -} -#endif /* ! HAVE_mpc_pow */ - - -/* Raise a complex number to positive power (power > 0). - This function will modify the content of power. - - Use Binary Method, which is not an optimal but a simple and reasonable - arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, - "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", - 3rd Edition, 1998. */ - -#if ! defined(HAVE_mpc_pow) -static void -complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power) -{ - mpfr_t x_r, x_i, tmp, re, im; - - gfc_set_model (mpc_realref (base->value.complex)); - mpfr_init (x_r); - mpfr_init (x_i); - mpfr_init (tmp); - mpfr_init (re); - mpfr_init (im); - - /* res = 1 */ -#ifdef HAVE_mpc - mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); -#else - mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif - - /* x = base */ - mpfr_set (x_r, mpc_realref (base->value.complex), GFC_RND_MODE); - mpfr_set (x_i, mpc_imagref (base->value.complex), GFC_RND_MODE); - - /* Macro for complex multiplication. We have to take care that - res_r/res_i and a_r/a_i can (and will) be the same variable. */ -#define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \ - mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \ - mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \ - mpfr_sub (re, re, tmp, GFC_RND_MODE), \ - \ - mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \ - mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \ - mpfr_add (res_i, im, tmp, GFC_RND_MODE), \ - mpfr_set (res_r, re, GFC_RND_MODE) - -#define res_r mpc_realref (result->value.complex) -#define res_i mpc_imagref (result->value.complex) - - /* for (; power > 0; x *= x) */ - for (; mpz_cmp_si (power, 0) > 0; CMULT(x_r,x_i,x_r,x_i,x_r,x_i)) - { - /* if (power & 1) res = res * x; */ - if (mpz_congruent_ui_p (power, 1, 2)) - CMULT(res_r,res_i,res_r,res_i,x_r,x_i); - - /* power /= 2; */ - mpz_fdiv_q_ui (power, power, 2); - } - -#undef res_r -#undef res_i -#undef CMULT - - mpfr_clears (x_r, x_i, tmp, re, im, NULL); -} -#endif /* ! HAVE_mpc_pow */ - - /* Raise a number to a power. */ static arith @@ -1028,12 +849,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); -#else - mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif break; default: @@ -1110,32 +926,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; case BT_COMPLEX: - { -#ifdef HAVE_mpc_pow_z - mpc_pow_z (result->value.complex, op1->value.complex, - op2->value.integer, GFC_MPC_RND_MODE); -#elif defined(HAVE_mpc_pow) - mpc_t apower; - gfc_set_model (mpc_realref (op1->value.complex)); - mpc_init2 (apower, mpfr_get_default_prec()); - mpc_set_z (apower, op2->value.integer, GFC_MPC_RND_MODE); - mpc_pow(result->value.complex, op1->value.complex, apower, - GFC_MPC_RND_MODE); - mpc_clear (apower); -#else - mpz_t apower; - - /* Compute op1**abs(op2) */ - mpz_init (apower); - mpz_abs (apower, op2->value.integer); - complex_pow (result, op1, apower); - mpz_clear (apower); - - /* If (op2 < 0), compute the inverse. */ - if (power_sign < 0) - complex_reciprocal (result); -#endif /* HAVE_mpc_pow */ - } + mpc_pow_z (result->value.complex, op1->value.complex, + op2->value.integer, GFC_MPC_RND_MODE); break; default: @@ -1176,63 +968,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) return ARITH_PROHIBIT; } -#ifdef HAVE_mpc_pow mpc_pow (result->value.complex, op1->value.complex, op2->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t x, y, r, t; - - gfc_set_model (mpc_realref (op1->value.complex)); - - mpfr_init (r); - -#ifdef HAVE_mpc - mpc_abs (r, op1->value.complex, GFC_RND_MODE); -#else - mpfr_hypot (r, op1->value.complex.r, op1->value.complex.i, - GFC_RND_MODE); -#endif - if (mpfr_cmp_si (r, 0) == 0) - { -#ifdef HAVE_mpc - mpc_set_ui (result->value.complex, 0, GFC_MPC_RND_MODE); -#else - mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif - mpfr_clear (r); - break; - } - mpfr_log (r, r, GFC_RND_MODE); - - mpfr_init (t); - -#ifdef HAVE_mpc - mpc_arg (t, op1->value.complex, GFC_RND_MODE); -#else - mpfr_atan2 (t, op1->value.complex.i, op1->value.complex.r, - GFC_RND_MODE); -#endif - - mpfr_init (x); - mpfr_init (y); - - mpfr_mul (x, mpc_realref (op2->value.complex), r, GFC_RND_MODE); - mpfr_mul (y, mpc_imagref (op2->value.complex), t, GFC_RND_MODE); - mpfr_sub (x, x, y, GFC_RND_MODE); - mpfr_exp (x, x, GFC_RND_MODE); - - mpfr_mul (y, mpc_realref (op2->value.complex), t, GFC_RND_MODE); - mpfr_mul (t, mpc_imagref (op2->value.complex), r, GFC_RND_MODE); - mpfr_add (y, y, t, GFC_RND_MODE); - mpfr_cos (t, y, GFC_RND_MODE); - mpfr_sin (y, y, GFC_RND_MODE); - mpfr_mul (mpc_realref (result->value.complex), x, t, GFC_RND_MODE); - mpfr_mul (mpc_imagref (result->value.complex), x, y, GFC_RND_MODE); - mpfr_clears (r, t, x, y, NULL); - } -#endif /* HAVE_mpc_pow */ } break; default: @@ -1350,12 +1087,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) static int compare_complex (gfc_expr *op1, gfc_expr *op2) { -#ifdef HAVE_mpc return mpc_cmp (op1->value.complex, op2->value.complex) == 0; -#else - return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r) - && mpfr_equal_p (op1->value.complex.i, op2->value.complex.i)); -#endif } @@ -2224,13 +1956,8 @@ gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind) gfc_expr *e; e = gfc_constant_result (BT_COMPLEX, kind, &real->where); -#ifdef HAVE_mpc mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, GFC_MPC_RND_MODE); -#else - mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE); - mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE); -#endif return e; } @@ -2350,12 +2077,7 @@ gfc_int2complex (gfc_expr *src, int kind) result = gfc_constant_result (BT_COMPLEX, kind, &src->where); -#ifdef HAVE_mpc mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); -#else - mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind)) != ARITH_OK) @@ -2433,12 +2155,7 @@ gfc_real2complex (gfc_expr *src, int kind) result = gfc_constant_result (BT_COMPLEX, kind, &src->where); -#ifdef HAVE_mpc mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); -#else - mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); @@ -2493,11 +2210,7 @@ gfc_complex2real (gfc_expr *src, int kind) result = gfc_constant_result (BT_REAL, kind, &src->where); -#ifdef HAVE_mpc mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); -#else - mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE); -#endif rc = gfc_check_real_range (result->value.real, kind); @@ -2528,12 +2241,7 @@ gfc_complex2complex (gfc_expr *src, int kind) result = gfc_constant_result (BT_COMPLEX, kind, &src->where); -#ifdef HAVE_mpc mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE); - mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE); -#endif rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); @@ -2698,13 +2406,7 @@ gfc_hollerith2complex (gfc_expr *src, int kind) hollerith2representation (result, src); gfc_interpret_complex (kind, (unsigned char *) result->representation.string, - result->representation.length, -#ifdef HAVE_mpc - result->value.complex -#else - result->value.complex.r, result->value.complex.i -#endif - ); + result->representation.length, result->value.complex); return result; } -- cgit v1.2.1 From 8c2c51e82e7f9bab7ba3eb60b1dc5a7bfbb12673 Mon Sep 17 00:00:00 2001 From: dfranke Date: Fri, 11 Dec 2009 21:08:39 +0000 Subject: 2009-12-11 Daniel Franke PR fortran/40290 * expr.c (gfc_type_convert_binary): Added warn-on-conversion flag, passed on to gfc_convert_type_warn() instead of gfc_convert_type(); enabled warnings on all callers but ... * arith.c (eval_intrinsic): Disabled warnings on implicit type conversion. * gfortran.h gfc_type_convert_binary): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155179 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index d119d1231f9..674b2462a49 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1577,7 +1577,7 @@ eval_intrinsic (gfc_intrinsic_op op, temp.value.op.op1 = op1; temp.value.op.op2 = op2; - gfc_type_convert_binary (&temp); + gfc_type_convert_binary (&temp, 0); if (op == INTRINSIC_EQ || op == INTRINSIC_NE || op == INTRINSIC_GE || op == INTRINSIC_GT -- cgit v1.2.1 From 126387b5b6b5a55db23d87e27562c91cc235c906 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Tue, 13 Apr 2010 01:59:35 +0000 Subject: 2010-04-12 Jerry DeLisle * array.c (extract_element): Restore function from trunk. (gfc_get_array_element): Restore function from trunk. (gfc_expand_constructor): Restore check against flag_max_array_constructor. * constructor.c (node_copy_and_append): Delete unused. * gfortran.h: Delete comment and extra include. * constructor.h: Bump copyright and clean up TODO comments. * resolve.c: Whitespace. 2010-04-12 Daniel Franke * simplify.c (compute_dot_product): Replaced usage of ADVANCE macro with direct access access to elements. Adjusted prototype, fixed all callers. (gfc_simplify_dot_product): Removed duplicate check for zero-sized array. (gfc_simplify_matmul): Removed usage of ADVANCE macro. (gfc_simplify_spread): Removed workaround, directly insert elements at a given array position. (gfc_simplify_transpose): Likewise. (gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding function calls. (gfc_simplify_unpack): Likewise. 2010-04-12 Daniel Franke * simplify.c (only_convert_cmplx_boz): Renamed to ... (convert_boz): ... this and moved to start of file. (gfc_simplify_abs): Whitespace fix. (gfc_simplify_acos): Whitespace fix. (gfc_simplify_acosh): Whitespace fix. (gfc_simplify_aint): Whitespace fix. (gfc_simplify_dint): Whitespace fix. (gfc_simplify_anint): Whitespace fix. (gfc_simplify_and): Replaced if-gate by more common switch-over-type. (gfc_simplify_dnint): Whitespace fix. (gfc_simplify_asin): Whitespace fix. (gfc_simplify_asinh): Moved creation of result-expr out of switch. (gfc_simplify_atan): Likewise. (gfc_simplify_atanh): Whitespace fix. (gfc_simplify_atan2): Whitespace fix. (gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED. (gfc_simplify_bessel_j1): Likewise. (gfc_simplify_bessel_jn): Likewise. (gfc_simplify_bessel_y0): Likewise. (gfc_simplify_bessel_y1): Likewise. (gfc_simplify_bessel_yn): Likewise. (gfc_simplify_ceiling): Reorderd statements. (simplify_cmplx): Use convert_boz(), check for constant arguments. Whitespace fix. (gfc_simplify_cmplx): Use correct default kind. Removed check for constant arguments. (gfc_simplify_complex): Replaced if-gate. Removed check for constant arguments. (gfc_simplify_conjg): Whitespace fix. (gfc_simplify_cos): Whitespace fix. (gfc_simplify_cosh): Replaced if-gate by more common switch-over-type. (gfc_simplify_dcmplx): Removed check for constant arguments. (gfc_simplify_dble): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_digits): Whitespace fix. (gfc_simplify_dim): Whitespace fix. (gfc_simplify_dprod): Reordered statements. (gfc_simplify_erf): Whitespace fix. (gfc_simplify_erfc): Whitespace fix. (gfc_simplify_epsilon): Whitespace fix. (gfc_simplify_exp): Whitespace fix. (gfc_simplify_exponent): Use convert_boz(). (gfc_simplify_floor): Reorderd statements. (gfc_simplify_gamma): Whitespace fix. (gfc_simplify_huge): Whitespace fix. (gfc_simplify_iand): Whitespace fix. (gfc_simplify_ieor): Whitespace fix. (simplify_intconv): Use gfc_convert_constant(). (gfc_simplify_int): Use simplify_intconv(). (gfc_simplify_int2): Reorderd statements. (gfc_simplify_idint): Reorderd statements. (gfc_simplify_ior): Whitespace fix. (gfc_simplify_ishftc): Removed duplicate type check. (gfc_simplify_len): Use range_check() instead of manual range check. (gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix. (gfc_simplify_log): Whitespace fix. (gfc_simplify_log10): Whitespace fix. (gfc_simplify_minval): Whitespace fix. (gfc_simplify_maxval): Whitespace fix. (gfc_simplify_mod): Whitespace fix. (gfc_simplify_modulo): Whitespace fix. (simplify_nint): Reorderd statements. (gfc_simplify_not): Whitespace fix. (gfc_simplify_or): Replaced if-gate by more common switch-over-type. (gfc_simplify_radix): Removed unused result-variable. Whitespace fix. (gfc_simplify_range): Removed unused result-variable. Whitespace fix. (gfc_simplify_real): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_realpart): Whitespace fix. (gfc_simplify_selected_char_kind): Removed unused result-variable. (gfc_simplify_selected_int_kind): Removed unused result-variable. (gfc_simplify_selected_real_kind): Removed unused result-variable. (gfc_simplify_sign): Whitespace fix. (gfc_simplify_sin): Whitespace fix. (gfc_simplify_sinh): Replaced if-gate by more common switch-over-type. (gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix. (gfc_simplify_tan): Replaced if-gate by more common switch-over-type. (gfc_simplify_tanh): Replaced if-gate by more common switch-over-type. (gfc_simplify_xor): Replaced if-gate by more common switch-over-type. 2010-04-12 Daniel Franke * gfortran.h (gfc_start_constructor): Removed. (gfc_get_array_element): Removed. * array.c (gfc_start_constructor): Removed, use gfc_get_array_expr instead. Fixed all callers. (extract_element): Removed. (gfc_expand_constructor): Temporarily removed check for max-array-constructor. Will be re-introduced later if still required. (gfc_get_array_element): Removed, use gfc_constructor_lookup_expr instead. Fixed all callers. * expr.c (find_array_section): Replaced manual lookup of elements by gfc_constructor_lookup. 2010-04-12 Daniel Franke * gfortran.h (gfc_get_null_expr): New prototype. (gfc_get_operator_expr): New prototype. (gfc_get_character_expr): New prototype. (gfc_get_iokind_expr): New prototype. * expr.c (gfc_get_null_expr): New. (gfc_get_character_expr): New. (gfc_get_iokind_expr): New. (gfc_get_operator_expr): Moved here from matchexp.c (build_node). * matchexp.c (build_node): Renamed and moved to expr.c (gfc_get_operator_expr). Reordered arguments to match other functions. Fixed all callers. (gfc_get_parentheses): Use specific function to build expr. * array.c (gfc_match_array_constructor): Likewise. * arith.c (eval_intrinsic): Likewise. (gfc_hollerith2int): Likewise. (gfc_hollerith2real): Likewise. (gfc_hollerith2complex): Likewise. (gfc_hollerith2logical): Likewise. * data.c (create_character_intializer): Likewise. * decl.c (gfc_match_null): Likewise. (enum_initializer): Likewise. * io.c (gfc_match_format): Likewise. (match_io): Likewise. * match.c (gfc_match_nullify): Likewise. * primary.c (match_string_constant): Likewise. (match_logical_constant): Likewise. (build_actual_constructor): Likewise. * resolve.c (build_default_init_expr): Likewise. * symbol.c (generate_isocbinding_symbol): Likewise. (gfc_build_class_symbol): Likewise. (gfc_find_derived_vtab): Likewise. * simplify.c (simplify_achar_char): Likewise. (gfc_simplify_adjustl): Likewise. (gfc_simplify_adjustr): Likewise. (gfc_simplify_and): Likewise. (gfc_simplify_bit_size): Likewise. (gfc_simplify_is_iostat_end): Likewise. (gfc_simplify_is_iostat_eor): Likewise. (gfc_simplify_isnan): Likewise. (simplify_bound): Likewise. (gfc_simplify_leadz): Likewise. (gfc_simplify_len_trim): Likewise. (gfc_simplify_logical): Likewise. (gfc_simplify_maxexponent): Likewise. (gfc_simplify_minexponent): Likewise. (gfc_simplify_new_line): Likewise. (gfc_simplify_null): Likewise. (gfc_simplify_or): Likewise. (gfc_simplify_precision): Likewise. (gfc_simplify_repeat): Likewise. (gfc_simplify_scan): Likewise. (gfc_simplify_size): Likewise. (gfc_simplify_trailz): Likewise. (gfc_simplify_trim): Likewise. (gfc_simplify_verify): Likewise. (gfc_simplify_xor): Likewise. * trans-io.c (build_dt): Likewise. (gfc_new_nml_name_expr): Removed. 2010-04-12 Daniel Franke * arith.h (gfc_constant_result): Removed prototype. * constructor.h (gfc_build_array_expr): Removed prototype. (gfc_build_structure_constructor_expr): Removed prototype. * gfortran.h (gfc_int_expr): Removed prototype. (gfc_logical_expr): Removed prototype. (gfc_get_array_expr): New prototype. (gfc_get_structure_constructor_expr): New prototype. (gfc_get_constant_expr): New prototype. (gfc_get_int_expr): New prototype. (gfc_get_logical_expr): New prototype. * arith.c (gfc_constant_result): Moved and renamed to expr.c (gfc_get_constant_expr). Fixed all callers. * constructor.c (gfc_build_array_expr): Moved and renamed to expr.c (gfc_get_array_expr). Split gfc_typespec argument to type and kind. Fixed all callers. (gfc_build_structure_constructor_expr): Moved and renamed to expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument to type and kind. Fixed all callers. * expr.c (gfc_logical_expr): Renamed to ... (gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers. (gfc_int_expr): Renamed to ... (gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all callers. (gfc_get_constant_expr): New. (gfc_get_array_expr): New. (gfc_get_structure_constructor_expr): New. * simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr instead. 2010-04-12 Daniel Franke * constructor.h: New. * constructor.c: New. * Make-lang.in: Add new files to F95_PARSER_OBJS. * arith.c (reducy_unary): Use constructor API. (reduce_binary_ac): Likewise. (reduce_binary_ca): Likewise. (reduce_binary_aa): Likewise. * check.c (gfc_check_pack): Likewise. (gfc_check_reshape): Likewise. (gfc_check_unpack): Likewise. * decl.c (add_init_expr_to_sym): Likewise. (build_struct): Likewise. * dependency.c (gfc_check_dependency): Likewise. (contains_forall_index_p): Likewise. * dump-parse-tree.c (show_constructor): Likewise. * expr.c (free_expr0): Likewise. (gfc_copy_expr): Likewise. (gfc_is_constant_expr): Likewise. (simplify_constructor): Likewise. (find_array_element): Likewise. (find_component_ref): Likewise. (find_array_section): Likewise. (find_substring_ref): Likewise. (simplify_const_ref): Likewise. (scalarize_intrinsic_call): Likewise. (check_alloc_comp_init): Likewise. (gfc_default_initializer): Likewise. (gfc_traverse_expr): Likewise. * iresolve.c (check_charlen_present): Likewise. (gfc_resolve_reshape): Likewise. (gfc_resolve_transfer): Likewise. * module.c (mio_constructor): Likewise. * primary.c (build_actual_constructor): Likewise. (gfc_match_structure_constructor): Likewise. * resolve.c (resolve_structure_cons): Likewise. * simplify.c (is_constant_array_expr): Likewise. (init_result_expr): Likewise. (transformational_result): Likewise. (simplify_transformation_to_scalar): Likewise. (simplify_transformation_to_array): Likewise. (gfc_simplify_dot_product): Likewise. (simplify_bound): Likewise. (simplify_matmul): Likewise. (simplify_minval_maxval): Likewise. (gfc_simplify_pack): Likewise. (gfc_simplify_reshape): Likewise. (gfc_simplify_shape): Likewise. (gfc_simplify_spread): Likewise. (gfc_simplify_transpose): Likewise. (gfc_simplify_unpack): Likewise.q (gfc_convert_constant): Likewise. (gfc_convert_char_constant): Likewise. * target-memory.c (size_array): Likewise. (encode_array): Likewise. (encode_derived): Likewise. (interpret_array): Likewise. (gfc_interpret_derived): Likewise. (expr_to_char): Likewise. (gfc_merge_initializers): Likewise. * trans-array.c (gfc_get_array_constructor_size): Likewise. (gfc_trans_array_constructor_value): Likewise. (get_array_ctor_strlen): Likewise. (gfc_constant_array_constructor_p): Likewise. (gfc_build_constant_array_constructor): Likewise. (gfc_trans_array_constructor): Likewise. (gfc_conv_array_initializer): Likewise. * trans-decl.c (check_constant_initializer): Likewise. * trans-expr.c (flatten_array_ctors_without_strlen): Likewise. (gfc_apply_interface_mapping_to_cons): Likewise. (gfc_trans_structure_assign): Likewise. (gfc_conv_structure): Likewise. * array.c (check_duplicate_iterator): Likewise. (match_array_list): Likewise. (match_array_cons_element): Likewise. (gfc_match_array_constructor): Likewise. (check_constructor_type): Likewise. (check_constructor): Likewise. (expand): Likewise. (expand_constructor): Likewise. (extract_element): Likewise. (gfc_expanded_ac): Likewise. (resolve_array_list): Likewise. (gfc_resolve_character_array_constructor): Likewise. (copy_iterator): Renamed to ... (gfc_copy_iterator): ... this. (gfc_append_constructor): Removed. (gfc_insert_constructor): Removed unused function. (gfc_get_constructor): Removed. (gfc_free_constructor): Removed. (qgfc_copy_constructor): Removed. * gfortran.h (struct gfc_expr): Removed member 'con_by_offset'. Removed all references. Replaced constructor list by splay-tree. (struct gfc_constructor): Removed member 'next', moved 'offset' from the inner struct, added member 'base'. (gfc_append_constructor): Removed prototype. (gfc_insert_constructor): Removed prototype. (gfc_get_constructor): Removed prototype. (gfc_free_constructor): Removed prototype. (qgfc_copy_constructor): Removed prototype. (gfc_copy_iterator): New prototype. * trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158253 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 297 ++++++++++++++++++---------------------------------- 1 file changed, 104 insertions(+), 193 deletions(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 674b2462a49..7a9741b0cdd 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1,5 +1,6 @@ /* Compiler arithmetic - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -30,6 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "arith.h" #include "target-memory.h" +#include "constructor.h" /* MPFR does not have a direct replacement for mpz_set_f() from GMP. It's easily implemented with a few calls though. */ @@ -399,47 +401,6 @@ gfc_check_real_range (mpfr_t p, int kind) } -/* Function to return a constant expression node of a given type and kind. */ - -gfc_expr * -gfc_constant_result (bt type, int kind, locus *where) -{ - gfc_expr *result; - - if (!where) - gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL"); - - result = gfc_get_expr (); - - result->expr_type = EXPR_CONSTANT; - result->ts.type = type; - result->ts.kind = kind; - result->where = *where; - - switch (type) - { - case BT_INTEGER: - mpz_init (result->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (kind); - mpfr_init (result->value.real); - break; - - case BT_COMPLEX: - gfc_set_model_kind (kind); - mpc_init2 (result->value.complex, mpfr_get_default_prec()); - break; - - default: - break; - } - - return result; -} - - /* Low-level arithmetic functions. All of these subroutines assume that all operands are of the same type and return an operand of the same type. The other thing about these subroutines is that they @@ -451,7 +412,7 @@ gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where); result->value.logical = !op1->value.logical; *resultp = result; @@ -464,8 +425,8 @@ gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical && op2->value.logical; *resultp = result; @@ -478,8 +439,8 @@ gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical || op2->value.logical; *resultp = result; @@ -492,8 +453,8 @@ gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical == op2->value.logical; *resultp = result; @@ -506,8 +467,8 @@ gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical != op2->value.logical; *resultp = result; @@ -621,7 +582,7 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -653,7 +614,7 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -687,7 +648,7 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -721,7 +682,7 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -758,7 +719,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) rc = ARITH_OK; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -826,7 +787,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) extern bool init_flag; rc = ARITH_OK; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op2->ts.type) { @@ -992,8 +953,8 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) int len; gcc_assert (op1->ts.kind == op2->ts.kind); - result = gfc_constant_result (BT_CHARACTER, op1->ts.kind, - &op1->where); + result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, + &op1->where); len = op1->value.character.length + op2->value.character.length; @@ -1162,8 +1123,8 @@ gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (op1->ts.type == BT_COMPLEX) ? compare_complex (op1, op2) : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0); @@ -1178,8 +1139,8 @@ gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (op1->ts.type == BT_COMPLEX) ? !compare_complex (op1, op2) : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0); @@ -1194,8 +1155,8 @@ gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0); *resultp = result; @@ -1208,8 +1169,8 @@ gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0); *resultp = result; @@ -1222,8 +1183,8 @@ gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0); *resultp = result; @@ -1236,8 +1197,8 @@ gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0); *resultp = result; @@ -1249,7 +1210,8 @@ static arith reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; arith rc; @@ -1257,9 +1219,8 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, return eval (op, result); rc = ARITH_OK; - head = gfc_copy_constructor (op->value.constructor); - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { rc = reduce_unary (eval, c->expr, &r); @@ -1270,18 +1231,15 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op->where); r->shape = gfc_copy_shape (op->shape, op->rank); - - r->ts = head->expr->ts; - r->where = op->where; r->rank = op->rank; - + r->value.constructor = head; *result = r; } @@ -1293,14 +1251,13 @@ static arith reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op1->value.constructor); - rc = ARITH_OK; - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (c->expr, op2, &r); @@ -1314,18 +1271,15 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); - - r->ts = head->expr->ts; - r->where = op1->where; r->rank = op1->rank; - + r->value.constructor = head; *result = r; } @@ -1337,14 +1291,13 @@ static arith reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op2->value.constructor); - rc = ARITH_OK; - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op2->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (op1, c->expr, &r); @@ -1358,18 +1311,15 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op2->where); r->shape = gfc_copy_shape (op2->shape, op2->rank); - - r->ts = head->expr->ts; - r->where = op2->where; r->rank = op2->rank; - + r->value.constructor = head; *result = r; } @@ -1386,52 +1336,41 @@ static arith reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *d, *head; + gfc_constructor_base head; + gfc_constructor *c, *d; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op1->value.constructor); + if (gfc_check_conformance (op1, op2, + "elemental binary operation") != SUCCESS) + return ARITH_INCOMMENSURATE; - rc = ARITH_OK; - d = op2->value.constructor; - - if (gfc_check_conformance (op1, op2, "elemental binary operation") - != SUCCESS) - rc = ARITH_INCOMMENSURATE; - else + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head), + d = gfc_constructor_first (op2->value.constructor); + c && d; + c = gfc_constructor_next (c), d = gfc_constructor_next (d)) { - for (c = head; c; c = c->next, d = d->next) - { - if (d == NULL) - { - rc = ARITH_INCOMMENSURATE; - break; - } - - rc = reduce_binary (eval, c->expr, d->expr, &r); - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } + rc = reduce_binary (eval, c->expr, d->expr, &r); + if (rc != ARITH_OK) + break; - if (d != NULL) - rc = ARITH_INCOMMENSURATE; + gfc_replace_expr (c->expr, r); } + if (c || d) + rc = ARITH_INCOMMENSURATE; + if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); - - r->ts = head->expr->ts; - r->where = op1->where; r->rank = op1->rank; - + r->value.constructor = head; *result = r; } @@ -1644,17 +1583,9 @@ eval_intrinsic (gfc_intrinsic_op op, runtime: /* Create a run-time expression. */ - result = gfc_get_expr (); + result = gfc_get_operator_expr (&op1->where, op, op1, op2); result->ts = temp.ts; - result->expr_type = EXPR_OP; - result->value.op.op = op; - - result->value.op.op1 = op1; - result->value.op.op2 = op2; - - result->where = op1->where; - return result; } @@ -1921,7 +1852,7 @@ gfc_convert_integer (const char *buffer, int kind, int radix, locus *where) gfc_expr *e; const char *t; - e = gfc_constant_result (BT_INTEGER, kind, where); + e = gfc_get_constant_expr (BT_INTEGER, kind, where); /* A leading plus is allowed, but not by mpz_set_str. */ if (buffer[0] == '+') t = buffer + 1; @@ -1940,7 +1871,7 @@ gfc_convert_real (const char *buffer, int kind, locus *where) { gfc_expr *e; - e = gfc_constant_result (BT_REAL, kind, where); + e = gfc_get_constant_expr (BT_REAL, kind, where); mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); return e; @@ -1955,7 +1886,7 @@ gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind) { gfc_expr *e; - e = gfc_constant_result (BT_COMPLEX, kind, &real->where); + e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where); mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, GFC_MPC_RND_MODE); @@ -2022,7 +1953,7 @@ gfc_int2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set (result->value.integer, src->value.integer); @@ -2052,7 +1983,7 @@ gfc_int2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); @@ -2075,7 +2006,7 @@ gfc_int2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); @@ -2099,7 +2030,7 @@ gfc_real2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); @@ -2122,7 +2053,7 @@ gfc_real2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); @@ -2153,7 +2084,7 @@ gfc_real2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); @@ -2184,7 +2115,7 @@ gfc_complex2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), &src->where); @@ -2208,7 +2139,7 @@ gfc_complex2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); @@ -2239,7 +2170,7 @@ gfc_complex2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); @@ -2284,7 +2215,7 @@ gfc_log2log (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = src->value.logical; return result; @@ -2298,7 +2229,7 @@ gfc_log2int (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set_si (result->value.integer, src->value.logical); return result; @@ -2312,7 +2243,7 @@ gfc_int2log (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); return result; @@ -2355,12 +2286,7 @@ gfc_expr * gfc_hollerith2int (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_INTEGER; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); hollerith2representation (result, src); gfc_interpret_integer (kind, (unsigned char *) result->representation.string, @@ -2376,12 +2302,7 @@ gfc_expr * gfc_hollerith2real (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_REAL; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); hollerith2representation (result, src); gfc_interpret_float (kind, (unsigned char *) result->representation.string, @@ -2397,12 +2318,7 @@ gfc_expr * gfc_hollerith2complex (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_COMPLEX; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); hollerith2representation (result, src); gfc_interpret_complex (kind, (unsigned char *) result->representation.string, @@ -2437,12 +2353,7 @@ gfc_expr * gfc_hollerith2logical (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_LOGICAL; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); hollerith2representation (result, src); gfc_interpret_logical (kind, (unsigned char *) result->representation.string, -- cgit v1.2.1 From 148aaa7fa6884e257d205df009ea315b6b521c9c Mon Sep 17 00:00:00 2001 From: dfranke Date: Thu, 13 May 2010 14:08:05 +0000 Subject: gcc/fortran/: 2010-05-13 Daniel Franke PR fortran/35779 * intrinsic.c (gfc_init_expr): Renamed to gfc_init_expr_flag. Updated all usages. * expr.c (init_flag): Removed; use gfc_init_expr_flag everywhere. * array.c (match_array_list): Pass on gfc_init_expr_flag when matching iterators. gcc/testsuite/: 2010-05-13 Daniel Franke PR fortran/35779 * gfortran.dg/initialization_25.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159366 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 7a9741b0cdd..1e90584be49 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -784,7 +784,6 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) int power_sign; gfc_expr *result; arith rc; - extern bool init_flag; rc = ARITH_OK; result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); @@ -899,7 +898,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_REAL: - if (init_flag) + if (gfc_init_expr_flag) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " "exponent in an initialization " @@ -921,7 +920,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_COMPLEX: { - if (init_flag) + if (gfc_init_expr_flag) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " "exponent in an initialization " -- cgit v1.2.1 From 77009a9ec3b3378fa660c982b3a3d0c5723b1517 Mon Sep 17 00:00:00 2001 From: mikael Date: Sun, 11 Jul 2010 12:14:25 +0000 Subject: 2010-07-11 Mikael Morin * arith.c (gfc_arith_done_1): Release mpfr internal caches. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162058 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/arith.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gcc/fortran/arith.c') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 1e90584be49..f555eb104cd 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -260,6 +260,8 @@ gfc_arith_done_1 (void) for (rp = gfc_real_kinds; rp->kind; rp++) mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); + + mpfr_free_cache (); } -- cgit v1.2.1