+2011-01-07 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/47189
+ PR fortran/47194
+ * gfortran.h (gfc_lval_expr_from_sym): Moved prototype.
+ * class.c (gfc_class_null_initializer): Initialize _vptr to declared
+ type.
+ * expr.c (gfc_lval_expr_from_sym): Moved here from symbol.c.
+ * resolve.c (resolve_deallocate_expr): _data component will be added
+ at translation stage.
+ * symbol.c (gfc_lval_expr_from_sym): Moved to expr.c.
+ * trans-stmt.c (gfc_trans_deallocate): Reset _vptr to declared type.
+
2011-01-06 Daniel Franke <franke.daniel@gmail.com>
PR fortran/33117
/* Build a NULL initializer for CLASS pointers,
- initializing the _data and _vptr components to zero. */
+ initializing the _data component to NULL and
+ the _vptr component to the declared type. */
gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts)
for (comp = ts->u.derived->components; comp; comp = comp->next)
{
gfc_constructor *ctor = gfc_constructor_get();
- ctor->expr = gfc_get_expr ();
- ctor->expr->expr_type = EXPR_NULL;
- ctor->expr->ts = comp->ts;
+ if (strcmp (comp->name, "_vptr") == 0)
+ ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+ else
+ ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
}
}
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ lval = gfc_get_expr ();
+ lval->expr_type = EXPR_VARIABLE;
+ lval->where = sym->declared_at;
+ lval->ts = sym->ts;
+ lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
+ {
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
+ }
+
+ return lval;
+}
+
+
/* Returns the array_spec of a full array expression. A NULL is
returned otherwise. */
gfc_array_spec *
void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
gfc_try gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
-gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
-
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
+gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
return FAILURE;
- if (e->ts.type == BT_CLASS)
- {
- /* Only deallocate the DATA component. */
- gfc_add_data_component (e);
- }
-
return SUCCESS;
}
}
-/*******A helper function for creating new expressions*************/
-
-
-gfc_expr *
-gfc_lval_expr_from_sym (gfc_symbol *sym)
-{
- gfc_expr *lval;
- lval = gfc_get_expr ();
- lval->expr_type = EXPR_VARIABLE;
- lval->where = sym->declared_at;
- lval->ts = sym->ts;
- lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
- /* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
- if (lval->rank)
- {
- lval->ref = gfc_get_ref ();
- lval->ref->type = REF_ARRAY;
- lval->ref->u.ar.type = AR_FULL;
- lval->ref->u.ar.dimen = lval->rank;
- lval->ref->u.ar.where = sym->declared_at;
- lval->ref->u.ar.as = sym->as;
- }
-
- return lval;
-}
-
-
/************** Symbol table management subroutines ****************/
/* Basic details: Fortran 95 requires a potentially unlimited number
{
gfc_se se;
gfc_alloc *al;
- gfc_expr *expr;
tree apstat, astat, pstat, stat, tmp;
stmtblock_t block;
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
- expr = al->expr;
+ gfc_expr *expr = gfc_copy_expr (al->expr);
gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ if (expr->ts.type == BT_CLASS)
+ gfc_add_data_component (expr);
+
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
}
}
tmp = gfc_array_deallocate (se.expr, pstat, expr);
+ gfc_add_expr_to_block (&se.pre, tmp);
}
else
{
expr, expr->ts);
gfc_add_expr_to_block (&se.pre, tmp);
+ /* Set to zero after deallocation. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
se.expr,
build_int_cst (TREE_TYPE (se.expr), 0));
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (al->expr->ts.type == BT_CLASS)
+ {
+ /* Reset _vptr component to declared type. */
+ gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
+ gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
+ gfc_add_vptr_component (lhs);
+ rhs = gfc_lval_expr_from_sym (vtab);
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
}
- gfc_add_expr_to_block (&se.pre, tmp);
-
/* Keep track of the number of failed deallocations by adding stat
of the last deallocation to the running total. */
if (code->expr1 || code->expr2)
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
-
+ gfc_free_expr (expr);
}
/* Set STAT. */
+2011-01-07 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/47189
+ PR fortran/47194
+ * gfortran.dg/storage_size_3.f08: Extended.
+
2011-01-07 Jakub Jelinek <jakub@redhat.com>
PR c++/47022
! { dg-do run }
!
! PR 47024: [OOP] STORAGE_SIZE (for polymorphic types): Segfault at run time
+! PR 47189: [OOP] calling STORAGE_SIZE on a NULL-initialized class pointer
+! PR 47194: [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic variable is unallocated
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
type t
integer(kind=4) :: a
end type
+
+class(t), pointer :: x => null()
class(t), allocatable :: y
+
+if (storage_size(x)/=32) call abort()
+if (storage_size(y)/=32) call abort()
+
+allocate(y)
+
if (storage_size(y)/=32) call abort()
+
+deallocate(y)
+
+if (storage_size(y)/=32) call abort()
+
end
projects / gcc.git / commitdiff