From 6f21288f8c3579ec7ae47615e76ba1e6ad25551f Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Thu, 27 Oct 2016 21:55:12 +0200 Subject: [PATCH] re PR fortran/78026 (ICE in gfc_resolve_omp_declare_simd, at fortran/openmp.c:5190) PR fortran/78026 * parse.c (decode_statement): Don't create namespace for possible select type here and destroy it afterwards. (parse_select_type_block): Set gfc_current_ns to new_st.ext.block.ns. (parse_executable, gfc_parse_file): Formatting fixes. * match.c (gfc_match_select_type): Create namespace for select type here, only after matching select type. Formatting fixes. Free that namespace if not returning MATCH_YES, after gfc_undo_symbols, otherwise remember it in new_st.ext.block.ns and switch to parent namespace anyway. * gfortran.dg/gomp/pr78026.f03: New test. * gfortran.dg/select_type_38.f03: New test. From-SVN: r241630 --- gcc/fortran/ChangeLog | 29 +++++++++++++++++------- gcc/fortran/match.c | 34 ++++++++++++++++++---------- gcc/fortran/parse.c | 21 ++++------------- gcc/testsuite/ChangeLog | 10 +++++--- gcc/testsuite/gfortran.dg/gomp/pr78026.f03 | 5 ++++ gcc/testsuite/gfortran.dg/select_type_38.f03 | 10 ++++++++ 6 files changed, 70 insertions(+), 39 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr78026.f03 create mode 100644 gcc/testsuite/gfortran.dg/select_type_38.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 085fd0d..625189f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,4 +1,17 @@ -2016-10-27 Fritz Reese +2016-10-27 Jakub Jelinek + + PR fortran/78026 + * parse.c (decode_statement): Don't create namespace for possible + select type here and destroy it afterwards. + (parse_select_type_block): Set gfc_current_ns to new_st.ext.block.ns. + (parse_executable, gfc_parse_file): Formatting fixes. + * match.c (gfc_match_select_type): Create namespace for select type + here, only after matching select type. Formatting fixes. Free that + namespace if not returning MATCH_YES, after gfc_undo_symbols, + otherwise remember it in new_st.ext.block.ns and switch to parent + namespace anyway. + +2016-10-27 Fritz Reese * expr.c (generate_union_initializer, get_union_initializer): New. * expr.c (component_initializer): Consider BT_UNION specially. @@ -21,7 +34,7 @@ suppress the error and return if the same procedure symbol is added more than once to the interface. -2016-10-26 Fritz Reese +2016-10-26 Fritz Reese * frontend-passes.c (gfc_code_walker): Add SHARE and CARRIAGECONTROL. * io.c (gfc_free_open, gfc_resolve_open, gfc_match_open): Ditto. @@ -32,7 +45,7 @@ * io.c (match_dec_etag, match_dec_ftag): New functions. * gfortran.texi: Document. -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * gfortran.texi: Document. * resolve.c (logical_to_bitwise): New function. @@ -56,17 +69,17 @@ * intrinsic.texi (cosd): New mathop. -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * match.c (gfc_match_intrinsic_op): Match ".XOR." with -std=legacy. * gfortran.texi: Document. -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * primary.c (gfc_match_rvalue): Match %LOC as LOC with -std=legacy. * gfortran.texi: Document. -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * decl.c (gfc_match_type): New function. * match.h (gfc_match_type): New function. @@ -74,12 +87,12 @@ * gfortran.texi: Update documentation. * parse.c (decode_statement): Invoke gfc_match_type. -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * gfortran.texi: Document. * gfortran.h (gfc_is_whitespace): Include form feed ('\f'). -2016-10-25 Fritz Reese +2016-10-25 Fritz Reese * invoke.texi, gfortran.texi: Touch up documentation of -fdec. * gfortran.h (gfc_option): Move flag_dec_structure out of gfc_option. diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 94aa830..0996a9e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5882,6 +5882,7 @@ gfc_match_select_type (void) char name[GFC_MAX_SYMBOL_LEN]; bool class_array; gfc_symbol *sym; + gfc_namespace *ns = gfc_current_ns; m = gfc_match_label (); if (m == MATCH_ERROR) @@ -5891,10 +5892,11 @@ gfc_match_select_type (void) if (m != MATCH_YES) return m; + gfc_current_ns = gfc_build_block_ns (ns); m = gfc_match (" %n => %e", name, &expr2); if (m == MATCH_YES) { - expr1 = gfc_get_expr(); + expr1 = gfc_get_expr (); expr1->expr_type = EXPR_VARIABLE; if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) { @@ -5916,7 +5918,11 @@ gfc_match_select_type (void) { m = gfc_match (" %e ", &expr1); if (m != MATCH_YES) - return m; + { + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; + } } m = gfc_match (" )%t"); @@ -5932,19 +5938,19 @@ gfc_match_select_type (void) allowed by the standard. TODO: see if it is sufficient to exclude component and substring references. */ - class_array = expr1->expr_type == EXPR_VARIABLE - && expr1->ts.type == BT_CLASS - && CLASS_DATA (expr1) - && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) - && (CLASS_DATA (expr1)->attr.dimension - || CLASS_DATA (expr1)->attr.codimension) - && expr1->ref - && expr1->ref->type == REF_ARRAY - && expr1->ref->next == NULL; + class_array = (expr1->expr_type == EXPR_VARIABLE + && expr1->ts.type == BT_CLASS + && CLASS_DATA (expr1) + && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) + && (CLASS_DATA (expr1)->attr.dimension + || CLASS_DATA (expr1)->attr.codimension) + && expr1->ref + && expr1->ref->type == REF_ARRAY + && expr1->ref->next == NULL); /* Check for F03:C811. */ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE - || (!class_array && expr1->ref != NULL))) + || (!class_array && expr1->ref != NULL))) { gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " "use associate-name=>"); @@ -5958,12 +5964,16 @@ gfc_match_select_type (void) new_st.ext.block.ns = gfc_current_ns; select_type_push (expr1->symtree->n.sym); + gfc_current_ns = ns; return MATCH_YES; cleanup: gfc_free_expr (expr1); gfc_free_expr (expr2); + gfc_undo_symbols (); + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); return m; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 760d3af..2aa2afc 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -295,7 +295,6 @@ static bool in_specification_block; static gfc_statement decode_statement (void) { - gfc_namespace *ns; gfc_statement st; locus old_locus; match m = MATCH_NO; @@ -424,12 +423,7 @@ decode_statement (void) match (NULL, gfc_match_associate, ST_ASSOCIATE); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); - - gfc_current_ns = gfc_build_block_ns (gfc_current_ns); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); - ns = gfc_current_ns; - gfc_current_ns = gfc_current_ns->parent; - gfc_free_namespace (ns); /* General statement matching: Instead of testing every possible statement, we eliminate most possibilities by peeking at the @@ -4103,6 +4097,7 @@ parse_select_type_block (void) gfc_code *cp; gfc_state_data s; + gfc_current_ns = new_st.ext.block.ns; accept_statement (ST_SELECT_TYPE); cp = gfc_state_stack->tail; @@ -5188,7 +5183,7 @@ parse_executable (gfc_statement st) break; case ST_SELECT_TYPE: - parse_select_type_block(); + parse_select_type_block (); break; case ST_DO: @@ -6027,12 +6022,11 @@ loop: prog_locus = gfc_current_locus; push_state (&s, COMP_PROGRAM, gfc_new_block); - main_program_symbol(gfc_current_ns, gfc_new_block->name); + main_program_symbol (gfc_current_ns, gfc_new_block->name); accept_statement (st); add_global_program (); parse_progunit (ST_NONE); goto prog_units; - break; case ST_SUBROUTINE: add_global_procedure (true); @@ -6040,7 +6034,6 @@ loop: accept_statement (st); parse_progunit (ST_NONE); goto prog_units; - break; case ST_FUNCTION: add_global_procedure (false); @@ -6048,7 +6041,6 @@ loop: accept_statement (st); parse_progunit (ST_NONE); goto prog_units; - break; case ST_BLOCK_DATA: push_state (&s, COMP_BLOCK_DATA, gfc_new_block); @@ -6083,7 +6075,6 @@ loop: main_program_symbol (gfc_current_ns, "MAIN__"); parse_progunit (st); goto prog_units; - break; } /* Handle the non-program units. */ @@ -6132,14 +6123,12 @@ prog_units: pop_state (); goto loop; - done: - +done: /* Do the resolution. */ resolve_all_program_units (gfc_global_ns_list); /* Do the parse tree dump. */ - gfc_current_ns - = flag_dump_fortran_original ? gfc_global_ns_list : NULL; + gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) if (!gfc_current_ns->proc_name diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9ce3f64..a8d187c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,9 +1,13 @@ 2016-10-27 Jakub Jelinek + PR fortran/78026 + * gfortran.dg/gomp/pr78026.f03: New test. + * gfortran.dg/select_type_38.f03: New test. + PR middle-end/78025 * g++.dg/gomp/declare-simd-7.C: New test. -2016-10-27 Fritz Reese +2016-10-27 Fritz Reese * gfortran.dg/dec_init_1.f90: Remove -fdump-tree-original. * gfortran.dg/dec_init_2.f90: Likewise. @@ -14,7 +18,7 @@ * gcc.dg/fold-narrowbopcst-1.c: New test. -2016-10-27 Fritz Reese +2016-10-27 Fritz Reese * gfortran.dg/dec_io_5.f90: Don't use "test.txt", and use dg-shouldfail/dg-output instead of XFAIL. @@ -70,7 +74,7 @@ * gfortran.dg/pr78061.f: New test. * g++.dg/pr78088.C: New test. -2016-10-26 Fritz Reese +2016-10-26 Fritz Reese * gfortran.dg/dec_io_1.f90: New test. * gfortran.dg/dec_io_2.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 b/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 new file mode 100644 index 0000000..61f9458 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 @@ -0,0 +1,5 @@ +! PR fortran/78026 +select type (a) ! { dg-error "Selector shall be polymorphic in SELECT TYPE statement" } +end select +!$omp declare simd(b) ! { dg-error "Unexpected !.OMP DECLARE SIMD statement" } +end ! { dg-error "should refer to containing procedure" "" { target *-*-* } .-1 } diff --git a/gcc/testsuite/gfortran.dg/select_type_38.f03 b/gcc/testsuite/gfortran.dg/select_type_38.f03 new file mode 100644 index 0000000..a643e99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_38.f03 @@ -0,0 +1,10 @@ + type :: t1 + end type + type, extends(t1) :: t2 + end type + class(t1), pointer :: a +lab1: select type (a) + end select lab1 +lab1: select type (a) ! { dg-error "Duplicate construct label" } + end select lab1 ! { dg-error "Expecting END PROGRAM statement" } +end -- 2.7.4