+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.
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). */
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;
}
gfc_commit_symbol (vtab);
if (vtype)
gfc_commit_symbol (vtype);
+ if (def_init)
+ gfc_commit_symbol (def_init);
}
else
gfc_undo_symbols ();
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)
{
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);
}
/* 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;
}
}
- 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 "
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))
}
-/* 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);
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);
+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
type(t2) :: z
-!!! first example (works)
+!!! first example (static)
z%j = 5
allocate(x,MOLD=z)
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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff