+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.
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
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 *);
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. */
}
+/* 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
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;
}
{
gfc_case *c = NULL;
match m;
- char name[GFC_MAX_SYMBOL_LEN];
if (gfc_current_state () != COMP_SELECT_TYPE)
{
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;
}
+/* 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
pop_state ();
accept_statement (st);
gfc_current_ns = gfc_current_ns->parent;
+ select_type_pop ();
}
}
+/* 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. */
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
+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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
