From f68aa5f6a6d710f12005ca2ee34f27d6a8a68745 Mon Sep 17 00:00:00 2001 From: Mark Eggleston Date: Mon, 3 Feb 2020 09:38:24 +0000 Subject: [PATCH 08/10] Support type promotion in calls to intrinsics Use -fdec-promotion or -fdec to enable this feature. Merged 2 commits: worked on by Ben Brewer , Francisco Redondo Marchena Re-worked by Mark Eggleston --- gcc/fortran/check.c | 71 +++++- gcc/fortran/intrinsic.c | 5 + gcc/fortran/iresolve.c | 91 ++++--- gcc/fortran/lang.opt | 4 + gcc/fortran/options.c | 1 + gcc/fortran/simplify.c | 266 ++++++++++++++++----- ...ec_intrinsic_int_real_array_const_promotion_1.f | 18 ++ ...ec_intrinsic_int_real_array_const_promotion_2.f | 18 ++ ...ec_intrinsic_int_real_array_const_promotion_3.f | 18 ++ .../dec_intrinsic_int_real_const_promotion_1.f | 90 +++++++ .../dec_intrinsic_int_real_const_promotion_2.f | 90 +++++++ .../dec_intrinsic_int_real_const_promotion_3.f | 92 +++++++ .../dec_intrinsic_int_real_promotion_1.f | 130 ++++++++++ .../dec_intrinsic_int_real_promotion_2.f | 130 ++++++++++ .../dec_intrinsic_int_real_promotion_3.f | 130 ++++++++++ .../dec_intrinsic_int_real_promotion_4.f | 118 +++++++++ .../dec_intrinsic_int_real_promotion_5.f | 118 +++++++++ .../dec_intrinsic_int_real_promotion_6.f | 118 +++++++++ .../dec_intrinsic_int_real_promotion_7.f | 118 +++++++++ gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f | 40 ++++ gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f | 40 ++++ gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f | 39 +++ 22 files changed, 1654 insertions(+), 91 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 4c0b83e8e6f..d428068674f 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1393,12 +1393,40 @@ gfc_check_allocated (gfc_expr *array) } +/* Check function where both arguments must be real or integer + and warn if they are different types. */ + +bool +check_int_real_promotion (gfc_expr *a, gfc_expr *b) +{ + gfc_expr *i; + + if (!int_or_real_check (a, 0)) + return false; + + if (!int_or_real_check (b, 1)) + return false; + + if (a->ts.type != b->ts.type) + { + i = (a->ts.type != BT_REAL ? a : b); + gfc_warning_now (OPT_Wconversion, "Conversion from INTEGER to REAL " + "at %L might lose precision", &i->where); + } + + return true; +} + + /* Common check function where the first argument must be real or integer and the second argument must be the same as the first. */ bool gfc_check_a_p (gfc_expr *a, gfc_expr *p) { + if (flag_dec_promotion) + return check_int_real_promotion (a, p); + if (!int_or_real_check (a, 0)) return false; @@ -3716,6 +3744,41 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) } +/* Check function where all arguments of an argument list must be real + or integer. */ + +static bool +check_rest_int_real (gfc_actual_arglist *arglist) +{ + gfc_actual_arglist *arg, *tmp; + gfc_expr *x; + int m, n; + + if (!min_max_args (arglist)) + return false; + + for (arg = arglist, n=1; arg; arg = arg->next, n++) + { + x = arg->expr; + if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + { + gfc_error ("% argument of %qs intrinsic at %L must be " + "INTEGER or REAL", n, gfc_current_intrinsic, &x->where); + return false; + } + + for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) + if (!gfc_check_conformance (tmp->expr, x, + "arguments 'a%d' and 'a%d' for " + "intrinsic '%s'", m, n, + gfc_current_intrinsic)) + return false; + } + + return true; +} + + bool gfc_check_min_max (gfc_actual_arglist *arg) { @@ -3740,7 +3803,10 @@ gfc_check_min_max (gfc_actual_arglist *arg) return false; } - return check_rest (x->ts.type, x->ts.kind, arg); + if (flag_dec_promotion && x->ts.type != BT_CHARACTER) + return check_rest_int_real (arg); + else + return check_rest (x->ts.type, x->ts.kind, arg); } @@ -5112,6 +5178,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift) bool gfc_check_sign (gfc_expr *a, gfc_expr *b) { + if (flag_dec_promotion) + return check_int_real_promotion (a, b); + if (!int_or_real_check (a, 0)) return false; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 30f9f14572b..1591f9dfc2f 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -4430,6 +4430,11 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, if (ts.kind == 0) ts.kind = actual->expr->ts.kind; + /* If kind promotion is allowed don't check for kind if it is smaller */ + if (flag_dec_promotion && ts.type == BT_INTEGER) + if (actual->expr->ts.kind < ts.kind) + ts.kind = actual->expr->ts.kind; + if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 73769615c20..df8a2fd4119 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -817,19 +817,22 @@ gfc_resolve_dble (gfc_expr *f, gfc_expr *a) void gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p) { - f->ts.type = a->ts.type; if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); + f->ts.kind = gfc_kind_max (a,p); + if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) + f->ts.type = BT_REAL; else - gfc_convert_type (a, &p->ts, 2); + f->ts.type = BT_INTEGER; + + if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) + gfc_convert_type (a, &f->ts, 2); + + if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) + gfc_convert_type (p, &f->ts, 2); } + else + f->ts = a->ts; f->value.function.name = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); @@ -1610,14 +1613,17 @@ gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args) /* Find the largest type kind. */ for (a = args->next; a; a = a->next) { + if (a->expr-> ts.type == BT_REAL) + f->ts.type = BT_REAL; + if (a->expr->ts.kind > f->ts.kind) f->ts.kind = a->expr->ts.kind; } - /* Convert all parameters to the required kind. */ + /* Convert all parameters to the required type and/or kind. */ for (a = args; a; a = a->next) { - if (a->expr->ts.kind != f->ts.kind) + if (a->expr->ts.type != f->ts.type || a->expr->ts.kind != f->ts.kind) gfc_convert_type (a->expr, &f->ts, 2); } @@ -2110,19 +2116,22 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, void gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) { - f->ts.type = a->ts.type; if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); + f->ts.kind = gfc_kind_max (a,p); + if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) + f->ts.type = BT_REAL; else - gfc_convert_type (a, &p->ts, 2); + f->ts.type = BT_INTEGER; + + if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) + gfc_convert_type (a, &f->ts, 2); + + if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) + gfc_convert_type (p, &f->ts, 2); } + else + f->ts = a->ts; f->value.function.name = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); @@ -2132,19 +2141,22 @@ gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) void gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p) { - f->ts.type = a->ts.type; if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); + f->ts.kind = gfc_kind_max (a,p); + if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) + f->ts.type = BT_REAL; else - gfc_convert_type (a, &p->ts, 2); + f->ts.type = BT_INTEGER; + + if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) + gfc_convert_type (a, &f->ts, 2); + + if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) + gfc_convert_type (p, &f->ts, 2); } + else + f->ts = a->ts; f->value.function.name = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), @@ -2519,9 +2531,26 @@ gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) void -gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) +gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b) { - f->ts = a->ts; + if (b != NULL) + { + f->ts.kind = gfc_kind_max (a, b); + if (a->ts.type == BT_REAL || b->ts.type == BT_REAL) + f->ts.type = BT_REAL; + else + f->ts.type = BT_INTEGER; + + if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) + gfc_convert_type (a, &f->ts, 2); + + if (b->ts.kind != f->ts.kind || b->ts.type != f->ts.type) + gfc_convert_type (b, &f->ts, 2); + } + else + { + f->ts = a->ts; + } f->value.function.name = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); } diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 0a6b4263e22..aceef2aa180 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -501,6 +501,10 @@ fdec-old-init Fortran Var(flag_dec_old_init) Enable support for old style initializers in derived types. +fdec-promotion +Fortran Var(flag_dec_promotion) +Add support for type promotion in intrinsic arguments. + fdec-structure Fortran Var(flag_dec_structure) Enable support for DEC STRUCTURE/RECORD. diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 86b28cfe3e6..82e5c9edf4b 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -82,6 +82,7 @@ set_dec_flags (int value) SET_BITFLAG (flag_dec_old_init, value, value); SET_BITFLAG (flag_dec_override_kind, value, value); SET_BITFLAG (flag_dec_non_logical_if, value, value); + SET_BITFLAG (flag_dec_promotion, value, value); } /* Finalize DEC flags. */ diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 248fe05ee48..cebc811b233 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2301,39 +2301,79 @@ gfc_simplify_digits (gfc_expr *x) } +/* Simplify function which sets the floating-point value of ar from + the value of a independently if a is integer of real. */ + +static void +simplify_int_real_promotion (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar) +{ + if (a->ts.type == BT_REAL) + { + mpfr_init2 (*ar, (a->ts.kind * 8)); + mpfr_set (*ar, a->value.real, GFC_RND_MODE); + } + else + { + mpfr_init2 (*ar, (b->ts.kind * 8)); + mpfr_set_z (*ar, a->value.integer, GFC_RND_MODE); + } +} + + +/* Simplify function which promotes a and b arguments from integer to real if + required in ar and br floating-point values. This function returns true if + a or b are reals and false otherwise. */ + +static bool +simplify_int_real_promotion2 (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar, + mpfr_t *br) +{ + if (a->ts.type != BT_REAL && b->ts.type != BT_REAL) + return false; + + simplify_int_real_promotion (a, b, ar); + simplify_int_real_promotion (b, a, br); + + return true; +} + + gfc_expr * gfc_simplify_dim (gfc_expr *x, gfc_expr *y) { gfc_expr *result; int kind; + mpfr_t xr; + mpfr_t yr; + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - result = gfc_get_constant_expr (x->ts.type, kind, &x->where); - - switch (x->ts.type) + if ((x->ts.type != BT_REAL && x->ts.type != BT_INTEGER) + || (y->ts.type != BT_REAL && y->ts.type != BT_INTEGER)) { - case BT_INTEGER: - if (mpz_cmp (x->value.integer, y->value.integer) > 0) - mpz_sub (result->value.integer, x->value.integer, y->value.integer); - else - mpz_set_ui (result->value.integer, 0); - - break; - - case BT_REAL: - if (mpfr_cmp (x->value.real, y->value.real) > 0) - mpfr_sub (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + gfc_internal_error ("gfc_simplify_dim(): Bad arguments"); + return NULL; + } - break; + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - default: - gfc_internal_error ("gfc_simplify_dim(): Bad type"); + if (simplify_int_real_promotion2 (x, y, &xr, &yr)) + { + result = gfc_get_constant_expr (BT_REAL, kind, &x->where); + if (mpfr_cmp (xr, yr) > 0) + mpfr_sub (result->value.real, xr, yr, GFC_RND_MODE); + else + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + } + else + { + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + if (mpz_cmp (x->value.integer, y->value.integer) > 0) + mpz_sub (result->value.integer, x->value.integer, y->value.integer); + else + mpz_set_ui (result->value.integer, 0); } return range_check (result, "DIM"); @@ -4921,13 +4961,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) { int ret; + mpfr_t *arp; + mpfr_t *erp; + mpfr_t ar; + mpfr_t er; + + if (arg->ts.type != extremum->ts.type) + { + if (arg->ts.type == BT_REAL) + { + arp = &arg->value.real; + } + else + { + mpfr_init2 (ar, (arg->ts.kind * 8)); + mpfr_set_z (ar, arg->value.integer, GFC_RND_MODE); + arp = &ar; + } + + if (extremum->ts.type == BT_REAL) + { + erp = &extremum->value.real; + } + else + { + mpfr_init2 (er, (extremum->ts.kind * 8)); + mpfr_set_z (er, extremum->value.integer, GFC_RND_MODE); + erp = &er; + } + + if (mpfr_nan_p (*erp)) + { + ret = 1; + extremum->ts.type = arg->ts.type; + extremum->ts.kind = arg->ts.kind; + if (arg->ts.type == BT_INTEGER) + { + mpz_init2 (extremum->value.integer, (arg->ts.kind * 8)); + mpz_set (extremum->value.integer, arg->value.integer); + } + else + { + mpfr_init2 (extremum->value.real, (arg->ts.kind * 8)); + mpfr_set (extremum->value.real, *arp, GFC_RND_MODE); + } + } + else if (mpfr_nan_p (*arp)) + ret = -1; + else + { + ret = mpfr_cmp (*arp, *erp) * sign; + if (ret > 0) + { + extremum->ts.type = arg->ts.type; + extremum->ts.kind = arg->ts.kind; + if (arg->ts.type == BT_INTEGER) + { + mpz_init2 (extremum->value.integer, (arg->ts.kind * 8)); + mpz_set (extremum->value.integer, arg->value.integer); + } + else + { + mpfr_init2 (extremum->value.real, (arg->ts.kind * 8)); + mpfr_set (extremum->value.real, *arp, GFC_RND_MODE); + } + } + } + + return ret; + } + switch (arg->ts.type) { case BT_INTEGER: ret = mpz_cmp (arg->value.integer, extremum->value.integer) * sign; if (ret > 0) - mpz_set (extremum->value.integer, arg->value.integer); + { + if (arg->ts.kind > extremum->ts.kind) + extremum->ts.kind = arg->ts.kind; + mpz_set (extremum->value.integer, arg->value.integer); + } break; case BT_REAL: @@ -5876,7 +5990,9 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) gfc_expr *result; int kind; - /* First check p. */ + mpfr_t ar; + mpfr_t pr; + if (p->expr_type != EXPR_CONSTANT) return NULL; @@ -5887,18 +6003,18 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) if (mpz_cmp_ui (p->value.integer, 0) == 0) { gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); + "P", &p->where); return &gfc_bad_expr; } - break; + break; case BT_REAL: if (mpfr_cmp_ui (p->value.real, 0) == 0) { gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); + "P", &p->where); return &gfc_bad_expr; - } - break; + } + break; default: gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); } @@ -5906,16 +6022,24 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) if (a->expr_type != EXPR_CONSTANT) return NULL; + if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) + { + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + return NULL; + } + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - if (a->ts.type == BT_INTEGER) - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - else + if (simplify_int_real_promotion2 (a, p, &ar, &pr)) { + result = gfc_get_constant_expr (BT_REAL, kind, &a->where); gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); + mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); + } + else + { + result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where); + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); } return range_check (result, "MOD"); @@ -5928,7 +6052,9 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) gfc_expr *result; int kind; - /* First check p. */ + mpfr_t ar; + mpfr_t pr; + if (p->expr_type != EXPR_CONSTANT) return NULL; @@ -5939,44 +6065,52 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) if (mpz_cmp_ui (p->value.integer, 0) == 0) { gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); + "P", &p->where); return &gfc_bad_expr; } - break; + break; case BT_REAL: if (mpfr_cmp_ui (p->value.real, 0) == 0) { gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); + "P", &p->where); return &gfc_bad_expr; - } - break; + } + break; default: gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); } + if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) + { + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + return NULL; + } + if (a->expr_type != EXPR_CONSTANT) return NULL; kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - if (a->ts.type == BT_INTEGER) - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - else + if (simplify_int_real_promotion2 (a, p, &ar, &pr)) { + result = gfc_get_constant_expr (BT_REAL, kind, &a->where); gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); + mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); if (mpfr_cmp_ui (result->value.real, 0) != 0) - { - if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) - mpfr_add (result->value.real, result->value.real, p->value.real, - GFC_RND_MODE); - } - else - mpfr_copysign (result->value.real, result->value.real, - p->value.real, GFC_RND_MODE); + { + if (mpfr_signbit (ar) != mpfr_signbit (pr)) + mpfr_add (result->value.real, result->value.real, pr, + GFC_RND_MODE); + } + else + mpfr_copysign (result->value.real, result->value.real, pr, + GFC_RND_MODE); + } + else + { + result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where); + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); } return range_check (result, "MODULO"); @@ -7532,27 +7666,41 @@ gfc_expr * gfc_simplify_sign (gfc_expr *x, gfc_expr *y) { gfc_expr *result; + bool neg; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + switch (y->ts.type) + { + case BT_INTEGER: + neg = (mpz_sgn (y->value.integer) < 0); + break; + + case BT_REAL: + neg = (mpfr_sgn (y->value.real) < 0); + break; + + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); + } + switch (x->ts.type) { case BT_INTEGER: mpz_abs (result->value.integer, x->value.integer); - if (mpz_sgn (y->value.integer) < 0) + if (neg) mpz_neg (result->value.integer, result->value.integer); break; case BT_REAL: - if (flag_sign_zero) + if (flag_sign_zero && y->ts.type == BT_REAL) mpfr_copysign (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); + GFC_RND_MODE); else - mpfr_setsign (result->value.real, x->value.real, - mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); + mpfr_setsign (result->value.real, x->value.real, neg, GFC_RND_MODE); break; default: diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f new file mode 100644 index 00000000000..25763852139 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test promotion between integers and reals for mod and modulo where +! A is a constant array and P is zero. +! +! Compilation errors are expected +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + program promotion_int_real_array_const + real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } + a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } + real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } + b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } + end program diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f new file mode 100644 index 00000000000..b78a46054f4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec-promotion" } +! +! Test promotion between integers and reals for mod and modulo where +! A is a constant array and P is zero. +! +! Compilation errors are expected +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + program promotion_int_real_array_const + real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } + a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } + real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } + b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } + end program diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f new file mode 100644 index 00000000000..318ab5db97e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-promotion" } +! +! Test promotion between integers and reals for mod and modulo where +! A is a constant array and P is zero. +! +! Compilation errors are expected +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + program promotion_int_real_array_const + real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } + a = mod([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } + real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } + b = modulo([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } + end program diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f new file mode 100644 index 00000000000..27eb2582bb2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f @@ -0,0 +1,90 @@ +! { dg-do run } +! { dg-options "-fdec -finit-real=snan" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real_const + ! array_nan 4th position value is NAN + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(4, 3) + if (m_i .ne. 1) STOP 1 + m_r = MOD(4.0, 3.0) + if (abs(m_r - 1.0) > 1.0D-6) STOP 2 + m_r = MOD(4, 3.0) + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(4.0, 3) + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + + md_i = MODULO(4, 3) + if (md_i .ne. 1) STOP 5 + md_r = MODULO(4.0, 3.0) + if (abs(md_r - 1.0) > 1.0D-6) STOP 6 + md_r = MODULO(4, 3.0) + if (abs(md_r - 1.0) > 1.0D-6) STOP 7 + md_r = MODULO(4.0, 3) + if (abs(md_r - 1.0) > 1.0D-6) STOP 8 + + d_i = DIM(4, 3) + if (d_i .ne. 1) STOP 9 + d_r = DIM(4.0, 3.0) + if (abs(d_r - 1.0) > 1.0D-6) STOP 10 + d_r = DIM(4.0, 3) + if (abs(d_r - 1.0) > 1.0D-6) STOP 11 + d_r = DIM(3, 4.0) + if (abs(d_r) > 1.0D-6) STOP 12 + + s_i = SIGN(-4, 3) + if (s_i .ne. 4) STOP 13 + s_r = SIGN(4.0, -3.0) + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 + s_r = SIGN(4.0, -3) + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 + s_r = SIGN(-4, 3.0) + if (abs(s_r - 4.0) > 1.0D-6) STOP 16 + + mx_i = MAX(-4, -3, 2, 1) + if (mx_i .ne. 2) STOP 17 + mx_r = MAX(-4.0, -3.0, 2.0, 1.0) + if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 + mx_r = MAX(-4, -3.0, 2.0, 1) + if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 20 + + mn_i = MIN(-4, -3, 2, 1) + if (mn_i .ne. -4) STOP 21 + mn_r = MIN(-4.0, -3.0, 2.0, 1.0) + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 + mn_r = MIN(-4, -3.0, 2.0, 1) + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 24 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f new file mode 100644 index 00000000000..bdd017b7280 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f @@ -0,0 +1,90 @@ +! { dg-do run } +! { dg-options "-fdec-promotion -finit-real=snan" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real_const + ! array_nan 4th position value is NAN + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(4, 3) + if (m_i .ne. 1) STOP 1 + m_r = MOD(4.0, 3.0) + if (abs(m_r - 1.0) > 1.0D-6) STOP 2 + m_r = MOD(4, 3.0) + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(4.0, 3) + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + + md_i = MODULO(4, 3) + if (md_i .ne. 1) STOP 5 + md_r = MODULO(4.0, 3.0) + if (abs(md_r - 1.0) > 1.0D-6) STOP 6 + md_r = MODULO(4, 3.0) + if (abs(md_r - 1.0) > 1.0D-6) STOP 7 + md_r = MODULO(4.0, 3) + if (abs(md_r - 1.0) > 1.0D-6) STOP 8 + + d_i = DIM(4, 3) + if (d_i .ne. 1) STOP 9 + d_r = DIM(4.0, 3.0) + if (abs(d_r - 1.0) > 1.0D-6) STOP 10 + d_r = DIM(4.0, 3) + if (abs(d_r - 1.0) > 1.0D-6) STOP 11 + d_r = DIM(3, 4.0) + if (abs(d_r) > 1.0D-6) STOP 12 + + s_i = SIGN(-4, 3) + if (s_i .ne. 4) STOP 13 + s_r = SIGN(4.0, -3.0) + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 + s_r = SIGN(4.0, -3) + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 + s_r = SIGN(-4, 3.0) + if (abs(s_r - 4.0) > 1.0D-6) STOP 16 + + mx_i = MAX(-4, -3, 2, 1) + if (mx_i .ne. 2) STOP 17 + mx_r = MAX(-4.0, -3.0, 2.0, 1.0) + if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 + mx_r = MAX(-4, -3.0, 2.0, 1) + if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 20 + + mn_i = MIN(-4, -3, 2, 1) + if (mn_i .ne. -4) STOP 21 + mn_r = MIN(-4.0, -3.0, 2.0, 1.0) + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 + mn_r = MIN(-4, -3.0, 2.0, 1) + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 24 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f new file mode 100644 index 00000000000..ce90a5667d6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f @@ -0,0 +1,92 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-promotion -finit-real=snan" } +! +! Test that there is no promotion between integers and reals in +! intrinsic operations. +! +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real_const + ! array_nan 4th position value is NAN + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(4, 3) + if (m_i .ne. 1) STOP 1 + m_r = MOD(4.0, 3.0) + if (abs(m_r - 1.0) > 1.0D-6) STOP 2 + m_r = MOD(4, 3.0) ! { dg-error "'a' and 'p' arguments" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(4.0, 3) ! { dg-error "'a' and 'p' arguments" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + + md_i = MODULO(4, 3) + if (md_i .ne. 1) STOP 5 + md_r = MODULO(4.0, 3.0) + if (abs(md_r - 1.0) > 1.0D-6) STOP 6 + md_r = MODULO(4, 3.0) ! { dg-error "'a' and 'p' arguments" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 7 + md_r = MODULO(4.0, 3) ! { dg-error "'a' and 'p' arguments" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 8 + + d_i = DIM(4, 3) + if (d_i .ne. 1) STOP 9 + d_r = DIM(4.0, 3.0) + if (abs(d_r - 1.0) > 1.0D-6) STOP 10 + d_r = DIM(4.0, 3) ! { dg-error "'x' and 'y' arguments" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 11 + d_r = DIM(3, 4.0) ! { dg-error "'x' and 'y' arguments" } + if (abs(d_r) > 1.0D-6) STOP 12 + + s_i = SIGN(-4, 3) + if (s_i .ne. 4) STOP 13 + s_r = SIGN(4.0, -3.0) + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 + s_r = SIGN(4.0, -3) ! { dg-error "'b' argument" } + if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 + s_r = SIGN(-4, 3.0) ! { dg-error "'b' argument" } + if (abs(s_r - 4.0) > 1.0D-6) STOP 16 + + mx_i = MAX(-4, -3, 2, 1) + if (mx_i .ne. 2) STOP 17 + mx_r = MAX(-4.0, -3.0, 2.0, 1.0) + if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 + mx_r = MAX(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" } + if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 20 + + mn_i = MIN(-4, -3, 2, 1) + if (mn_i .ne. -4) STOP 21 + mn_r = MIN(-4.0, -3.0, 2.0, 1.0) + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 + mn_r = MIN(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" } + if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 24 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f new file mode 100644 index 00000000000..5c2cd931a4b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f @@ -0,0 +1,130 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + INTEGER a_i/4/ + INTEGER*4 a2_i/4/ + INTEGER b_i/3/ + INTEGER*8 b2_i/3/ + INTEGER x_i/2/ + INTEGER y_i/1/ + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + REAL b_r/3.0/ + REAL*8 b2_r/3.0/ + REAL x_r/2.0/ + REAL y_r/1.0/ + + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + ! array_nan 4th position value is NAN + array_nan(4) = 0/l + + m_i = MOD(a_i, b_i) + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_i) + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_i) + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_i) + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_i) + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_i) + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_i) + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_i) + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_i) + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_i, a_r) + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_i) + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_i) + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_r) + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_r) + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_i) + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_r) + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_r, x_r, y_i) + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 30 + + mn_i = MIN(-a_i, -b_i, x_i, y_i) + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_i, x_i, y_i) + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_r, x_r, y_r) + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_r, x_r, y_r) + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_r, x_r, y_i) + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 36 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f new file mode 100644 index 00000000000..d64d468f7d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f @@ -0,0 +1,130 @@ +! { dg-do run } +! { dg-options "-fdec-promotion" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + INTEGER a_i/4/ + INTEGER*4 a2_i/4/ + INTEGER b_i/3/ + INTEGER*8 b2_i/3/ + INTEGER x_i/2/ + INTEGER y_i/1/ + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + REAL b_r/3.0/ + REAL*8 b2_r/3.0/ + REAL x_r/2.0/ + REAL y_r/1.0/ + + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + ! array_nan 4th position value is NAN + array_nan(4) = 0/l + + m_i = MOD(a_i, b_i) + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_i) + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_i) + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_i) + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_i) + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_i) + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_i) + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_i) + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_i) + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_i, a_r) + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_i) + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_i) + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_r) + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_r) + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_i) + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_r) + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_r, x_r, y_i) + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 30 + + mn_i = MIN(-a_i, -b_i, x_i, y_i) + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_i, x_i, y_i) + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_r, x_r, y_r) + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_r, x_r, y_r) + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_r, x_r, y_i) + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 36 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f new file mode 100644 index 00000000000..0708b666633 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f @@ -0,0 +1,130 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-promotion" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + INTEGER a_i/4/ + INTEGER*4 a2_i/4/ + INTEGER b_i/3/ + INTEGER*8 b2_i/3/ + INTEGER x_i/2/ + INTEGER y_i/1/ + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + REAL b_r/3.0/ + REAL*8 b2_r/3.0/ + REAL x_r/2.0/ + REAL y_r/1.0/ + + REAL array_nan(4) + DATA array_nan(1)/-4.0/ + DATA array_nan(2)/3.0/ + DATA array_nan(3)/-2/ + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + ! array_nan 4th position value is NAN + array_nan(4) = 0/l + + m_i = MOD(a_i, b_i) + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_i) + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_r) + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_r) ! { dg-error "'a' and 'p' arguments" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_i) + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_i) + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_r) + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_r) ! { dg-error "'a' and 'p' arguments" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_i) + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_i) + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_r) + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_i) ! { dg-error "'x' and 'y' arguments" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_i, a_r) ! { dg-error "'x' and 'y' arguments" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_i) + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_i) ! { dg-error "'b' argument" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_r) + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_r) ! { dg-error "'b' argument" } + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_i) ! { dg-error "'b' argument" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_r) ! { dg-error "'b' argument" } + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_i, x_i, y_i) + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_r, x_r, y_r) + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + mx_i = MAXLOC(array_nan, 1) + if (mx_i .ne. 2) STOP 30 + + mn_i = MIN(-a_i, -b_i, x_i, y_i) + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_i, x_i, y_i) + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_r, x_r, y_r) + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_r, x_r, y_r) + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + mn_i = MINLOC(array_nan, 1) + if (mn_i .ne. 1) STOP 36 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f new file mode 100644 index 00000000000..efa4f236410 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f @@ -0,0 +1,118 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + LOGICAL a_l + LOGICAL*4 a2_l + LOGICAL b_l + LOGICAL*8 b2_l + LOGICAL x_l + LOGICAL y_l + CHARACTER a_c + CHARACTER*4 a2_c + CHARACTER b_c + CHARACTER*8 b2_c + CHARACTER x_c + CHARACTER y_c + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(a_l, b_l) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_l, b2_l) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_c, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_c, b2_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_l, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_c, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_l, b_l) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_l, b2_l) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_c, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_c, b2_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_l, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_c, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_l, b_l) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_l, b2_l) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_c, b_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_c, b2_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_c, b_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_l, a_c) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_l, b_l) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_l, b2_l) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_c, -b_c) ! { dg-error "" } + if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" } + s_r = SIGN(a2_c, -b2_c) ! { dg-error "" } + if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" } + s_r = SIGN(a_c, -b_l) ! { dg-error "" } + if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" } + s_r = SIGN(-a_l, b_c) ! { dg-error "" } + if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" } + + mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" } + if (mx_i .ne. x_l) STOP 25 ! { dg-error "" } + mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } + if (mx_i .ne. x_l) STOP 26 ! { dg-error "" } + mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" } + mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" } + mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" } + + mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" } + if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" } + mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } + if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" } + mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" } + mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" } + if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" } + mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" } + if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" } + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f new file mode 100644 index 00000000000..d023af5086d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f @@ -0,0 +1,118 @@ +! { dg-do compile } +! { dg-options "-fdec-promotion" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + LOGICAL a_l + LOGICAL*4 a2_l + LOGICAL b_l + LOGICAL*8 b2_l + LOGICAL x_l + LOGICAL y_l + CHARACTER a_c + CHARACTER*4 a2_c + CHARACTER b_c + CHARACTER*8 b2_c + CHARACTER x_c + CHARACTER y_c + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(a_l, b_l) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_l, b2_l) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_c, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_c, b2_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_l, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_c, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_l, b_l) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_l, b2_l) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_c, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_c, b2_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_l, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_c, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_l, b_l) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_l, b2_l) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_c, b_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_c, b2_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_c, b_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_l, a_c) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_l, b_l) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_l, b2_l) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_c, -b_c) ! { dg-error "" } + if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" } + s_r = SIGN(a2_c, -b2_c) ! { dg-error "" } + if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" } + s_r = SIGN(a_c, -b_l) ! { dg-error "" } + if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" } + s_r = SIGN(-a_l, b_c) ! { dg-error "" } + if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" } + + mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" } + if (mx_i .ne. x_l) STOP 25 ! { dg-error "" } + mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } + if (mx_i .ne. x_l) STOP 26 ! { dg-error "" } + mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" } + mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" } + mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" } + if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" } + + mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" } + if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" } + mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } + if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" } + mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" } + if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" } + mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" } + if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" } + mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" } + if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" } + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f new file mode 100644 index 00000000000..00f8fb88f1b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f @@ -0,0 +1,118 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + INTEGER a_i/4/ + INTEGER*4 a2_i/4/ + CHARACTER b_c + CHARACTER*8 b2_c + INTEGER x_i/2/ + CHARACTER y_c + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + LOGICAL b_l + LOGICAL*8 b2_l + REAL x_r/2.0/ + LOGICAL y_l + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(a_i, b_c) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_c) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_c) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_c) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_c) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_c) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_c, a_r) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_c) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_c) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_l) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_l) ! { dg-error "" } + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_c) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_l) ! { dg-error "" } + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + + mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" } + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" } + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f new file mode 100644 index 00000000000..1d4150d81c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f @@ -0,0 +1,118 @@ +! { dg-do compile } +! { dg-options "-fdec-promotion" } +! +! Test promotion between integers and reals in intrinsic operations. +! These operations are: mod, modulo, dim, sign, min, max, minloc and +! maxloc. +! +! Contributed by Francisco Redondo Marchena +! and Jeff Law +! Modified by Mark Eggleston +! + PROGRAM promotion_int_real + REAL l/0.0/ + INTEGER a_i/4/ + INTEGER*4 a2_i/4/ + CHARACTER b_c + CHARACTER*8 b2_c + INTEGER x_i/2/ + CHARACTER y_c + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + LOGICAL b_l + LOGICAL*8 b2_l + REAL x_r/2.0/ + LOGICAL y_l + + INTEGER m_i/0/ + REAL m_r/0.0/ + + INTEGER md_i/0/ + REAL md_r/0.0/ + + INTEGER d_i/0/ + REAL d_r/0.0/ + + INTEGER s_i/0/ + REAL s_r/0.0/ + + INTEGER mn_i/0/ + REAL mn_r/0.0/ + + INTEGER mx_i/0/ + REAL mx_r/0.0/ + + m_i = MOD(a_i, b_c) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_c) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_l) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_c) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_c) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_c) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_l) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_c) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_c) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_c) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_l) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_c) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_c, a_r) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_c) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_c) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_l) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_l) ! { dg-error "" } + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_c) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_l) ! { dg-error "" } + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + + mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" } + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" } + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f new file mode 100644 index 00000000000..435bf98350c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f @@ -0,0 +1,40 @@ +!{ dg-do run } +!{ dg-options "-fdec" } +! +! integer types of a smaller kind than expected should be +! accepted by type specific intrinsic functions +! +! Contributed by Mark Eggleston +! + program test_small_type_promtion + implicit none + integer(1) :: a = 1 + integer :: i + if (iiabs(-9_1).ne.9) stop 1 + if (iabs(-9_1).ne.9) stop 2 + if (iabs(-9_2).ne.9) stop 3 + if (jiabs(-9_1).ne.9) stop 4 + if (jiabs(-9_2).ne.9) stop 5 + if (iishft(1_1, 2).ne.4) stop 6 + if (jishft(1_1, 2).ne.4) stop 7 + if (jishft(1_2, 2).ne.4) stop 8 + if (kishft(1_1, 2).ne.4) stop 9 + if (kishft(1_2, 2).ne.4) stop 10 + if (kishft(1_4, 2).ne.4) stop 11 + if (imod(17_1, 3).ne.2) stop 12 + if (jmod(17_1, 3).ne.2) stop 13 + if (jmod(17_2, 3).ne.2) stop 14 + if (kmod(17_1, 3).ne.2) stop 15 + if (kmod(17_2, 3).ne.2) stop 16 + if (kmod(17_4, 3).ne.2) stop 17 + if (inot(5_1).ne.-6) stop 18 + if (jnot(5_1).ne.-6) stop 19 + if (jnot(5_2).ne.-6) stop 20 + if (knot(5_1).ne.-6) stop 21 + if (knot(5_2).ne.-6) stop 22 + if (knot(5_4).ne.-6) stop 23 + if (isign(-77_1, 1).ne.77) stop 24 + if (isign(-77_1, -1).ne.-77) stop 25 + if (isign(-77_2, 1).ne.77) stop 26 + if (isign(-77_2, -1).ne.-77) stop 27 + end program diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f new file mode 100644 index 00000000000..7b1697ca665 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f @@ -0,0 +1,40 @@ +!{ dg-do run } +!{ dg-options "-fdec-intrinsic-ints -fdec-promotion" } +! +! integer types of a smaller kind than expected should be +! accepted by type specific intrinsic functions +! +! Contributed by Mark Eggleston +! + program test_small_type_promtion + implicit none + integer(1) :: a = 1 + integer :: i + if (iiabs(-9_1).ne.9) stop 1 + if (iabs(-9_1).ne.9) stop 2 + if (iabs(-9_2).ne.9) stop 3 + if (jiabs(-9_1).ne.9) stop 4 + if (jiabs(-9_2).ne.9) stop 5 + if (iishft(1_1, 2).ne.4) stop 6 + if (jishft(1_1, 2).ne.4) stop 7 + if (jishft(1_2, 2).ne.4) stop 8 + if (kishft(1_1, 2).ne.4) stop 9 + if (kishft(1_2, 2).ne.4) stop 10 + if (kishft(1_4, 2).ne.4) stop 11 + if (imod(17_1, 3).ne.2) stop 12 + if (jmod(17_1, 3).ne.2) stop 13 + if (jmod(17_2, 3).ne.2) stop 14 + if (kmod(17_1, 3).ne.2) stop 15 + if (kmod(17_2, 3).ne.2) stop 16 + if (kmod(17_4, 3).ne.2) stop 17 + if (inot(5_1).ne.-6) stop 18 + if (jnot(5_1).ne.-6) stop 19 + if (jnot(5_2).ne.-6) stop 20 + if (knot(5_1).ne.-6) stop 21 + if (knot(5_2).ne.-6) stop 22 + if (knot(5_4).ne.-6) stop 23 + if (isign(-77_1, 1).ne.77) stop 24 + if (isign(-77_1, -1).ne.-77) stop 25 + if (isign(-77_2, 1).ne.77) stop 26 + if (isign(-77_2, -1).ne.-77) stop 27 + end program diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f new file mode 100644 index 00000000000..db8dff6c55d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f @@ -0,0 +1,39 @@ +!{ dg-do compile } +!{ dg-options "-fdec -fno-dec-promotion" } +! +! integer types of a smaller kind than expected should be +! accepted by type specific intrinsic functions +! +! Contributed by Mark Eggleston +! + program test_small_type_promtion + integer(1) :: a = 1 + integer :: i + if (iiabs(-9_1).ne.9) stop 1 + if (iabs(-9_1).ne.9) stop 2 ! { dg-error "type mismatch in argument" } + if (iabs(-9_2).ne.9) stop 3 ! { dg-error "type mismatch in argument" } + if (jiabs(-9_1).ne.9) stop 4 + if (jiabs(-9_2).ne.9) stop 5 + if (iishft(1_1, 2).ne.4) stop 6 + if (jishft(1_1, 2).ne.4) stop 7 + if (jishft(1_2, 2).ne.4) stop 8 + if (kishft(1_1, 2).ne.4) stop 9 + if (kishft(1_2, 2).ne.4) stop 10 + if (kishft(1_4, 2).ne.4) stop 11 + if (imod(17_1, 3).ne.2) stop 12 + if (jmod(17_1, 3).ne.2) stop 13 + if (jmod(17_2, 3).ne.2) stop 14 + if (kmod(17_1, 3).ne.2) stop 15 + if (kmod(17_2, 3).ne.2) stop 16 + if (kmod(17_4, 3).ne.2) stop 17 + if (inot(5_1).ne.-6) stop 18 + if (jnot(5_1).ne.-6) stop 19 + if (jnot(5_2).ne.-6) stop 20 + if (knot(5_1).ne.-6) stop 21 + if (knot(5_2).ne.-6) stop 22 + if (knot(5_4).ne.-6) stop 23 + if (isign(-77_1, 1).ne.77) stop 24 ! { dg-error "type mismatch in argument" } + if (isign(-77_1, -1).ne.-77) stop 25 ! { dg-error "type mismatch in argument" } + if (isign(-77_2, 1).ne.77) stop 26 ! { dg-error "type mismatch in argument" } + if (isign(-77_2, -1).ne.-77) stop 27 ! { dg-error "type mismatch in argument" } + end program -- 2.11.0