This patch fixes expressions involving polymorphic arrays and, thus,
MOVE_ALLOC.
I have also two minor fixes (cf. trans-decl.c).
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
2012-01-26 Tobias Burnus <bur...@net-b.de>
PR fortran/51970
PR fortran/51977
* primary.c (gfc_match_varspec. gfc_match_rvalue): Set
handle array spec for BT_CLASS.
* expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym)
* frontend-passes.c (create_var): Ditto.
* resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto.
* trans-decl.c (gfc_trans_deferred_vars): Use class_pointer
instead of attr.pointer.
(gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert.
* trans-stmt.c (trans_associate_var): Ask for the descriptor.
2012-01-26 Tobias Burnus <bur...@net-b.de>
PR fortran/51970
PR fortran/51977
* gfortran.dg/move_alloc_13.f90: New.
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (Revision 183575)
+++ gcc/fortran/primary.c (Arbeitskopie)
@@ -1868,18 +1868,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
&& (CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.codimension)))
{
+ gfc_array_spec *as;
+
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
variables. We'll leave the decision till resolve time. */
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag,
- sym->ts.type == BT_CLASS && CLASS_DATA (sym)
- ? (CLASS_DATA (sym)->as
- ? CLASS_DATA (sym)->as->corank : 0)
- : (sym->as ? sym->as->corank : 0));
+ if (equiv_flag)
+ as = NULL;
+ else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ as = CLASS_DATA (sym)->as;
+ else
+ as = sym->as;
+
+ m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
+ as ? as->corank : 0);
if (m != MATCH_YES)
return m;
@@ -2893,7 +2899,10 @@ gfc_match_rvalue (gfc_expr **result)
e->value.function.actual = actual_arglist;
e->where = gfc_current_locus;
- if (sym->as != NULL)
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as)
+ e->rank = CLASS_DATA (sym)->as->rank;
+ else if (sym->as != NULL)
e->rank = sym->as->rank;
if (!sym->attr.function
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 183575)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -1175,6 +1175,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_
gfc_se se;
gfc_init_se (&se, NULL);
+ se.descriptor_only = 1;
gfc_conv_expr (&se, e);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (Revision 183575)
+++ gcc/fortran/expr.c (Arbeitskopie)
@@ -3805,9 +3805,12 @@ gfc_get_variable_expr (gfc_symtree *var)
e->symtree = var;
e->ts = var->n.sym->ts;
- if (var->n.sym->as != NULL)
+ if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
+ || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+ && CLASS_DATA (var->n.sym)->as))
{
- e->rank = var->n.sym->as->rank;
+ e->rank = var->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
@@ -3836,7 +3839,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
lval->ref->u.ar.type = AR_FULL;
lval->ref->u.ar.dimen = lval->rank;
lval->ref->u.ar.where = sym->declared_at;
- lval->ref->u.ar.as = sym->as;
+ lval->ref->u.ar.as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as : sym->as;
}
return lval;
Index: gcc/fortran/frontend-passes.c
===================================================================
--- gcc/fortran/frontend-passes.c (Revision 183575)
+++ gcc/fortran/frontend-passes.c (Arbeitskopie)
@@ -328,7 +328,8 @@ create_var (gfc_expr * e)
result->ref->type = REF_ARRAY;
result->ref->u.ar.type = AR_FULL;
result->ref->u.ar.where = e->where;
- result->ref->u.ar.as = symbol->as;
+ result->ref->u.ar.as = symbol->ts.type == BT_CLASS
+ ? CLASS_DATA (symbol)->as : symbol->as;
if (gfc_option.warn_array_temp)
gfc_warning ("Creating array temporary at %L", &(e->where));
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 183575)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -1740,13 +1740,17 @@ resolve_actual_arglist (gfc_actual_arglist *arg, p
got_variable:
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
- if (sym->as != NULL)
+ if ((sym->as != NULL && sym->ts.type != BT_CLASS)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as))
{
- e->rank = sym->as->rank;
+ e->rank = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as->rank : sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = sym->as;
+ e->ref->u.ar.as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as : sym->as;
}
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
@@ -7930,13 +7934,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_t
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
- if (tsym->ts.type == BT_CLASS)
- sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
- else
- sym->attr.target = tsym->attr.target || tsym->attr.pointer;
-
- if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
- target->rank = sym->as ? sym->as->rank : 0;
+ sym->attr.target = tsym->attr.target
+ || gfc_expr_attr (target).pointer;
}
/* Get type if this was not already set. Note that it can be
@@ -7951,10 +7950,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_t
&& !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
- if (sym->attr.dimension
- && (target->ts.type == BT_CLASS
- ? !CLASS_DATA (target)->attr.dimension
- : target->rank == 0))
+ if (sym->attr.dimension && target->rank == 0)
{
gfc_error ("Associate-name '%s' at %L is used as array",
sym->name, &sym->declared_at);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 183575)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -3687,7 +3687,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf
}
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)->attr.pointer))
+ && CLASS_DATA (sym)->attr.class_pointer))
continue;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
@@ -5341,7 +5341,8 @@ gfc_generate_function_code (gfc_namespace * ns)
null_pointer_node));
else if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable
- && sym->attr.dimension == 0 && sym->result == sym)
+ && CLASS_DATA (sym)->attr.dimension == 0
+ && sym->result == sym)
{
tmp = CLASS_DATA (sym)->backend_decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF,
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 183575)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -7237,10 +7237,11 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
+ gcc_assert (from_expr->ts.type != BT_CLASS
+ || to_expr->ts.type == BT_CLASS);
+
if (from_expr->rank == 0)
{
- gcc_assert (from_expr->ts.type != BT_CLASS
- || to_expr->ts.type == BT_CLASS);
if (from_expr->ts.type != BT_CLASS)
from_expr2 = from_expr;
else
Index: gcc/testsuite/gfortran.dg/move_alloc_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/move_alloc_13.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/move_alloc_13.f90 (Arbeitskopie)
@@ -0,0 +1,39 @@
+! { dg-do run}
+!
+! PR fortran/51970
+! PR fortran/51977
+!
+type t
+end type t
+type, extends(t) :: t2
+ integer :: a
+end type t2
+
+class(t), allocatable :: y(:), z(:)
+
+allocate(y(2), source=[t2(2), t2(3)])
+call func2(y,z)
+
+select type(z)
+ type is(t2)
+ if (any (z(:)%a /= [2, 3])) call abort()
+ class default
+ call abort()
+end select
+
+contains
+ function func(x)
+ class (t), allocatable :: x(:), func(:)
+ call move_alloc (x, func)
+ end function
+
+ function func1(x)
+ class (t), allocatable :: x(:), func1(:)
+ call move_alloc (func1, x)
+ end function
+
+ subroutine func2(x, y)
+ class (t), allocatable :: x(:), y(:)
+ call move_alloc (x, y)
+ end subroutine
+end
