OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Janus Weil 2009-10-09 22:25:19 +02:00
parent 21ece9b288
commit 7431bf06bc
7 changed files with 135 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View File

@ -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.

16
gcc/fortran/gfortran.h
View File

@ -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 *);

46
gcc/fortran/match.c
View File

@ -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;

12
gcc/fortran/parse.c
View File

@ -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 ();
}

19
gcc/fortran/symbol.c
View File

@ -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

5
gcc/testsuite/ChangeLog
View File

@ -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

38
gcc/testsuite/gfortran.dg/select_type_6.f03 Normal file
View File

@ -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