Hi!
This PR has been reported as something related to OpenMP, but in the end
I think it is unrelated, the bug I see is in the select type parsing.
The problem is that if select type is the very first stmt in the TU,
we parse it and before actually accepting that ST_SELECT_TYPE, we perform
various tasks needed for MAIN__ - e.g. assign gfc_current_ns proc_name.
The problem is that when parsing select type, we create a nested
gfc_namespace and so the name is assigned to this nested namespace rather
than its parent (and various other operations done on this namespace).
Also, it seems decode_statement is grossly inefficient, for any of the
statements handled in the /* General statement matching: ... */
switch we allocate a new namespace:
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);
only to free it a few lines later in the likely case that we aren't seeing
select type. And in select_type_38.f03 testcase below I've also tried
to construct a testcase where it is invalid - because the gfc_match_label
on the select_type already goes into the new namespace, no errors are
diagnosed if the same label is used on multiple select type statements
(but we diagnose same label on select case, if etc.).
So, the patch defers creating the new namespace until we really need it
(thus, label is put still into the parent namespace, and only create
the namespace after successfully parsing select type (, and then arrange
either if we don't return MATCH_YES to free the namespace again in the
gfc_match_select_type, or, when returning MATCH_YES, to keep the namespace
only in new_st.ext.block.ns and not in gfc_current_ns. Then, only in
parse_select_type_block we switch back to that namespace.
Bootstrapped/regtested on x86_64-linux and i686-linux, ok for trunk?
2016-10-27 Jakub Jelinek <ja...@redhat.com>
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.
--- gcc/fortran/parse.c.jj 2016-10-25 18:23:27.000000000 +0200
+++ gcc/fortran/parse.c 2016-10-27 12:19:52.843900690 +0200
@@ -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
--- gcc/fortran/match.c.jj 2016-10-25 18:23:27.000000000 +0200
+++ gcc/fortran/match.c 2016-10-27 12:38:37.727813583 +0200
@@ -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;
}
--- gcc/testsuite/gfortran.dg/gomp/pr78026.f03.jj 2016-10-27
12:27:16.142335687 +0200
+++ gcc/testsuite/gfortran.dg/gomp/pr78026.f03 2016-10-27 12:26:53.000000000
+0200
@@ -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 }
--- gcc/testsuite/gfortran.dg/select_type_38.f03.jj 2016-10-27
12:28:32.423381918 +0200
+++ gcc/testsuite/gfortran.dg/select_type_38.f03 2016-10-27
12:28:13.000000000 +0200
@@ -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
Jakub
