SOURCES/0005-Allow-comparisons-between-INTEGER-and-REAL.patch
@@ -1,48 +1,1117 @@ From ab5aa6f7c04e7193c5387bc74db2605c4dc07f01 Mon Sep 17 00:00:00 2001 From: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Thu, 4 Feb 2016 16:46:46 +0000 Subject: [PATCH 05/23] Allow comparisons between INTEGER and REAL This feature is enabled with the `-std=extra-legacy` compiler flag. --- 0005-Allow-comparisons-between-INTEGER-and-REAL.patch diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 4f2d216..fd0d280 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -901,6 +901,24 @@ gfc_check_allocated (gfc_expr *array) diff -Nrup a/gcc/fortran/check.c b/gcc/fortran/check.c --- a/gcc/fortran/check.c 2018-06-05 11:49:50.228072283 -0600 +++ b/gcc/fortran/check.c 2018-06-05 11:50:45.287707664 -0600 @@ -901,12 +901,40 @@ gfc_check_allocated (gfc_expr *array) } +/* Attempt to promote types of A and B so that they are + equivalent, if possible. */ +void +promote_types (gfc_expr *a, gfc_expr *b) +/* 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) +{ + if (a->ts.type == b->ts.type) + return; + if (a->ts.type == BT_REAL && b->ts.type == BT_INTEGER) + 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) + { + gfc_convert_type_warn (b, &a->ts, 2, 1); + return; + 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); + } + if (a->ts.type == BT_INTEGER && b->ts.type == BT_REAL) + { + gfc_convert_type_warn (a, &b->ts, 2, 1); + } + + 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. */ @@ -910,6 +928,9 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) 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; + if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) + promote_types(a, p); @@ -3035,6 +3063,41 @@ check_rest (bt type, int kind, gfc_actua } +/* Check function where all arguments of an argument list must be real + or integer. */ + if (a->ts.type != p->ts.type) +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) { @@ -3059,7 +3122,10 @@ gfc_check_min_max (gfc_actual_arglist *a 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); } @@ -4293,6 +4359,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr * 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 -Nrup a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c --- a/gcc/fortran/iresolve.c 2017-03-08 10:35:49.000000000 -0700 +++ b/gcc/fortran/iresolve.c 2018-06-05 11:50:45.287707664 -0600 @@ -892,19 +892,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) { gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " - 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); @@ -1669,14 +1672,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); } @@ -1958,19 +1964,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), f->ts.kind); @@ -1980,19 +1989,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), @@ -2364,9 +2376,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), a->ts.kind); } diff -Nrup a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c --- a/gcc/fortran/simplify.c 2018-06-05 11:49:50.231072264 -0600 +++ b/gcc/fortran/simplify.c 2018-06-05 11:51:17.284495772 -0600 @@ -2088,39 +2088,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"); @@ -4427,12 +4466,82 @@ gfc_simplify_merge_bits (gfc_expr *i, gf static void min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) { + 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)) + { + 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_cmp (*arp, *erp) * sign) > 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; + } + switch (arg->ts.type) { case BT_INTEGER: - if (mpz_cmp (arg->value.integer, - extremum->value.integer) * sign > 0) - mpz_set (extremum->value.integer, arg->value.integer); + if ((mpz_cmp (arg->value.integer, + extremum->value.integer) * sign) > 0) + { + 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: @@ -4641,41 +4750,48 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr gfc_expr *result; int kind; + mpfr_t ar; + mpfr_t pr; + if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) return NULL; + if ((a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) + || (p->ts.type != BT_REAL && p->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); - switch (a->ts.type) + if (simplify_int_real_promotion2 (a, p, &ar, &pr)) { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument MOD at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - break; + result = gfc_get_constant_expr (BT_REAL, kind, &a->where); - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MOD at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } + if (mpfr_cmp_ui (pr, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MOD at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - break; + gfc_set_model_kind (kind); + mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); + } + else + { + result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where); - default: - gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument MOD at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); } return range_check (result, "MOD"); @@ -4688,52 +4804,55 @@ gfc_simplify_modulo (gfc_expr *a, gfc_ex gfc_expr *result; int kind; + mpfr_t ar; + mpfr_t pr; + if (a->expr_type != EXPR_CONSTANT || p->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); - - switch (a->ts.type) + if ((a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) + || (p->ts.type != BT_REAL && p->ts.type != BT_INTEGER)) { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. This processor just opts - to not handle it at all. */ - gfc_error ("Second argument of MODULO at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + return NULL; + } - break; + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MODULO at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } + 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); - 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); - break; + if (mpfr_cmp_ui (pr, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MODULO at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + gfc_set_model_kind (kind); + mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); + if (mpfr_cmp_ui (result->value.real, 0) != 0) + { + 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); - default: - gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. This processor just opts + to not handle it at all. */ + gfc_error ("Second argument of MODULO at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); } return range_check (result, "MODULO"); @@ -6133,27 +6252,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 -Nrup a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f --- a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f 1969-12-31 17:00:00.000000000 -0700 +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f 2018-06-05 11:50:45.288707657 -0600 @@ -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 -Nrup a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f --- a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f 1969-12-31 17:00:00.000000000 -0700 +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f 2018-06-05 11:50:45.288707657 -0600 @@ -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_i + LOGICAL*4 a2_i + LOGICAL b_i + LOGICAL*8 b2_i + LOGICAL x_i + LOGICAL y_i + CHARACTER a_r + CHARACTER*4 a2_r + CHARACTER b_r + CHARACTER*8 b2_r + CHARACTER x_r + CHARACTER y_r + + 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_i) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_i) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_i) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_i) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_i) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_i) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_i) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_i) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_r) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_r) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_i) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_i, a_r) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_i) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_i) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_r) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 ! { dg-error "" } + s_r = SIGN(a2_r, -b2_r) ! { dg-error "" } + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 ! { dg-error "" } + s_r = SIGN(a_r, -b_i) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 ! { dg-error "" } + s_r = SIGN(-a_i, b_r) ! { dg-error "" } + if (abs(s_r - a_r) > 1.0D-6) STOP 24 ! { dg-error "" } + + mx_i = MAX(-a_i, -b_i, x_i, y_i) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 25 ! { dg-error "" } + mx_i = MAX(-a2_i, -b2_i, x_i, y_i) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 26 ! { dg-error "" } + mx_r = MAX(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 ! { dg-error "" } + mx_r = MAX(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 ! { dg-error "" } + mx_r = MAX(-a_i, -b_r, x_r, y_i) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 ! { dg-error "" } + + mn_i = MIN(-a_i, -b_i, x_i, y_i) ! { dg-error "" } + if (mn_i .ne. -a_i) STOP 31 ! { dg-error "" } + mn_i = MIN(-a2_i, -b2_i, x_i, y_i) ! { dg-error "" } + if (mn_i .ne. -a2_i) STOP 32 ! { dg-error "" } + mn_r = MIN(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 ! { dg-error "" } + mn_r = MIN(-a2_r, -b2_r, x_r, y_r) ! { dg-error "" } + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 ! { dg-error "" } + mn_r = MIN(-a_i, -b_r, x_r, y_i) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 ! { dg-error "" } + END PROGRAM diff -Nrup a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f --- a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f 1969-12-31 17:00:00.000000000 -0700 +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f 2018-06-05 11:50:45.288707657 -0600 @@ -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_i + CHARACTER*8 b2_i + INTEGER x_i/2/ + CHARACTER y_i + REAL a_r/4.0/ + REAL*4 a2_r/4.0/ + LOGICAL b_r + LOGICAL*8 b2_r + REAL x_r/2.0/ + LOGICAL y_r + + 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_i) ! { dg-error "" } + if (m_i .ne. 1) STOP 1 + m_i = MOD(a2_i, b2_i) ! { dg-error "" } + if (m_i .ne. 1) STOP 2 + m_r = MOD(a_r, b_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 3 + m_r = MOD(a2_r, b2_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 4 + m_r = MOD(a_i, b_r) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 5 + m_r = MOD(a_r, b_i) ! { dg-error "" } + if (abs(m_r - 1.0) > 1.0D-6) STOP 6 + + md_i = MODULO(a_i, b_i) ! { dg-error "" } + if (md_i .ne. 1) STOP 7 + md_i = MODULO(a2_i, b2_i) ! { dg-error "" } + if (md_i .ne. 1) STOP 8 + md_r = MODULO(a_r, b_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 9 + md_r = MODULO(a2_r, b2_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 10 + md_r = MODULO(a_i, b_r) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 11 + md_r = MODULO(a_r, b_i) ! { dg-error "" } + if (abs(md_r - 1.0) > 1.0D-6) STOP 12 + + d_i = DIM(a_i, b_i) ! { dg-error "" } + if (d_i .ne. 1) STOP 13 + d_i = DIM(a2_i, b2_i) ! { dg-error "" } + if (d_i .ne. 1) STOP 14 + d_r = DIM(a_r, b_r) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 15 + d_r = DIM(a2_r, b2_r) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 16 + d_r = DIM(a_r, b_i) ! { dg-error "" } + if (abs(d_r - 1.0) > 1.0D-6) STOP 17 + d_r = DIM(b_i, a_r) ! { dg-error "" } + if (abs(d_r) > 1.0D-6) STOP 18 + + s_i = SIGN(-a_i, b_i) ! { dg-error "" } + if (s_i .ne. 4) STOP 19 + s_i = SIGN(-a2_i, b2_i) ! { dg-error "" } + if (s_i .ne. 4) STOP 20 + s_r = SIGN(a_r, -b_r) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 + s_r = SIGN(a2_r, -b2_r) ! { dg-error "" } + if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 + s_r = SIGN(a_r, -b_i) ! { dg-error "" } + if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 + s_r = SIGN(-a_i, b_r) ! { dg-error "" } + if (abs(s_r - a_r) > 1.0D-6) STOP 24 + + mx_i = MAX(-a_i, -b_i, x_i, y_i) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 25 + mx_i = MAX(-a2_i, -b2_i, x_i, y_i) ! { dg-error "" } + if (mx_i .ne. x_i) STOP 26 + mx_r = MAX(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 27 + mx_r = MAX(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 28 + mx_r = MAX(-a_i, -b_r, x_r, y_i) ! { dg-error "" } + if (abs(mx_r - x_r) > 1.0D-6) STOP 29 + + mn_i = MIN(-a_i, -b_i, x_i, y_i) ! { dg-error "" } + if (mn_i .ne. -a_i) STOP 31 + mn_i = MIN(-a2_i, -b2_i, x_i, y_i) ! { dg-error "" } + if (mn_i .ne. -a2_i) STOP 32 + mn_r = MIN(-a_r, -b_r, x_r, y_r) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 + mn_r = MIN(-a2_r, -b2_r, x_r, y_r) ! { dg-error "" } + if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 + mn_r = MIN(-a_i, -b_r, x_r, y_i) ! { dg-error "" } + if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 + END PROGRAM diff -Nrup a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f --- a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f 1969-12-31 17:00:00.000000000 -0700 +++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f 2018-06-05 11:50:45.288707657 -0600 @@ -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 SOURCES/0006-Allow-blank-format-items-in-format-strings.patch
@@ -11,8 +11,22 @@ --- 0006-Allow-blank-format-items-in-format-strings.patch commit 8e205f3940a364318d0cd2197a9897142632b336 Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Thu Feb 4 16:59:41 2016 +0000 Allow blank format items in format strings This has to be written in a slightly verbose manner because GCC 7 defaults to building with -Werror=implicit-fallthrough which prevents us from just falling through to the default: case. This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index b2fa741..aa3443f 100644 index 0bec4ee39b2..d93dcfadd61 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -752,6 +752,16 @@ format_item_1: @@ -32,3 +46,25 @@ default: error = unexpected_element; goto syntax; diff --git a/gcc/testsuite/gfortran.dg/dec_format_empty_item.f b/gcc/testsuite/gfortran.dg/dec_format_empty_item.f new file mode 100644 index 00000000000..e817001e38a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_format_empty_item.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test blank/empty format items in format string +! + PROGRAM blank_format_items + INTEGER A/0/ + + OPEN(1, status="scratch") + WRITE(1, 10) 100 + REWIND(1) + READ(1, 10) A + IF (a.NE.100) STOP 1 + PRINT 10, A +10 FORMAT( I5,) + END SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch
@@ -6,13 +6,21 @@ This feature is enabled by the `-std=extra-legacy` compiler flag. --- 0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch commit 44861a8907c8d849193287231a464d34fcce522d Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Mon Oct 5 13:45:15 2015 +0100 Allow more than one character as argument to ICHAR This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index fd0d280..b84022b 100644 index 4f2d21610b9..38a90519c81 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2493,7 +2493,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) @@ -2472,7 +2472,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) else return true; @@ -22,7 +30,7 @@ gfc_error ("Argument of %s at %L must be of length one", gfc_current_intrinsic, &c->where); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index d64f2f3..fce03df 100644 index 80c96371ad9..6e05bb444ed 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2774,7 +2774,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) @@ -43,3 +51,27 @@ { gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); return &gfc_bad_expr; diff --git a/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f b/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f new file mode 100644 index 00000000000..c97746d4a4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test ICHAR and IACHAR with more than one character as argument +! + PROGRAM ichar_more_than_one_character + CHARACTER*4 st/'Test'/ + INTEGER i + + i = ICHAR(st) + if (i.NE.84) STOP 1 + i = IACHAR(st) + if (i.NE.84) STOP 2 + i = ICHAR('Test') + if (i.NE.84) STOP 3 + i = IACHAR('Test') + if (i.NE.84) STOP 4 + END SOURCES/0008-Allow-non-integer-substring-indexes.patch
@@ -6,10 +6,18 @@ This feature is enabled by the `-std=extra-legacy` compiler flag. --- 0008-Allow-non-integer-substring-indexes.patch commit 9f05bda69f21d7a7c17b58ff0b6392bfd1a06bae Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Mon Oct 5 14:05:03 2015 +0100 Allow non-integer substring indexes This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 84a4827..667cc50 100644 index 84a4827a1b7..667cc5073e3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4680,6 +4680,17 @@ resolve_substring (gfc_ref *ref) @@ -48,3 +56,26 @@ if (ref->u.ss.end->ts.type != BT_INTEGER) { gfc_error ("Substring end index at %L must be of type INTEGER", diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f new file mode 100644 index 00000000000..8f5c8eb3c0e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test not integer substring indexes +! + PROGRAM not_integer_substring_indexes + CHARACTER*5 st/'Tests'/ + CHARACTER*4 st2 + REAL ir/1.0/ + REAL ir2/4.0/ + + st2 = st(ir:4) + st2 = st(1:ir2) + st2 = st(1.0:4) + st2 = st(1:4.0) + st2 = st(1.5:4) + END SOURCES/0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch
@@ -9,19 +9,33 @@ boolean operations. This feature is enabled with the `-std=extra-legacy` compiler flag. --- 0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch Fixup commit f40dbd54915de8155aad94bfa19c22f11b8a8eae Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Wed Oct 7 16:31:18 2015 -0400 Convert LOGICAL to INTEGER for arithmetic ops, and vice versa We allow converting LOGICAL types to INTEGER when doing arithmetic operations, and converting INTEGER types to LOGICAL for use in boolean operations. This feature is enabled with the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 667cc50..33b441a 100644 index 667cc5073e3..33b441aa1bc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3627,6 +3627,22 @@ is_character_based (bt type) for the conversion. */ @@ -3623,6 +3623,22 @@ is_character_based (bt type) return type == BT_CHARACTER || type == BT_HOLLERITH; } static void +/* If E is a logical, convert it to an integer and issue a warning + for the conversion. */ + +static void +convert_integer_to_logical (gfc_expr *e) +{ + if (e->ts.type == BT_INTEGER) @@ -34,13 +48,9 @@ + } +} + +/* If E is a logical, convert it to an integer and issue a warning + for the conversion. */ + +static void convert_logical_to_integer (gfc_expr *e) { if (e->ts.type == BT_LOGICAL) /* If E is a logical, convert it to an integer and issue a warning for the conversion. */ @@ -3733,6 +3749,12 @@ resolve_operator (gfc_expr *e) case INTRINSIC_OR: case INTRINSIC_EQV: @@ -66,3 +76,36 @@ if (op1->ts.type == BT_LOGICAL) { e->ts.type = BT_LOGICAL; diff --git a/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f b/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f new file mode 100644 index 00000000000..7b9ec0d0cd2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test convertion between logical and integer for logical operators +! + PROGRAM logical_integer_conversion + LOGICAL lpos /.true./ + INTEGER ineg/0/ + INTEGER ires + LOGICAL lres + + ! Test Logicals converted to Integers + if ((lpos.AND.ineg).EQ.1) STOP 3 + if ((ineg.AND.lpos).NE.0) STOP 4 + ires = (.true..AND.0) + if (ires.NE.0) STOP 5 + ires = (1.AND..false.) + if (ires.EQ.1) STOP 6 + + ! Test Integers converted to Logicals + if (lpos.EQ.ineg) STOP 7 + if (ineg.EQ.lpos) STOP 8 + lres = (.true..EQ.0) + if (lres) STOP 9 + lres = (1.EQ..false.) + if (lres) STOP 10 + END SOURCES/0010-Allow-mixed-string-length-and-array-specification-in.patch
@@ -8,8 +8,16 @@ 0010-Allow-mixed-string-length-and-array-specification-in.patch commit 05124ea7df2ee14620d5c24ffe972db3dcab4f4e Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Wed Oct 7 17:04:06 2015 -0400 Allow mixed string length and array specification in character declarations. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 6d3d28a..c90f9de 100644 index 6d3d28af127..c90f9de5a78 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2145,6 +2145,35 @@ check_function_name (char *name) @@ -132,3 +140,19 @@ } /* The dummy arguments and result of the abreviated form of MODULE diff --git a/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f new file mode 100644 index 00000000000..69b110edb25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test character declaration with mixed string length and array specification +! + PROGRAM character_declaration + CHARACTER ASPEC_SLENGTH*2 (5) /'01','02','03','04','05'/ + CHARACTER SLENGTH_ASPEC(5)*2 /'01','02','03','04','05'/ + if (ASPEC_SLENGTH(3).NE.SLENGTH_ASPEC(3)) STOP 1 + END SOURCES/0011-Allow-character-to-int-conversions-in-DATA-statement.patch
@@ -8,8 +8,18 @@ 0011-Allow-character-to-int-conversions-in-DATA-statement.patch commit 11b148af8967669bcebd91ea6fdae28e9ec8e97c Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Wed Oct 7 18:23:31 2015 -0400 Allow character-to-int conversions in DATA statements This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index f347c75..9982b8d 100644 index f347c753702..9982b8d0e85 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3294,6 +3294,10 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, @@ -23,3 +33,20 @@ if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) return true; diff --git a/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f b/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f new file mode 100644 index 00000000000..e0e4f735243 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test character to int conversion in DATA types +! + PROGRAM char_int_data_type + INTEGER*1 ai(2) + + DATA ai/'1',1/ + if(ai(1).NE.49) STOP 1 + END SOURCES/0012-Allow-old-style-initializers-in-derived-types.patch
@@ -10,12 +10,22 @@ This feature is enabled by the `-std=extra-legacy` compiler flag. --- 0012-Allow-old-style-initializers-in-derived-types.patch commit a9ee9b2c45580d0e52670cec4d3d68095dabc178 Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Thu Feb 4 16:00:30 2016 +0000 Allow old-style initializers in derived types Drop unnecessary whitespace This allows simple declarations in derived types and structures, such as: LOGICAL*1 NIL /0/ Only single value expressions are allowed at the moment. This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index c90f9de..3ad9c2c 100644 index c90f9de5a78..3ad9c2c8b40 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2437,12 +2437,30 @@ variable_decl (int elem) @@ -54,3 +64,31 @@ /* For structure components, read the initializer as a special expression and let the rest of this function apply the initializer as usual. */ diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f new file mode 100644 index 00000000000..eac7de987e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test old style initializers in derived types +! + PROGRAM spec_in_var + TYPE STRUCT1 + INTEGER*4 ID /8/ + INTEGER*4 TYPE /5/ + INTEGER*8 DEFVAL /0/ + CHARACTER*(5) NAME /'tests'/ + LOGICAL*1 NIL /0/ + END TYPE STRUCT1 + + TYPE (STRUCT1) SINST + + if(SINST%ID.NE.8) STOP 1 + if(SINST%TYPE.NE.5) STOP 2 + if(SINST%DEFVAL.NE.0) STOP 3 + if(SINST%NAME.NE.'tests') STOP 4 + if(SINST%NIL) STOP 5 + END SOURCES/0013-Allow-per-variable-kind-specification.patch
@@ -14,8 +14,20 @@ 0013-Allow-per-variable-kind-specification.patch Allow per-variable kind specification. INTEGER*4 x*2, y*8 The per-variable sizes override the kind specified in the type. At the moment, you can follow this with an array specification, so INTEGER x*2(10) is OK, but not the other way round. This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 3ad9c2c..832904a 100644 index 3ad9c2c8b40..faa08d9c4bb 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1019,6 +1019,24 @@ syntax: @@ -57,9 +69,13 @@ /* When we get here, we've just matched a list of attributes and maybe a type and a double colon. The next thing we expect to see @@ -2216,9 +2237,18 @@ variable_decl (int elem) if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) && current_ts.type == BT_CHARACTER) @@ -2213,12 +2234,20 @@ variable_decl (int elem) cl_match = MATCH_NO; /* Check for a character length clause before an array clause */ - if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) - && current_ts.type == BT_CHARACTER) + if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) { - cl_match = match_character_length_clause (&cl, &cl_deferred, elem); - if (cl_match == MATCH_ERROR) @@ -79,7 +95,7 @@ } /* Now we could see the optional array spec. or character length. */ @@ -2412,6 +2442,13 @@ variable_decl (int elem) @@ -2412,6 +2441,13 @@ variable_decl (int elem) goto cleanup; } @@ -93,3 +109,21 @@ if (!check_function_name (name)) { m = MATCH_ERROR; diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f new file mode 100644 index 00000000000..0341a176aca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test kind specification in variable not in type +! + PROGRAM spec_in_var + INTEGER ai*1/1/ + REAL ar*4/1.0/ + + if(ai.NE.1) STOP 1 + if(abs(ar - 1.0) > 1.0D-6) STOP 2 + END SOURCES/0014-Allow-non-logical-expressions-in-IF-statements.patch
@@ -8,61 +8,136 @@ 0014-Allow-non-logical-expressions-in-IF-statements.patch diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 682f7b0..c63b834 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "match.h" #include "parse.h" +#include "arith.h" int gfc_matching_ptr_assignment = 0; int gfc_matching_procptr_assignment = 0; @@ -1666,7 +1667,17 @@ got_match: *p->next = new_st; p->next->loc = gfc_current_locus; - p->expr1 = expr; + if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) + && expr->ts.type != BT_LOGICAL) + { + p->expr1 = gfc_ne (expr, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); + gfc_warning_now (0, "The type of condition in this IF statement isn't LOGICAL; it will be true if it evaluates to nonzero."); + } + else + { + p->expr1 = expr; + } + p->op = EXEC_IF; gfc_clear_new_st (); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 3aedb1d..e926ba6 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include <setjmp.h> #include "match.h" #include "parse.h" +#include "arith.h" /* Current statement label. Zero means no statement label. Because new_st can get wiped during statement matching, we have to keep it separate. */ @@ -4036,6 +4037,14 @@ parse_if_block (void) d = add_statement (); d->expr1 = top->expr1; Allow non-logical expressions in IF statements This feature is enabled by the `-std=extra-legacy` compiler flag. Signed-off-by: Ben Brewer <ben.brewer@codethink.co.uk> Signed-off-by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 33b441aa1bc..f979915e856 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9919,10 +9919,23 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) switch (b->op) { case EXEC_IF: - if (t && b->expr1 != NULL - && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &b->expr1->where); + if (t && b->expr1 != NULL) + { + if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY && b->expr1->ts.type != BT_LOGICAL) + { + gfc_expr* cast; + cast = gfc_ne (b->expr1, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); + if (cast == NULL) + gfc_internal_error ("gfc_resolve_blocks(): Failed to cast to LOGICAL in IF"); + b->expr1 = cast; + gfc_warning (0, "Non-LOGICAL type in IF statement condition %L" + " will be true if it evaluates to nonzero", &b->expr1->where); + } + + if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) + && top->expr1->ts.type != BT_LOGICAL) + { + d->expr1 = gfc_ne (top->expr1, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); + gfc_warning_now (0, "The type of condition in this IF statement isn't LOGICAL; it will be true if it evaluates to nonzero."); + } + top->expr1 = NULL; top->block = d; + if ((b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &b->expr1->where); + } break; case EXEC_WHERE: @@ -11182,11 +11195,23 @@ start: break; case EXEC_IF: - if (t && code->expr1 != NULL - && (code->expr1->ts.type != BT_LOGICAL - || code->expr1->rank != 0)) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &code->expr1->where); + if (t && code->expr1 != NULL) + { + if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY && code->expr1->ts.type != BT_LOGICAL) + { + gfc_expr* cast; + cast = gfc_ne (code->expr1, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); + if (cast == NULL) + gfc_internal_error ("gfc_resolve_code(): Failed to cast to LOGICAL in IF"); + code->expr1 = cast; + gfc_warning (0, "Non-LOGICAL type in IF statement condition %L" + " will be true if it evaluates to nonzero", &code->expr1->where); + } + + if ((code->expr1->ts.type != BT_LOGICAL || code->expr1->rank != 0)) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &code->expr1->where); + } break; case EXEC_CALL: diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f new file mode 100644 index 00000000000..ad23fcfc9af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Allow logical expressions in if statements and blocks +! + PROGRAM logical_exp_if_st_bl + INTEGER ipos/1/ + INTEGER ineg/0/ + + ! Test non logical variables + if (ineg) STOP 1 ! { dg-warning "if it evaluates to nonzero" } + if (0) STOP 2 ! { dg-warning "if it evaluates to nonzero" } + + ! Test non logical expressions in if statements + if (MOD(ipos, 1)) STOP 3 ! { dg-warning "if it evaluates to nonzero" } + + ! Test non logical expressions in if blocks + if (MOD(2 * ipos, 2)) then ! { dg-warning "if it evaluates to nonzero" } + STOP 4 + endif + END commit cf72338b9468fad669b60600bcce7918a8d4591e Author: Jeff Law <law@redhat.com> Date: Tue Jun 5 15:45:41 2018 -0600 Additional test for 0014-Allow-non-logical-expressions-in-IF-statements.patch "Allow non-logical expressions in IF statements" diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f new file mode 100644 index 00000000000..7da6aaceec7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } + + function othersub1() + integer*4 othersub1 + othersub1 = 1 + end + function othersub2() + integer*4 othersub2 + othersub2 = 2 + end + program MAIN + integer*4 othersub1 + integer*4 othersub2 +c the if (integer) works here + if (othersub2()) then ! { dg-warning "" } + write (*,*), 'othersub2 is true' +c but fails in the "else if" + else if (othersub1()) then ! { dg-warning "" } + write (*,*), 'othersub2 is false, othersub1 is true' + endif + end + SOURCES/0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch
@@ -9,10 +9,9 @@ 0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a32de3e..e222003 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h diff -Nrup a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h --- a/gcc/fortran/gfortran.h 2018-06-05 11:59:14.269337049 -0600 +++ b/gcc/fortran/gfortran.h 2018-06-05 11:59:52.830081690 -0600 @@ -646,6 +646,8 @@ enum gfc_reverse GFC_INHIBIT_REVERSE }; @@ -31,11 +30,10 @@ bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); bool gfc_has_vector_subscript (gfc_expr*); gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 162f777..fc73e31 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -682,7 +682,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) diff -Nrup a/gcc/fortran/interface.c b/gcc/fortran/interface.c --- a/gcc/fortran/interface.c 2018-03-03 06:51:39.000000000 -0700 +++ b/gcc/fortran/interface.c 2018-06-05 12:01:11.218559539 -0600 @@ -682,7 +682,7 @@ gfc_compare_derived_types (gfc_symbol *d /* Compare two typespecs, recursively if necessary. */ bool @@ -44,7 +42,7 @@ { /* See if one of the typespecs is a BT_VOID, which is what is being used to allow the funcs like c_f_pointer to accept any pointer type. @@ -721,12 +721,23 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) @@ -721,12 +721,23 @@ gfc_compare_types (gfc_typespec *ts1, gf return compare_union_types (ts1->u.derived, ts2->u.derived); if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) @@ -69,7 +67,7 @@ static bool compare_type (gfc_symbol *s1, gfc_symbol *s2) @@ -743,7 +754,9 @@ compare_type (gfc_symbol *s1, gfc_symbol *s2) @@ -743,7 +754,9 @@ compare_type (gfc_symbol *s1, gfc_symbol return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; } @@ -80,7 +78,7 @@ static bool compare_rank (gfc_symbol *s1, gfc_symbol *s2) { @@ -2150,7 +2163,7 @@ argument_rank_mismatch (const char *name, locus *where, @@ -2150,7 +2163,7 @@ argument_rank_mismatch (const char *name static bool compare_parameter (gfc_symbol *formal, gfc_expr *actual, @@ -89,7 +87,7 @@ { gfc_ref *ref; bool rank_check, is_pointer; @@ -2242,7 +2255,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, @@ -2242,7 +2255,7 @@ compare_parameter (gfc_symbol *formal, g && actual->ts.type != BT_HOLLERITH && formal->ts.type != BT_ASSUMED && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) @@ -108,7 +106,7 @@ { gfc_actual_arglist **new_arg, *a, *actual; gfc_formal_arglist *f; @@ -2918,7 +2932,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, @@ -2918,7 +2932,7 @@ compare_actual_formal (gfc_actual_arglis } if (!compare_parameter (f->sym, a->expr, ranks_must_agree, @@ -117,7 +115,7 @@ return false; /* TS 29113, 6.3p2. */ @@ -3666,7 +3680,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) @@ -3666,7 +3680,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ /* For a statement function, check that types and type parameters of actual arguments and dummy arguments match. */ if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, @@ -127,17 +125,16 @@ return false; if (!check_intents (dummy_args, *ap)) @@ -3715,7 +3730,8 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) @@ -3715,7 +3730,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac } if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, - comp->attr.elemental, false, where)) + comp->attr.elemental, false, where, + MATCH_EXACT)) + comp->attr.elemental, false, where, MATCH_EXACT)) return; check_intents (comp->ts.interface->formal, *ap); @@ -3729,7 +3745,7 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) @@ -3729,7 +3744,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac GENERIC resolution. */ bool @@ -146,7 +143,7 @@ { gfc_formal_arglist *dummy_args; bool r; @@ -3740,7 +3756,7 @@ gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) @@ -3740,7 +3755,7 @@ gfc_arglist_matches_symbol (gfc_actual_a dummy_args = gfc_sym_get_dummy_args (sym); r = !sym->attr.elemental; @@ -155,7 +152,7 @@ { check_intents (dummy_args, *args); if (warn_aliasing) @@ -3766,7 +3782,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, @@ -3766,7 +3781,8 @@ gfc_search_interface (gfc_interface *int locus null_expr_loc; gfc_actual_arglist *a; bool has_null_arg = false; @@ -165,7 +162,7 @@ for (a = *ap; a; a = a->next) if (a->expr && a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) @@ -3776,38 +3793,43 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, @@ -3776,38 +3792,43 @@ gfc_search_interface (gfc_interface *int break; } @@ -236,7 +233,7 @@ } } @@ -3942,7 +3964,7 @@ matching_typebound_op (gfc_expr** tb_base, @@ -3942,7 +3963,7 @@ matching_typebound_op (gfc_expr** tb_bas /* Check if this arglist matches the formal. */ argcopy = gfc_copy_actual_arglist (args); @@ -245,11 +242,10 @@ gfc_free_actual_arglist (argcopy); /* Return if we found a match. */ diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 371f5b8..846492a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -4229,6 +4229,16 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, diff -Nrup a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c --- a/gcc/fortran/intrinsic.c 2018-06-05 11:59:14.278336990 -0600 +++ b/gcc/fortran/intrinsic.c 2018-06-05 11:59:52.831081683 -0600 @@ -4229,6 +4229,16 @@ check_arglist (gfc_actual_arglist **ap, if (ts.kind == 0) ts.kind = actual->expr->ts.kind; @@ -266,11 +262,10 @@ if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 33b441a..f82c298 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6055,7 +6055,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) diff -Nrup a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c --- a/gcc/fortran/resolve.c 2018-06-05 11:59:14.291336904 -0600 +++ b/gcc/fortran/resolve.c 2018-06-05 11:59:52.833081670 -0600 @@ -6055,7 +6055,7 @@ resolve_typebound_generic_call (gfc_expr && gfc_sym_get_dummy_args (target) == NULL); /* Check if this arglist matches the formal. */ SOURCES/0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch
@@ -9,8 +9,18 @@ 0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch commit 1635277d719de05fbd37a2887273ce893bf43198 Author: Jim MacArthur <jim.macarthur@codethink.co.uk> Date: Wed Nov 18 15:08:56 2015 +0000 Add the SEQUENCE attribute by default if it's not present. This feature is enabled by the `-std=extra-legacy` compiler flag. Test written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f82c298..a831f70 100644 index 2e60984b3bd..022b9230ec9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -963,9 +963,16 @@ resolve_common_vars (gfc_common_head *common_block, bool named_common) @@ -33,3 +43,26 @@ if (csym->ts.u.derived->attr.alloc_comp) gfc_error_now ("Derived type variable %qs in COMMON at %L " "has an ultimate component that is " diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f new file mode 100644 index 00000000000..c0851c8bc77 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=extra-legacy" } +! +! Test add default SEQUENCE attribute to COMMON blocks +! + PROGRAM sequence_att_common + TYPE STRUCT1 + INTEGER*4 ID + INTEGER*4 TYPE + INTEGER*8 DEFVAL + CHARACTER*(4) NAME + LOGICAL*1 NIL + END TYPE STRUCT1 + + TYPE (STRUCT1) SINST + COMMON /BLOCK1/ SINST + END SOURCES/gcc7-fortran-include.patch
New file @@ -0,0 +1,240 @@ commit 858a1903ea946c9947d492209453a8973846b9f7 Author: Jeff Law <law@torsion.usersys.redhat.com> Date: Tue May 29 13:56:59 2018 -0400 Fix bloomberg INCLUDE issue diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 55d6daf..9c9a208 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -2129,6 +2129,38 @@ preprocessor_line (gfc_char_t *c) current_file->line++; } +/* Add LINE with length LEN and truncation status TRUNC to + FILE_CHANGES. */ +static void +add_line (gfc_char_t *line, int len, int trunc) +{ + gfc_linebuf *b; + + b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size + + (len + 1) * sizeof (gfc_char_t)); + + + b->location = linemap_line_start (line_table, current_file->line++, len); + /* ??? We add the location for the maximum column possible here, + because otherwise if the next call creates a new line-map, it + will not reserve space for any offset. */ + if (len > 0) + linemap_position_for_column (line_table, len); + + b->file = current_file; + b->truncated = trunc; + wide_strcpy (b->line, line); + + if (line_head == NULL) + line_head = b; + else + line_tail->next = b; + + line_tail = b; + + while (file_changes_cur < file_changes_count) + file_changes[file_changes_cur++].lb = b; +} static bool load_file (const char *, const char *, bool); @@ -2139,7 +2171,7 @@ static bool load_file (const char *, const char *, bool); processed or true if we matched an include. */ static bool -include_line (gfc_char_t *line) +include_line (FILE *input, gfc_char_t *line, int *len, int *trunc) { gfc_char_t quote, *c, *begin, *stop; char *filename; @@ -2173,6 +2205,33 @@ include_line (gfc_char_t *line) while (*c == ' ' || *c == '\t') c++; + /* If we have reached EOL, read ahead to find the quote. We eat + any whitespace. We use getchar behind the back of load_line and + put it back if we do not find what we are looking for. */ + int new_line_len = 0; + int new_trunc = 0; + gfc_char_t *new_line = NULL; + if (*c == '\0') + { + unsigned char x; + + do + x = getc (input); + while (x == ' ' || x == '\t' || x == '\r' || x == '\n'); + + /* Always put the character back. */ + ungetc (x, input); + + /* If we did not fine the quote, put the character back and + return that no INCLUDE has processed. */ + if (x != '"' && x != '\'') + return false; + + /* Read the next line and continue processing. */ + new_trunc = load_line (input, &new_line, &new_line_len, NULL); + c = new_line; + } + /* Find filename between quotes. */ quote = *c++; @@ -2184,16 +2243,45 @@ include_line (gfc_char_t *line) while (*c != quote && *c != '\0') c++; + /* Reached EOL without finding ending quote. */ if (*c == '\0') - return false; + { + /* If we loaded another line, then we want to add the + original line and return the current line. + + We do not try to support multi-line filenames for + INCLUDE statements. */ + if (new_line) + { + add_line (line, *len, *trunc); + *line = *new_line; + *len = new_line_len; + *trunc = new_trunc; + } + return false; + } stop = c++; + /* Consume trailing whitespace on this line. */ while (*c == ' ' || *c == '\t') c++; + /* If we encounter real characters before reaching EOL, then + we do not consider this an include line. */ if (*c != '\0' && *c != '!') - return false; + { + /* If we loaded another line, then we want to add the + original line and return the current line. */ + if (new_line) + { + add_line (line, *len, *trunc); + *line = *new_line; + *len = new_line_len; + *trunc = new_trunc; + } + return false; + } /* We have an include line at this point. */ @@ -2215,7 +2303,6 @@ static bool load_file (const char *realfilename, const char *displayedname, bool initial) { gfc_char_t *line; - gfc_linebuf *b; gfc_file *f; FILE *input; int len, line_len; @@ -2370,39 +2457,13 @@ load_file (const char *realfilename, const char *displayedname, bool initial) but the first line that's not a preprocessor line. */ first_line = false; - if (include_line (line)) + if (include_line (input, line, &len, &trunc)) { current_file->line++; continue; } - /* Add line. */ - - b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size - + (len + 1) * sizeof (gfc_char_t)); - - - b->location - = linemap_line_start (line_table, current_file->line++, len); - /* ??? We add the location for the maximum column possible here, - because otherwise if the next call creates a new line-map, it - will not reserve space for any offset. */ - if (len > 0) - linemap_position_for_column (line_table, len); - - b->file = current_file; - b->truncated = trunc; - wide_strcpy (b->line, line); - - if (line_head == NULL) - line_head = b; - else - line_tail->next = b; - - line_tail = b; - - while (file_changes_cur < file_changes_count) - file_changes[file_changes_cur++].lb = b; + add_line (line, len, trunc); } /* Release the line buffer allocated in load_line. */ diff --git a/gcc/testsuite/gfortran.dg/include_10.f90 b/gcc/testsuite/gfortran.dg/include_10.f90 new file mode 100644 index 0000000..5a9bb5b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/include_10.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Ensure that we handle the pathname on a separate line than +! the include directivbe +! + +subroutine one() + include + "include_4.inc" + integer(i4) :: i +end subroutine one diff --git a/gcc/testsuite/gfortran.dg/include_11.f90 b/gcc/testsuite/gfortran.dg/include_11.f90 new file mode 100644 index 0000000..44b23e03 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/include_11.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Ensure that we can make an assignment to a variable named +! include. +! + +subroutine one() + integer :: include + include = 5 +end subroutine one diff --git a/gcc/testsuite/gfortran.dg/include_12.f90 b/gcc/testsuite/gfortran.dg/include_12.f90 new file mode 100644 index 0000000..8679b20 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/include_12.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Ensure we can make an assignment to a variable named include using +! a line continuation +! + +subroutine one() + integer :: include + include & + = 5 +end subroutine one SOURCES/gcc7-fortranlines.patch
New file @@ -0,0 +1,36 @@ diff -Nrup a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c --- a/gcc/fortran/scanner.c 2017-03-08 12:35:48.000000000 -0500 +++ b/gcc/fortran/scanner.c 2018-05-03 19:01:52.000000000 -0400 @@ -2097,6 +2097,10 @@ preprocessor_line (gfc_char_t *c) in the linemap. Alternative could be using GC or updating linemap to point to the new name, but there is no API for that currently. */ current_file->filename = xstrdup (filename); + + /* We need to tell the linemap API that the filename changed. Just + changing current_file is insufficient. */ + linemap_add (line_table, LC_RENAME, false, current_file->filename, line); } /* Set new line number. */ diff -Nrup a/gcc/testsuite/gfortran.dg/linefile.f90 b/gcc/testsuite/gfortran.dg/linefile.f90 --- a/gcc/testsuite/gfortran.dg/linefile.f90 1969-12-31 19:00:00.000000000 -0500 +++ b/gcc/testsuite/gfortran.dg/linefile.f90 2018-05-07 13:34:22.000000000 -0400 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wall" } + +! This will verify that the # <line> <file> directive later does not +! mess up the diagnostic on this line +SUBROUTINE s(dummy) ! { dg-warning "Unused" } + INTEGER, INTENT(in) :: dummy +END SUBROUTINE + +# 12345 "foo-f" +SUBROUTINE s2(dummy) + INTEGER, INTENT(in) :: dummy +END SUBROUTINE +! We want to check that the # directive changes the filename in the +! diagnostic. Nothing else really matters here. dg-regexp allows us +! to see the entire diagnostic. We just have to make sure to consume +! the entire message. +! { dg-regexp "foo-f\[^\n]*" } SOURCES/gcc7-libstdc++-compat.patch
@@ -5910,7 +5910,7 @@ + $(LTCXXCOMPILE) -std=gnu++1z -c $< --- libstdc++-v3/src/nonshared11/random48.cc.jj 2017-05-31 12:11:25.234560624 +0200 +++ libstdc++-v3/src/nonshared11/random48.cc 2017-05-31 15:25:50.424872511 +0200 @@ -0,0 +1,72 @@ @@ -0,0 +1,95 @@ +// Copyright (C) 2013-2017 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -5959,6 +5959,29 @@ +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEC1Em"); +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEC2Em"); +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEclEv"); +#elif defined(__s390__) +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE10shift_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE10state_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11_M_gen_randEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_bE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_cE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_dE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_lE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_sE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_tE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_uE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE12default_seedE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE25initialization_multiplierE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE3maxEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE3minEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE4seedEj"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE7discardEy"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE8xor_maskE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE9mask_bitsE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE9word_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEC1Ej"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEC2Ej"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEclEv"); +#else +asm (".hidden _ZNSt23mersenne_twister_engineIjLj32ELj624ELj397ELj31ELj2567483615ELj11ELj4294967295ELj7ELj2636928640ELj15ELj4022730752ELj18ELj1812433253EE10shift_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLj32ELj624ELj397ELj31ELj2567483615ELj11ELj4294967295ELj7ELj2636928640ELj15ELj4022730752ELj18ELj1812433253EE10state_sizeE"); @@ -8202,7 +8225,7 @@ +#endif --- libstdc++-v3/src/nonshared11/random.cc.jj 2017-05-31 12:11:25.236560600 +0200 +++ libstdc++-v3/src/nonshared11/random.cc 2017-05-31 15:25:50.425872499 +0200 @@ -0,0 +1,71 @@ @@ -0,0 +1,94 @@ +// Copyright (C) 2013-2017 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -8250,6 +8273,29 @@ +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEC1Em"); +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEC2Em"); +asm (".hidden _ZNSt23mersenne_twister_engineImLm32ELm624ELm397ELm31ELm2567483615ELm11ELm4294967295ELm7ELm2636928640ELm15ELm4022730752ELm18ELm1812433253EEclEv"); +#elif defined(__s390__) +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE10shift_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE10state_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11_M_gen_randEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_bE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_cE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_dE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_lE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_sE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_tE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE11tempering_uE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE12default_seedE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE25initialization_multiplierE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE3maxEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE3minEv"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE4seedEj"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE7discardEy"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE8xor_maskE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE9mask_bitsE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EE9word_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEC1Ej"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEC2Ej"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLm32ELm624ELm397ELm31ELj2567483615ELm11ELj4294967295ELm7ELj2636928640ELm15ELj4022730752ELm18ELj1812433253EEclEv"); +#else +asm (".hidden _ZNSt23mersenne_twister_engineIjLj32ELj624ELj397ELj31ELj2567483615ELj11ELj4294967295ELj7ELj2636928640ELj15ELj4022730752ELj18ELj1812433253EE10shift_sizeE"); +asm (".hidden _ZNSt23mersenne_twister_engineIjLj32ELj624ELj397ELj31ELj2567483615ELj11ELj4294967295ELj7ELj2636928640ELj15ELj4022730752ELj18ELj1812433253EE10state_sizeE"); SOURCES/gcc7-rh1570967.patch
New file @@ -0,0 +1,81 @@ commit 63256634cd46529bb3e839838f03dc4164feaa4c Author: foreese <foreese@138bc75d-0d04-0410-961f-82ee72b054a4> Date: Thu Aug 10 12:36:44 2017 +0000 2017-08-10 Fritz Reese <Reese-Fritz@zai.com> gcc/fortran/ChangeLog: * options.c (set_dec_flags, gfc_post_options): Only set flag_d_lines with -fdec when not set by user. gcc/testsuite/ChangeLog: gfortran.dg/ * dec_d_lines_1.f, dec_d_lines_2.f: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@251024 138bc75d-0d04-0410-961f-82ee72b054a4 diff --git gcc/fortran/options.c gcc/fortran/options.c index 283c8354e06..cd254e93229 100644 --- gcc/fortran/options.c +++ gcc/fortran/options.c @@ -57,9 +57,6 @@ set_dec_flags (int value) | GFC_STD_GNU | GFC_STD_LEGACY; gfc_option.warn_std &= ~(GFC_STD_LEGACY | GFC_STD_F95_DEL); - /* Set -fd-lines-as-comments by default. */ - if (value && gfc_current_form != FORM_FREE && gfc_option.flag_d_lines == -1) - gfc_option.flag_d_lines = 0; /* Set other DEC compatibility extensions. */ flag_dollar_ok |= value; @@ -339,8 +336,15 @@ gfc_post_options (const char **pfilename) diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation, DK_ERROR, UNKNOWN_LOCATION); } - else if (warn_line_truncation == -1) - warn_line_truncation = 0; + else + { + /* With -fdec, set -fd-lines-as-comments by default in fixed form. */ + if (flag_dec && gfc_option.flag_d_lines == -1) + gfc_option.flag_d_lines = 0; + + if (warn_line_truncation == -1) + warn_line_truncation = 0; + } /* If -pedantic, warn about the use of GNU extensions. */ if (pedantic && (gfc_option.allow_std & GFC_STD_GNU) != 0) diff --git gcc/testsuite/gfortran.dg/dec_d_lines_1.f gcc/testsuite/gfortran.dg/dec_d_lines_1.f new file mode 100644 index 00000000000..2cc7a01daff --- /dev/null +++ gcc/testsuite/gfortran.dg/dec_d_lines_1.f @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-ffixed-form -fd-lines-as-code -fdec" } +! +! Ensure -fd-lines-as-code is not overridden by -fdec. +! + i = 0 +d end + subroutine s +D end diff --git gcc/testsuite/gfortran.dg/dec_d_lines_2.f gcc/testsuite/gfortran.dg/dec_d_lines_2.f new file mode 100644 index 00000000000..31eaf5f2328 --- /dev/null +++ gcc/testsuite/gfortran.dg/dec_d_lines_2.f @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-ffixed-form -fdec" } +! +! Ensure -fd-lines-as-comments is enabled by default with -fdec. +! +d This is a comment. +D This line, too. + end SPECS/gcc.spec
@@ -95,7 +95,7 @@ Summary: GCC version 7 Name: %{?scl_prefix}gcc Version: %{gcc_version} Release: %{gcc_release}.4%{?dist} Release: %{gcc_release}.10%{?dist} # libgcc, libgfortran, libgomp, libstdc++ and crtstuff have # GCC Runtime Exception. License: GPLv3+ and GPLv3+ with exceptions and GPLv2+ with exceptions and LGPLv2+ and BSD @@ -258,6 +258,7 @@ Patch13: gcc7-rh1512529-aarch64.patch Patch14: gcc7-pr84524.patch Patch15: gcc7-pr84128.patch Patch16: gcc7-rh1570967.patch Patch1000: gcc7-libstdc++-compat.patch Patch1001: gcc7-alt-compat-test.patch @@ -291,6 +292,10 @@ Patch3019: 0019-Add-tests-for-AUTOMATIC-keyword.patch Patch3020: 0020-Add-test-for-STRUCTURE-and-RECORD.patch Patch3022: 0022-Default-values-for-certain-field-descriptors-in-form.patch Patch3023: gcc7-fortranlines.patch Patch3024: gcc7-fortran-include.patch %if 0%{?rhel} >= 7 %global nonsharedver 48 @@ -683,6 +688,7 @@ %patch13 -p0 -b .rh1512529-aarch64~ %patch14 -p0 -b .pr84524~ %patch15 -p0 -b .pr84128~ %patch16 -p0 -b .rh1570967~ %if 0%{?rhel} <= 7 %patch1000 -p0 -b .libstdc++-compat~ @@ -738,6 +744,8 @@ %patch3019 -p1 -b .fortran19~ %patch3020 -p1 -b .fortran20~ %patch3022 -p1 -b .fortran22~ %patch3023 -p1 -b .fortran23~ %patch3024 -p1 -b .fortran24~ %endif echo 'Red Hat %{version}-%{gcc_release}' > gcc/DEV-PHASE @@ -2893,6 +2901,29 @@ %doc rpm.doc/changelogs/libcc1/ChangeLog* %changelog * Tue Jun 12 2018 Marek Polacek <polacek@redhat.com> 7.3.1-5.10 - bump for rebuild * Tue Jun 05 2018 Jeff Law <polacek@redhat.com> 7.3.1-5.9 - Fix INCLUDE handling when pathname is on a separate line - Integrate updates to patches #0005 and #0014. Add testcases for - various legacy fortran extensions (#1586289) * Sat May 19 2018 Marek Polacek <polacek@redhat.com> 7.3.1-5.8 - bump for rebuild * Wed May 9 2018 Marek Polacek <polacek@redhat.com> 7.3.1-5.7 - fix 0014-Allow-non-logical-expressions-in-IF-statements.patch: also allow non logical expressions in ELSE-IF statements * Mon Apr 23 2018 Jeff Law <law@redhat.com> 7.3.1-5.6 - Fix handling of -fdlines-as-comments when -fdec is enabled (#1570967) * Tue Apr 17 2018 Marek Polacek <polacek@redhat.com> 7.3.1-5.5 - fix a goof in 0013-Allow-per-variable-kind-specification.patch * Thu Mar 29 2018 Jeff Law <law@redhat.com> 7.3.1-5.4 - Add Jakub's patch to generalize default exponent handling to instead cover all DEC runtime extensions
