Commit f8e566e5 by Steven G. Kargl Committed by Paul Brook

arith.c: Add #define for model numbers.

2004-08-06  Steven G. Kargl  <kargls@comcast.net>

	* arith.c: Add #define for model numbers.  Remove global GMP variables.
	(natural_logarithm,common_logarithm,exponential,sine,
	cosine,arctangent,hypercos,hypersine ): Remove.
	(gfc_mpfr_to_mpz,gfc_set_model_kind,gfc_set_model): New functions.
	(arctangent2,gfc_arith_init_1,gfc_arith_done_1
	gfc_check_real_range, gfc_constant_result, gfc_range_check,
	gfc_arith_uminus,gfc_arith_plus, gfc_arith_minus, gfc_arith_times,
	gfc_arith_divide,complex_reciprocal,complex_pow_ui,
	gfc_arith_power,gfc_compare_expr,compare_complex,gfc_convert_real,
	gfc_convert_complex,gfc_int2real,gfc_int2complex,
	gfc_real2int,gfc_real2real,gfc_real2complex,
	gfc_complex2int,gfc_complex2real,gfc_complex2complex): Convert GMP
	to MPFR, use new functions.
	* arith.h: Remove extern global variables.
	(natural_logarithm,common_logarithm,exponential, sine, cosine,
	arctangent,hypercos,hypersine): Remove prototypes.
	(arctangent2): Update prototype from GMP to MPFR.
	(gfc_mpfr_to_mpz, gfc_set_model_kind,gfc_set_model): Add prototypes.
	* dump-parse-tree.c (gfc_show_expr): Convert GMP to MPFR.
	* expr.c (free_expr0,gfc_copy_expr): Convert GMP to MPFR.
	* gfortran.h (GFC_REAL_BITS): Remove.
	(arith): Add ARITH_NAN.
	Include mpfr.h.  Define GFC_RND_MODE.
	Rename GCC_GFORTRAN_H GFC_GFC_H.
	(gfc_expr): Convert GMP to MPFR.
	* module.c: Add arith.h, correct type in comment.
	(mio_gmp_real): Convert GMP to MPFR.
	(mio_expr):  Use gfc_set_model_kind().
	* primary.c:  Update copyright date with 2004.
	(match_real_constant,match_const_complex_part): Convert GMP to MPFR.
	* simplify.c: Remove global GMP variables
	(gfc_simplify_abs,gfc_simplify_acos,gfc_simplify_aimag,
	gfc_simplify_aint,gfc_simplify_dint,gfc_simplify_anint,
	gfc_simplify_dnint,gfc_simplify_asin,gfc_simplify_atan,
	gfc_simplify_atan2,gfc_simplify_ceiling,simplify_cmplx,
	gfc_simplify_conjg,gfc_simplify_cos,gfc_simplify_cosh,
	gfc_simplify_dim,gfc_simplify_dprod,gfc_simplify_epsilon,
	gfc_simplify_exp,gfc_simplify_exponent,gfc_simplify_floor,
	gfc_simplify_fraction,gfc_simplify_huge,gfc_simplify_int,
	gfc_simplify_ifix,gfc_simplify_idint,gfc_simplify_log,
	gfc_simplify_log10,simplify_min_max,gfc_simplify_mod,
	gfc_simplify_modulo,gfc_simplify_nearest,simplify_nint,
	gfc_simplify_rrspacing,gfc_simplify_scale,
	gfc_simplify_set_exponent,gfc_simplify_sign,gfc_simplify_sin,
	gfc_simplify_sinh,gfc_simplify_spacing,gfc_simplify_sqrt,
	gfc_simplify_tan,gfc_simplify_tanh,gfc_simplify_tiny,
	gfc_simplify_init_1,gfc_simplify_done_1):  Convert GMP to MPFR.
	Use new functions.
	* trans-const.c (gfc_conv_mpfr_to_tree): Rename from
	gfc_conv_mpf_to_tree.  Convert it to use MPFR
	(gfc_conv_constant_to_tree): Use it.
	* trans-const.h: Update prototype for gfc_conv_mpfr_to_tree().
	* trans-intrinsic.c: Add arith.h, remove gmp.h
	(gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod): Convert GMP to MPFR.

From-SVN: r85652
parent 1b4ed0bc
2004-08-06 Steven G. Kargl <kargls@comcast.net>
* arith.c: Add #define for model numbers. Remove global GMP variables.
(natural_logarithm,common_logarithm,exponential,sine,
cosine,arctangent,hypercos,hypersine ): Remove.
(gfc_mpfr_to_mpz,gfc_set_model_kind,gfc_set_model): New functions.
(arctangent2,gfc_arith_init_1,gfc_arith_done_1
gfc_check_real_range, gfc_constant_result, gfc_range_check,
gfc_arith_uminus,gfc_arith_plus, gfc_arith_minus, gfc_arith_times,
gfc_arith_divide,complex_reciprocal,complex_pow_ui,
gfc_arith_power,gfc_compare_expr,compare_complex,gfc_convert_real,
gfc_convert_complex,gfc_int2real,gfc_int2complex,
gfc_real2int,gfc_real2real,gfc_real2complex,
gfc_complex2int,gfc_complex2real,gfc_complex2complex): Convert GMP
to MPFR, use new functions.
* arith.h: Remove extern global variables.
(natural_logarithm,common_logarithm,exponential, sine, cosine,
arctangent,hypercos,hypersine): Remove prototypes.
(arctangent2): Update prototype from GMP to MPFR.
(gfc_mpfr_to_mpz, gfc_set_model_kind,gfc_set_model): Add prototypes.
* dump-parse-tree.c (gfc_show_expr): Convert GMP to MPFR.
* expr.c (free_expr0,gfc_copy_expr): Convert GMP to MPFR.
* gfortran.h (GFC_REAL_BITS): Remove.
(arith): Add ARITH_NAN.
Include mpfr.h. Define GFC_RND_MODE.
Rename GCC_GFORTRAN_H GFC_GFC_H.
(gfc_expr): Convert GMP to MPFR.
* module.c: Add arith.h, correct type in comment.
(mio_gmp_real): Convert GMP to MPFR.
(mio_expr): Use gfc_set_model_kind().
* primary.c: Update copyright date with 2004.
(match_real_constant,match_const_complex_part): Convert GMP to MPFR.
* simplify.c: Remove global GMP variables
(gfc_simplify_abs,gfc_simplify_acos,gfc_simplify_aimag,
gfc_simplify_aint,gfc_simplify_dint,gfc_simplify_anint,
gfc_simplify_dnint,gfc_simplify_asin,gfc_simplify_atan,
gfc_simplify_atan2,gfc_simplify_ceiling,simplify_cmplx,
gfc_simplify_conjg,gfc_simplify_cos,gfc_simplify_cosh,
gfc_simplify_dim,gfc_simplify_dprod,gfc_simplify_epsilon,
gfc_simplify_exp,gfc_simplify_exponent,gfc_simplify_floor,
gfc_simplify_fraction,gfc_simplify_huge,gfc_simplify_int,
gfc_simplify_ifix,gfc_simplify_idint,gfc_simplify_log,
gfc_simplify_log10,simplify_min_max,gfc_simplify_mod,
gfc_simplify_modulo,gfc_simplify_nearest,simplify_nint,
gfc_simplify_rrspacing,gfc_simplify_scale,
gfc_simplify_set_exponent,gfc_simplify_sign,gfc_simplify_sin,
gfc_simplify_sinh,gfc_simplify_spacing,gfc_simplify_sqrt,
gfc_simplify_tan,gfc_simplify_tanh,gfc_simplify_tiny,
gfc_simplify_init_1,gfc_simplify_done_1): Convert GMP to MPFR.
Use new functions.
* trans-const.c (gfc_conv_mpfr_to_tree): Rename from
gfc_conv_mpf_to_tree. Convert it to use MPFR
(gfc_conv_constant_to_tree): Use it.
* trans-const.h: Update prototype for gfc_conv_mpfr_to_tree().
* trans-intrinsic.c: Add arith.h, remove gmp.h
(gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod): Convert GMP to MPFR.
2004-08-06 Victor Leikehman <lei@il.ibm.com> 2004-08-06 Victor Leikehman <lei@il.ibm.com>
Paul Brook <paul@codesourcery.com> Paul Brook <paul@codesourcery.com>
......
...@@ -24,19 +24,14 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA ...@@ -24,19 +24,14 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "gfortran.h" #include "gfortran.h"
/* Constants calculated during initialization. */ /* MPFR does not have mpfr_atan2(), which needs to return the principle
extern mpf_t pi, half_pi, two_pi, e; value of atan2(). MPFR also does not have the conversion of a mpfr_t
to a mpz_t, so declare a function for this as well. */
/* Calculate mathematically interesting functions. */
void natural_logarithm (mpf_t *, mpf_t *); void arctangent2 (mpfr_t, mpfr_t, mpfr_t);
void common_logarithm (mpf_t *, mpf_t *); void gfc_mpfr_to_mpz(mpz_t, mpfr_t);
void exponential (mpf_t *, mpf_t *); void gfc_set_model_kind (int);
void sine (mpf_t *, mpf_t *); void gfc_set_model (mpfr_t);
void cosine (mpf_t *, mpf_t *);
void arctangent (mpf_t *, mpf_t *);
void arctangent2 (mpf_t *, mpf_t *, mpf_t *);
void hypercos (mpf_t *, mpf_t *);
void hypersine (mpf_t *, mpf_t *);
/* Return a constant result of a given type and kind, with locus. */ /* Return a constant result of a given type and kind, with locus. */
gfc_expr *gfc_constant_result (bt, int, locus *); gfc_expr *gfc_constant_result (bt, int, locus *);
......
...@@ -363,7 +363,7 @@ gfc_show_expr (gfc_expr * p) ...@@ -363,7 +363,7 @@ gfc_show_expr (gfc_expr * p)
break; break;
case BT_REAL: case BT_REAL:
mpf_out_str (stdout, 10, 0, p->value.real); mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
if (p->ts.kind != gfc_default_real_kind ()) if (p->ts.kind != gfc_default_real_kind ())
gfc_status ("_%d", p->ts.kind); gfc_status ("_%d", p->ts.kind);
break; break;
...@@ -388,13 +388,13 @@ gfc_show_expr (gfc_expr * p) ...@@ -388,13 +388,13 @@ gfc_show_expr (gfc_expr * p)
case BT_COMPLEX: case BT_COMPLEX:
gfc_status ("(complex "); gfc_status ("(complex ");
mpf_out_str (stdout, 10, 0, p->value.complex.r); mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind ()) if (p->ts.kind != gfc_default_complex_kind ())
gfc_status ("_%d", p->ts.kind); gfc_status ("_%d", p->ts.kind);
gfc_status (" "); gfc_status (" ");
mpf_out_str (stdout, 10, 0, p->value.complex.i); mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind ()) if (p->ts.kind != gfc_default_complex_kind ())
gfc_status ("_%d", p->ts.kind); gfc_status ("_%d", p->ts.kind);
......
...@@ -154,7 +154,7 @@ free_expr0 (gfc_expr * e) ...@@ -154,7 +154,7 @@ free_expr0 (gfc_expr * e)
break; break;
case BT_REAL: case BT_REAL:
mpf_clear (e->value.real); mpfr_clear (e->value.real);
break; break;
case BT_CHARACTER: case BT_CHARACTER:
...@@ -162,8 +162,8 @@ free_expr0 (gfc_expr * e) ...@@ -162,8 +162,8 @@ free_expr0 (gfc_expr * e)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
mpf_clear (e->value.complex.r); mpfr_clear (e->value.complex.r);
mpf_clear (e->value.complex.i); mpfr_clear (e->value.complex.i);
break; break;
default: default:
...@@ -365,12 +365,17 @@ gfc_copy_expr (gfc_expr * p) ...@@ -365,12 +365,17 @@ gfc_copy_expr (gfc_expr * p)
break; break;
case BT_REAL: case BT_REAL:
mpf_init_set (q->value.real, p->value.real); gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.real);
mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
mpf_init_set (q->value.complex.r, p->value.complex.r); gfc_set_model_kind (q->ts.kind);
mpf_init_set (q->value.complex.i, p->value.complex.i); mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
break; break;
case BT_CHARACTER: case BT_CHARACTER:
......
...@@ -59,7 +59,6 @@ char *alloca (); ...@@ -59,7 +59,6 @@ char *alloca ();
/* Major control parameters. */ /* Major control parameters. */
#define GFC_MAX_SYMBOL_LEN 63 #define GFC_MAX_SYMBOL_LEN 63
#define GFC_REAL_BITS 100 /* Number of bits in g95's floating point numbers. */
#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */ #define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */
#define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */ #define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */ #define GFC_LETTERS 26 /* Number of letters in the alphabet. */
...@@ -184,7 +183,7 @@ extern mstring intrinsic_operators[]; ...@@ -184,7 +183,7 @@ extern mstring intrinsic_operators[];
/* Arithmetic results. */ /* Arithmetic results. */
typedef enum typedef enum
{ ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, { ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN,
ARITH_DIV0, ARITH_0TO0, ARITH_INCOMMENSURATE ARITH_DIV0, ARITH_0TO0, ARITH_INCOMMENSURATE
} }
arith; arith;
...@@ -930,6 +929,8 @@ gfc_intrinsic_sym; ...@@ -930,6 +929,8 @@ gfc_intrinsic_sym;
EXPR_ARRAY An array constructor. */ EXPR_ARRAY An array constructor. */
#include <gmp.h> #include <gmp.h>
#include <mpfr.h>
#define GFC_RND_MODE GMP_RNDN
typedef struct gfc_expr typedef struct gfc_expr
{ {
...@@ -953,13 +954,14 @@ typedef struct gfc_expr ...@@ -953,13 +954,14 @@ typedef struct gfc_expr
union union
{ {
mpz_t integer;
mpf_t real;
int logical; int logical;
mpz_t integer;
mpfr_t real;
struct struct
{ {
mpf_t r, i; mpfr_t r, i;
} }
complex; complex;
...@@ -1023,7 +1025,7 @@ typedef struct ...@@ -1023,7 +1025,7 @@ typedef struct
int kind, radix, digits, min_exponent, max_exponent; int kind, radix, digits, min_exponent, max_exponent;
int range, precision; int range, precision;
mpf_t epsilon, huge, tiny; mpfr_t epsilon, huge, tiny;
} }
gfc_real_info; gfc_real_info;
...@@ -1555,7 +1557,6 @@ match gfc_intrinsic_sub_interface (gfc_code *, int); ...@@ -1555,7 +1557,6 @@ match gfc_intrinsic_sub_interface (gfc_code *, int);
/* simplify.c */ /* simplify.c */
void gfc_simplify_init_1 (void); void gfc_simplify_init_1 (void);
void gfc_simplify_done_1 (void);
/* match.c -- FIXME */ /* match.c -- FIXME */
void gfc_free_iterator (gfc_iterator *, int); void gfc_free_iterator (gfc_iterator *, int);
......
...@@ -1492,6 +1492,11 @@ add_functions (void) ...@@ -1492,6 +1492,11 @@ add_functions (void)
gfc_check_rand, NULL, NULL, gfc_check_rand, NULL, NULL,
i, BT_INTEGER, 4, 0); i, BT_INTEGER, 4, 0);
/* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and
ran() use slightly different shoddy multiplicative congruential
PRNG. */
make_alias ("ran");
make_generic ("rand", GFC_ISYM_RAND); make_generic ("rand", GFC_ISYM_RAND);
add_sym_1 ("range", 0, 1, BT_INTEGER, di, add_sym_1 ("range", 0, 1, BT_INTEGER, di,
......
...@@ -309,7 +309,6 @@ gfc_done_1 (void) ...@@ -309,7 +309,6 @@ gfc_done_1 (void)
gfc_scanner_done_1 (); gfc_scanner_done_1 ();
gfc_intrinsic_done_1 (); gfc_intrinsic_done_1 ();
gfc_simplify_done_1 ();
gfc_iresolve_done_1 (); gfc_iresolve_done_1 ();
gfc_arith_done_1 (); gfc_arith_done_1 ();
} }
......
...@@ -71,6 +71,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA ...@@ -71,6 +71,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include <time.h> #include <time.h>
#include "gfortran.h" #include "gfortran.h"
#include "arith.h"
#include "match.h" #include "match.h"
#include "parse.h" /* FIXME */ #include "parse.h" /* FIXME */
...@@ -519,7 +520,7 @@ gfc_match_use (void) ...@@ -519,7 +520,7 @@ gfc_match_use (void)
tail->next = new; tail->next = new;
tail = new; tail = new;
/* See what kind of interface we're dealing with. Asusume it is /* See what kind of interface we're dealing with. Assume it is
not an operator. */ not an operator. */
new->operator = INTRINSIC_NONE; new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
...@@ -2245,7 +2246,7 @@ mio_gmp_integer (mpz_t * integer) ...@@ -2245,7 +2246,7 @@ mio_gmp_integer (mpz_t * integer)
static void static void
mio_gmp_real (mpf_t * real) mio_gmp_real (mpfr_t * real)
{ {
mp_exp_t exponent; mp_exp_t exponent;
char *p; char *p;
...@@ -2255,14 +2256,14 @@ mio_gmp_real (mpf_t * real) ...@@ -2255,14 +2256,14 @@ mio_gmp_real (mpf_t * real)
if (parse_atom () != ATOM_STRING) if (parse_atom () != ATOM_STRING)
bad_module ("Expected real string"); bad_module ("Expected real string");
mpf_init (*real); mpfr_init (*real);
mpf_set_str (*real, atom_string, -16); mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string); gfc_free (atom_string);
} }
else else
{ {
p = mpf_get_str (NULL, &exponent, 16, 0, *real); p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
atom_string = gfc_getmem (strlen (p) + 20); atom_string = gfc_getmem (strlen (p) + 20);
sprintf (atom_string, "0.%s@%ld", p, exponent); sprintf (atom_string, "0.%s@%ld", p, exponent);
...@@ -2507,10 +2508,12 @@ mio_expr (gfc_expr ** ep) ...@@ -2507,10 +2508,12 @@ mio_expr (gfc_expr ** ep)
break; break;
case BT_REAL: case BT_REAL:
gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real); mio_gmp_real (&e->value.real);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.complex.r); mio_gmp_real (&e->value.complex.r);
mio_gmp_real (&e->value.complex.i); mio_gmp_real (&e->value.complex.i);
break; break;
......
/* Primary expression subroutines /* Primary expression subroutines
Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. Copyright (C) 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
This file is part of GNU G95. This file is part of GNU G95.
...@@ -436,7 +436,7 @@ done: ...@@ -436,7 +436,7 @@ done:
buffer = alloca (count + 1); buffer = alloca (count + 1);
memset (buffer, '\0', count + 1); memset (buffer, '\0', count + 1);
/* Hack for mpf_init_set_str(). */ /* Hack for mpfr_set_str(). */
p = buffer; p = buffer;
while (count > 0) while (count > 0)
{ {
...@@ -497,7 +497,7 @@ done: ...@@ -497,7 +497,7 @@ done:
case ARITH_UNDERFLOW: case ARITH_UNDERFLOW:
if (gfc_option.warn_underflow) if (gfc_option.warn_underflow)
gfc_warning ("Real constant underflows its kind at %C"); gfc_warning ("Real constant underflows its kind at %C");
mpf_set_ui(e->value.real, 0); mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break; break;
default: default:
...@@ -1076,12 +1076,12 @@ done: ...@@ -1076,12 +1076,12 @@ done:
buffer = alloca (count + 1); buffer = alloca (count + 1);
memset (buffer, '\0', count + 1); memset (buffer, '\0', count + 1);
/* Hack for mpf_init_set_str(). */ /* Hack for mpfr_set_str(). */
p = buffer; p = buffer;
while (count > 0) while (count > 0)
{ {
c = gfc_next_char (); c = gfc_next_char ();
if (c == 'd') if (c == 'd' || c == 'q')
c = 'e'; c = 'e';
*p++ = c; *p++ = c;
count--; count--;
......
...@@ -234,7 +234,7 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind) ...@@ -234,7 +234,7 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind)
/* Converts a real constant into backend form. Uses an intermediate string /* Converts a real constant into backend form. Uses an intermediate string
representation. */ representation. */
tree tree
gfc_conv_mpf_to_tree (mpf_t f, int kind) gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
{ {
tree res; tree res;
tree type; tree type;
...@@ -251,13 +251,9 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind) ...@@ -251,13 +251,9 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind)
} }
assert (gfc_real_kinds[n].kind); assert (gfc_real_kinds[n].kind);
assert (gfc_real_kinds[n].radix == 2);
n = MAX (abs (gfc_real_kinds[n].min_exponent), n = MAX (abs (gfc_real_kinds[n].min_exponent),
abs (gfc_real_kinds[n].max_exponent)); abs (gfc_real_kinds[n].max_exponent));
#if 0
edigits = 2 + (int) (log (n) / log (gfc_real_kinds[n].radix));
#endif
edigits = 1; edigits = 1;
while (n > 0) while (n > 0)
{ {
...@@ -265,8 +261,11 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind) ...@@ -265,8 +261,11 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind)
edigits += 3; edigits += 3;
} }
if (kind == gfc_default_double_kind())
p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
else
p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
p = mpf_get_str (NULL, &exp, 10, 0, f);
/* We also have one minus sign, "e", "." and a null terminator. */ /* We also have one minus sign, "e", "." and a null terminator. */
q = (char *) gfc_getmem (strlen (p) + edigits + 4); q = (char *) gfc_getmem (strlen (p) + edigits + 4);
...@@ -294,6 +293,7 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind) ...@@ -294,6 +293,7 @@ gfc_conv_mpf_to_tree (mpf_t f, int kind)
type = gfc_get_real_type (kind); type = gfc_get_real_type (kind);
res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type))); res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
gfc_free (q); gfc_free (q);
gfc_free (p); gfc_free (p);
...@@ -321,16 +321,16 @@ gfc_conv_constant_to_tree (gfc_expr * expr) ...@@ -321,16 +321,16 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL: case BT_REAL:
return gfc_conv_mpf_to_tree (expr->value.real, expr->ts.kind); return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
case BT_LOGICAL: case BT_LOGICAL:
return build_int_2 (expr->value.logical, 0); return build_int_2 (expr->value.logical, 0);
case BT_COMPLEX: case BT_COMPLEX:
{ {
tree real = gfc_conv_mpf_to_tree (expr->value.complex.r, tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
expr->ts.kind); expr->ts.kind);
tree imag = gfc_conv_mpf_to_tree (expr->value.complex.i, tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
expr->ts.kind); expr->ts.kind);
return build_complex (NULL_TREE, real, imag); return build_complex (NULL_TREE, real, imag);
......
...@@ -23,7 +23,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA ...@@ -23,7 +23,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
tree gfc_conv_mpz_to_tree (mpz_t, int); tree gfc_conv_mpz_to_tree (mpz_t, int);
/* Returns a REAL_CST. */ /* Returns a REAL_CST. */
tree gfc_conv_mpf_to_tree (mpf_t, int); tree gfc_conv_mpfr_to_tree (mpfr_t, int);
/* Build a tree for a constant. Must be an EXPR_CONSTANT gfc_expr. /* Build a tree for a constant. Must be an EXPR_CONSTANT gfc_expr.
For CHARACTER literal constants, the caller still has to set the For CHARACTER literal constants, the caller still has to set the
......
...@@ -33,9 +33,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA ...@@ -33,9 +33,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "real.h" #include "real.h"
#include "tree-gimple.h" #include "tree-gimple.h"
#include "flags.h" #include "flags.h"
#include <gmp.h>
#include <assert.h> #include <assert.h>
#include "gfortran.h" #include "gfortran.h"
#include "arith.h"
#include "intrinsic.h" #include "intrinsic.h"
#include "trans.h" #include "trans.h"
#include "trans-const.h" #include "trans-const.h"
...@@ -308,7 +308,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) ...@@ -308,7 +308,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
tree arg; tree arg;
tree tmp; tree tmp;
tree cond; tree cond;
mpf_t huge; mpfr_t huge;
int n; int n;
int kind; int kind;
...@@ -363,14 +363,15 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) ...@@ -363,14 +363,15 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
arg = gfc_evaluate_now (arg, &se->pre); arg = gfc_evaluate_now (arg, &se->pre);
/* Test if the value is too large to handle sensibly. */ /* Test if the value is too large to handle sensibly. */
mpf_init (huge); gfc_set_model_kind (kind);
mpfr_init (huge);
n = gfc_validate_kind (BT_INTEGER, kind); n = gfc_validate_kind (BT_INTEGER, kind);
mpf_set_z (huge, gfc_integer_kinds[n].huge); mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
tmp = gfc_conv_mpf_to_tree (huge, kind); tmp = gfc_conv_mpfr_to_tree (huge, kind);
cond = build (LT_EXPR, boolean_type_node, arg, tmp); cond = build (LT_EXPR, boolean_type_node, arg, tmp);
mpf_neg (huge, huge); mpfr_neg (huge, huge, GFC_RND_MODE);
tmp = gfc_conv_mpf_to_tree (huge, kind); tmp = gfc_conv_mpfr_to_tree (huge, kind);
tmp = build (GT_EXPR, boolean_type_node, arg, tmp); tmp = build (GT_EXPR, boolean_type_node, arg, tmp);
cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
itype = gfc_get_int_type (kind); itype = gfc_get_int_type (kind);
...@@ -378,6 +379,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) ...@@ -378,6 +379,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
tmp = build_fix_expr (&se->pre, arg, itype, op); tmp = build_fix_expr (&se->pre, arg, itype, op);
tmp = convert (type, tmp); tmp = convert (type, tmp);
se->expr = build (COND_EXPR, type, cond, tmp, arg); se->expr = build (COND_EXPR, type, cond, tmp, arg);
mpfr_clear (huge);
} }
...@@ -777,7 +779,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) ...@@ -777,7 +779,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
tree zero; tree zero;
tree test; tree test;
tree test2; tree test2;
mpf_t huge; mpfr_t huge;
int n; int n;
arg = gfc_conv_intrinsic_function_args (se, expr); arg = gfc_conv_intrinsic_function_args (se, expr);
...@@ -799,14 +801,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) ...@@ -799,14 +801,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
tmp = build (RDIV_EXPR, type, arg, arg2); tmp = build (RDIV_EXPR, type, arg, arg2);
/* Test if the value is too large to handle sensibly. */ /* Test if the value is too large to handle sensibly. */
mpf_init (huge); gfc_set_model_kind (expr->ts.kind);
mpfr_init (huge);
n = gfc_validate_kind (BT_INTEGER, expr->ts.kind); n = gfc_validate_kind (BT_INTEGER, expr->ts.kind);
mpf_set_z (huge, gfc_integer_kinds[n].huge); mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
test2 = build (LT_EXPR, boolean_type_node, tmp, test); test2 = build (LT_EXPR, boolean_type_node, tmp, test);
mpf_neg (huge, huge); mpfr_neg (huge, huge, GFC_RND_MODE);
test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
test = build (GT_EXPR, boolean_type_node, tmp, test); test = build (GT_EXPR, boolean_type_node, tmp, test);
test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2); test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2);
...@@ -816,6 +819,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) ...@@ -816,6 +819,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
tmp = build (COND_EXPR, type, test2, tmp, arg); tmp = build (COND_EXPR, type, test2, tmp, arg);
tmp = build (MULT_EXPR, type, tmp, arg2); tmp = build (MULT_EXPR, type, tmp, arg2);
se->expr = build (MINUS_EXPR, type, arg, tmp); se->expr = build (MINUS_EXPR, type, arg, tmp);
mpfr_clear (huge);
break; break;
default: default:
...@@ -1423,7 +1427,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) ...@@ -1423,7 +1427,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
switch (arrayexpr->ts.type) switch (arrayexpr->ts.type)
{ {
case BT_REAL: case BT_REAL:
tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
break; break;
case BT_INTEGER: case BT_INTEGER:
...@@ -1564,7 +1568,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) ...@@ -1564,7 +1568,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
switch (expr->ts.type) switch (expr->ts.type)
{ {
case BT_REAL: case BT_REAL:
tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
break; break;
case BT_INTEGER: case BT_INTEGER:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment