===================================================================
@@ -1,12 +1,27 @@
! { 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
===================================================================
@@ -2245,35 +2245,6 @@ done:
}
-/*******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
===================================================================
@@ -83,7 +83,8 @@ gfc_add_component_ref (gfc_expr *e, const char *na
/* 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)
@@ -98,9 +99,10 @@ 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);
}
===================================================================
@@ -2536,8 +2536,6 @@ void gfc_free_st_label (gfc_st_label *);
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 *);
@@ -2701,6 +2699,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc
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);
===================================================================
@@ -4738,7 +4738,6 @@ gfc_trans_deallocate (gfc_code *code)
{
gfc_se se;
gfc_alloc *al;
- gfc_expr *expr;
tree apstat, astat, pstat, stat, tmp;
stmtblock_t block;
@@ -4766,9 +4765,12 @@ gfc_trans_deallocate (gfc_code *code)
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);
@@ -4797,6 +4799,7 @@ gfc_trans_deallocate (gfc_code *code)
}
}
tmp = gfc_array_deallocate (se.expr, pstat, expr);
+ gfc_add_expr_to_block (&se.pre, tmp);
}
else
{
@@ -4804,13 +4807,26 @@ gfc_trans_deallocate (gfc_code *code)
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)
@@ -4822,7 +4838,7 @@ gfc_trans_deallocate (gfc_code *code)
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
-
+ gfc_free_expr (expr);
}
/* Set STAT. */
===================================================================
@@ -3707,6 +3707,32 @@ gfc_get_variable_expr (gfc_symtree *var)
}
+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 *
===================================================================
@@ -6417,12 +6417,6 @@ resolve_deallocate_expr (gfc_expr *e)
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;
}