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

re PR fortran/41581 ([OOP] Allocation of a CLASS with SOURCE=<class> does not work) 

2009-10-13  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41581
	* decl.c (encapsulate_class_symbol): Add new component '$size'.
	* resolve.c (resolve_allocate_expr): Move CLASS handling to
	gfc_trans_allocate.
	(resolve_class_assign): Replaced by gfc_trans_class_assign.
	(resolve_code): Remove calls to resolve_class_assign.
	* trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
	* trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
	(gfc_conv_procedure_call): For CLASS dummies, set the
	$size component.
	(gfc_trans_class_assign): New function, replacing resolve_class_assign.
	* trans-stmt.h (gfc_trans_class_assign): New prototype.
	* trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
	CLASS variables. Do proper initialization. Move some code here from
	resolve_allocate_expr.


2009-10-13  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41581
	* gfortran.dg/class_allocate_2.f03: Modified.
	* gfortran.dg/class_allocate_3.f03: New test case.

From-SVN: r152715
This commit is contained in:
Janus Weil 2009-10-13 18:12:24 +02:00
parent b9e467a24a
commit f43085aaa3
10 changed files with 287 additions and 102 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-13 Janus Weil <janus@gcc.gnu.org>
PR fortran/41581
* decl.c (encapsulate_class_symbol): Add new component '$size'.
* resolve.c (resolve_allocate_expr): Move CLASS handling to
gfc_trans_allocate.
(resolve_class_assign): Replaced by gfc_trans_class_assign.
(resolve_code): Remove calls to resolve_class_assign.
* trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
* trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
(gfc_conv_procedure_call): For CLASS dummies, set the
$size component.
(gfc_trans_class_assign): New function, replacing resolve_class_assign.
* trans-stmt.h (gfc_trans_class_assign): New prototype.
* trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
CLASS variables. Do proper initialization. Move some code here from
resolve_allocate_expr.
2009-10-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/38439

11
gcc/fortran/decl.c
View File

@ -1028,7 +1028,8 @@ verify_c_interop_param (gfc_symbol *sym)
/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
A CLASS entity is represented by an encapsulating type, which contains the
declared type as '$data' component, plus an integer component '$vindex'
which determines the dynamic type. */
which determines the dynamic type, and another integer '$size', which
contains the size of the dynamic type structure. */
static gfc_try
encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@ -1089,6 +1090,14 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (0);
/* Add component '$size'. */
if (gfc_add_component (fclass, "$size", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (0);
}
fclass->attr.extension = 1;

82
gcc/fortran/resolve.c
View File

@ -5844,7 +5844,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
gfc_code *init_st;
gfc_symbol *sym;
gfc_alloc *a;
gfc_component *c;
@ -5948,41 +5947,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
return FAILURE;
}
if (e->ts.type == BT_CLASS)
{
/* Initialize VINDEX for CLASS objects. */
init_st = gfc_get_code ();
init_st->loc = code->loc;
init_st->expr1 = gfc_expr_to_initialize (e);
init_st->op = EXEC_ASSIGN;
gfc_add_component_ref (init_st->expr1, "$vindex");
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
init_st->expr2 = gfc_copy_expr (code->expr3);
gfc_add_component_ref (init_st->expr2, "$vindex");
}
else
{
/* vindex is fixed at compile time. */
int vindex;
if (code->expr3)
vindex = code->expr3->ts.u.derived->vindex;
else if (code->ext.alloc.ts.type == BT_DERIVED)
vindex = code->ext.alloc.ts.u.derived->vindex;
else if (e->ts.type == BT_CLASS)
vindex = e->ts.u.derived->components->ts.u.derived->vindex;
else
vindex = e->ts.u.derived->vindex;
init_st->expr2 = gfc_int_expr (vindex);
}
init_st->expr2->where = init_st->expr1->where = init_st->loc;
init_st->next = code->next;
code->next = init_st;
/* Only allocate the DATA component. */
gfc_add_component_ref (e, "$data");
}
if (pointer || dimension == 0)
return SUCCESS;
@ -7567,44 +7531,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
/* Check an assignment to a CLASS object (pointer or ordinary assignment). */
static void
resolve_class_assign (gfc_code *code)
{
gfc_code *assign_code = gfc_get_code ();
if (code->expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the vindex. */
assign_code->next = code->next;
code->next = assign_code;
assign_code->op = EXEC_ASSIGN;
assign_code->expr1 = gfc_copy_expr (code->expr1);
gfc_add_component_ref (assign_code->expr1, "$vindex");
if (code->expr2->ts.type == BT_DERIVED)
/* vindex is constant, determined at compile time. */
assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
else if (code->expr2->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
assign_code->expr2 = gfc_copy_expr (code->expr2);
gfc_add_component_ref (assign_code->expr2, "$vindex");
}
else if (code->expr2->expr_type == EXPR_NULL)
assign_code->expr2 = gfc_int_expr (0);
else
gcc_unreachable ();
}
/* Modify the actual pointer assignment. */
if (code->expr2->ts.type == BT_CLASS)
code->op = EXEC_ASSIGN;
else
gfc_add_component_ref (code->expr1, "$data");
}
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@ -7734,10 +7660,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
else
goto call;
}
if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code);
break;
case EXEC_LABEL_ASSIGN:
@ -7759,10 +7681,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
break;
gfc_check_pointer_assign (code->expr1, code->expr2);
if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code);
break;
case EXEC_ARITHMETIC_IF:

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

@ -1519,6 +1519,7 @@ get_proc_ptr_comp (gfc_expr *e)
e2 = gfc_copy_expr (e);
e2->expr_type = EXPR_VARIABLE;
gfc_conv_expr (&comp_se, e2);
gfc_free_expr (e2);
return build_fold_addr_expr_loc (input_location, comp_se.expr);
}
@ -2775,6 +2776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tree data;
tree vindex;
tree size;
/* The derived type needs to be converted to a temporary
CLASS object. */
@ -2788,13 +2790,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
var, tmp, NULL_TREE);
tmp = fsym->ts.u.derived->components->next->backend_decl;
vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
tmp = fsym->ts.u.derived->components->next->next->backend_decl;
size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
/* Set the vindex. */
tmp = build_int_cst (TREE_TYPE (vindex),
e->ts.u.derived->vindex);
tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
gfc_add_modify (&parmse.pre, vindex, tmp);
/* Set the size. */
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
gfc_add_modify (&parmse.pre, size,
fold_convert (TREE_TYPE (size), tmp));
/* Now set the data field. */
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
@ -5261,3 +5270,75 @@ gfc_trans_assign (gfc_code * code)
{
return gfc_trans_assignment (code->expr1, code->expr2, false);
}
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
tree
gfc_trans_class_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_start_block (&block);
if (code->expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '$vindex' field. */
gfc_expr *lhs,*rhs;
lhs = gfc_copy_expr (code->expr1);
gfc_add_component_ref (lhs, "$vindex");
if (code->expr2->ts.type == BT_DERIVED)
/* vindex is constant, determined at compile time. */
rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
else if (code->expr2->expr_type == EXPR_NULL)
rhs = gfc_int_expr (0);
else
gcc_unreachable ();
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_add_expr_to_block (&block, tmp);
/* Insert another assignment which sets the '$size' field. */
lhs = gfc_copy_expr (code->expr1);
gfc_add_component_ref (lhs, "$size");
if (code->expr2->ts.type == BT_DERIVED)
{
/* Size is fixed at compile time. */
gfc_se lse;
gfc_init_se (&lse, NULL);
gfc_conv_expr (&lse, lhs);
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
else if (code->expr2->expr_type == EXPR_NULL)
{
rhs = gfc_int_expr (0);
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_add_expr_to_block (&block, tmp);
}
else
gcc_unreachable ();
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (code->expr2->ts.type == BT_CLASS)
code->op = EXEC_ASSIGN;
else
gfc_add_component_ref (code->expr1, "$data");
if (code->op == EXEC_ASSIGN)
tmp = gfc_trans_assign (code);
else if (code->op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assign (code);
else
gcc_unreachable();
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}

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

@ -3976,7 +3976,7 @@ tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
gfc_expr *expr, *init_e, *rhs;
gfc_expr *expr, *init_e;
gfc_se se;
tree tmp;
tree parm;
@ -4006,7 +4006,10 @@ gfc_trans_allocate (gfc_code * code)
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = al->expr;
expr = gfc_copy_expr (al->expr);
if (expr->ts.type == BT_CLASS)
gfc_add_component_ref (expr, "$data");
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
@ -4022,13 +4025,14 @@ gfc_trans_allocate (gfc_code * code)
/* Determine allocate size. */
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
gfc_typespec *ts;
/* TODO: Size must be determined at run time, since it must equal
the size of the dynamic type of SOURCE, not the declared type. */
gfc_error ("Using SOURCE= with a class variable at %L not "
"supported yet", &code->loc);
ts = &code->expr3->ts.u.derived->components->ts;
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
gfc_expr *sz;
gfc_se se_sz;
sz = gfc_copy_expr (code->expr3);
gfc_add_component_ref (sz, "$size");
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
tmp = se_sz.expr;
}
else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
@ -4070,19 +4074,122 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block. */
if (code->expr3)
{
rhs = gfc_copy_expr (code->expr3);
gfc_expr *rhs = gfc_copy_expr (code->expr3);
if (rhs->ts.type == BT_CLASS)
gfc_add_component_ref (rhs, "$data");
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), rhs, false);
{
gfc_se dst,src,len;
gfc_expr *sz;
gfc_add_component_ref (rhs, "$data");
sz = gfc_copy_expr (code->expr3);
gfc_add_component_ref (sz, "$size");
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&len, NULL);
gfc_conv_expr (&dst, expr);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&len, sz);
gfc_free_expr (sz);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, len.expr);
}
else
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
rhs, false);
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
/* Default initializer for CLASS variables. */
else if (al->expr->ts.type == BT_CLASS
&& code->ext.alloc.ts.type == BT_DERIVED
&& (init_e = gfc_default_initializer (&code->ext.alloc.ts)))
{
gfc_se dst,src;
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_conv_expr (&dst, expr);
gfc_conv_expr (&src, init_e);
gfc_add_block_to_block (&block, &src.pre);
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
tmp = gfc_build_memcpy_call (dst.expr, src.expr, tmp);
gfc_add_expr_to_block (&block, tmp);
}
/* Add default initializer for those derived types that need them. */
else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts)))
else if (expr->ts.type == BT_DERIVED
&& (init_e = gfc_default_initializer (&expr->ts)))
{
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true);
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
init_e, true);
gfc_add_expr_to_block (&block, tmp);
}
/* Allocation of CLASS entities. */
gfc_free_expr (expr);
expr = al->expr;
if (expr->ts.type == BT_CLASS)
{
gfc_expr *lhs,*rhs;
/* Initialize VINDEX for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$vindex");
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_component_ref (rhs, "$vindex");
}
else
{
/* vindex is fixed at compile time. */
int vindex;
if (code->expr3)
vindex = code->expr3->ts.u.derived->vindex;
else if (code->ext.alloc.ts.type == BT_DERIVED)
vindex = code->ext.alloc.ts.u.derived->vindex;
else if (expr->ts.type == BT_CLASS)
vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
else
vindex = expr->ts.u.derived->vindex;
rhs = gfc_int_expr (vindex);
}
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
/* Initialize SIZE for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$size");
rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* Size must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_component_ref (rhs, "$size");
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_add_expr_to_block (&block, tmp);
}
else
{
/* Size is fixed at compile time. */
gfc_typespec *ts;
gfc_se lse;
gfc_init_se (&lse, NULL);
gfc_conv_expr (&lse, lhs);
if (code->expr3)
ts = &code->expr3->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
ts = &expr->ts.u.derived->components->ts;
else
ts = &expr->ts;
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
}
/* STAT block. */

1
gcc/fortran/trans-stmt.h
View File

@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *);
tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_assign (gfc_code *code);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);

10
gcc/fortran/trans.c
View File

@ -1079,7 +1079,10 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_ASSIGN:
res = gfc_trans_assign (code);
if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code);
else
res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
@ -1087,7 +1090,10 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_POINTER_ASSIGN:
res = gfc_trans_pointer_assign (code);
if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code);
else
res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2009-10-13 Janus Weil <janus@gcc.gnu.org>
PR fortran/41581
* gfortran.dg/class_allocate_2.f03: Modified.
* gfortran.dg/class_allocate_3.f03: New test case.
2009-10-13 Richard Guenther <rguenther@suse.de>
PR lto/41668

2
gcc/testsuite/gfortran.dg/class_allocate_2.f03
View File

@ -7,7 +7,7 @@ type :: t
end type t
class(t), allocatable :: c,d
allocate(t :: d)
allocate(c,source=d) ! { dg-error "not supported yet" }
allocate(c,source=d)
end
type, abstract :: t

39
gcc/testsuite/gfortran.dg/class_allocate_3.f03 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! PR 41581: [OOP] Allocation of a CLASS with SOURCE=<class> does not work
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
type t
end type t
type,extends(t) :: t2
integer :: i = 54
real :: r = 384.02
end type t2
class(t), allocatable :: m1, m2
allocate(t2 :: m2)
select type(m2)
type is (t2)
print *, m2%i, m2%r
if (m2%i/=54) call abort()
if (abs(m2%r-384.02)>1E-3) call abort()
m2%i = 42
m2%r = -4.0
class default
call abort()
end select
allocate(m1, source=m2)
select type(m1)
type is (t2)
print *, m1%i, m1%r
if (m1%i/=42) call abort()
if (abs(m1%r+4.0)>1E-3) call abort()
class default
call abort()
end select
end