re PR fortran/44541 ([OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD)
2010-09-01 Janus Weil <janus@gcc.gnu.org> PR fortran/44541 * class.c (gfc_find_derived_vtab): Add component '$def_init'. * resolve.c (resolve_allocate_expr): Defer handling of default initialization to 'gfc_trans_allocate'. (apply_default_init,resolve_symbol): Handle polymorphic dummies. (resolve_fl_derived): Suppress error messages for vtypes. * trans-stmt.c (gfc_trans_allocate): Handle initialization via polymorphic MOLD expression. * trans-expr.c (gfc_trans_class_init_assign): Now only used for dummy initialization. 2010-09-01 Janus Weil <janus@gcc.gnu.org> PR fortran/44541 * gfortran.dg/allocate_alloc_opt_10.f90: Extended. * gfortran.dg/class_dummy_1.f03: New. From-SVN: r163744
This commit is contained in:
Janus Weil
parent
596aa3f09d
commit
50f308010c
|
|
@ -1,3 +1,16 @@
|
|||
2010-09-01 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44541
|
||||
* class.c (gfc_find_derived_vtab): Add component '$def_init'.
|
||||
* resolve.c (resolve_allocate_expr): Defer handling of default
|
||||
initialization to 'gfc_trans_allocate'.
|
||||
(apply_default_init,resolve_symbol): Handle polymorphic dummies.
|
||||
(resolve_fl_derived): Suppress error messages for vtypes.
|
||||
* trans-stmt.c (gfc_trans_allocate): Handle initialization via
|
||||
polymorphic MOLD expression.
|
||||
* trans-expr.c (gfc_trans_class_init_assign): Now only used for
|
||||
dummy initialization.
|
||||
|
||||
2010-09-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
* gfortran.texi (preprocessing): Update URL to COCO.
|
||||
|
|
|
|||
|
|
@ -319,7 +319,7 @@ gfc_symbol *
|
|||
gfc_find_derived_vtab (gfc_symbol *derived)
|
||||
{
|
||||
gfc_namespace *ns;
|
||||
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
|
||||
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
|
||||
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
|
||||
|
||||
/* Find the top-level namespace (MODULE or PROGRAM). */
|
||||
|
|
@ -408,6 +408,33 @@ gfc_find_derived_vtab (gfc_symbol *derived)
|
|||
c->initializer = gfc_get_null_expr (NULL);
|
||||
}
|
||||
|
||||
/* Add component $def_init. */
|
||||
if (gfc_add_component (vtype, "$def_init", &c) == FAILURE)
|
||||
goto cleanup;
|
||||
c->attr.pointer = 1;
|
||||
c->attr.access = ACCESS_PRIVATE;
|
||||
c->ts.type = BT_DERIVED;
|
||||
c->ts.u.derived = derived;
|
||||
if (derived->attr.abstract)
|
||||
c->initializer = NULL;
|
||||
else
|
||||
{
|
||||
/* Construct default initialization variable. */
|
||||
sprintf (name, "def_init$%s", derived->name);
|
||||
gfc_get_symbol (name, ns, &def_init);
|
||||
def_init->attr.target = 1;
|
||||
def_init->attr.save = SAVE_EXPLICIT;
|
||||
def_init->attr.access = ACCESS_PUBLIC;
|
||||
def_init->attr.flavor = FL_VARIABLE;
|
||||
gfc_set_sym_referenced (def_init);
|
||||
def_init->ts.type = BT_DERIVED;
|
||||
def_init->ts.u.derived = derived;
|
||||
def_init->value = gfc_default_initializer (&def_init->ts);
|
||||
|
||||
c->initializer = gfc_lval_expr_from_sym (def_init);
|
||||
}
|
||||
|
||||
/* Add procedure pointers for type-bound procedures. */
|
||||
add_procs_to_declared_vtab (derived, vtype);
|
||||
vtype->attr.vtype = 1;
|
||||
}
|
||||
|
|
@ -427,6 +454,8 @@ cleanup:
|
|||
gfc_commit_symbol (vtab);
|
||||
if (vtype)
|
||||
gfc_commit_symbol (vtype);
|
||||
if (def_init)
|
||||
gfc_commit_symbol (def_init);
|
||||
}
|
||||
else
|
||||
gfc_undo_symbols ();
|
||||
|
|
|
|||
|
|
@ -6710,37 +6710,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
sym->name, &e->where);
|
||||
goto failure;
|
||||
}
|
||||
|
||||
if (!code->expr3 || code->expr3->mold)
|
||||
{
|
||||
/* Add default initializer for those derived types that need them. */
|
||||
gfc_expr *init_e = NULL;
|
||||
gfc_typespec ts;
|
||||
|
||||
if (code->ext.alloc.ts.type == BT_DERIVED)
|
||||
ts = code->ext.alloc.ts;
|
||||
else if (code->expr3)
|
||||
ts = code->expr3->ts;
|
||||
else
|
||||
ts = e->ts;
|
||||
|
||||
if (ts.type == BT_DERIVED)
|
||||
init_e = gfc_default_initializer (&ts);
|
||||
/* FIXME: Use default init of dynamic type (cf. PR 44541). */
|
||||
else if (e->ts.type == BT_CLASS)
|
||||
init_e = gfc_default_initializer (&ts.u.derived->components->ts);
|
||||
|
||||
if (init_e)
|
||||
{
|
||||
gfc_code *init_st = gfc_get_code ();
|
||||
init_st->loc = code->loc;
|
||||
init_st->op = EXEC_INIT_ASSIGN;
|
||||
init_st->expr1 = gfc_expr_to_initialize (e);
|
||||
init_st->expr2 = init_e;
|
||||
init_st->next = code->next;
|
||||
code->next = init_st;
|
||||
}
|
||||
}
|
||||
|
||||
if (e->ts.type == BT_CLASS)
|
||||
{
|
||||
|
|
@ -9503,7 +9472,7 @@ apply_default_init (gfc_symbol *sym)
|
|||
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
|
||||
init = gfc_default_initializer (&sym->ts);
|
||||
|
||||
if (init == NULL)
|
||||
if (init == NULL && sym->ts.type != BT_CLASS)
|
||||
return;
|
||||
|
||||
build_init_assign (sym, init);
|
||||
|
|
@ -11429,7 +11398,7 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
}
|
||||
|
||||
/* Check type-spec if this is not the parent-type component. */
|
||||
if ((!sym->attr.extension || c != sym->components)
|
||||
if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
|
||||
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
|
|
@ -11488,8 +11457,8 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
}
|
||||
}
|
||||
|
||||
if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
|
||||
&& c->ts.u.derived->components == NULL
|
||||
if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
|
||||
&& c->attr.pointer && c->ts.u.derived->components == NULL
|
||||
&& !c->ts.u.derived->attr.zero_comp)
|
||||
{
|
||||
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
|
||||
|
|
@ -12194,6 +12163,14 @@ resolve_symbol (gfc_symbol *sym)
|
|||
apply_default_init (sym);
|
||||
}
|
||||
|
||||
if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
|
||||
&& sym->attr.dummy && sym->attr.intent == INTENT_OUT
|
||||
&& !sym->attr.pointer && !sym->attr.allocatable)
|
||||
{
|
||||
apply_default_init (sym);
|
||||
gfc_set_sym_referenced (sym);
|
||||
}
|
||||
|
||||
/* If this symbol has a type-spec, check it. */
|
||||
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
|
||||
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
|
||||
|
|
|
|||
|
|
@ -5760,27 +5760,39 @@ gfc_trans_assign (gfc_code * code)
|
|||
}
|
||||
|
||||
|
||||
/* Special case for initializing a CLASS variable on allocation.
|
||||
A MEMCPY is needed to copy the full data of the dynamic type,
|
||||
which may be different from the declared type. */
|
||||
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
|
||||
A MEMCPY is needed to copy the full data from the default initializer
|
||||
of the dynamic type. */
|
||||
|
||||
tree
|
||||
gfc_trans_class_init_assign (gfc_code *code)
|
||||
{
|
||||
stmtblock_t block;
|
||||
tree tmp, memsz;
|
||||
gfc_se dst,src;
|
||||
|
||||
tree tmp;
|
||||
gfc_se dst,src,memsz;
|
||||
gfc_expr *lhs,*rhs,*sz;
|
||||
|
||||
gfc_start_block (&block);
|
||||
|
||||
|
||||
lhs = gfc_copy_expr (code->expr1);
|
||||
gfc_add_component_ref (lhs, "$data");
|
||||
|
||||
rhs = gfc_copy_expr (code->expr1);
|
||||
gfc_add_component_ref (rhs, "$vptr");
|
||||
gfc_add_component_ref (rhs, "$def_init");
|
||||
|
||||
sz = gfc_copy_expr (code->expr1);
|
||||
gfc_add_component_ref (sz, "$vptr");
|
||||
gfc_add_component_ref (sz, "$size");
|
||||
|
||||
gfc_init_se (&dst, NULL);
|
||||
gfc_init_se (&src, NULL);
|
||||
gfc_add_component_ref (code->expr1, "$data");
|
||||
gfc_conv_expr (&dst, code->expr1);
|
||||
gfc_conv_expr (&src, code->expr2);
|
||||
gfc_init_se (&memsz, NULL);
|
||||
gfc_conv_expr (&dst, lhs);
|
||||
gfc_conv_expr (&src, rhs);
|
||||
gfc_conv_expr (&memsz, sz);
|
||||
gfc_add_block_to_block (&block, &src.pre);
|
||||
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
|
||||
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
|
||||
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
|
|
|
|||
|
|
@ -4399,6 +4399,54 @@ gfc_trans_allocate (gfc_code * code)
|
|||
gfc_free_expr (rhs);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Add default initializer for those derived types that need them. */
|
||||
gfc_expr *rhs = NULL;
|
||||
gfc_typespec ts;
|
||||
|
||||
if (code->ext.alloc.ts.type == BT_DERIVED)
|
||||
ts = code->ext.alloc.ts;
|
||||
else if (code->expr3)
|
||||
ts = code->expr3->ts;
|
||||
else
|
||||
ts = expr->ts;
|
||||
|
||||
if (ts.type == BT_DERIVED)
|
||||
{
|
||||
rhs = gfc_default_initializer (&ts);
|
||||
gfc_resolve_expr (rhs);
|
||||
}
|
||||
else if (ts.type == BT_CLASS)
|
||||
{
|
||||
rhs = gfc_copy_expr (code->expr3);
|
||||
gfc_add_component_ref (rhs, "$vptr");
|
||||
gfc_add_component_ref (rhs, "$def_init");
|
||||
}
|
||||
|
||||
if (rhs)
|
||||
{
|
||||
gfc_expr *lhs = gfc_expr_to_initialize (expr);
|
||||
if (al->expr->ts.type == BT_DERIVED)
|
||||
{
|
||||
tmp = gfc_trans_assignment (lhs, rhs, true, false);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
else if (al->expr->ts.type == BT_CLASS)
|
||||
{
|
||||
gfc_se dst,src;
|
||||
gfc_init_se (&dst, NULL);
|
||||
gfc_init_se (&src, NULL);
|
||||
gfc_conv_expr (&dst, lhs);
|
||||
gfc_conv_expr (&src, rhs);
|
||||
gfc_add_block_to_block (&block, &src.pre);
|
||||
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
gfc_free_expr (lhs);
|
||||
gfc_free_expr (rhs);
|
||||
}
|
||||
}
|
||||
|
||||
/* Allocation of CLASS entities. */
|
||||
gfc_free_expr (expr);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2010-09-01 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44541
|
||||
* gfortran.dg/allocate_alloc_opt_10.f90: Extended.
|
||||
* gfortran.dg/class_dummy_1.f03: New.
|
||||
|
||||
2010-09-01 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR middle-end/45458
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ class(t1),allocatable :: x,y
|
|||
type(t2) :: z
|
||||
|
||||
|
||||
!!! first example (works)
|
||||
!!! first example (static)
|
||||
|
||||
z%j = 5
|
||||
allocate(x,MOLD=z)
|
||||
|
|
@ -25,22 +25,22 @@ select type (x)
|
|||
type is (t2)
|
||||
print *,x%j
|
||||
if (x%j/=4) call abort
|
||||
x%j = 5
|
||||
class default
|
||||
call abort()
|
||||
end select
|
||||
|
||||
|
||||
!!! second example (fails)
|
||||
!!! FIXME: uncomment once implemented (cf. PR 44541)
|
||||
!!! second example (dynamic, PR 44541)
|
||||
|
||||
! allocate(y,MOLD=x)
|
||||
!
|
||||
! select type (y)
|
||||
! type is (t2)
|
||||
! print *,y%j
|
||||
! if (y%j/=4) call abort
|
||||
! class default
|
||||
! call abort()
|
||||
! end select
|
||||
allocate(y,MOLD=x)
|
||||
|
||||
select type (y)
|
||||
type is (t2)
|
||||
print *,y%j
|
||||
if (y%j/=4) call abort
|
||||
class default
|
||||
call abort()
|
||||
end select
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 44541: [OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD
|
||||
!
|
||||
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
implicit none
|
||||
|
||||
type t
|
||||
integer :: a = 1
|
||||
end type t
|
||||
|
||||
type, extends(t) :: t2
|
||||
integer :: b = 3
|
||||
end type t2
|
||||
|
||||
type(t2) :: y
|
||||
|
||||
y%a = 44
|
||||
y%b = 55
|
||||
call intent_out (y)
|
||||
if (y%a/=1 .or. y%b/=3) call abort()
|
||||
|
||||
y%a = 66
|
||||
y%b = 77
|
||||
call intent_out_unused (y)
|
||||
if (y%a/=1 .or. y%b/=3) call abort()
|
||||
|
||||
contains
|
||||
|
||||
subroutine intent_out(x)
|
||||
class(t), intent(out) :: x
|
||||
select type (x)
|
||||
type is (t2)
|
||||
if (x%a/=1 .or. x%b/=3) call abort()
|
||||
end select
|
||||
end subroutine
|
||||
|
||||
subroutine intent_out_unused(x)
|
||||
class(t), intent(out) :: x
|
||||
end subroutine
|
||||
|
||||
end
|
||||
Loading…
Reference in New Issue