@@ -2562,13 +2562,19 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of
- target-memory.c/gfc_element_size for 'size'. */
+ target-memory.c/gfc_element_size for 'size'. Special handling
+ for character arrays, that are not constant sized: to support
+ len(str)*kind, only the kind information is stored in the
+ vtab. */
e = gfc_get_expr ();
e->ts = *ts;
e->expr_type = EXPR_VARIABLE;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL,
- (int)gfc_element_size (e));
+ ts->type == BT_CHARACTER
+ && charlen == 0 ?
+ ts->kind :
+ (int)gfc_element_size (e));
gfc_free_expr (e);
/* Add component _extends. */
@@ -3168,6 +3168,7 @@ void gfc_add_component_ref (gfc_expr *, const char *);
void gfc_add_class_array_ref (gfc_expr *);
#define gfc_add_data_component(e) gfc_add_component_ref(e,"_data")
#define gfc_add_vptr_component(e) gfc_add_component_ref(e,"_vptr")
+#define gfc_add_len_component(e) gfc_add_component_ref(e,"_len")
#define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash")
#define gfc_add_size_component(e) gfc_add_component_ref(e,"_size")
#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
@@ -4975,8 +4975,7 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
- gfc_typespec *ts)
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
{
tree type;
tree tmp;
@@ -5156,9 +5155,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = TYPE_SIZE_UNIT (tmp);
}
}
- else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
- /* FIXME: Properly handle characters. See PR 57456. */
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
else
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -5230,7 +5226,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
+ tree *nelems, gfc_expr *expr3)
{
tree tmp;
tree pointer;
@@ -5315,7 +5311,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3, ts);
+ expr3_elem_size, nelems, expr3);
if (dimension)
{
@@ -8022,7 +8018,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
fold_convert (TREE_TYPE (dst_data), tmp));
}
- tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+ tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
+ UNLIMITED_POLY (c));
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_finish_block (&tmpblock);
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *, gfc_typespec *);
+ tree, tree *, gfc_expr *);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -268,6 +268,57 @@ gfc_vptr_size_get (tree vptr)
#undef VTABLE_FINAL_FIELD
+/* Search for the last _class ref in the chain of references of this expression
+ and cut the chain there. After that copy the cut down expression to CUT. */
+
+gfc_expr *
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
+{
+ gfc_expr *base_expr;
+ gfc_ref *ref, *class_ref, *tail;
+
+ /* Find the last class reference. */
+ class_ref = NULL;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ class_ref = ref;
+
+ if (ref->next == NULL)
+ break;
+ }
+
+ /* Remove and store all subsequent references after the
+ CLASS reference. */
+ if (class_ref)
+ {
+ tail = class_ref->next;
+ class_ref->next = NULL;
+ }
+ else
+ {
+ tail = e->ref;
+ e->ref = NULL;
+ }
+
+ base_expr = gfc_expr_to_initialize (e);
+
+ /* Restore the original tail expression. */
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = tail;
+ }
+ else
+ {
+ gfc_free_ref_list (e->ref);
+ e->ref = tail;
+ }
+ return base_expr;
+}
+
+
/* Reset the vptr to the declared type, e.g. after deallocation. */
void
@@ -317,6 +368,22 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
}
+/* Reset the len for unlimited polymorphic objects. */
+
+void
+gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
+{
+ gfc_expr *e;
+ gfc_se se_len;
+ e = gfc_find_and_cut_at_last_class_ref (expr);
+ gfc_add_len_component (e);
+ gfc_init_se (&se_len, NULL);
+ gfc_conv_expr (&se_len, e);
+ gfc_add_modify (block, se_len.expr,
+ fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
+ gfc_free_expr (e);
+}
+
/* Obtain the vptr of the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
@@ -925,22 +992,25 @@ gfc_get_class_array_ref (tree index, tree class_decl)
that the _vptr is set. */
tree
-gfc_copy_class_to_class (tree from, tree to, tree nelems)
+gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
{
tree fcn;
tree fcn_type;
tree from_data;
+ tree from_len;
tree to_data;
+ tree to_len;
tree to_ref;
tree from_ref;
vec<tree, va_gc> *args;
tree tmp;
+ tree stdcopy;
+ tree extcopy;
tree index;
- stmtblock_t loopbody;
- stmtblock_t body;
- gfc_loopinfo loop;
args = NULL;
+ /* To prevent warnings for uninitialization. */
+ from_len = to_len = NULL_TREE;
if (from != NULL_TREE)
fcn = gfc_class_vtab_copy_get (from);
@@ -950,14 +1020,36 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
fcn_type = TREE_TYPE (TREE_TYPE (fcn));
if (from != NULL_TREE)
- from_data = gfc_class_data_get (from);
+ from_data = gfc_class_data_get (from);
else
from_data = gfc_class_vtab_def_init_get (to);
+ if (unlimited)
+ {
+ if (from != NULL_TREE && unlimited)
+ from_len = gfc_class_len_get (from);
+ else
+ {
+ mpz_t len_zero;
+
+ mpz_init (len_zero);
+ mpz_set_ui (len_zero, 0);
+ from_len = gfc_conv_mpz_to_tree (len_zero, gfc_index_integer_kind);
+ mpz_clear (len_zero);
+ }
+ }
+
to_data = gfc_class_data_get (to);
+ if (unlimited)
+ to_len = gfc_class_len_get (to);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
{
+ stmtblock_t loopbody;
+ stmtblock_t body;
+ stmtblock_t ifbody;
+ gfc_loopinfo loop;
+
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, nelems,
@@ -989,8 +1081,41 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
loop.loopvar[0] = index;
loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &loopbody);
- gfc_add_block_to_block (&body, &loop.pre);
- tmp = gfc_finish_block (&body);
+ gfc_init_block (&ifbody);
+ gfc_add_block_to_block (&ifbody, &loop.pre);
+ stdcopy = gfc_finish_block (&ifbody);
+ if (unlimited)
+ {
+ vec_safe_push (args, from_len);
+ vec_safe_push (args, to_len);
+ tmp = build_call_vec (fcn_type, fcn, args);
+ /* Build the body of the loop. */
+ gfc_init_block (&loopbody);
+ gfc_add_expr_to_block (&loopbody, tmp);
+
+ /* Build the loop and return. */
+ gfc_init_loopinfo (&loop);
+ loop.dimen = 1;
+ loop.from[0] = gfc_index_zero_node;
+ loop.loopvar[0] = index;
+ loop.to[0] = nelems;
+ gfc_trans_scalarizing_loops (&loop, &loopbody);
+ gfc_init_block (&ifbody);
+ gfc_add_block_to_block (&ifbody, &loop.pre);
+ extcopy = gfc_finish_block (&ifbody);
+
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ from_len, integer_zero_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, extcopy, stdcopy);
+ gfc_add_expr_to_block (&body, tmp);
+ tmp = gfc_finish_block (&body);
+ }
+ else
+ {
+ gfc_add_expr_to_block (&body, stdcopy);
+ tmp = gfc_finish_block (&body);
+ }
gfc_cleanup_loop (&loop);
}
else
@@ -998,7 +1123,20 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
vec_safe_push (args, from_data);
vec_safe_push (args, to_data);
- tmp = build_call_vec (fcn_type, fcn, args);
+ stdcopy = build_call_vec (fcn_type, fcn, args);
+
+ if (unlimited)
+ {
+ vec_safe_push (args, from_len);
+ vec_safe_push (args, to_len);
+ extcopy = build_call_vec (fcn_type, fcn, args);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ from_len, integer_zero_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, extcopy, stdcopy);
+ }
+ else
+ tmp = stdcopy;
}
return tmp;
@@ -4958,9 +4958,8 @@ tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *e;
gfc_expr *expr;
- gfc_se se;
+ gfc_se se, se_sz;
tree tmp;
tree parm;
tree stat;
@@ -4969,21 +4968,23 @@ gfc_trans_allocate (gfc_code * code)
tree label_errmsg;
tree label_finish;
tree memsz;
- tree expr3;
- tree slen3;
+ tree al_vptr, al_len;
+ /* If an expr3 is present, then store the tree for accessing its _vptr,
+ and _len components in the variables, respectively. The element size,
+ i.e. _vptr%size, is stored in expr3_esize and the expression to compute
+ the memsz in expr3_memsz. Any of the trees may be the NULL_TREE
+ indicating that this is not available for expr3's type. */
+ tree expr3, expr3_vptr, expr3_len, expr3_esize;
stmtblock_t block;
stmtblock_t post;
- gfc_expr *sz;
- gfc_se se_sz;
- tree class_expr;
tree nelems;
- tree memsize = NULL_TREE;
- tree classexpr = NULL_TREE;
+ bool upoly_expr, tmp_expr3_len_flag = false;
if (!code->ext.alloc.list)
return NULL_TREE;
- stat = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
+ expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
gfc_init_block (&block);
@@ -5017,201 +5018,336 @@ gfc_trans_allocate (gfc_code * code)
TREE_USED (label_finish) = 0;
}
- expr3 = NULL_TREE;
- slen3 = NULL_TREE;
+ /* When an expr3 is given, try to evaluate it only once. In most cases
+ expr3 is invariant for all elements of the allocation list. Exceptions are
+ only arrays. Furthermore do(es) the standard(s) prevent a dependency of
+ expr3 on the objects to allocate. Therefore it is save to pre-evaluate
+ expr3 for complicated expressions, i.e., everything not a variable or
+ constant.
+ When an array allocation is wanted, then the following block nevertheless
+ evaluates the _vptr, _len and element_size for expr3. */
+ if (code->expr3)
+ {
+ bool vtab_needed = false;
+ /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
+ the expression is only needed to get the _vptr, _len a.s.o. */
+ tree expr3_tmp = NULL_TREE;
+
+ /* Figure whether we need the vtab from expr3. */
+ for (al = code->ext.alloc.list; al != NULL; al = al->next)
+ if (al->expr->ts.type == BT_CLASS)
+ {
+ vtab_needed = true;
+ break;
+ }
+
+ /* A array expr3 needs the scalarizer, therefore do not process it
+ here. */
+ if (code->expr3->expr_type != EXPR_ARRAY
+ && (!code->expr3->symtree || !code->expr3->symtree->n.sym->as)
+ && !gfc_is_class_array_ref (code->expr3, NULL))
+ {
+ /* When expr3 is a variable, i.e., a very simple expression, then
+ convert it once here. */
+ if ((code->expr3->expr_type == EXPR_VARIABLE)
+ || code->expr3->expr_type == EXPR_CONSTANT)
+ {
+ if (!code->expr3->mold || code->expr3->ts.type == BT_CHARACTER
+ || vtab_needed)
+ {
+ /* Convert expr3 to a tree. */
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post, &se.post);
+ }
+ /* else expr3 = NULL_TREE set above. */
+ }
+ else
+ {
+ /* In all other cases evaluate the expr3 and create a
+ temporary. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_reference (&se, code->expr3);
+ if (code->expr3->ts.type == BT_CLASS)
+ gfc_conv_class_to_class (&se, code->expr3, code->expr3->ts,
+ false, true, false, false);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post, &se.post);
+ /* Prevent aliasing, i.e., se.expr may be already a variable
+ declaration. */
+ if (!VAR_P (se.expr))
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se.expr);
+ tmp = gfc_evaluate_now (tmp, &block);
+ }
+ else
+ tmp = se.expr;
+ if (!code->expr3->mold)
+ expr3 = tmp;
+ else
+ expr3_tmp = tmp;
+ /* When he length of a char array is easily available here, get
+ and store it for future reference. */
+ if (se.string_length)
+ expr3_len = gfc_evaluate_now (se.string_length, &block);
+ }
+ }
+
+ /* Figure how to get the _vtab entry. This also retrieves the tree for
+ accessing the _len component, because only unlimited polymorphic
+ objects, which are a subcategory of class types, have a _len
+ component. */
+ if (code->expr3->ts.type == BT_CLASS)
+ {
+ gfc_expr *rhs;
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
+ if (expr3 != NULL_TREE && !code->expr3->ref)
+ tmp = gfc_class_vptr_get (expr3);
+ else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
+ tmp = gfc_class_vptr_get (expr3_tmp);
+ else
+ {
+ rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
+ gfc_add_vptr_component (rhs);
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, rhs);
+ tmp = se.expr;
+ gfc_free_expr (rhs);
+ }
+ /* Set the element size. */
+ expr3_esize = gfc_vptr_size_get (tmp);
+ if (vtab_needed)
+ expr3_vptr = tmp;
+ /* Initialize the ref to the _len component. */
+ if (expr3_len == NULL_TREE && code->expr3->symtree
+ && UNLIMITED_POLY (code->expr3->symtree->n.sym))
+ {
+ /* Same like for retrieving the _vptr. */
+ if (expr3 != NULL_TREE && !code->expr3->ref)
+ expr3_len = gfc_class_len_get (expr3);
+ else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
+ expr3_len = gfc_class_len_get (expr3_tmp);
+ else
+ {
+ rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
+ gfc_add_len_component (rhs);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, rhs);
+ expr3_len = se.expr;
+ gfc_free_expr (rhs);
+ }
+ }
+ }
+ else
+ {
+ /* When the object to allocate is polymorphic type, then it needs its
+ vtab set correctly, so deduce the required _vtab and _len from the
+ source expression. */
+ if (vtab_needed)
+ {
+ /* VPTR is fixed at compile time. */
+ gfc_symbol *vtab;
+
+ vtab = gfc_find_vtab (&code->expr3->ts);
+ gcc_assert (vtab);
+ expr3_vptr = gfc_build_addr_expr (NULL_TREE,
+ gfc_get_symbol_decl (vtab));
+ }
+ /* _len component needs to be set, when ts is a character
+ array. */
+ if (expr3_len == NULL_TREE && code->expr3->ts.type == BT_CHARACTER)
+ {
+ if (code->expr3->ts.u.cl
+ && code->expr3->ts.u.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
+ gfc_add_block_to_block (&block, &se.pre);
+ expr3_len = gfc_evaluate_now (se.expr, &block);
+ }
+ gcc_assert (expr3_len);
+ }
+ /* For character arrays only the kind's size is needed, because the
+ array mem_size is computed to be _len * (elem_size = kind_size).
+ For all other get the element size in the common way. */
+ if (code->expr3->ts.type == BT_CHARACTER)
+ expr3_esize = TYPE_SIZE_UNIT (
+ gfc_get_char_type (code->expr3->ts.kind));
+ else
+ expr3_esize = TYPE_SIZE_UNIT (
+ gfc_typenode_for_spec (&code->expr3->ts));
+ }
+ gcc_assert (expr3_esize);
+ expr3_esize = fold_convert (sizetype, expr3_esize);
+ }
+ else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+ {
+ /* Compute the explicit typespec given only once for all objects to
+ allocate. */
+ if (code->ext.alloc.ts.type != BT_CHARACTER)
+ expr3_esize = TYPE_SIZE_UNIT (
+ gfc_typenode_for_spec (&code->ext.alloc.ts));
+ else
+ {
+ gfc_expr *sz;
+ gcc_assert (code->ext.alloc.ts.u.cl->length != NULL);
+ sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ tmp = TYPE_SIZE_UNIT (gfc_get_char_type (code->ext.alloc.ts.kind));
+ expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (se_sz.expr),
+ fold_convert (TREE_TYPE (se_sz.expr),
+ tmp),
+ se_sz.expr);
+ }
+ }
+ /* Loop over all objects to allocate. */
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = gfc_copy_expr (al->expr);
+ /* UNLIMITED_POLY () needs the _data component to be set, when expr is a
+ unlimited polymorphic object. But the _data component has not been set
+ yet, so check the derived type's attr for the unlimited polymorphic
+ flag to be safe. */
+ upoly_expr = UNLIMITED_POLY (expr)
+ || (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.unlimited_polymorphic);
+ gfc_init_se (&se, NULL);
+ /* For class types prepare the expressions to ref the _vptr
+ and the _len component. The latter for unlimited polymorphic types
+ only. */
if (expr->ts.type == BT_CLASS)
- gfc_add_data_component (expr);
-
- gfc_init_se (&se, NULL);
+ {
+ gfc_expr *expr_ref_vptr, *expr_ref_len;
+ gfc_add_data_component (expr);
+ /* Prep the vptr handle. */
+ expr_ref_vptr = gfc_copy_expr (al->expr);
+ gfc_add_vptr_component (expr_ref_vptr);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr_ref_vptr);
+ al_vptr = se.expr;
+ se.want_pointer = 0;
+ gfc_free_expr (expr_ref_vptr);
+ /* Allocated unlimited polymorphic objects always have a _len
+ component. */
+ if (upoly_expr)
+ {
+ expr_ref_len = gfc_copy_expr (al->expr);
+ gfc_add_len_component (expr_ref_len);
+ gfc_conv_expr (&se, expr_ref_len);
+ al_len = se.expr;
+ gfc_free_expr (expr_ref_len);
+ }
+ else
+ /* In a loop ensure that all loop variable dependent variables are
+ initialized at the same spot in all execution paths. */
+ al_len = NULL_TREE;
+ }
+ else
+ al_vptr = al_len = NULL_TREE;
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
-
- /* Evaluate expr3 just once if not a variable. */
- if (al == code->ext.alloc.list
- && al->expr->ts.type == BT_CLASS
- && code->expr3
- && code->expr3->ts.type == BT_CLASS
- && code->expr3->expr_type != EXPR_VARIABLE)
- {
- gfc_init_se (&se_sz, NULL);
- gfc_conv_expr_reference (&se_sz, code->expr3);
- gfc_conv_class_to_class (&se_sz, code->expr3,
- code->expr3->ts, false, true, false, false);
- gfc_add_block_to_block (&se.pre, &se_sz.pre);
- gfc_add_block_to_block (&se.post, &se_sz.post);
- classexpr = build_fold_indirect_ref_loc (input_location,
- se_sz.expr);
- classexpr = gfc_evaluate_now (classexpr, &se.pre);
- memsize = gfc_class_vtab_size_get (classexpr);
- memsize = fold_convert (sizetype, memsize);
- }
-
- memsz = memsize;
- class_expr = classexpr;
-
+ if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+ /* se.string_length now stores the .string_length variable of expr
+ needed to allocate character(len=:) arrays. */
+ al_len = se.string_length;
+
+ /* When allocating an array one can not use much of the pre-evaluated
+ expr3 expressions, because for most of them the scalarizer is needed
+ which is not available in the pre-evaluation step. Therefore
+ gfc_array_allocate () is responsible (and able) to handle the
+ complete array allocation. Only the element size needs to be provided,
+ which is done most of the time by the pre-evaluation step. */
nelems = NULL_TREE;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
- memsz, &nelems, code->expr3, &code->ext.alloc.ts))
+ expr3_esize, &nelems, code->expr3))
{
- bool unlimited_char;
-
- unlimited_char = UNLIMITED_POLY (al->expr)
- && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER)
- || (code->ext.alloc.ts.type == BT_CHARACTER
- && code->ext.alloc.ts.u.cl
- && code->ext.alloc.ts.u.cl->length));
+ /* A scalar or derived type. First compute the size to allocate. */
- /* A scalar or derived type. */
-
- /* Determine allocate size. */
- if (al->expr->ts.type == BT_CLASS
- && !unlimited_char
- && code->expr3
- && memsz == NULL_TREE)
- {
- if (code->expr3->ts.type == BT_CLASS)
- {
- sz = gfc_copy_expr (code->expr3);
- gfc_add_vptr_component (sz);
- gfc_add_size_component (sz);
- gfc_init_se (&se_sz, NULL);
- gfc_conv_expr (&se_sz, sz);
- gfc_free_expr (sz);
- memsz = se_sz.expr;
- }
- else
- memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
- }
- else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
- || unlimited_char) && code->expr3)
+ /* expr3_len is set when expr3 is unlimited polymorphic object or
+ a deferred length string. */
+ if (expr3_len != NULL_TREE)
{
- if (!code->expr3->ts.u.cl->backend_decl)
- {
- /* Convert and use the length expression. */
- gfc_init_se (&se_sz, NULL);
- if (code->expr3->expr_type == EXPR_VARIABLE
- || code->expr3->expr_type == EXPR_CONSTANT)
- {
- gfc_conv_expr (&se_sz, code->expr3);
- gfc_add_block_to_block (&se.pre, &se_sz.pre);
- se_sz.string_length
- = gfc_evaluate_now (se_sz.string_length, &se.pre);
- gfc_add_block_to_block (&se.pre, &se_sz.post);
- memsz = se_sz.string_length;
- }
- else if (code->expr3->mold
- && code->expr3->ts.u.cl
- && code->expr3->ts.u.cl->length)
- {
- gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
- gfc_add_block_to_block (&se.pre, &se_sz.pre);
- se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
- gfc_add_block_to_block (&se.pre, &se_sz.post);
- memsz = se_sz.expr;
- }
- else
- {
- /* This is would be inefficient and possibly could
- generate wrong code if the result were not stored
- in expr3/slen3. */
- if (slen3 == NULL_TREE)
- {
- gfc_conv_expr (&se_sz, code->expr3);
- gfc_add_block_to_block (&se.pre, &se_sz.pre);
- expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
- gfc_add_block_to_block (&post, &se_sz.post);
- slen3 = gfc_evaluate_now (se_sz.string_length,
- &se.pre);
- }
- memsz = slen3;
- }
- }
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (expr3_esize), expr3_esize,
+ fold_convert (TREE_TYPE (expr3_esize),
+ expr3_len));
+ if (code->expr3->ts.type != BT_CLASS)
+ /* expr3 is a deferred length string, i.e., we are done. */
+ memsz = tmp;
else
- /* Otherwise use the stored string length. */
- memsz = code->expr3->ts.u.cl->backend_decl;
- tmp = al->expr->ts.u.cl->backend_decl;
-
- /* Store the string length. */
- if (tmp && TREE_CODE (tmp) == VAR_DECL)
- gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
- memsz));
- else if (al->expr->ts.type == BT_CHARACTER
- && al->expr->ts.deferred && se.string_length)
- gfc_add_modify (&se.pre, se.string_length,
- fold_convert (TREE_TYPE (se.string_length),
- memsz));
- else if ((al->expr->ts.type == BT_DERIVED
- || al->expr->ts.type == BT_CLASS)
- && expr->ts.u.derived->attr.unlimited_polymorphic)
{
- tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
- gfc_add_modify (&se.pre, tmp,
- fold_convert (TREE_TYPE (tmp),
- memsz));
+ /* For unlimited polymorphic enties build
+ (len > 0) ? element_size * len : element_size
+ to compute the number of bytes to allocate. This allows
+ allocating of unlimited polymorphic objects from an expr3
+ that is unlimited polymorphic, too, and stores a _len
+ dependent object, e.g., a string. */
+ memsz = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, expr3_len,
+ integer_zero_node);
+ memsz = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (expr3_esize),
+ memsz, tmp, expr3_esize);
}
-
- /* Convert to size in bytes, using the character KIND. */
- if (unlimited_char)
- tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
- else
- tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
- tmp = TYPE_SIZE_UNIT (tmp);
- memsz = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (tmp), memsz));
}
- else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
- || unlimited_char)
+ else if (expr3_esize != NULL_TREE)
+ /* Any other object in expr3 just needs element size bytes. */
+ memsz = expr3_esize;
+ else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+ || (upoly_expr && code->ext.alloc.ts.type == BT_CHARACTER))
{
- gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
+ /* Allocating deferred length char arrays need the length to
+ allocate in the alloc_type_spec. But also unlimited
+ polymorphic objects may be allocated as char arrays. Both are
+ handled here. */
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
gfc_add_block_to_block (&se.pre, &se_sz.pre);
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
gfc_add_block_to_block (&se.pre, &se_sz.post);
- /* Store the string length. */
- if ((expr->symtree->n.sym->ts.type == BT_CLASS
- || expr->symtree->n.sym->ts.type == BT_DERIVED)
- && expr->ts.u.derived->attr.unlimited_polymorphic)
- /* For unlimited polymorphic entities get the backend_decl of
- the _len component for that. */
- tmp = gfc_class_len_get (gfc_get_symbol_decl (
- expr->symtree->n.sym));
- else
- /* Else use what is stored in the charlen->backend_decl. */
- tmp = al->expr->ts.u.cl->backend_decl;
- gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
- se_sz.expr));
- tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
- tmp = TYPE_SIZE_UNIT (tmp);
+ expr3_len = se_sz.expr;
+ tmp_expr3_len_flag = true;
+ tmp = TYPE_SIZE_UNIT (
+ gfc_get_char_type (code->ext.alloc.ts.kind));
memsz = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (se_sz.expr),
- se_sz.expr));
+ TREE_TYPE (tmp),
+ fold_convert (TREE_TYPE (tmp),
+ expr3_len),
+ tmp);
}
- else if (code->ext.alloc.ts.type != BT_UNKNOWN)
- memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
- else if (memsz == NULL_TREE)
- memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
-
- if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+ else if (expr->ts.type == BT_CHARACTER)
{
- memsz = se.string_length;
-
- /* Convert to size in bytes, using the character KIND. */
- tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
- tmp = TYPE_SIZE_UNIT (tmp);
+ /* Compute the number of bytes needed to allocate a fixed length
+ char array. */
+ gcc_assert (se.string_length != NULL_TREE);
+ tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (tmp), memsz));
+ fold_convert (TREE_TYPE (tmp),
+ se.string_length));
}
+ else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+ /* Handle all types, where the alloc_type_spec is set. */
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ else
+ /* Handle size compuation of the type declared to alloc. */
+ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));;
/* Allocate - for non-pointers with re-alloc checking. */
if (gfc_expr_attr (expr).allocatable)
@@ -5244,124 +5380,103 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
- /* We need the vptr of CLASS objects to be initialized. */
- e = gfc_copy_expr (al->expr);
- if (e->ts.type == BT_CLASS)
+ /* Set the vptr. */
+ if (al_vptr != NULL_TREE)
{
- gfc_expr *lhs, *rhs;
- gfc_se lse;
- gfc_ref *ref, *class_ref, *tail;
-
- /* Find the last class reference. */
- class_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- class_ref = ref;
-
- if (ref->next == NULL)
- break;
- }
-
- /* Remove and store all subsequent references after the
- CLASS reference. */
- if (class_ref)
- {
- tail = class_ref->next;
- class_ref->next = NULL;
- }
- else
- {
- tail = e->ref;
- e->ref = NULL;
- }
-
- lhs = gfc_expr_to_initialize (e);
- gfc_add_vptr_component (lhs);
-
- /* Remove the _vptr component and restore the original tail
- references. */
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- class_ref->next = tail;
- }
- else
- {
- gfc_free_ref_list (e->ref);
- e->ref = tail;
- }
-
- if (class_expr != NULL_TREE)
- {
- /* Polymorphic SOURCE: VPTR must be determined at run time. */
- gfc_init_se (&lse, NULL);
- lse.want_pointer = 1;
- gfc_conv_expr (&lse, lhs);
- tmp = gfc_class_vptr_get (class_expr);
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
- else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
- {
- /* Polymorphic SOURCE: VPTR must be determined at run time. */
- rhs = gfc_copy_expr (code->expr3);
- gfc_add_vptr_component (rhs);
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (rhs);
- rhs = gfc_expr_to_initialize (e);
- }
+ if (expr3_vptr != NULL_TREE)
+ /* The vtab is already known, so just assign it. */
+ gfc_add_modify (&block, al_vptr,
+ fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
else
{
/* VPTR is fixed at compile time. */
gfc_symbol *vtab;
gfc_typespec *ts;
+
if (code->expr3)
+ /* Although expr3 is pre-evaluated above, it may happen, that
+ for arrays or in mold= cases the pre-evaluation was not
+ successful. In these rare cases take the vtab from the
+ typespec of expr3 here. */
ts = &code->expr3->ts;
- else if (e->ts.type == BT_DERIVED)
- ts = &e->ts;
- else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr))
+ else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
+ /* The alloc_type_spec gives the type to allocate or the
+ al is unlimited polymorphic, which enforces the use of an
+ alloc_type_spec that is not necessarily a BT_DERIVED. */
ts = &code->ext.alloc.ts;
- else if (e->ts.type == BT_CLASS)
- ts = &CLASS_DATA (e)->ts;
else
- ts = &e->ts;
-
- if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
- {
- vtab = gfc_find_vtab (ts);
- gcc_assert (vtab);
- gfc_init_se (&lse, NULL);
- lse.want_pointer = 1;
- gfc_conv_expr (&lse, lhs);
- tmp = gfc_build_addr_expr (NULL_TREE,
- gfc_get_symbol_decl (vtab));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
+ /* Prepare for setting the vtab as declared. */
+ ts = &expr->ts;
+
+ vtab = gfc_find_vtab (ts);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE,
+ gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&block, al_vptr,
+ fold_convert (TREE_TYPE (al_vptr), tmp));
}
- gfc_free_expr (lhs);
}
- gfc_free_expr (e);
-
+ /* Add assignment for string length. */
+ if (al_len != NULL_TREE)
+ {
+ if (expr3_len != NULL_TREE)
+ {
+ gfc_add_modify (&block, al_len, fold_convert (TREE_TYPE (al_len),
+ expr3_len));
+ /* When tmp_expr3_len_flag is set, then expr3_len is abused to
+ carry the length information from the alloc_type. Clear it to
+ prevent setting incorrect len information in future loop
+ iterations. */
+ if (tmp_expr3_len_flag)
+ /* No need to reset tmp_expr3_len_flag, because the presence of
+ an expr3 can not change within in the loop. */
+ expr3_len = NULL_TREE;
+ }
+ else if (code->ext.alloc.ts.type == BT_CHARACTER
+ && code->ext.alloc.ts.u.cl->length)
+ {
+ /* The length of the string in characters is needed. expr3_esize
+ contains the number of bytes needed for the string to pass
+ to gfc_array_allocate (), therefore can not be resused
+ here. */
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+ gfc_add_modify (&block, al_len,
+ fold_convert (TREE_TYPE (al_len), se_sz.expr));
+ }
+ else
+ /* No length information needed, because type to allocate has no
+ length. Set _len to 0. */
+ gfc_add_modify (&block, al_len,
+ fold_convert (TREE_TYPE (al_len),
+ integer_zero_node));
+ }
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (class_expr != NULL_TREE)
+ if (expr3 != NULL_TREE
+ && (VAR_P (expr3) || TREE_CODE (expr3) == ADDR_EXPR)
+ && code->expr3->ts.type == BT_CLASS &&
+ (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED))
{
tree to;
to = TREE_OPERAND (se.expr, 0);
-
- tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+ tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr);
+ }
+ else if (code->expr3->ts.type == BT_CHARACTER)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_trans_string_copy (&block,
+ al_len, tmp, code->expr3->ts.kind,
+ expr3_len, expr3, code->expr3->ts.kind);
+ tmp = NULL_TREE;
}
else if (al->expr->ts.type == BT_CLASS)
{
- gfc_actual_arglist *actual;
+ gfc_actual_arglist *actual, *last_arg;
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
@@ -5371,15 +5486,15 @@ gfc_trans_allocate (gfc_code * code)
actual->expr = gfc_copy_expr (rhs);
if (rhs->ts.type == BT_CLASS)
gfc_add_data_component (actual->expr);
- actual->next = gfc_get_actual_arglist ();
- actual->next->expr = gfc_copy_expr (al->expr);
- actual->next->expr->ts.type = BT_CLASS;
- gfc_add_data_component (actual->next->expr);
+ last_arg = actual->next = gfc_get_actual_arglist ();
+ last_arg->expr = gfc_copy_expr (al->expr);
+ last_arg->expr->ts.type = BT_CLASS;
+ gfc_add_data_component (last_arg->expr);
dataref = NULL;
/* Make sure we go up through the reference chain to
the _data reference, where the arrayspec is found. */
- for (ref = actual->next->expr->ref; ref; ref = ref->next)
+ for (ref = last_arg->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT
&& strcmp (ref->u.c.component->name, "_data") == 0)
dataref = ref;
@@ -5413,7 +5528,10 @@ gfc_trans_allocate (gfc_code * code)
}
if (rhs->ts.type == BT_CLASS)
{
- ppc = gfc_copy_expr (rhs);
+ if (rhs->ref)
+ ppc = gfc_find_and_cut_at_last_class_ref (rhs);
+ else
+ ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
@@ -5422,6 +5540,7 @@ gfc_trans_allocate (gfc_code * code)
ppc_code = gfc_get_code (EXEC_CALL);
ppc_code->resolved_sym = ppc->symtree->n.sym;
+ ppc_code->loc = al->expr->where;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
@@ -5430,15 +5549,49 @@ gfc_trans_allocate (gfc_code * code)
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+ /* We need to add the
+ if (al_len > 0)
+ al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
+ else
+ al_vptr->copy (expr3_data, al_data);
+ block, because al is unlimited polymorphic or a deferred length
+ char array, whose copy routine needs the array length's as
+ third and fourth arguments. */
+ if (al_len && UNLIMITED_POLY (code->expr3))
+ {
+ tree stdcopy, extcopy;
+ /* Add al%_len. */
+ last_arg->next = gfc_get_actual_arglist ();
+ last_arg = last_arg->next;
+ last_arg->expr = gfc_find_and_cut_at_last_class_ref (
+ al->expr);
+ gfc_add_component_ref (last_arg->expr, "_len");
+ /* Add expr3's length. */
+ last_arg->next = gfc_get_actual_arglist ();
+ last_arg = last_arg->next;
+ if (code->expr3->ts.type == BT_CLASS)
+ {
+ last_arg->expr =
+ gfc_find_and_cut_at_last_class_ref (code->expr3);
+ gfc_add_len_component (last_arg->expr);
+ }
+ else if (code->expr3->ts.type == BT_CHARACTER)
+ last_arg->expr =
+ gfc_copy_expr (code->expr3->ts.u.cl->length);
+ else
+ gcc_unreachable ();
+
+ stdcopy = tmp;
+ extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, expr3_len,
+ integer_zero_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp, extcopy, stdcopy);
+ }
gfc_free_statements (ppc_code);
}
- else if (expr3 != NULL_TREE)
- {
- tmp = build_fold_indirect_ref_loc (input_location, se.expr);
- gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
- slen3, expr3, code->expr3->ts.kind);
- tmp = NULL_TREE;
- }
else
{
/* Switch off automatic reallocation since we have just done
@@ -5459,12 +5612,13 @@ gfc_trans_allocate (gfc_code * code)
object, we can use gfc_copy_class_to_class in its
initialization mode. */
tmp = TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
+ tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
+ upoly_expr);
gfc_add_expr_to_block (&block, tmp);
}
gfc_free_expr (expr);
- }
+ } // for-loop
/* STAT. */
if (code->expr1)
@@ -5642,7 +5796,14 @@ gfc_trans_deallocate (gfc_code *code)
}
if (al->expr->ts.type == BT_CLASS)
- gfc_reset_vptr (&se.pre, al->expr);
+ {
+ gfc_reset_vptr (&se.pre, al->expr);
+ if (UNLIMITED_POLY (al->expr)
+ || (al->expr->ts.type == BT_DERIVED
+ && al->expr->ts.u.derived->attr.unlimited_polymorphic))
+ /* Clear _len, too. */
+ gfc_reset_len (&se.pre, al->expr);
+ }
}
else
{
@@ -5657,7 +5818,14 @@ gfc_trans_deallocate (gfc_code *code)
gfc_add_expr_to_block (&se.pre, tmp);
if (al->expr->ts.type == BT_CLASS)
- gfc_reset_vptr (&se.pre, al->expr);
+ {
+ gfc_reset_vptr (&se.pre, al->expr);
+ if (UNLIMITED_POLY (al->expr)
+ || (al->expr->ts.type == BT_DERIVED
+ && al->expr->ts.u.derived->attr.unlimited_polymorphic))
+ /* Clear _len, too. */
+ gfc_reset_len (&se.pre, al->expr);
+ }
}
if (code->expr1)
@@ -350,6 +350,7 @@ tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_get (tree);
+gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
/* Get an accessor to the class' vtab's * field, when a class handle is
available. */
tree gfc_class_vtab_hash_get (tree);
@@ -366,9 +367,10 @@ tree gfc_vptr_def_init_get (tree);
tree gfc_vptr_copy_get (tree);
tree gfc_vptr_final_get (tree);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
+void gfc_reset_len (stmtblock_t *, gfc_expr *);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
-tree gfc_copy_class_to_class (tree, tree, tree);
+tree gfc_copy_class_to_class (tree, tree, tree, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
@@ -23,12 +23,14 @@ program test
implicit none
character(LEN=:), allocatable, target :: S
character(LEN=100) :: res
- class(*), pointer :: ucp
+ class(*), pointer :: ucp, ucp2
call sub1 ("long test string", 16)
call sub2 ()
S = "test"
ucp => S
call sub3 (ucp)
+ allocate (ucp2, source=ucp)
+ call sub3 (ucp2)
call sub4 (S, 4)
call sub4 ("This is a longer string.", 24)
call bar (S, res)
@@ -5,52 +5,178 @@
program test
implicit none
- class(*), pointer :: P
+ class(*), pointer :: P1, P2, P3
+ class(*), pointer, dimension(:) :: PA1
+ class(*), allocatable :: A1, A2
integer :: string_len = 10 *2
+ character(len=:), allocatable, target :: str
+ character(len=:,kind=4), allocatable :: str4
- allocate(character(string_len)::P)
+ str = "string for test"
+ str4 = 4_"string for test"
- select type(P)
+ allocate(character(string_len)::P1)
+
+ select type(P1)
+ type is (character(*))
+ P1 ="some test string"
+ if (P1 .ne. "some test string") call abort ()
+ if (len(P1) .ne. 20) call abort ()
+ if (len(P1) .eq. len("some test string")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(A1, source = P1)
+
+ select type(A1)
+ type is (character(*))
+ if (A1 .ne. "some test string") call abort ()
+ if (len(A1) .ne. 20) call abort ()
+ if (len(A1) .eq. len("some test string")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(A2, source = convertType(P1))
+
+ select type(A2)
+ type is (character(*))
+ if (A2 .ne. "some test string") call abort ()
+ if (len(A2) .ne. 20) call abort ()
+ if (len(A2) .eq. len("some test string")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(P2, source = str)
+
+ select type(P2)
+ type is (character(*))
+ if (P2 .ne. "string for test") call abort ()
+ if (len(P2) .eq. 20) call abort ()
+ if (len(P2) .ne. len("string for test")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(P3, source = "string for test")
+
+ select type(P3)
+ type is (character(*))
+ if (P3 .ne. "string for test") call abort ()
+ if (len(P3) .eq. 20) call abort ()
+ if (len(P3) .ne. len("string for test")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(character(len=10)::PA1(3))
+
+ select type(PA1)
type is (character(*))
- P ="some test string"
- if (P .ne. "some test string") then
- call abort ()
- end if
- if (len(P) .ne. 20) then
- call abort ()
- end if
- if (len(P) .eq. len("some test string")) then
- call abort ()
- end if
+ PA1(1) = "string 10 "
+ if (PA1(1) .ne. "string 10 ") call abort ()
+ if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
class default
call abort ()
end select
- deallocate(P)
+ deallocate(PA1)
+ deallocate(P3)
+! if (len(P3) .ne. 0) call abort() ! Can't check, because select
+! type would be needed, which needs the vptr, which is 0 now.
+ deallocate(P2)
+ deallocate(A2)
+ deallocate(A1)
+ deallocate(P1)
! Now for kind=4 chars.
- allocate(character(len=20,kind=4)::P)
+ allocate(character(len=20,kind=4)::P1)
- select type(P)
+ select type(P1)
type is (character(len=*,kind=4))
- P ="some test string"
- if (P .ne. 4_"some test string") then
- call abort ()
- end if
- if (len(P) .ne. 20) then
- call abort ()
- end if
- if (len(P) .eq. len("some test string")) then
- call abort ()
- end if
+ P1 ="some test string"
+ if (P1 .ne. 4_"some test string") call abort ()
+ if (len(P1) .ne. 20) call abort ()
+ if (len(P1) .eq. len("some test string")) call abort ()
type is (character(len=*,kind=1))
call abort ()
class default
call abort ()
end select
- deallocate(P)
+ allocate(A1, source=P1)
+
+ select type(A1)
+ type is (character(len=*,kind=4))
+ if (A1 .ne. 4_"some test string") call abort ()
+ if (len(A1) .ne. 20) call abort ()
+ if (len(A1) .eq. len("some test string")) call abort ()
+ type is (character(len=*,kind=1))
+ call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(A2, source = convertType(P1))
+
+ select type(A2)
+ type is (character(len=*, kind=4))
+ if (A2 .ne. 4_"some test string") call abort ()
+ if (len(A2) .ne. 20) call abort ()
+ if (len(A2) .eq. len("some test string")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(P2, source = str4)
+
+ select type(P2)
+ type is (character(len=*,kind=4))
+ if (P2 .ne. 4_"string for test") call abort ()
+ if (len(P2) .eq. 20) call abort ()
+ if (len(P2) .ne. len("string for test")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(P3, source = convertType(P2))
+
+ select type(P3)
+ type is (character(len=*, kind=4))
+ if (P3 .ne. 4_"string for test") call abort ()
+ if (len(P3) .eq. 20) call abort ()
+ if (len(P3) .ne. len("string for test")) call abort ()
+ class default
+ call abort ()
+ end select
+
+ allocate(character(kind=4, len=10)::PA1(3))
+
+ select type(PA1)
+ type is (character(len=*, kind=4))
+ PA1(1) = 4_"string 10 "
+ if (PA1(1) .ne. 4_"string 10 ") call abort ()
+ if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
+ class default
+ call abort ()
+ end select
+
+ deallocate(PA1)
+ deallocate(P3)
+ deallocate(P2)
+ deallocate(A2)
+ deallocate(P1)
+ deallocate(A1)
+
+contains
+ function convertType(in)
+ class(*), pointer, intent(in) :: in
+ class(*), pointer :: convertType
+ convertType => in
+ end function
end program test