diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9fac2a77322..c54639a15b5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2009-10-09 Janus Weil + + 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 * arith.c (arith_power): Use mpc_pow_z. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d6ad992dda7..c602600165b 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 d2c3ef021f4..3542944a50b 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 770c7efe9f6..49d449cfdc8 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 befa90b8c49..2641df82b35 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 b971b731402..537f11fb140 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-10-09 Janus Weil + + PR fortran/41579 + * gfortran.dg/select_type_6.f03: New test. + 2009-10-09 Jakub Jelinek 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 00000000000..3b3c08e2296 --- /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 + + 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