From 87c9fca50cbe7ca997fa4aaa70f5aa44d9e5db79 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sun, 23 Oct 2016 18:12:28 +0000 Subject: [PATCH] re PR fortran/54730 (ICE in gfc_typenode_for_spec, at fortran/trans-types.c:1066) 2016-10-23 Steven G. Kargl PR fortran/54730 PR fortran/78033 * array.c (gfc_match_array_constructor): Remove checkpointing introduced in r196416 (original fix for PR fortran/54730). Move initialization to top of function. * match.c (gfc_match_type_spec): Special case matching for REAL. 2016-10-23 Steven G. Kargl PR fortran/54730 PR fortran/78033 * gfortran.dg/pr78033.f90: New test. From-SVN: r241451 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/array.c | 28 +++------ gcc/fortran/match.c | 115 ++++++++++++++++++++++++++++++---- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/pr78033.f90 | 23 +++++++ 5 files changed, 147 insertions(+), 34 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr78033.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d057d0f..0931104 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2016-10-23 Steven G. Kargl + + PR fortran/54730 + PR fortran/78033 + * array.c (gfc_match_array_constructor): Remove checkpointing + introduced in r196416 (original fix for PR fortran/54730). Move + initialization to top of function. + * match.c (gfc_match_type_spec): Special case matching for REAL. + 2016-10-23 Paul Thomas PR fortran/69834 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 3e0218a..e6917a5 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1091,7 +1091,6 @@ gfc_match_array_constructor (gfc_expr **result) { gfc_constructor *c; gfc_constructor_base head; - gfc_undo_change_set changed_syms; gfc_expr *expr; gfc_typespec ts; locus where; @@ -1099,6 +1098,9 @@ gfc_match_array_constructor (gfc_expr **result) const char *end_delim; bool seen_ts; + head = NULL; + seen_ts = false; + if (gfc_match (" (/") == MATCH_NO) { if (gfc_match (" [") == MATCH_NO) @@ -1115,12 +1117,9 @@ gfc_match_array_constructor (gfc_expr **result) end_delim = " /)"; where = gfc_current_locus; - head = NULL; - seen_ts = false; /* Try to match an optional "type-spec ::" */ gfc_clear_ts (&ts); - gfc_new_undo_checkpoint (changed_syms); m = gfc_match_type_spec (&ts); if (m == MATCH_YES) { @@ -1130,16 +1129,12 @@ gfc_match_array_constructor (gfc_expr **result) { if (!gfc_notify_std (GFC_STD_F2003, "Array constructor " "including type specification at %C")) - { - gfc_restore_last_undo_checkpoint (); - goto cleanup; - } + goto cleanup; if (ts.deferred) { gfc_error ("Type-spec at %L cannot contain a deferred " "type parameter", &where); - gfc_restore_last_undo_checkpoint (); goto cleanup; } @@ -1148,24 +1143,15 @@ gfc_match_array_constructor (gfc_expr **result) { gfc_error ("Type-spec at %L cannot contain an asterisk for a " "type parameter", &where); - gfc_restore_last_undo_checkpoint (); goto cleanup; } } } else if (m == MATCH_ERROR) - { - gfc_restore_last_undo_checkpoint (); - goto cleanup; - } + goto cleanup; - if (seen_ts) - gfc_drop_last_undo_checkpoint (); - else - { - gfc_restore_last_undo_checkpoint (); - gfc_current_locus = where; - } + if (!seen_ts) + gfc_current_locus = where; if (gfc_match (end_delim) == MATCH_YES) { diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index a19968b..ae9e1d0 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1989,6 +1989,7 @@ gfc_match_type_spec (gfc_typespec *ts) { match m; locus old_locus; + char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_clear_ts (ts); gfc_gobble_whitespace (); @@ -2013,13 +2014,6 @@ gfc_match_type_spec (gfc_typespec *ts) goto kind_selector; } - if (gfc_match ("real") == MATCH_YES) - { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - goto kind_selector; - } - if (gfc_match ("double precision") == MATCH_YES) { ts->type = BT_REAL; @@ -2053,6 +2047,103 @@ gfc_match_type_spec (gfc_typespec *ts) goto kind_selector; } + /* REAL is a real pain because it can be a type, intrinsic subprogram, + or list item in a type-list of an OpenMP reduction clause. Need to + differentiate REAL([KIND]=scalar-int-initialization-expr) from + REAL(A,[KIND]) and REAL(KIND,A). */ + + m = gfc_match (" %n", name); + if (m == MATCH_YES && strcmp (name, "real") == 0) + { + char c; + gfc_expr *e; + locus where; + + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + + gfc_gobble_whitespace (); + + /* Prevent REAL*4, etc. */ + c = gfc_peek_ascii_char (); + if (c == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + /* Found leading colon in REAL::, a trailing ')' in for example + TYPE IS (REAL), or REAL, for an OpenMP list-item. */ + if (c == ':' || c == ')' || (flag_openmp && c == ',')) + return MATCH_YES; + + /* Found something other than the opening '(' in REAL(... */ + if (c != '(') + return MATCH_NO; + else + gfc_next_char (); /* Burn the '('. */ + + /* Look for the optional KIND=. */ + where = gfc_current_locus; + m = gfc_match ("%n", name); + if (m == MATCH_YES) + { + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (c == '=') + { + if (strcmp(name, "a") == 0) + return MATCH_NO; + else if (strcmp(name, "kind") == 0) + goto found; + else + return MATCH_ERROR; + } + else + gfc_current_locus = where; + } + else + gfc_current_locus = where; + +found: + + m = gfc_match_init_expr (&e); + if (m == MATCH_NO || m == MATCH_ERROR) + return MATCH_NO; + + /* If a comma appears, it is an intrinsic subprogram. */ + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == ',') + { + gfc_free_expr (e); + return MATCH_NO; + } + + /* If ')' appears, we have REAL(initialization-expr), here check for + a scalar integer initialization-expr and valid kind parameter. */ + if (c == ')') + { + if (e->ts.type != BT_INTEGER || e->rank > 0) + { + gfc_free_expr (e); + return MATCH_NO; + } + + gfc_next_char (); /* Burn the ')'. */ + ts->kind = (int) mpz_get_si (e->value.integer); + if (gfc_validate_kind (BT_REAL, ts->kind , true) == -1) + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + gfc_free_expr (e); + + return MATCH_YES; + } + } + /* If a type is not matched, simply return MATCH_NO. */ gfc_current_locus = old_locus; return MATCH_NO; @@ -2060,6 +2151,8 @@ gfc_match_type_spec (gfc_typespec *ts) kind_selector: gfc_gobble_whitespace (); + + /* This prevents INTEGER*4, etc. */ if (gfc_peek_ascii_char () == '*') { gfc_error ("Invalid type-spec at %C"); @@ -2068,13 +2161,9 @@ kind_selector: m = gfc_match_kind_spec (ts, false); + /* No kind specifier found. */ if (m == MATCH_NO) - m = MATCH_YES; /* No kind specifier found. */ - - /* gfortran may have matched REAL(a=1), which is the keyword form of the - intrinsic procedure. */ - if (ts->type == BT_REAL && m == MATCH_ERROR) - m = MATCH_NO; + m = MATCH_YES; return m; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8178f8d..6d2c80f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2016-10-23 Steven G. Kargl + + PR fortran/54730 + PR fortran/78033 + * gfortran.dg/pr78033.f90: New test. + 2016-10-23 Paul Thomas PR fortran/69834 diff --git a/gcc/testsuite/gfortran.dg/pr78033.f90 b/gcc/testsuite/gfortran.dg/pr78033.f90 new file mode 100644 index 0000000..ce794b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr78033.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +subroutine f(n, x, y) + + implicit none + + integer, parameter :: knd = kind(1.e0) + + integer, intent(in) :: n + complex(knd), intent(in) :: x(1:n) + + integer i + real(knd) y(2*n) + + y = [real(x), aimag(x)] + y = [real(x(1:n)), aimag(x(1:n))] + y = [real(knd) :: 1] + y = [real(kind=42) :: 1] { dg-error "Invalid type-spec" } + y = [real(kind=knd) :: 1] + y = [real(kind=knd, a=1.)] + y = [real(a=1.)] + y = [real(a=1, kind=knd)] + +end subroutine f -- 2.7.4