commit a2ddfaea2bbe8ea26c37c1d31db71c56855e10ce Author: Francisco Redondo Marchena Date: Mon Apr 9 15:10:02 2018 +0100 Add support for type promotion in intrinsic arguments This feature is supported by the DEC compiler and can be enabled using the -fdec flag. Signed-off-by: Ben Brewer Tests written by: Francisco Redondo Marchena Jeff Law diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index fd0b00a..423d2cb 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -932,12 +932,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) + return check_int_real_promotion (a, p); + if (!int_or_real_check (a, 0)) return false; @@ -3140,6 +3168,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) { @@ -3164,7 +3227,10 @@ gfc_check_min_max (gfc_actual_arglist *arg) return false; } - return check_rest (x->ts.type, x->ts.kind, arg); + if (flag_dec && x->ts.type != BT_CHARACTER) + return check_rest_int_real (arg); + else + return check_rest (x->ts.type, x->ts.kind, arg); } @@ -4426,6 +4492,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift) bool gfc_check_sign (gfc_expr *a, gfc_expr *b) { + if (flag_dec) + return check_int_real_promotion (a, b); + if (!int_or_real_check (a, 0)) return false; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index f15b8f2..0932180 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -892,19 +892,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); @@ -1659,14 +1662,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); } @@ -2050,19 +2056,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); @@ -2072,19 +2081,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), @@ -2455,9 +2467,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/simplify.c b/gcc/fortran/simplify.c index 7603f30..2de9a29 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2254,39 +2254,78 @@ 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"); @@ -4881,13 +4920,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) { 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: @@ -5457,7 +5570,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; @@ -5468,18 +5583,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"); } @@ -5487,16 +5602,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"); @@ -5509,7 +5632,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; @@ -5520,44 +5645,50 @@ 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"); @@ -6976,27 +7107,40 @@ 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) - mpfr_copysign (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); + if (flag_sign_zero && y->ts.type == BT_REAL) + mpfr_copysign (result->value.real, x->value.real, y->value.real, 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.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f new file mode 100644 index 0000000..d77a46e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f @@ -0,0 +1,14 @@ +! { 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 +! + 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_const_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f new file mode 100644 index 0000000..2784b34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f @@ -0,0 +1,86 @@ +! { dg-do compile } +! { 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. +! + 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_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f new file mode 100644 index 0000000..354c773 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f @@ -0,0 +1,114 @@ +! { 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. +! + 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-3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f new file mode 100644 index 0000000..92d1b45 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f @@ -0,0 +1,114 @@ +! { 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. +! + 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.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f new file mode 100644 index 0000000..785331e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f @@ -0,0 +1,126 @@ +! { 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. +! + 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