Projects
home:pandora:RobinOS23
gcc
_service:download_src_package:gcc12-fortran-fde...
Sign Up
Log In
Username
Password
Overview
Repositories
Revisions
Requests
Users
Attributes
Meta
File _service:download_src_package:gcc12-fortran-fdec-promotion.patch of Package gcc
From 7a27318818e359a277f2fa5f7dc3932d0fb950f5 Mon Sep 17 00:00:00 2001 From: Mark Eggleston <markeggleston@gcc.gnu.org> Date: Fri, 22 Jan 2021 14:58:07 +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 <ben.brewer@codethink.co.uk>, Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> and Jeff Law <law@redhat.com> Re-worked by Mark Eggleston <mark.eggleston@codethink.com> --- gcc/fortran/check.cc | 71 +++++- gcc/fortran/intrinsic.cc | 5 + gcc/fortran/iresolve.cc | 91 ++++--- gcc/fortran/lang.opt | 4 + gcc/fortran/options.cc | 1 + gcc/fortran/simplify.cc | 240 ++++++++++++++---- ...trinsic_int_real_array_const_promotion_1.f | 18 ++ ...trinsic_int_real_array_const_promotion_2.f | 18 ++ ...trinsic_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 +++++++++ .../gfortran.dg/dec_kind_promotion-1.f | 40 +++ .../gfortran.dg/dec_kind_promotion-2.f | 40 +++ .../gfortran.dg/dec_kind_promotion-3.f | 39 +++ 22 files changed, 1639 insertions(+), 80 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.cc b/gcc/fortran/check.cc index 623c1cc470e..e20a834a860 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1396,12 +1396,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; @@ -3724,6 +3752,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 ("%<a%d%> 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) { @@ -3748,7 +3811,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); } @@ -5121,6 +5187,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.cc b/gcc/fortran/intrinsic.cc index e68eff8bdbb..81b3a24c2be 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -4467,6 +4467,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.cc b/gcc/fortran/iresolve.cc index e17fe45f080..b9cdaff2499 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -834,19 +834,22 @@ gfc_resolve_dble (gfc_expr *f, gfc_expr 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), @@ -1622,14 +1625,17 @@ gfc_resolve_minmax (const char *name, gf /* 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); } @@ -2130,19 +2136,22 @@ gfc_resolve_minval (gfc_expr *f, gfc_exp 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), @@ -2153,19 +2162,22 @@ gfc_resolve_mod (gfc_expr *f, gfc_expr * 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), @@ -2543,9 +2555,26 @@ gfc_resolve_shift (gfc_expr *f, gfc_expr 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), gfc_type_abi_kind (&a->ts)); diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index d886c2f33ed..4ca2f93f2df 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -505,6 +505,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.cc b/gcc/fortran/options.cc index a946c86790a..15079c7e95a 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -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.cc b/gcc/fortran/simplify.cc index 9900572424f..3419e06fec2 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -2333,39 +2333,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"); @@ -4953,6 +4993,76 @@ 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: @@ -5912,7 +6022,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; @@ -5942,16 +6054,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"); @@ -5964,7 +6084,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; @@ -5991,28 +6113,36 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 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"); @@ -7578,27 +7708,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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <francisco.marchena@codethink.co.uk> +! and Jeff Law <law@redhat.com> +! Modified by Mark Eggleston <mark.eggleston@codethink.com> +! + 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 <mark.eggleston@codethink.com> +! + 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 <mark.eggleston@codethink.com> +! + 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 <mark.eggleston@codethink.com> +! + 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.27.0
Locations
Projects
Search
Status Monitor
Help
Open Build Service
OBS Manuals
API Documentation
OBS Portal
Reporting a Bug
Contact
Mailing List
Forums
Chat (IRC)
Twitter
Open Build Service (OBS)
is an
openSUSE project
.
浙ICP备2022010568号-2