On 13/06/21 15:46, José Rui Faustino de Sousa wrote:
Hi All!
Proposed patch to:
And again I forgot to add the patch...
Sorry for the inconvenience.
Best regards,
José Rui
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 93118ad..5670d18 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -443,7 +443,7 @@ gfc_is_class_container_ref (gfc_expr *e)
component to the corresponding type (or the declared type, given by ts). */
gfc_expr *
-gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr, bool pointer)
{
gfc_expr *init;
gfc_component *comp;
@@ -464,7 +464,10 @@ gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
if (strcmp (comp->name, "_vptr") == 0 && vtab)
ctor->expr = gfc_lval_expr_from_sym (vtab);
else if (init_expr && init_expr->expr_type != EXPR_NULL)
- ctor->expr = gfc_copy_expr (init_expr);
+ ctor->expr = gfc_copy_expr (init_expr);
+ else if (strcmp (comp->name, "_data") == 0 && pointer)
+ ctor->expr = (init_expr && init_expr->expr_type == EXPR_NULL)
+ ? (gfc_get_null_expr (NULL)) : (NULL);
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 956003e..32b2849 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4433,15 +4433,19 @@ bool
gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
{
gfc_expr lvalue;
+ gfc_array_spec *as;
bool r;
- bool pointer, proc_pointer;
+ bool is_class, pointer, proc_pointer;
memset (&lvalue, '\0', sizeof (gfc_expr));
+ is_class = (sym->ts.type == BT_CLASS) && CLASS_DATA (sym);
+ as = is_class ? (CLASS_DATA (sym)->as) : (sym->as);
+
lvalue.expr_type = EXPR_VARIABLE;
lvalue.ts = sym->ts;
- if (sym->as)
- lvalue.rank = sym->as->rank;
+ if (as)
+ lvalue.rank = as->rank;
lvalue.symtree = XCNEW (gfc_symtree);
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
@@ -4461,7 +4465,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
}
else
{
- pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ pointer = is_class
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
proc_pointer = sym->attr.proc_pointer;
}
@@ -4883,32 +4887,21 @@ get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
}
static bool
-class_allocatable (gfc_component *comp)
-{
- return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.allocatable;
-}
-
-static bool
-class_pointer (gfc_component *comp)
-{
- return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.pointer;
-}
-
-static bool
comp_allocatable (gfc_component *comp)
{
- return comp->attr.allocatable || class_allocatable (comp);
+ if (comp->ts.type == BT_CLASS && CLASS_DATA (comp))
+ return CLASS_DATA (comp)->attr.allocatable;
+ return comp->attr.allocatable;
}
static bool
comp_pointer (gfc_component *comp)
{
- return comp->attr.pointer
- || comp->attr.proc_pointer
- || comp->attr.class_pointer
- || class_pointer (comp);
+ if (comp->attr.proc_pointer)
+ return true;
+ if (comp->ts.type == BT_CLASS && CLASS_DATA (comp))
+ return CLASS_DATA (comp)->attr.class_pointer;
+ return comp->attr.pointer;
}
/* Fetch or generate an initializer for the given component.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cbc95d3..52a76bc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3673,7 +3673,7 @@ void gfc_add_class_array_ref (gfc_expr *);
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
-gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
+gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *, bool);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_expr *gfc_get_len_component (gfc_expr *e, int);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6bcd2b..891f82a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -406,20 +406,288 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
+
+/* Create a new dtype constructor. */
+
+static tree
+build_init_dtype (tree ctor, int rank)
+{
+ tree type;
+ tree field;
+ tree value;
+ tree init;
+ vec<constructor_elt, va_gc> *vlst = NULL;
+
+ gcc_assert (TREE_CODE (ctor) == CONSTRUCTOR);
+ type = TREE_TYPE (ctor);
+
+ value = gfc_get_expr_from_ctor (ctor, 0);
+ if (value == NULL_TREE)
+ value = integer_zero_node;
+ if (!TREE_CONSTANT (value) || TREE_SIDE_EFFECTS (value))
+ value = (DECL_INITIAL (value))
+ ? (DECL_INITIAL (value)) : (integer_zero_node);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), 0);
+ gcc_assert (field != NULL_TREE);
+ value = fold_convert (TREE_TYPE (field), value);
+ CONSTRUCTOR_APPEND_ELT (vlst, field, value);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), 2);
+ gcc_assert (field != NULL_TREE);
+ value = build_int_cst (TREE_TYPE (field), rank);
+ CONSTRUCTOR_APPEND_ELT (vlst, field, value);
+
+ value = gfc_get_expr_from_ctor (ctor, 3);
+ if (value == NULL_TREE)
+ value = integer_zero_node;
+ field = gfc_advance_chain (TYPE_FIELDS (type), 3);
+ gcc_assert (field != NULL_TREE);
+ CONSTRUCTOR_APPEND_ELT (vlst, field, value);
+
+ init = build_constructor (type, vlst);
+ TREE_CONSTANT (init) = 1;
+
+ return init;
+}
+
+
+/* Find the old dtype constructor and create a new one. */
+
+static tree
+build_init_desc_dtype (tree desc, int rank, tree chain)
+{
+ tree type;
+ tree field;
+ tree cref;
+ tree value;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+ gcc_assert (field != NULL_TREE);
+ type = TREE_TYPE (field);
+ cref = fold_build3_loc (input_location, COMPONENT_REF, type,
+ desc, field, NULL_TREE);
+
+ value = gfc_get_expr_from_chain (cref, chain);
+ gcc_assert (value != NULL_TREE);
+
+ return build_init_dtype (value, rank);
+}
+
+
+/* Append one of dim fields to vector. */
+
+static bool
+append_init_dim (tree base, unsigned field_idx, tree chain,
+ vec<constructor_elt, va_gc> **vlst)
+{
+ tree type, field, cref, value;
+
+ type = TREE_TYPE (base);
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+ gcc_assert (field != NULL_TREE);
+ type = TREE_TYPE (field);
+ cref = fold_build3_loc (input_location, COMPONENT_REF, type,
+ base, field, NULL_TREE);
+
+ value = gfc_get_expr_from_chain (cref, chain);
+ if (value == NULL_TREE)
+ return false;
+ gcc_assert (TREE_CONSTANT (value) && !TREE_SIDE_EFFECTS (value));
+
+ CONSTRUCTOR_APPEND_ELT (*vlst, field, fold_convert (type, value));
+ return true;
+}
+
+
+/* Create a dim constructor. */
+
+static tree
+build_init_dim (tree base, tree chain)
+{
+ tree init = NULL_TREE;
+ vec<constructor_elt, va_gc> *vlst = NULL;
+
+ append_init_dim (base, STRIDE_SUBFIELD, chain, &vlst);
+ append_init_dim (base, LBOUND_SUBFIELD, chain, &vlst);
+ append_init_dim (base, UBOUND_SUBFIELD, chain, &vlst);
+
+ if (!vec_safe_is_empty (vlst))
+ {
+ init = build_constructor (TREE_TYPE (base), vlst);
+ TREE_CONSTANT (init) = 1;
+ }
+
+ return init;
+}
+
+
+/* Create the dim array constructor. */
+
+static tree
+build_init_desc_dim (tree desc, int rank, tree chain)
+{
+ tree type;
+ tree field;
+ tree cref;
+ tree base;
+ tree idim;
+ tree init;
+ vec<constructor_elt, va_gc> *vlst = NULL;
+ int idx;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+ gcc_assert (field != NULL_TREE);
+ type = TREE_TYPE (field);
+ cref = fold_build3_loc (input_location, COMPONENT_REF, type,
+ desc, field, NULL_TREE);
+
+ for (idx = 0; idx<rank; idx++)
+ {
+ idim = build_int_cst (gfc_array_index_type, idx);
+ base = gfc_build_array_ref (cref, idim, NULL);
+ init = build_init_dim (base, chain);
+ if (init == NULL_TREE)
+ continue;
+ CONSTRUCTOR_APPEND_ELT (vlst, NULL_TREE, init);
+ }
+
+ init = NULL_TREE;
+ if (!vec_safe_is_empty (vlst))
+ {
+ init = build_constructor (type, vlst);
+ TREE_CONSTANT (init) = 1;
+ }
+
+ return init;
+}
+
+
+/* Append the field to the vector. */
+
+static bool
+append_desc_field (tree desc, int rank, unsigned field_idx, tree chain,
+ vec<constructor_elt, va_gc> **vlst)
+{
+ tree field, type, cref, value;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+ gcc_assert (field != NULL_TREE);
+ type = TREE_TYPE (field);
+ cref = fold_build3_loc (input_location, COMPONENT_REF, type,
+ desc, field, NULL_TREE);
+
+ switch (field_idx)
+ {
+ case DTYPE_FIELD:
+ {
+ value = build_init_desc_dtype (desc, rank, chain);
+ break;
+ }
+ case DIMENSION_FIELD:
+ {
+ value = build_init_desc_dim (desc, rank, chain);
+ break;
+ }
+ default:
+ value = gfc_get_expr_from_chain (cref, chain);
+ break;
+ }
+
+ if (value == NULL_TREE)
+ return false;
+ gcc_assert (TREE_CONSTANT (value) && !TREE_SIDE_EFFECTS (value));
+
+ value = fold_convert (type, value);
+ CONSTRUCTOR_APPEND_ELT (*vlst, field, value);
+ return true;
+}
+
+/* Create an array descriptor constructor. */
+
+static tree
+build_init_descriptor (tree desc, int rank, tree chain)
+{
+ tree type;
+ tree init;
+ vec<constructor_elt, va_gc> *vlst = NULL;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ append_desc_field (desc, rank, DATA_FIELD, chain, &vlst);
+ append_desc_field (desc, rank, OFFSET_FIELD, chain, &vlst);
+ append_desc_field (desc, rank, DTYPE_FIELD, chain, &vlst);
+ append_desc_field (desc, rank, SPAN_FIELD, chain, &vlst);
+ append_desc_field (desc, rank, DIMENSION_FIELD, chain, &vlst);
+
+ init = NULL_TREE;
+ if (!vec_safe_is_empty (vlst))
+ {
+ init = build_constructor (type, vlst);
+ TREE_CONSTANT (init) = 1;
+ }
+
+ return init;
+}
+
+
+/* Build a descriptor containing only a dtype. */
+
+tree
+gfc_build_init_descriptor_dtype (tree type, int rank)
+{
+ tree tmp;
+ tree field;
+ tree dtype;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ tmp = gfc_get_element_type (type);
+ dtype = gfc_get_dtype_rank_type (rank, tmp, true);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+ dtype = fold_convert (TREE_TYPE (field), dtype);
+ tmp = build_constructor_single (type, field, dtype);
+ TREE_CONSTANT (tmp) = 1;
+
+ return tmp;
+}
+
+
/* Build a null array descriptor constructor. */
tree
-gfc_build_null_descriptor (tree type)
+gfc_build_null_descriptor (tree type, int rank)
{
tree field;
- tree tmp;
+ tree tmp, dtype;
+ vec<constructor_elt, va_gc> *v = NULL;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- gcc_assert (DATA_FIELD == 0);
- field = TYPE_FIELDS (type);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, field,
+ fold_convert (TREE_TYPE (field), null_pointer_node));
+
+ tmp = gfc_get_element_type (type);
+ dtype = gfc_get_dtype_rank_type (rank, tmp, true);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, field,
+ fold_convert (TREE_TYPE (field), dtype));
/* Set a NULL data pointer. */
- tmp = build_constructor_single (type, field, null_pointer_node);
+ tmp = build_constructor (type, v);
TREE_CONSTANT (tmp) = 1;
/* All other fields are ignored. */
@@ -427,6 +695,52 @@ gfc_build_null_descriptor (tree type)
}
+/* Build a null array descriptor constructor. */
+
+tree
+gfc_build_init_descriptor (tree decl, int rank, gfc_expr * expr)
+{
+ gfc_se lse;
+ stmtblock_t block;
+ tree type;
+ tree init;
+
+ type = TREE_TYPE (decl);
+ if (expr == NULL)
+ return gfc_build_init_descriptor_dtype (type, rank);
+ if (expr && expr->expr_type == EXPR_NULL)
+ return gfc_build_null_descriptor (type, rank);
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ gfc_start_block (&block);
+ gfc_init_se (&lse, NULL);
+ lse.expr = decl;
+
+ /* Assign directly to the LHS's descriptor. */
+ lse.unlimited_polymorphic =
+ gfc_class_unlimited_poly (DECL_CONTEXT (decl));
+ lse.direct_byref = 1;
+ gfc_conv_expr_descriptor (&lse, expr);
+
+ gfc_add_block_to_block (&block, &lse.pre);
+ gfc_add_block_to_block (&block, &lse.post);
+ init = gfc_finish_block (&block);
+
+ /* gcc_assert (TREE_CODE (init) == BIND_EXPR);
+ decl = BIND_EXPR_VARS (init);
+ gcc_assert (VAR_P (decl));
+ init = BIND_EXPR_BODY (init);
+ gcc_assert (TREE_CODE (init) == STATEMENT_LIST); */
+
+ init = build_init_descriptor (decl, rank, init);
+
+ TREE_CONSTANT (init) = 1;
+ return init;
+}
+
+
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
@@ -890,15 +1204,41 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* Generate an initializer for a static pointer or allocatable array. */
-void
+tree
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
- tree type;
+ tree type, init;
+ bool is_class;
+ bool is_pointer;
+ symbol_attribute *attr;
+ gfc_array_spec *as;
+ int rank;
gcc_assert (TREE_STATIC (sym->backend_decl));
- /* Just zero the data member. */
type = TREE_TYPE (sym->backend_decl);
- DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ is_class = (sym->ts.type == BT_CLASS) && CLASS_DATA (sym);
+ attr = is_class ? &(CLASS_DATA (sym)->attr) : &(sym->attr);
+ is_pointer = is_class ? attr->class_pointer : attr->pointer;
+ as = is_class ? (CLASS_DATA (sym)->as) : (sym->as);
+ rank = as ? as->rank : 0;
+
+ if (attr->allocatable
+ || (sym->value && sym->value->expr_type == EXPR_NULL))
+ init = gfc_build_null_descriptor (type, rank);
+ else if (is_pointer)
+ {
+ if (sym->value)
+ init = gfc_build_init_descriptor (sym->backend_decl, rank, sym->value);
+ else
+ init = gfc_build_init_descriptor_dtype (type, rank);
+ }
+ else
+ gcc_unreachable ();
+
+ DECL_INITIAL (sym->backend_decl) = init;
+ return init;
}
@@ -6128,7 +6468,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
if (expr->expr_type == EXPR_CONSTANT)
gfc_conv_constant (&se, expr);
else
- gfc_conv_structure (&se, expr, 1);
+ gfc_conv_structure_initializer (&se, expr);
CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type,
TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
@@ -6211,7 +6551,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
break;
case EXPR_STRUCTURE:
- gfc_conv_structure (&se, c->expr, 1);
+ gfc_conv_structure_initializer (&se, c->expr);
break;
default:
@@ -6234,7 +6574,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
break;
case EXPR_NULL:
- return gfc_build_null_descriptor (type);
+ return gfc_build_null_descriptor (type, expr->rank);
default:
gcc_unreachable ();
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e4d443d..2413c7d 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -70,7 +70,7 @@ tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
/* Add initialization for deferred arrays. */
void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate an initializer for a static pointer or allocatable array. */
-void gfc_trans_static_array_pointer (gfc_symbol *);
+tree gfc_trans_static_array_pointer (gfc_symbol *);
/* Get the procedure interface for a function call. */
gfc_symbol *gfc_get_proc_ifc_for_expr (gfc_expr *);
@@ -129,7 +129,9 @@ void gfc_set_delta (gfc_loopinfo *);
/* Resolve array assignment dependencies. */
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
-tree gfc_build_null_descriptor (tree);
+tree gfc_build_null_descriptor (tree, int);
+/* Build an array descriptor constructor. */
+tree gfc_build_init_descriptor (tree, int, gfc_expr*);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index a11cf4c..9242641 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -705,11 +705,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
if (s->sym->value)
{
/* Add the initializer for this field. */
- tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
- TREE_TYPE (s->field),
- s->sym->attr.dimension,
- s->sym->attr.pointer
- || s->sym->attr.allocatable, false);
+ tmp = gfc_conv_sym_initializer (s->field, s->sym);
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
}
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c32bd05..dd53643 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1374,7 +1374,10 @@ gfc_create_string_length (gfc_symbol * sym)
sym->ts.u.cl->backend_decl = length;
if (static_length)
- TREE_STATIC (length) = 1;
+ {
+ TREE_STATIC (length) = 1;
+ DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, 0);
+ }
if (sym->ns->proc_name->attr.flavor == FL_MODULE
&& (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
@@ -1861,12 +1864,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& sym->value && sym->value->expr_type != EXPR_NULL
&& sym->value->ts.u.cl->length)
{
+ tree tmp;
gfc_expr *len = sym->value->ts.u.cl->length;
- DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
- TREE_TYPE (length),
- false, false, false);
- DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
- DECL_INITIAL (length));
+
+ tmp = gfc_conv_expr_initializer (length, len);
+ DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node, tmp);
}
else
gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
@@ -1917,13 +1919,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
every time the procedure is entered. The TREE_STATIC is
in this case due to -fmax-stack-var-size=. */
- DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl), sym->attr.dimension
- || (sym->attr.codimension
- && sym->attr.allocatable),
- sym->attr.pointer || sym->attr.allocatable
- || sym->ts.type == BT_CLASS,
- sym->attr.proc_pointer);
+ DECL_INITIAL (decl) = gfc_conv_sym_initializer (decl, sym);
}
if (!TREE_STATIC (decl)
@@ -2057,10 +2053,7 @@ get_proc_pointer_decl (gfc_symbol *sym)
if (TREE_STATIC (decl) && sym->value)
{
/* Add static initializer. */
- DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl),
- sym->attr.dimension,
- false, true);
+ DECL_INITIAL (decl) = gfc_conv_sym_initializer (decl, sym);
}
/* Handle threadprivate procedure pointers. */
@@ -4811,8 +4804,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
|| (CLASS_DATA (sym)->attr.codimension
&& flag_coarray != GFC_FCOARRAY_LIB))
{
+ int rank = CLASS_DATA (sym)->as->rank;
+
tmp = gfc_class_data_get (sym->backend_decl);
- tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+ tmp = gfc_build_null_descriptor (TREE_TYPE (tmp), rank);
}
else
tmp = null_pointer_node;
@@ -5555,6 +5550,8 @@ static void
gfc_emit_parameter_debug_info (gfc_symbol *sym)
{
tree decl;
+ gfc_array_spec *as;
+ bool is_class;
if (sym->attr.flavor != FL_PARAMETER
&& (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
@@ -5576,6 +5573,9 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
|| sym->attr.assign)
return;
+ is_class = (sym->ts.type == BT_CLASS) && CLASS_DATA (sym);
+ as = is_class ? (CLASS_DATA (sym)->as) : (sym->as);
+
if (sym->ts.type == BT_CHARACTER)
{
gfc_conv_const_charlen (sym->ts.u.cl);
@@ -5586,16 +5586,16 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
return;
- if (sym->as)
+ if (as)
{
int n;
- if (sym->as->type != AS_EXPLICIT)
+ if (as->type != AS_EXPLICIT)
return;
- for (n = 0; n < sym->as->rank; n++)
- if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
- || sym->as->upper[n] == NULL
- || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
+ for (n = 0; n < as->rank; n++)
+ if (as->lower[n]->expr_type != EXPR_CONSTANT
+ || as->upper[n] == NULL
+ || as->upper[n]->expr_type != EXPR_CONSTANT)
return;
}
@@ -5620,10 +5620,7 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
TREE_USED (decl) = 1;
if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
TREE_PUBLIC (decl) = 1;
- DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl),
- sym->attr.dimension,
- false, false);
+ DECL_INITIAL (decl) = gfc_conv_sym_initializer (decl, sym);
debug_hooks->early_global_decl (decl);
}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index de406ad..6842207 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -256,6 +256,25 @@ gfc_class_vptr_get (tree decl)
}
+/* Try to find if a type is unlimited polymorphic. */
+
+bool
+gfc_class_unlimited_poly (tree type)
+{
+ tree len;
+
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (TREE_CODE (type) != RECORD_TYPE)
+ return false;
+ if (!GFC_CLASS_TYPE_P (type))
+ return false;
+
+ len = gfc_advance_chain (TYPE_FIELDS (type), CLASS_LEN_FIELD);
+ return len != NULL_TREE;
+}
+
+
tree
gfc_class_len_get (tree decl)
{
@@ -7956,11 +7975,15 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
The other parameters describe the variable of the component being
initialized. EXPR may be null. */
-tree
-gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
- bool array, bool pointer, bool procptr)
+static tree
+gfc_conv_initializer_common (tree decl, gfc_expr * expr, gfc_typespec *ts, int rank,
+ bool allocatable, bool pointer, bool procptr)
{
gfc_se se;
+ tree type;
+ bool arrayish, is_null;
+
+ type = TREE_TYPE (decl);
if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
&& ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
@@ -7985,12 +8008,20 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
gcc_unreachable ();
}
- if (array && !procptr)
+ is_null = (expr && expr->expr_type == EXPR_NULL);
+
+ arrayish = ((TREE_CODE (type) == ARRAY_TYPE && GFC_ARRAY_TYPE_P (type))
+ || GFC_DESCRIPTOR_TYPE_P (type));
+
+ if (arrayish && !procptr)
{
tree ctor;
+
/* Arrays need special handling. */
- if (pointer)
- ctor = gfc_build_null_descriptor (type);
+ if (allocatable || is_null)
+ ctor = gfc_build_null_descriptor (type, rank);
+ else if (pointer)
+ ctor = gfc_build_init_descriptor (decl, rank, expr);
/* Special case assigning an array to zero. */
else if (is_zero_initializer_p (expr))
ctor = build_constructor (type, NULL);
@@ -7999,18 +8030,21 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
TREE_STATIC (ctor) = 1;
return ctor;
}
- else if (pointer || procptr)
+ else if (allocatable || pointer || procptr)
{
if (ts->type == BT_CLASS && !procptr)
{
gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+ gfc_conv_structure_initializer (&se,
+ gfc_class_initializer (ts, expr, pointer));
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
TREE_STATIC (se.expr) = 1;
return se.expr;
}
- else if (!expr || expr->expr_type == EXPR_NULL)
+ else if ((allocatable && !procptr) || is_null)
return fold_convert (type, null_pointer_node);
+ else if (expr == NULL)
+ return NULL_TREE;
else
{
gfc_init_se (&se, NULL);
@@ -8027,10 +8061,11 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
case_bt_struct:
case BT_CLASS:
gfc_init_se (&se, NULL);
- if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
- gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+ if (ts->type == BT_CLASS && is_null)
+ gfc_conv_structure_initializer (&se,
+ gfc_class_initializer (ts, expr, false));
else
- gfc_conv_structure (&se, expr, 1);
+ gfc_conv_structure_initializer (&se, expr);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
TREE_STATIC (se.expr) = 1;
return se.expr;
@@ -8053,6 +8088,65 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
}
+
+tree
+gfc_conv_sym_initializer (tree decl, gfc_symbol * sym)
+{
+ tree ctor;
+ symbol_attribute *attr;
+ gfc_array_spec *as;
+ bool is_class, is_pointer;
+ int rank;
+
+ is_class = (sym->ts.type == BT_CLASS) && CLASS_DATA (sym);
+ attr = is_class ? &(CLASS_DATA (sym)->attr) : &(sym->attr);
+ is_pointer = is_class ? attr->class_pointer : attr->pointer;
+ as = is_class ? (CLASS_DATA (sym)->as) : (sym->as);
+ rank = as ? as->rank : 0;
+
+ ctor = gfc_conv_initializer_common (decl, sym->value, &sym->ts, rank,
+ attr->allocatable, is_pointer,
+ sym->attr.proc_pointer);
+ return ctor;
+}
+
+
+tree
+gfc_conv_comp_initializer (tree decl, gfc_component * c, gfc_expr * expr)
+{
+ tree ctor;
+ symbol_attribute *attr;
+ gfc_array_spec *as;
+ bool is_class, is_pointer;
+ int rank;
+
+ is_class = (c->ts.type == BT_CLASS) && CLASS_DATA (c);
+ attr = is_class ? &(CLASS_DATA (c)->attr) : &(c->attr);
+ is_pointer = is_class ? attr->class_pointer : attr->pointer;
+ as = is_class ? (CLASS_DATA (c)->as) : (c->as);
+ rank = as ? as->rank : 0;
+
+ ctor = gfc_conv_initializer_common (decl, expr, &c->ts, rank,
+ attr->allocatable, is_pointer,
+ c->attr.proc_pointer);
+ return ctor;
+}
+
+
+tree
+gfc_conv_expr_initializer (tree decl, gfc_expr * expr)
+{
+ tree ctor;
+ symbol_attribute attr;
+
+ attr = gfc_expr_attr (expr);
+ ctor = gfc_conv_initializer_common (decl, expr, &expr->ts, expr->rank,
+ attr.allocatable, attr.pointer,
+ attr.proc_pointer);
+ return ctor;
+}
+
+
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
@@ -8474,8 +8568,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_class_initializer (&cm->ts, expr),
- false);
+ gfc_class_initializer (&cm->ts, expr, cm->attr.class_pointer), false);
gfc_add_expr_to_block (&block, tmp);
}
else if ((cm->attr.dimension || cm->attr.codimension)
@@ -8834,56 +8927,57 @@ gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
/* Add the map initializer on top. */
if (ctor != NULL && ctor->expr != NULL)
{
+ tree val;
+
gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
- tree val = gfc_conv_initializer (ctor->expr, &un->ts,
- TREE_TYPE (un->backend_decl),
- un->attr.dimension, un->attr.pointer,
- un->attr.proc_pointer);
+ val = gfc_conv_comp_initializer (un->backend_decl, un, ctor->expr);
CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
}
}
+/* Build an expression for a constructor. */
+
+static void
+gfc_conv_structure (gfc_se * se, gfc_expr * expr)
+{
+ tree type;
+ tree tmp;
+
+ gcc_assert (se->ss == NULL);
+ gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ /* Create a temporary variable and fill it in. */
+ se->expr = gfc_create_var (type, expr->ts.u.derived->name);
+ /* The symtree in expr is NULL, if the code to generate is for
+ initializing the static members only. */
+ tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
+ se->want_coarray);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ return;
+}
+
+
/* Build an expression for a constructor. If init is nonzero then
this is part of a static variable initializer. */
void
-gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
+gfc_conv_structure_initializer (gfc_se * se, gfc_expr * expr)
{
gfc_constructor *c;
gfc_component *cm;
tree val;
tree type;
- tree tmp;
vec<constructor_elt, va_gc> *v = NULL;
gcc_assert (se->ss == NULL);
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
- type = gfc_typenode_for_spec (&expr->ts);
-
- if (!init)
- {
- /* Create a temporary variable and fill it in. */
- se->expr = gfc_create_var (type, expr->ts.u.derived->name);
- /* The symtree in expr is NULL, if the code to generate is for
- initializing the static members only. */
- tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
- se->want_coarray);
- gfc_add_expr_to_block (&se->pre, tmp);
- return;
- }
cm = expr->ts.u.derived->components;
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
{
- /* Skip absent members in default initializers and allocatable
- components. Although the latter have a default initializer
- of EXPR_NULL,... by default, the static nullify is not needed
- since this is done every time we come into scope. */
- if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
- continue;
-
if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "_extends") == 0
&& cm->initializer->symtree)
@@ -8903,27 +8997,39 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
val));
}
else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
- fold_convert (TREE_TYPE (cm->backend_decl),
- integer_zero_node));
+ {
+ tree len = integer_zero_node;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (c->expr->ts.u.cl);
+ if (c->expr->ts.u.cl->backend_decl)
+ len = c->expr->ts.u.cl->backend_decl;
+ if (!TREE_CONSTANT (len) || TREE_SIDE_EFFECTS (len))
+ if (DECL_INITIAL (len))
+ len = DECL_INITIAL (len);
+ }
+
+ len = fold_convert (TREE_TYPE (cm->backend_decl), len);
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, len);
+ }
else if (cm->ts.type == BT_UNION)
gfc_conv_union_initializer (v, cm, c->expr);
else
{
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl),
- cm->attr.dimension, cm->attr.pointer,
- cm->attr.proc_pointer);
- val = unshare_expr_without_location (val);
-
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ val = gfc_conv_comp_initializer (cm->backend_decl, cm, c->expr);
+ if (val)
+ {
+ val = unshare_expr_without_location (val);
+ /* Append it to the constructor list. */
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
}
}
+ type = gfc_typenode_for_spec (&expr->ts);
se->expr = build_constructor (type, v);
- if (init)
- TREE_CONSTANT (se->expr) = 1;
+ TREE_CONSTANT (se->expr) = 1;
}
@@ -9034,7 +9140,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
break;
case EXPR_STRUCTURE:
- gfc_conv_structure (se, expr, 0);
+ gfc_conv_structure (se, expr);
break;
case EXPR_ARRAY:
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 5582e40..c525b9a 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1480,7 +1480,7 @@ gfc_get_desc_dim_type (void)
unknown cases abort. */
tree
-gfc_get_dtype_rank_type (int rank, tree etype)
+gfc_get_dtype_rank_type (int rank, tree etype, bool static_flag)
{
tree ptype;
tree size;
@@ -1558,6 +1558,14 @@ gfc_get_dtype_rank_type (int rank, tree etype)
gcc_assert (size);
STRIP_NOPS (size);
+ if (TREE_CODE (size) == SAVE_EXPR)
+ size = TREE_OPERAND (size, 0);
+ STRIP_NOPS (size);
+ if (static_flag && (!TREE_CONSTANT (size) || TREE_SIDE_EFFECTS (size)))
+ size = (DECL_INITIAL (size))
+ ? (DECL_INITIAL (size)) : (integer_zero_node);
+
+ STRIP_NOPS (size);
size = fold_convert (size_type_node, size);
tmp = get_dtype_type_node ();
field = gfc_advance_chain (TYPE_FIELDS (tmp),
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 3b45ce2..e6243e6 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -113,7 +113,7 @@ int gfc_return_by_reference (gfc_symbol *);
int gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
-tree gfc_get_dtype_rank_type (int, tree);
+tree gfc_get_dtype_rank_type (int, tree, bool static_flag = false);
tree gfc_get_dtype (tree, int *rank = NULL);
tree gfc_get_ppc_type (gfc_component *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index f26e91b..27efdda 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1774,6 +1774,89 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
}
+/* Simple equality check. */
+
+bool
+tree_ref_equal (tree a, tree b)
+{
+ int len, idx;
+
+ if (a == b)
+ return true;
+ if (!a || !b)
+ return false;
+ len = TREE_OPERAND_LENGTH (a);
+ if (len == 0 || len != TREE_OPERAND_LENGTH (b))
+ return false;
+ for (idx=0; idx<len; idx++)
+ if (!tree_ref_equal (TREE_OPERAND (a, idx), TREE_OPERAND (b, idx)))
+ return false;
+ return true;
+}
+
+/* Get RHS for given LHS in a MODIFY_EXPR. */
+
+tree
+gfc_get_expr_from_chain (tree base, tree chain)
+{
+ tree stmt;
+
+ switch (TREE_CODE (chain))
+ {
+ case MODIFY_EXPR:
+ {
+ stmt = chain;
+ gcc_assert (TREE_OPERAND_LENGTH (stmt) == 2);
+ if (tree_ref_equal (base, TREE_OPERAND (stmt, 0)))
+ return TREE_OPERAND (stmt, 1);
+ break;
+ }
+ case STATEMENT_LIST:
+ {
+ tree_stmt_iterator iter;
+
+ for (iter = tsi_start (chain); !tsi_end_p (iter); tsi_next (&iter))
+ {
+ stmt = tsi_stmt (iter);
+ if (TREE_CODE (stmt) != MODIFY_EXPR)
+ continue;
+ gcc_assert (TREE_OPERAND_LENGTH (stmt) == 2);
+ if (tree_ref_equal (base, TREE_OPERAND (stmt, 0)))
+ return TREE_OPERAND (stmt, 1);
+ }
+ break;
+ }
+ default:
+ break;
+ }
+ return NULL_TREE;
+}
+
+
+/* Get value from CONSTRUCTOR. */
+
+tree
+gfc_get_expr_from_ctor (tree ctor, int index)
+{
+ tree type, field, findx, value;
+ unsigned idx;
+
+ gcc_assert (TREE_CODE (ctor) == CONSTRUCTOR);
+ type = TREE_TYPE (ctor);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), index);
+ gcc_assert (field != NULL_TREE);
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, findx, value)
+ {
+ value = (field == findx) ? (STRIP_NOPS (value)) : (NULL_TREE);
+ if (value)
+ break;
+ }
+
+ return value;
+}
+
+
/* Add an expression to another one, either at the front or the back. */
static void
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d1d4a1d..2d8ef7f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -424,6 +424,7 @@ gfc_wrapped_block;
tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
+bool gfc_class_unlimited_poly (tree);
tree gfc_class_len_get (tree);
tree gfc_class_len_or_zero_get (tree);
tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
@@ -566,7 +567,7 @@ tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
void gfc_trans_common (gfc_namespace *);
/* Translate a derived type constructor. */
-void gfc_conv_structure (gfc_se *, gfc_expr *, int);
+void gfc_conv_structure_initializer (gfc_se *, gfc_expr *);
/* Return an expression which determines if a dummy parameter is present. */
tree gfc_conv_expr_present (gfc_symbol *, bool use_saved_decl = false);
@@ -590,6 +591,10 @@ void gfc_conv_string_length (gfc_charlen *, gfc_expr *, stmtblock_t *);
/* Ensure type sizes can be gimplified. */
void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
+/* Get RHS from LHS in a list of statements. */
+tree gfc_get_expr_from_chain (tree, tree);
+/* Get value from CONSTRUCTOR. */
+tree gfc_get_expr_from_ctor (tree, int);
/* Add an expression to the end of a block. */
void gfc_add_expr_to_block (stmtblock_t *, tree);
/* Add an expression to the beginning of a block. */
@@ -654,7 +659,9 @@ bool gfc_get_module_backend_decl (gfc_symbol *);
tree gfc_get_symbol_decl (gfc_symbol *);
/* Build a static initializer. */
-tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool);
+tree gfc_conv_sym_initializer (tree, gfc_symbol *);
+tree gfc_conv_comp_initializer (tree, gfc_component *, gfc_expr *);
+tree gfc_conv_expr_initializer (tree, gfc_expr *);
/* Assign a default initializer to a derived type. */
void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool);
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
index d251477..8914365 100644
--- a/gcc/testsuite/gfortran.dg/class_allocate_14.f90
+++ b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
@@ -25,6 +25,6 @@ call sub()
call sub2()
end
-! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.data=0B}, ._vptr=&__vtab_m_T};" 1 "original" } }
+! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.data=0B, .dtype={.elem_len=4, .rank=1, .type=5}}, ._vptr=&__vtab_m_T};" 1 "original" } }
! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y = {._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/init_flag_19.f03 b/gcc/testsuite/gfortran.dg/init_flag_19.f03
index bbcee8a..39dbc29 100644
--- a/gcc/testsuite/gfortran.dg/init_flag_19.f03
+++ b/gcc/testsuite/gfortran.dg/init_flag_19.f03
@@ -30,7 +30,7 @@ end
! { dg-final { scan-tree-dump-times "\.ival *= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "\.rval *= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "\.bt_ptr *= *0" 1 "original" } }
-! { dg-final { scan-tree-dump-times "\.bt_alloc *= *0" 1 "original" } }
-! { dg-final { scan-tree-dump-times "\.class_alloc(?: *= *\{)?\._data *= *0" 1 "original" } }
-! { dg-final { scan-tree-dump-times "\.class_ptr(?: *= *\{)?\._data *= *0" 1 "original" } }
-! { dg-final { scan-tree-dump-times "calloc(?: *= *\{)?\._data *= *0" 1 "original" } }
+! { dg-final { scan-tree-dump-times "\.bt_alloc *= *0" 2 "original" } }
+! { dg-final { scan-tree-dump-times "\.class_alloc(?: *= *\{)?\._data *= *0" 2 "original" } }
+! { dg-final { scan-tree-dump-times "\.class_ptr *= *\{\._data *= *0" 1 "original" } }
+! { dg-final { scan-tree-dump-times "calloc(?: *= *\{)?\._data *= *0" 2 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/init_workout.f90 b/gcc/testsuite/gfortran.dg/init_workout.f90
new file mode 100644
index 0000000..528624b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/init_workout.f90
@@ -0,0 +1,306 @@
+! { dg-do run }
+!
+! Test the fix for PR101047/101048
+!
+
+program save_p
+
+ implicit none
+
+ integer :: i
+ integer, parameter :: n = 11
+ integer, parameter :: m = 7
+ integer, parameter :: r = 3
+ integer, parameter :: s = 7
+ integer, parameter :: u(*) = [(i, i=1,n)]
+ character, parameter :: v(*) = [(achar(i+iachar("A")-1), i=1,n)]
+ character(len=m), parameter :: w(*) = [(repeat(achar(i+iachar("A")-1), m), i=1,n)]
+
+ type :: foo_t
+ integer :: i
+ end type foo_t
+
+ type, extends(foo_t) :: bar_t
+ integer :: a(n)
+ end type bar_t
+
+ integer, target :: a(n) = u
+ integer, save, pointer :: pi1(:)
+ integer, pointer :: pi2(:) =>null()
+ integer, pointer :: pi3(:) =>a
+ integer, pointer :: pi4(:) =>a(r:s)
+
+ character, target :: c1(n) = v
+ character, save, pointer :: pc1(:)
+ character, pointer :: pc2(:) =>null()
+ character, pointer :: pc3(:) =>c1
+ character, pointer :: pc4(:) =>c1(r:s)
+
+ character(len=m), target :: cl(n) = w
+ character(len=m), save, pointer :: pl1(:)
+ character(len=m), pointer :: pl2(:) =>null()
+ character(len=m), pointer :: pl3(:) =>cl
+ character(len=m), pointer :: pl4(:) =>cl(r:s)
+
+ character(len=:), save, pointer :: pd1(:)
+ character(len=:), pointer :: pd2(:) =>null()
+ character(len=:), pointer :: pd3(:) =>c1
+ character(len=:), pointer :: pd4(:) =>c1(r:s)
+ character(len=:), pointer :: pd5(:) =>cl
+ character(len=:), pointer :: pd6(:) =>cl(r:s)
+
+ type(foo_t), target :: f(n) = [(foo_t(i), i=1,n)]
+ type(foo_t), save, pointer :: pf1(:)
+ type(foo_t), pointer :: pf2(:) =>null()
+ type(foo_t), pointer :: pf3(:) =>f
+ type(foo_t), pointer :: pf4(:) =>f(r:s)
+
+ type(bar_t), target :: b(n) = [(bar_t(i, i*u), i=1,n)]
+ type(bar_t), save, pointer :: pb1(:)
+ type(bar_t), pointer :: pb2(:) =>null()
+ type(bar_t), pointer :: pb3(:) =>b
+ type(bar_t), pointer :: pb4(:) =>b(r:s)
+
+ class(foo_t), save, pointer :: pf5(:)
+ class(foo_t), pointer :: pf6(:) =>null()
+ class(foo_t), pointer :: pf7(:) =>f
+ class(foo_t), pointer :: pf8(:) =>f(r:s)
+ class(foo_t), pointer :: pf9(:) =>b
+ class(foo_t), pointer :: pfa(:) =>b(r:s)
+
+ class(bar_t), save, pointer :: pb5(:)
+ class(bar_t), pointer :: pb6(:) =>null()
+ class(bar_t), pointer :: pb7(:) =>b
+ class(bar_t), pointer :: pb8(:) =>b(r:s)
+
+ class(*), save, pointer :: pu1(:)
+ class(*), pointer :: pu2(:) =>null()
+ class(*), pointer :: pu3(:) =>a
+ class(*), pointer :: pu4(:) =>a(r:s)
+ class(*), pointer :: pu5(:) =>c1
+ class(*), pointer :: pu6(:) =>c1(r:s)
+ class(*), pointer :: pu7(:) =>cl
+ class(*), pointer :: pu8(:) =>cl(r:s)
+ class(*), pointer :: pu9(:) =>f
+ class(*), pointer :: pua(:) =>f(r:s)
+ class(*), pointer :: pub(:) =>b
+ class(*), pointer :: puc(:) =>b(r:s)
+
+ nullify(pi1)
+ if(associated(pi2)) stop 1
+ !
+ if(.not.associated(pi3)) stop 2
+ if(.not.associated(pi3, a)) stop 3
+ if(any(pi3/=u)) stop 4
+ !
+ if(.not.associated(pi4)) stop 5
+ if(.not.associated(pi4, a(r:s))) stop 6
+ if(any(pi4/=u(r:s))) stop 7
+ !
+ nullify(pc1)
+ if(associated(pc2)) stop 8
+ !
+ if(.not.associated(pc3)) stop 9
+ if(.not.associated(pc3, c1)) stop 10
+ if(any(pc3/=v)) stop 11
+ !
+ if(.not.associated(pc4)) stop 12
+ if(.not.associated(pc4, c1(r:s))) stop 13
+ if(any(pc4/=v(r:s))) stop 14
+ !
+ nullify(pl1)
+ if(associated(pl2)) stop 15
+ !
+ if(.not.associated(pl3)) stop 16
+ if(.not.associated(pl3, cl)) stop 17
+ if(any(pl3/=w)) stop 18
+ !
+ if(.not.associated(pl4)) stop 19
+ if(.not.associated(pl4, cl(r:s))) stop 20
+ if(any(pl4/=w(r:s))) stop 21
+ !
+ nullify(pd1)
+ if(associated(pd2)) stop 22
+ !
+ if(.not.associated(pd3)) stop 23
+ if(.not.associated(pd3, c1)) stop 24
+ if(any(pd3/=v)) stop 25
+ !
+ if(.not.associated(pd4)) stop 26
+ if(.not.associated(pd4, c1(r:s))) stop 27
+ if(any(pd4/=v(r:s))) stop 28
+ !
+ if(.not.associated(pd5)) stop 29
+ if(.not.associated(pd5, cl)) stop 30
+ if(any(pd5/=w)) stop 31
+ !
+ if(.not.associated(pd6)) stop 32
+ if(.not.associated(pd6, cl(r:s))) stop 33
+ if(any(pd6/=w(r:s))) stop 34
+ !
+ nullify(pf1)
+ if(associated(pf2)) stop 35
+ !
+ if(.not.associated(pf3)) stop 36
+ if(.not.associated(pf3, f)) stop 37
+ if(any(pf3(:)%i/=u)) stop 38
+ !
+ if(.not.associated(pf4)) stop 39
+ if(.not.associated(pf4, f(r:s))) stop 40
+ if(any(pf4(:)%i/=u(r:s))) stop 41
+ !
+ nullify(pb1)
+ if(associated(pb2)) stop 42
+ !
+ if(.not.associated(pb3)) stop 43
+ if(.not.associated(pb3, b)) stop 44
+ if(any(pb3(:)%i/=u)) stop 45
+ do i = 1, n
+ if(any(pb3(i)%a/=i*u)) stop 46
+ end do
+ !
+ if(.not.associated(pb4)) stop 47
+ if(.not.associated(pb4, b(r:s))) stop 48
+ if(any(pb4(:)%i/=u(r:s))) stop 49
+ do i = 1, s-r+1
+ if(any(pb4(i)%a/=(r+i-1)*u)) stop 50
+ end do
+ !
+ nullify(pf5)
+ if(associated(pf6)) stop 51
+ !
+ if(.not.associated(pf7)) stop 52
+ if(.not.associated(pf7, f)) stop 53
+ if(any(pf7(:)%i/=u)) stop 54
+ !
+ if(.not.associated(pf8)) stop 55
+ if(.not.associated(pf8, f(r:s))) stop 56
+ if(any(pf8(:)%i/=u(r:s))) stop 57
+ !
+ if(.not.associated(pf9)) stop 58
+ if(.not.associated(pf9, b)) stop 59
+ if(any(pf9(:)%i/=u)) stop 60
+ !
+ if(.not.associated(pfa)) stop 61
+ if(.not.associated(pfa, b(r:s))) stop 62
+ if(any(pfa(:)%i/=u(r:s))) stop 63
+ !
+ nullify(pb5)
+ if(associated(pb6)) stop 64
+ !
+ if(.not.associated(pb7)) stop 65
+ if(.not.associated(pb7, b)) stop 66
+ if(any(pb7(:)%i/=u)) stop 67
+ do i = 1, n
+ if(any(pb7(i)%a/=i*u)) stop 68
+ end do
+ !
+ if(.not.associated(pb8)) stop 69
+ if(.not.associated(pb8, b(r:s))) stop 70
+ if(any(pb8(:)%i/=u(r:s))) stop 71
+ do i = 1, s-r+1
+ if(any(pb8(i)%a/=(r+i-1)*u)) stop 72
+ end do
+ !
+ nullify(pu1)
+ if(associated(pu2)) stop 73
+ !
+ if(.not.associated(pu3)) stop 29
+ if(.not.associated(pu3, a)) stop 74
+ select type(pu3)
+ type is(integer)
+ if(any(pu3/=a)) stop 75
+ class default
+ stop 76
+ end select
+ !
+ if(.not.associated(pu4)) stop 77
+ if(.not.associated(pu4, a(r:s))) stop 78
+ select type(pu4)
+ type is(integer)
+ if(any(pu4/=a(r:s))) stop 79
+ class default
+ stop 80
+ end select
+ !
+ if(.not.associated(pu5)) stop 81
+ if(.not.associated(pu5, c1)) stop 82
+ select type(pu5)
+ type is(character(len=*))
+ if(any(pu5/=c1)) stop 83
+ class default
+ stop 84
+ end select
+ !
+ if(.not.associated(pu6)) stop 85
+ if(.not.associated(pu6, c1(r:s))) stop 86
+ select type(pu6)
+ type is(character(len=*))
+ if(any(pu6/=c1(r:s))) stop 87
+ class default
+ stop 88
+ end select
+ !
+ if(.not.associated(pu7)) stop 89
+ if(.not.associated(pu7, cl)) stop 90
+ select type(pu7)
+ type is(character(len=*))
+ if(any(pu7/=cl)) stop 91
+ class default
+ stop 91
+ end select
+ !
+ if(.not.associated(pu8)) stop 92
+ if(.not.associated(pu8, cl(r:s))) stop 93
+ select type(pu8)
+ type is(character(len=*))
+ if(any(pu8/=cl(r:s))) stop 94
+ class default
+ stop 95
+ end select
+ !
+ if(.not.associated(pu9)) stop 95
+ if(.not.associated(pu9, f)) stop 96
+ select type(pu9)
+ type is(foo_t)
+ if(any(pu9(:)%i/=u)) stop 97
+ class default
+ stop 98
+ end select
+ !
+ if(.not.associated(pua)) stop 99
+ if(.not.associated(pua, f(r:s))) stop 100
+ select type(pua)
+ type is(foo_t)
+ if(any(pua(:)%i/=u(r:s))) stop 101
+ class default
+ stop 102
+ end select
+ !
+ if(.not.associated(pub)) stop 102
+ if(.not.associated(pub, b)) stop 103
+ select type(pub)
+ type is(bar_t)
+ if(any(pub(:)%i/=u)) stop 104
+ do i = 1, n
+ if(any(pub(i)%a/=i*u)) stop 105
+ end do
+ class default
+ stop 98
+ end select
+ !
+ if(.not.associated(puc)) stop 106
+ if(.not.associated(puc, b(r:s))) stop 107
+ select type(puc)
+ type is(bar_t)
+ if(any(puc(:)%i/=u(r:s))) stop 108
+ do i = 1, s-r+1
+ if(any(puc(i)%a/=(r+i-1)*u)) stop 109
+ end do
+ class default
+ stop 110
+ end select
+ stop
+
+end program save_p
+
