+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
/* 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,
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;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_code *init_st;
gfc_symbol *sym;
gfc_alloc *a;
gfc_component *c;
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;
}
-/* 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. */
else
goto call;
}
-
- if (code->expr1->ts.type == BT_CLASS)
- resolve_class_assign (code);
-
break;
case EXEC_LABEL_ASSIGN:
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:
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);
}
{
tree data;
tree vindex;
+ tree size;
/* The derived type needs to be converted to a temporary
CLASS object. */
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)
{
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);
+}
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;
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);
/* 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));
/* 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);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ /* Allocation of CLASS entities. */
+ gfc_free_expr (expr);
+ expr = al->expr;
+ if (expr->ts.type == BT_CLASS)
{
- tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true);
+ 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);
}
}
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 *);
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:
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:
+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
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
--- /dev/null
+! { 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
git://gcc.gnu.org / gcc.git / commitdiff