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

re PR fortran/41600 ([OOP] SELECT TYPE with associate-name => exp: Arrays not supported) 

2012-05-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* trans-array.c (build_array_ref): New static function.
	(gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
	* trans-expr.c (gfc_get_vptr_from_expr): New function.
	(gfc_conv_derived_to_class): Add a new argument for a caller
	supplied vptr and use it if it is not NULL.
	(gfc_conv_procedure_call): Add NULL to call to above.
	symbol.c (gfc_is_associate_pointer): Return true if symbol is
	a class object.
	* trans-stmt.c (trans_associate_var): Handle class associate-
	names.
	* expr.c (gfc_get_variable_expr): Supply the array-spec if
	possible.
	* trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
	for class types.
	* trans.h : Add prototypes for gfc_get_vptr_from_expr and
	gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
	* resolve.c (resolve_variable): For class arrays, ensure that
	the target expression has all the necessary _data references.
	(resolve_assoc_var): Throw a "not yet implemented" error for
	class array selectors that need a temporary.
	* match.c (copy_ts_from_selector_to_associate,
	select_derived_set_tmp, select_class_set_tmp): New functions.
	(select_type_set_tmp): Call one of last two new functions.
	(gfc_match_select_type): Copy_ts_from_selector_to_associate is
	called if associate-name is typed.

	PR fortran/53191
	* resolve.c (resolve_ref): C614 applied to class expressions.


2012-05-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* gfortran.dg/select_type_26.f03 : New test.
	* gfortran.dg/select_type_27.f03 : New test.

	PR fortran/53191
	* gfortran.dg/select_type_28.f03 : New test.

From-SVN: r187192
This commit is contained in:
Paul Thomas 2012-05-05 08:49:43 +00:00
parent 4ecad771dd
commit 8f75db9fd3
14 changed files with 623 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/fortran/ChangeLog
View File

@ -1,3 +1,35 @@
2012-05-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41600
* trans-array.c (build_array_ref): New static function.
(gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
* trans-expr.c (gfc_get_vptr_from_expr): New function.
(gfc_conv_derived_to_class): Add a new argument for a caller
supplied vptr and use it if it is not NULL.
(gfc_conv_procedure_call): Add NULL to call to above.
symbol.c (gfc_is_associate_pointer): Return true if symbol is
a class object.
* trans-stmt.c (trans_associate_var): Handle class associate-
names.
* expr.c (gfc_get_variable_expr): Supply the array-spec if
possible.
* trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
for class types.
* trans.h : Add prototypes for gfc_get_vptr_from_expr and
gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
* resolve.c (resolve_variable): For class arrays, ensure that
the target expression has all the necessary _data references.
(resolve_assoc_var): Throw a "not yet implemented" error for
class array selectors that need a temporary.
* match.c (copy_ts_from_selector_to_associate,
select_derived_set_tmp, select_class_set_tmp): New functions.
(select_type_set_tmp): Call one of last two new functions.
(gfc_match_select_type): Copy_ts_from_selector_to_associate is
called if associate-name is typed.
PR fortran/53191
* resolve.c (resolve_ref): C614 applied to class expressions.
2012-05-05 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/49010

3
gcc/fortran/expr.c
View File

@ -3821,6 +3821,9 @@ gfc_get_variable_expr (gfc_symtree *var)
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
? CLASS_DATA (var->n.sym)->as
: var->n.sym->as);
}
return e;

209
gcc/fortran/match.c
View File

@ -5112,6 +5112,78 @@ gfc_match_select (void)
}
/* Transfer the selector typespec to the associate name. */
static void
copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
assoc_sym = associate->symtree->n.sym;
/* Ensure that any array reference is resolved. */
gfc_resolve_expr (selector);
/* At this stage the expression rank and arrayspec dimensions have
not been completely sorted out. We must get the expr2->rank
right here, so that the correct class container is obtained. */
ref = selector->ref;
while (ref && ref->next)
ref = ref->next;
if (selector->ts.type == BT_CLASS
&& CLASS_DATA (selector)->as
&& ref && ref->type == REF_ARRAY)
{
if (ref->u.ar.type == AR_FULL)
selector->rank = CLASS_DATA (selector)->as->rank;
else if (ref->u.ar.type == AR_SECTION)
selector->rank = ref->u.ar.dimen;
else
selector->rank = 0;
}
if (selector->ts.type != BT_CLASS)
{
/* The correct class container has to be available. */
if (selector->rank)
{
assoc_sym->attr.dimension = 1;
assoc_sym->as = gfc_get_array_spec ();
assoc_sym->as->rank = selector->rank;
assoc_sym->as->type = AS_DEFERRED;
}
else
assoc_sym->as = NULL;
assoc_sym->ts.type = BT_CLASS;
assoc_sym->ts.u.derived = selector->ts.u.derived;
assoc_sym->attr.pointer = 1;
gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
&assoc_sym->as, false);
}
else
{
/* The correct class container has to be available. */
if (selector->rank)
{
assoc_sym->attr.dimension = 1;
assoc_sym->as = gfc_get_array_spec ();
assoc_sym->as->rank = selector->rank;
assoc_sym->as->type = AS_DEFERRED;
}
else
assoc_sym->as = NULL;
assoc_sym->ts.type = BT_CLASS;
assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
assoc_sym->attr.pointer = 1;
gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
&assoc_sym->as, false);
}
}
/* Push the current selector onto the SELECT TYPE stack. */
static void
@ -5126,14 +5198,85 @@ select_type_push (gfc_symbol *sel)
}
/* Set the temporary for the current SELECT TYPE selector. */
/* Set the temporary for the current derived type SELECT TYPE selector. */
static void
select_type_set_tmp (gfc_typespec *ts)
static gfc_symtree *
select_derived_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
return tmp;
}
/* Set the temporary for the current class SELECT TYPE selector. */
static gfc_symtree *
select_class_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
if (select_type_stack->selector->ts.type == BT_CLASS
&& !select_type_stack->selector->attr.class_ok)
return NULL;
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
tmp->n.sym->attr.pointer = 1;
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
return tmp;
}
static void
select_type_set_tmp (gfc_typespec *ts)
{
gfc_symtree *tmp;
if (!ts)
{
select_type_stack->tmp = NULL;
@ -5143,47 +5286,15 @@ select_type_set_tmp (gfc_typespec *ts)
if (!gfc_type_is_extensible (ts->u.derived))
return;
/* Logic is a LOT clearer with separate functions for class and derived
type temporaries! There are not many more lines of code either. */
if (ts->type == BT_CLASS)
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
tmp = select_class_set_tmp (ts);
else
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
tmp = select_derived_set_tmp (ts);
/* Copy across the array spec to the selector, taking care as to
whether or not it is a class object or not. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
if (ts->type == BT_CLASS)
{
CLASS_DATA (tmp->n.sym)->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
CLASS_DATA (tmp->n.sym)->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
CLASS_DATA (tmp->n.sym)->as
= CLASS_DATA (select_type_stack->selector)->as;
}
else
{
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as = gfc_get_array_spec ();
tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
}
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
if (tmp == NULL)
return;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
@ -5194,7 +5305,7 @@ select_type_set_tmp (gfc_typespec *ts)
select_type_stack->tmp = tmp;
}
/* Match a SELECT TYPE statement. */
match
@ -5204,6 +5315,7 @@ gfc_match_select_type (void)
match m;
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
gfc_symbol *sym;
m = gfc_match_label ();
if (m == MATCH_ERROR)
@ -5225,13 +5337,16 @@ gfc_match_select_type (void)
m = MATCH_ERROR;
goto cleanup;
}
sym = expr1->symtree->n.sym;
if (expr2->ts.type == BT_UNKNOWN)
expr1->symtree->n.sym->attr.untyped = 1;
sym->attr.untyped = 1;
else
expr1->symtree->n.sym->ts = expr2->ts;
expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
expr1->symtree->n.sym->attr.referenced = 1;
expr1->symtree->n.sym->attr.class_ok = 1;
copy_ts_from_selector_to_associate (expr1, expr2);
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
sym->attr.class_ok = 1;
}
else
{

42
gcc/fortran/resolve.c
View File

@ -4904,14 +4904,19 @@ resolve_ref (gfc_expr *expr)
{
/* F03:C614. */
if (ref->u.c.component->attr.pointer
|| ref->u.c.component->attr.proc_pointer)
|| ref->u.c.component->attr.proc_pointer
|| (ref->u.c.component->ts.type == BT_CLASS
&& CLASS_DATA (ref->u.c.component)->attr.pointer))
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
"attribute at %L", &expr->where);
return FAILURE;
}
else if (ref->u.c.component->attr.allocatable)
else if (ref->u.c.component->attr.allocatable
|| (ref->u.c.component->ts.type == BT_CLASS
&& CLASS_DATA (ref->u.c.component)->attr.allocatable))
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
@ -5081,9 +5086,15 @@ resolve_variable (gfc_expr *e)
}
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case. */
if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return FAILURE;
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
{
if (sym->ts.type == BT_CLASS)
gfc_fix_class_refs (e);
if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return FAILURE;
}
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
@ -7941,7 +7952,7 @@ gfc_type_is_extensible (gfc_symbol *sym)
}
/* Resolve an associate name: Resolve target and ensure the type-spec is
/* Resolve an associate-name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
@ -7997,8 +8008,25 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
sym->attr.dimension = 0;
return;
}
if (target->rank > 0)
/* We cannot deal with class selectors that need temporaries. */
if (target->ts.type == BT_CLASS
&& gfc_ref_needs_temporary_p (target->ref))
{
gfc_error ("CLASS selector at %L needs a temporary which is not "
"yet implemented", &target->where);
return;
}
if (target->ts.type != BT_CLASS && target->rank > 0)
sym->attr.dimension = 1;
else if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
/* The associate-name will have a correct type by now. Make absolutely
sure that it has not picked up a dimension attribute. */
if (sym->ts.type == BT_CLASS)
sym->attr.dimension = 0;
if (sym->attr.dimension)
{

3
gcc/fortran/symbol.c
View File

@ -4882,6 +4882,9 @@ gfc_is_associate_pointer (gfc_symbol* sym)
if (!sym->assoc)
return false;
if (sym->ts.type == BT_CLASS)
return true;
if (!sym->assoc->variable)
return false;

40
gcc/fortran/trans-array.c
View File

@ -3068,6 +3068,36 @@ add_to_offset (tree *cst_offset, tree *offset, tree t)
}
}
static tree
build_array_ref (tree desc, tree offset, tree decl)
{
tree tmp;
/* Class array references need special treatment because the assigned
type size needs to be used to point to the element. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& TREE_CODE (desc) == COMPONENT_REF
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
{
tree type = gfc_get_element_type (TREE_TYPE (desc));
tmp = TREE_OPERAND (desc, 0);
tmp = gfc_get_class_array_ref (offset, tmp);
tmp = fold_convert (build_pointer_type (type), tmp);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
}
else
{
tmp = gfc_conv_array_data (desc);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = gfc_build_array_ref (tmp, offset, decl);
}
return tmp;
}
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be
@ -3195,10 +3225,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
}
@ -6010,10 +6037,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
return;
}
tmp = gfc_conv_array_data (desc);
tmp = build_fold_indirect_ref_loc (input_location,
tmp);
tmp = gfc_build_array_ref (tmp, offset, NULL);
tmp = build_array_ref (desc, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */

40
gcc/fortran/trans-expr.c
View File

@ -147,11 +147,25 @@ gfc_vtable_copy_get (tree decl)
#undef VTABLE_COPY_FIELD
/* Obtain the vptr of the last class reference in an expression. */
tree
gfc_get_vptr_from_expr (tree expr)
{
tree tmp = expr;
while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
tmp = TREE_OPERAND (tmp, 0);
tmp = gfc_class_vptr_get (tmp);
return tmp;
}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. */
static void
class object of the 'declared' type. If vptr is not NULL, this is
used for the temporary class object. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
gfc_typespec class_ts, tree vptr)
{
gfc_symbol *vtab;
gfc_ss *ss;
@ -167,11 +181,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
if (vptr != NULL_TREE)
{
/* Use the dynamic vptr. */
tmp = vptr;
}
else
{
/* In this case the vtab corresponds to the derived type and the
vptr must point to it. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
}
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
@ -3531,7 +3553,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
gfc_conv_derived_to_class (&parmse, e, fsym->ts);
gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
}
else if (se->ss && se->ss->info->useflags)
{

51
gcc/fortran/trans-stmt.c
View File

@ -1140,6 +1140,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_expr *e;
tree tmp;
bool class_target;
tree desc;
tree offset;
tree dim;
int n;
gcc_assert (sym->assoc);
e = sym->assoc->target;
@ -1191,8 +1195,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_finish_block (&se.post));
}
/* CLASS arrays just need the descriptor to be directly assigned. */
else if (class_target && sym->attr.dimension)
/* Derived type temporaries, arising from TYPE IS, just need the
descriptor of class arrays to be assigned directly. */
else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension)
{
gfc_se se;
@ -1217,7 +1222,47 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
/* Class associate-names come this way because they are
unconditionally associate pointers and the symbol is scalar. */
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
/* For a class array we need a descriptor for the selector. */
gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e));
/* Obtain a temporary class container for the result. */
gfc_conv_class_to_class (&se, e, sym->ts, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
/* Set the offset. */
desc = gfc_class_data_get (se.expr);
offset = gfc_index_zero_node;
for (n = 0; n < e->rank; n++)
{
dim = gfc_rank_cst[n];
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
gfc_conv_descriptor_stride_get (desc, dim),
gfc_conv_descriptor_lbound_get (desc, dim));
offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
offset, tmp);
}
gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
}
else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
{
/* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e);
/* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
else
gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);

3
gcc/fortran/trans-types.c
View File

@ -1106,6 +1106,9 @@ gfc_typenode_for_spec (gfc_typespec * spec)
case BT_CLASS:
basetype = gfc_get_derived_type (spec->u.derived);
if (spec->type == BT_CLASS)
GFC_CLASS_TYPE_P (basetype) = 1;
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the

4
gcc/fortran/trans.h
View File

@ -348,8 +348,10 @@ tree gfc_vtable_size_get (tree);
tree gfc_vtable_extends_get (tree);
tree gfc_vtable_def_init_get (tree);
tree gfc_vtable_copy_get (tree);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
/* Initialize an init/cleanup block. */
@ -827,6 +829,8 @@ struct GTY((variable_size)) lang_decl {
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
/* Fortran POINTER type. */
#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
/* Fortran CLASS type. */
#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and
descriptorless array types. */
#define GFC_TYPE_ARRAY_LBOUND(node, dim) \

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2012-05-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41600
* gfortran.dg/select_type_26.f03 : New test.
* gfortran.dg/select_type_27.f03 : New test.
PR fortran/53191
* gfortran.dg/select_type_28.f03 : New test.
2012-05-05 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/49010

110
gcc/testsuite/gfortran.dg/select_type_26.f03 Normal file
View File

@ -0,0 +1,110 @@
! { dg-do run }
! Tests fix for PR41600 and further SELECT TYPE functionality.
!
! Reported by Tobias Burnus <burnus@gcc.gnu.org>
!
implicit none
type t0
integer :: j = 42
end type t0
type, extends(t0) :: t1
integer :: k = 99
end type t1
type t
integer :: i
class(t0), allocatable :: foo(:)
end type t
type t_scalar
integer :: i
class(t0), allocatable :: foo
end type t_scalar
type(t) :: m
type(t_scalar) :: m1(4)
integer :: n
! Test the fix for PR41600 itself - first with m%foo of declared type.
allocate(m%foo(3), source = [(t0(n), n = 1,3)])
select type(bar => m%foo)
type is(t0)
if (any (bar%j .ne. [1,2,3])) call abort
type is(t1)
call abort
end select
deallocate(m%foo)
allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
! Then with m%foo of another dynamic type.
select type(bar => m%foo)
type is(t0)
call abort
type is(t1)
if (any (bar%k .ne. [40,50,60])) call abort
end select
! Try it with a selector array section.
select type(bar => m%foo(2:3))
type is(t0)
call abort
type is(t1)
if (any (bar%k .ne. [50,60])) call abort
end select
! Try it with a selector array element.
select type(bar => m%foo(2))
type is(t0)
call abort
type is(t1)
if (bar%k .ne. 50) call abort
end select
! Now try class is and a selector which is an array section of an associate name.
select type(bar => m%foo)
type is(t0)
call abort
class is (t1)
if (any (bar%j .ne. [4,5,6])) call abort
select type (foobar => bar(3:2:-1))
type is (t1)
if (any (foobar%k .ne. [60,50])) call abort
end select
end select
! Now try class is and a selector which is an array element of an associate name.
select type(bar => m%foo)
type is(t0)
call abort
class is (t1)
if (any (bar%j .ne. [4,5,6])) call abort
select type (foobar => bar(2))
type is (t1)
if (foobar%k .ne. 50) call abort
end select
end select
! Check class a component of an element of an array. Note that an array of such
! objects cannot be allowed since the elements could have different dynamic types.
! (F2003 C614)
do n = 1, 2
allocate(m1(n)%foo, source = t1(n*99, n*999))
end do
do n = 3, 4
allocate(m1(n)%foo, source = t0(n*99))
end do
select type(bar => m1(3)%foo)
type is(t0)
if (bar%j .ne. 297) call abort
type is(t1)
call abort
end select
select type(bar => m1(1)%foo)
type is(t0)
call abort
type is(t1)
if (bar%k .ne. 999) call abort
end select
end

115
gcc/testsuite/gfortran.dg/select_type_27.f03 Normal file
View File

@ -0,0 +1,115 @@
! { dg-do run }
! Tests fix for PR41600 and further SELECT TYPE functionality.
! This differs from the original and select_type_26.f03 by 'm'
! being a class object rather than a derived type.
!
! Reported by Tobias Burnus <burnus@gcc.gnu.org>
!
implicit none
type t0
integer :: j = 42
end type t0
type, extends(t0) :: t1
integer :: k = 99
end type t1
type t
integer :: i
class(t0), allocatable :: foo(:)
end type t
type t_scalar
integer :: i
class(t0), allocatable :: foo
end type t_scalar
class(t), allocatable :: m
class(t_scalar), allocatable :: m1(:)
integer :: n
allocate (m)
allocate (m1(4))
! Test the fix for PR41600 itself - first with m%foo of declared type.
allocate(m%foo(3), source = [(t0(n), n = 1,3)])
select type(bar => m%foo)
type is(t0)
if (any (bar%j .ne. [1,2,3])) call abort
type is(t1)
call abort
end select
deallocate(m%foo)
allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
! Then with m%foo of another dynamic type.
select type(bar => m%foo)
type is(t0)
call abort
type is(t1)
if (any (bar%k .ne. [40,50,60])) call abort
end select
! Try it with a selector array section.
select type(bar => m%foo(2:3))
type is(t0)
call abort
type is(t1)
if (any (bar%k .ne. [50,60])) call abort
end select
! Try it with a selector array element.
select type(bar => m%foo(2))
type is(t0)
call abort
type is(t1)
if (bar%k .ne. 50) call abort
end select
! Now try class is and a selector which is an array section of an associate name.
select type(bar => m%foo)
type is(t0)
call abort
class is (t1)
if (any (bar%j .ne. [4,5,6])) call abort
select type (foobar => bar(3:2:-1))
type is (t1)
if (any (foobar%k .ne. [60,50])) call abort
end select
end select
! Now try class is and a selector which is an array element of an associate name.
select type(bar => m%foo)
type is(t0)
call abort
class is (t1)
if (any (bar%j .ne. [4,5,6])) call abort
select type (foobar => bar(2))
type is (t1)
if (foobar%k .ne. 50) call abort
end select
end select
! Check class a component of an element of an array. Note that an array of such
! objects cannot be allowed since the elements could have different dynamic types.
! (F2003 C614)
do n = 1, 2
allocate(m1(n)%foo, source = t1(n*99, n*999))
end do
do n = 3, 4
allocate(m1(n)%foo, source = t0(n*99))
end do
select type(bar => m1(3)%foo)
type is(t0)
if (bar%j .ne. 297) call abort
type is(t1)
call abort
end select
select type(bar => m1(1)%foo)
type is(t0)
call abort
type is(t1)
if (bar%k .ne. 999) call abort
end select
end

36
gcc/testsuite/gfortran.dg/select_type_28.f03 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do compile }
!
! Fix for PR53191
!
implicit none
type t0
integer :: j = 42
end type t0
type, extends(t0) :: t1
integer :: k = 99
end type t1
type t
integer :: i
class(t0), allocatable :: foo
end type t
type(t) :: m(4)
integer :: n
do n = 1, 2
allocate(m(n)%foo, source = t0(n*99))
end do
do n = 3, 4
allocate(m(n)%foo, source = t1(n*99, n*999))
end do
! An array of objects with ultimate class components cannot be a selector
! since each element could have a different dynamic type. (F2003 C614)
select type(bar => m%foo) ! { dg-error "part reference with nonzero rank" }
type is(t0)
if (any (bar%j .ne. [99, 198, 297, 396])) call abort
type is(t1)
call abort
end select
end