mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-17 20:11:06 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/44541 ([OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD)

Browse Source 
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 2010-09-01 22:50:46 +02:00
parent 596aa3f09d
commit 50f308010c
8 changed files with 188 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

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

31
gcc/fortran/class.c
View File

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

47
gcc/fortran/resolve.c
View File

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

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

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

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

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

6
gcc/testsuite/ChangeLog
View File

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

24
gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90
View File

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

43
gcc/testsuite/gfortran.dg/class_dummy_1.f03 Normal file
View File

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