Re: [Patch, fortran] PR fortran/50071 Duplicate statement labels from different scoping units rejected.

[Mikael Morin <mikael dot morin at sfr dot fr>]

On Sunday 14 August 2011 09:35:56 Tobias Burnus wrote:
> I think the following is valid and it is still rejected (it is accepted
> by NAG 5.1 and ifort):
> 
> 1 type t
>      integer :: i
>    end type t
> 
>    goto 1
> 1 print *, 'Hello'
> end
> 
> Related but separate issue: BLOCK also starts a new scoping unit, but
> the following is rejected:
> 
>     block
>       goto 1
>       print *, 'Hello'
> 1    continue
>     end block
> 1  continue
> end
> 
> 
> Also the following is rejected:
> 
>     block
>       goto 1
>       print *, 'Hello'
> 1  end block
> end
> 
> variant, which is rejected (note: Associate does not start a new scoping
> unit, just a new block):
> 
>    integer :: i
>    associate (j => i)
>      goto 1
>      print *, 'Hello'
> 1  end associate
> end
> 
Hem, OK; it is a can of Pandora.

I can propose the following ad-hoc fix for the two latter cases.

It uses the same hack as is used for IF, SELECT, and possibly others:
make a dummy code that will get the label.
The difference is that here, the dummy code is inserted in the nested scope 
(i.e. in the BLOCK or ASSOCIATE scope) instead of the parent one.

For consistency, I renamed EXEC_END_BLOCK to EXEC_END_NESTED_BLOCK, and reused 
EXEC_END_BLOCK for the new code.


The patch passes gfortran.dg/*goto* and gfortran.dg/*label*, and I'm doing a 
full regression test. Is that OK?



About your two former cases, the first one looks especially tricky. For the 
second one, it may be valid, but a warning would be nice IMO as one of the 
labels is masked by the other. Both cases need more investigation anyway.

Mikael.

Attachment: pr50071_3.CL
Description: Text document

diff --git a/gfortran.h b/gfortran.h
index 34afae4..bbccc08 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -2048,8 +2048,8 @@ gfc_association_list;
 /* Executable statements that fill gfc_code structures.  */
 typedef enum
 {
-  EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN,
-  EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
+  EXEC_NOP = 1, EXEC_END_NESTED_BLOCK, EXEC_END_BLOCK, EXEC_ASSIGN,
+  EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
diff --git a/parse.c b/parse.c
index 2910ab5..b894ee8 100644
--- a/parse.c
+++ b/parse.c
@@ -1115,6 +1115,8 @@ check_statement_label (gfc_statement st)
     case ST_ENDIF:
     case ST_END_SELECT:
     case ST_END_CRITICAL:
+    case ST_END_BLOCK:
+    case ST_END_ASSOCIATE:
     case_executable:
     case_exec_markers:
       type = ST_LABEL_TARGET;
@@ -1627,6 +1629,18 @@ accept_statement (gfc_statement st)
     case ST_END_CRITICAL:
       if (gfc_statement_label != NULL)
 	{
+	  new_st.op = EXEC_END_NESTED_BLOCK;
+	  add_statement ();
+	}
+      break;
+
+      /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
+         one parallel block.  Thus, we add the special code to the nested block
+	 itself, instead of the parent one.  */
+    case ST_END_BLOCK:
+    case ST_END_ASSOCIATE:
+      if (gfc_statement_label != NULL)
+	{
 	  new_st.op = EXEC_END_BLOCK;
 	  add_statement ();
 	}
diff --git a/resolve.c b/resolve.c
index b8a8ebb..fcb5083 100644
--- a/resolve.c
+++ b/resolve.c
@@ -8202,7 +8202,7 @@ find_reachable_labels (gfc_code *block)
      up through the code_stack.  */
   for (c = block; c; c = c->next)
     {
-      if (c->here && c->op != EXEC_END_BLOCK)
+      if (c->here && c->op != EXEC_END_NESTED_BLOCK)
 	bitmap_set_bit (cs_base->reachable_labels, c->here->value);
     }
 
@@ -8382,7 +8382,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 
   if (stack)
     {
-      gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
+      gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
       return;
     }
 
@@ -9118,6 +9118,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	{
 	case EXEC_NOP:
 	case EXEC_END_BLOCK:
+	case EXEC_END_NESTED_BLOCK:
 	case EXEC_CYCLE:
 	case EXEC_PAUSE:
 	case EXEC_STOP:
diff --git a/st.c b/st.c
index c051d6a..572baaf 100644
--- a/st.c
+++ b/st.c
@@ -89,6 +89,7 @@ gfc_free_statement (gfc_code *p)
     {
     case EXEC_NOP:
     case EXEC_END_BLOCK:
+    case EXEC_END_NESTED_BLOCK:
     case EXEC_ASSIGN:
     case EXEC_INIT_ASSIGN:
     case EXEC_GOTO:
diff --git a/trans.c b/trans.c
index 4c97cfd..4a71c43 100644
--- a/trans.c
+++ b/trans.c
@@ -1188,6 +1188,7 @@ trans_code (gfc_code * code, tree cond)
 	{
 	case EXEC_NOP:
 	case EXEC_END_BLOCK:
+	case EXEC_END_NESTED_BLOCK:
 	case EXEC_END_PROCEDURE:
 	  res = NULL_TREE;
 	  break;