re PR fortran/41579 ([OOP] Nesting of SELECT TYPE)

2009-10-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41579
	* gfortran.h (gfc_select_type_stack): New struct, to be used as a stack
	for SELECT TYPE statements.
	(select_type_stack): New global variable.
	(type_selector,select_type_tmp): Removed.
	* match.c (type_selector,type_selector): Removed.
	(select_type_stack): New variable, serving as a stack for
	SELECT TYPE statements.
	(select_type_push,select_type_set_tmp): New functions.
	(gfc_match_select_type): Call select_type_push.
	(gfc_match_type_is): Call select_type_set_tmp.
	* parse.c (select_type_pop): New function.
	(parse_select_type_block): Call select_type_pop.
	* symbol.c (select_type_insert_tmp): New function.
	(gfc_find_sym_tree): Call select_type_insert_tmp.


2009-10-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41579
	* gfortran.dg/select_type_6.f03: New test.

From-SVN: r152600

7 files changed, 135 insertions, 19 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9fac2a7..c54639a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2009-10-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41579
+	* gfortran.h (gfc_select_type_stack): New struct, to be used as a stack
+	for SELECT TYPE statements.
+	(select_type_stack): New global variable.
+	(type_selector,select_type_tmp): Removed.
+	* match.c (type_selector,type_selector): Removed.
+	(select_type_stack): New variable, serving as a stack for
+	SELECT TYPE statements.
+	(select_type_push,select_type_set_tmp): New functions.
+	(gfc_match_select_type): Call select_type_push.
+	(gfc_match_type_is): Call select_type_set_tmp.
+	* parse.c (select_type_pop): New function.
+	(parse_select_type_block): Call select_type_pop.
+	* symbol.c (select_type_insert_tmp): New function.
+	(gfc_find_sym_tree): Call select_type_insert_tmp.
+
 2009-10-07  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	* arith.c (arith_power): Use mpc_pow_z.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d6ad992..c602600 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2208,6 +2208,18 @@ iterator_stack;
 extern iterator_stack *iter_stack;
 
 
+/* Used for (possibly nested) SELECT TYPE statements.  */
+typedef struct gfc_select_type_stack
+{
+  gfc_symbol *selector;			/* Current selector variable.  */
+  gfc_symtree *tmp;			/* Current temporary variable.  */
+  struct gfc_select_type_stack *prev;	/* Previous element on stack.  */
+}
+gfc_select_type_stack;
+extern gfc_select_type_stack *select_type_stack;
+#define gfc_get_select_type_stack() XCNEW (gfc_select_type_stack)
+
+
 /* Node in the linked list used for storing finalizer procedures.  */
 
 typedef struct gfc_finalizer
@@ -2566,10 +2578,6 @@ void gfc_free_equiv (gfc_equiv *);
 void gfc_free_data (gfc_data *);
 void gfc_free_case_list (gfc_case *);
 
-/* Used for SELECT TYPE statements.  */
-extern gfc_symbol *type_selector;
-extern gfc_symtree *select_type_tmp;
-
 /* matchexp.c -- FIXME too?  */
 gfc_expr *gfc_get_parentheses (gfc_expr *);
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index d2c3ef0..3542944 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -29,9 +29,8 @@ along with GCC; see the file COPYING3.  If not see
 int gfc_matching_procptr_assignment = 0;
 bool gfc_matching_prefix = false;
 
-/* Used for SELECT TYPE statements.  */
-gfc_symbol *type_selector;
-gfc_symtree *select_type_tmp;
+/* Stack of SELECT TYPE statements.  */
+gfc_select_type_stack *select_type_stack = NULL;
 
 /* For debugging and diagnostic purposes.  Return the textual representation
    of the intrinsic operator OP.  */
@@ -4021,6 +4020,38 @@ gfc_match_select (void)
 }
 
 
+/* Push the current selector onto the SELECT TYPE stack.  */
+
+static void
+select_type_push (gfc_symbol *sel)
+{
+  gfc_select_type_stack *top = gfc_get_select_type_stack ();
+  top->selector = sel;
+  top->tmp = NULL;
+  top->prev = select_type_stack;
+
+  select_type_stack = top;
+}
+
+
+/* Set the temporary for the current SELECT TYPE selector.  */
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp;
+
+  sprintf (name, "tmp$%s", ts->u.derived->name);
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+  tmp->n.sym->ts = *ts;
+  tmp->n.sym->attr.referenced = 1;
+  tmp->n.sym->attr.pointer = 1;
+
+  select_type_stack->tmp = tmp;
+}
+
+
 /* Match a SELECT TYPE statement.  */
 
 match
@@ -4082,7 +4113,7 @@ gfc_match_select_type (void)
   new_st.expr2 = expr2;
   new_st.ext.ns = gfc_current_ns;
 
-  type_selector = expr1->symtree->n.sym;
+  select_type_push (expr1->symtree->n.sym);
 
   return MATCH_YES;
 }
@@ -4167,7 +4198,6 @@ gfc_match_type_is (void)
 {
   gfc_case *c = NULL;
   match m;
-  char name[GFC_MAX_SYMBOL_LEN];
 
   if (gfc_current_state () != COMP_SELECT_TYPE)
     {
@@ -4199,11 +4229,7 @@ gfc_match_type_is (void)
   new_st.ext.case_list = c;
 
   /* Create temporary variable.  */
-  sprintf (name, "tmp$%s", c->ts.u.derived->name);
-  gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false);
-  select_type_tmp->n.sym->ts = c->ts;
-  select_type_tmp->n.sym->attr.referenced = 1;
-  select_type_tmp->n.sym->attr.pointer = 1;
+  select_type_set_tmp (&c->ts);
 
   return MATCH_YES;
 
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 770c7ef..49d449c 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2887,6 +2887,17 @@ parse_select_block (void)
 }
 
 
+/* Pop the current selector from the SELECT TYPE stack.  */
+
+static void
+select_type_pop (void)
+{
+  gfc_select_type_stack *old = select_type_stack;
+  select_type_stack = old->prev;
+  gfc_free (old);
+}
+
+
 /* Parse a SELECT TYPE construct (F03:R821).  */
 
 static void
@@ -2959,6 +2970,7 @@ done:
   pop_state ();
   accept_statement (st);
   gfc_current_ns = gfc_current_ns->parent;
+  select_type_pop ();
 }
 
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index befa90b..2641df8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2461,6 +2461,19 @@ ambiguous_symbol (const char *name, gfc_symtree *st)
 }
 
 
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+   selector on the stack. If yes, replace it by the corresponding temporary.  */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+  gfc_select_type_stack *stack = select_type_stack;
+  for (; stack; stack = stack->prev)
+    if ((*st)->n.sym == stack->selector)
+      *st = stack->tmp;
+}
+
+
 /* Search for a symtree starting in the current namespace, resorting to
    any parent namespaces if requested by a nonzero parent_flag.
    Returns nonzero if the name is ambiguous.  */
@@ -2479,11 +2492,7 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
       st = gfc_find_symtree (ns->sym_root, name);
       if (st != NULL)
 	{
-	  /* Special case: If we're in a SELECT TYPE block,
-	    replace the selector variable by a temporary.  */
-	  if (gfc_current_state () == COMP_SELECT_TYPE
-	      && st && st->n.sym == type_selector)
-	    st = select_type_tmp;
+	  select_type_insert_tmp (&st);
 
 	  *result = st;
 	  /* Ambiguous generic interfaces are permitted, as long
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b971b73..537f11f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-10-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41579
+	* gfortran.dg/select_type_6.f03: New test.
+
 2009-10-09  Jakub Jelinek  <jakub@redhat.com>
 
 	PR preprocessor/41445
diff --git a/gcc/testsuite/gfortran.dg/select_type_6.f03 b/gcc/testsuite/gfortran.dg/select_type_6.f03
new file mode 100644
index 0000000..3b3c08e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_6.f03
@@ -0,0 +1,38 @@
+! { dg-do run }
+!
+! PR 41579: [OOP/Polymorphism] Nesting of SELECT TYPE
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+ type t1
+ end type t1
+
+ type, extends(t1) :: t2
+  integer :: i
+ end type t2
+
+ type, extends(t1) :: t3
+  integer :: j
+ end type t3
+
+ class(t1), allocatable :: mt2, mt3
+ allocate(t2 :: mt2)
+ allocate(t3 :: mt3)
+
+ select type (mt2)
+ type is(t2)
+   mt2%i = 5
+   print *,mt2%i
+   select type(mt3)
+   type is(t3)
+     mt3%j = 2*mt2%i
+     print *,mt3%j
+     if (mt3%j /= 10) call abort()
+   class default
+     call abort()
+   end select
+ class default
+   call abort()
+ end select
+
+end