+2015-03-24 Andre Vehreschild <vehre@gmx.de>
+
+ PR fortran/64787
+ PR fortran/57456
+ PR fortran/63230
+ * class.c (gfc_add_component_ref): Free no longer needed
+ ref-chains to prevent memory loss.
+ (find_intrinsic_vtab): For deferred length char arrays or
+ unlimited polymorphic objects, store the size in bytes of one
+ character in the size component of the vtab.
+ * gfortran.h: Added gfc_add_len_component () define.
+ * trans-array.c (gfc_trans_create_temp_array): Switched to new
+ function name for getting a class' vtab's field.
+ (build_class_array_ref): Likewise.
+ (gfc_array_init_size): Using the size information from allocate
+ more consequently now, i.e., the typespec of the entity to
+ allocate is no longer needed. This is to address the last open
+ comment in PR fortran/57456.
+ (gfc_array_allocate): Likewise.
+ (structure_alloc_comps): gfc_copy_class_to_class () needs to
+ know whether the class is unlimited polymorphic.
+ * trans-array.h: Changed interface of gfc_array_allocate () to
+ reflect the no longer needed typespec.
+ * trans-expr.c (gfc_find_and_cut_at_last_class_ref): New.
+ (gfc_reset_len): New.
+ (gfc_get_class_array_ref): Switch to new function name for
+ getting a class' vtab's field.
+ (gfc_copy_class_to_class): Added flag to know whether the class
+ to copy is unlimited polymorphic. Adding _len dependent code
+ then, which calls ->vptr->copy () with four arguments adding
+ the length information ->vptr->copy(from, to, from_len, to_cap).
+ (gfc_conv_procedure_call): Switch to new function name for
+ getting a class' vtab's field.
+ (alloc_scalar_allocatable_for_assignment): Use the string_length
+ as computed by gfc_conv_expr and not the statically backend_decl
+ which may be incorrect when ref-ing.
+ (gfc_trans_assignment_1): Use the string_length variable and
+ not the rse.string_length. The former has been computed more
+ generally.
+ * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Switch to new
+ function name for getting a class' vtab's field.
+ (gfc_conv_intrinsic_storage_size): Likewise.
+ (gfc_conv_intrinsic_transfer): Likewise.
+ * trans-stmt.c (gfc_trans_allocate): Restructured to evaluate
+ source=expr3 only once before the loop over the objects to
+ allocate, when the objects are not arrays. Doing correct _len
+ initialization and calling of vptr->copy () fixing PR 64787.
+ (gfc_trans_deallocate): Reseting _len to 0, preventing future
+ errors.
+ * trans.c (gfc_build_array_ref): Switch to new function name
+ for getting a class' vtab's field.
+ (gfc_add_comp_finalizer_call): Likewise.
+ * trans.h: Define the prototypes for the gfc_class_vtab_*_get ()
+ and gfc_vptr_*_get () functions.
+ Added gfc_find_and_cut_at_last_class_ref () and
+ gfc_reset_len () routine prototype. Added flag to
+ gfc_copy_class_to_class () prototype to signal an unlimited
+ polymorphic entity to copy.
+
2015-03-24 Iain Sandoe <iain@codesourcery.com>
Tobias Burnus <burnus@net-b.de>
}
if (*tail != NULL && strcmp (name, "_data") == 0)
next = *tail;
+ else
+ /* Avoid losing memory. */
+ gfc_free_ref_list (*tail);
(*tail) = gfc_get_ref();
(*tail)->next = next;
(*tail)->type = REF_COMPONENT;
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. */
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")
elemsize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
else
- elemsize = gfc_vtable_size_get (class_expr);
+ elemsize = gfc_class_vtab_size_get (class_expr);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
return false;
- size = gfc_vtable_size_get (decl);
+ size = gfc_class_vtab_size_get (decl);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
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;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
or_expr = boolean_false_node;
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));
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;
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)
{
dst_data = gfc_class_data_get (dcmp);
src_data = gfc_class_data_get (comp);
- size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+ size = fold_convert (size_type_node,
+ gfc_class_vtab_size_get (comp));
if (CLASS_DATA (c)->attr.dimension)
{
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);
/* 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 *,
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_LEN_FIELD);
+ CLASS_LEN_FIELD);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len,
NULL_TREE);
}
+/* Get the specified FIELD from the VPTR. */
+
static tree
-gfc_vtable_field_get (tree decl, int field)
+vptr_field_get (tree vptr, int fieldno)
{
- tree size;
- tree vptr;
- vptr = gfc_class_vptr_get (decl);
+ tree field;
vptr = build_fold_indirect_ref_loc (input_location, vptr);
- size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
- field);
- size = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (size), vptr, size,
- NULL_TREE);
- /* Always return size as an array index type. */
- if (field == VTABLE_SIZE_FIELD)
- size = fold_convert (gfc_array_index_type, size);
- gcc_assert (size);
- return size;
+ field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
+ fieldno);
+ field = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), vptr, field,
+ NULL_TREE);
+ gcc_assert (field);
+ return field;
}
-tree
-gfc_vtable_hash_get (tree decl)
-{
- return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
-}
-
+/* Get the field from the class' vptr. */
-tree
-gfc_vtable_size_get (tree decl)
+static tree
+class_vtab_field_get (tree decl, int fieldno)
{
- return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
+ tree vptr;
+ vptr = gfc_class_vptr_get (decl);
+ return vptr_field_get (vptr, fieldno);
}
-tree
-gfc_vtable_extends_get (tree decl)
-{
- return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
+/* Define a macro for creating the class_vtab_* and vptr_* accessors in
+ unison. */
+#define VTAB_GET_FIELD_GEN(name, field) tree \
+gfc_class_vtab_## name ##_get (tree cl) \
+{ \
+ return class_vtab_field_get (cl, field); \
+} \
+ \
+tree \
+gfc_vptr_## name ##_get (tree vptr) \
+{ \
+ return vptr_field_get (vptr, field); \
}
+VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
+VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
+VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
+VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
+VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
-tree
-gfc_vtable_def_init_get (tree decl)
-{
- return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
-}
+/* The size field is returned as an array index type. Therefore treat
+ it and only it specially. */
tree
-gfc_vtable_copy_get (tree decl)
+gfc_class_vtab_size_get (tree cl)
{
- return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
+ tree size;
+ size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
+ /* Always return size as an array index type. */
+ size = fold_convert (gfc_array_index_type, size);
+ gcc_assert (size);
+ return size;
}
-
tree
-gfc_vtable_final_get (tree decl)
+gfc_vptr_size_get (tree vptr)
{
- return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
+ tree size;
+ size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
+ /* Always return size as an array index type. */
+ size = fold_convert (gfc_array_index_type, size);
+ gcc_assert (size);
+ return size;
}
#undef VTABLE_FINAL_FIELD
+/* Search for the last _class ref in the chain of references of this
+ expression and cut the chain there. Albeit this routine is similiar
+ to class.c::gfc_add_component_ref (), is there a significant
+ difference: gfc_add_component_ref () concentrates on an array ref to
+ be the last ref in the chain. This routine is oblivious to the kind
+ of refs following. */
+
+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
}
+/* 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. */
gfc_get_class_array_ref (tree index, tree class_decl)
{
tree data = gfc_class_data_get (class_decl);
- tree size = gfc_vtable_size_get (class_decl);
+ tree size = gfc_class_vtab_size_get (class_decl);
tree offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
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 on uninitialized variables. */
+ from_len = to_len = NULL_TREE;
if (from != NULL_TREE)
- fcn = gfc_vtable_copy_get (from);
+ fcn = gfc_class_vtab_copy_get (from);
else
- fcn = gfc_vtable_copy_get (to);
+ fcn = gfc_class_vtab_copy_get (to);
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_vtable_def_init_get (to);
+ from_data = gfc_class_vtab_def_init_get (to);
+
+ if (unlimited)
+ {
+ if (from != NULL_TREE && unlimited)
+ from_len = gfc_class_len_get (from);
+ else
+ from_len = integer_zero_node;
+ }
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,
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
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;
}
+
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
CLASS_DATA (expr->value.function.esym->result)->attr);
}
- final_fndecl = gfc_vtable_final_get (se->expr);
+ final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
final_fndecl,
tmp = build_call_expr_loc (input_location,
final_fndecl, 3,
gfc_build_addr_expr (NULL, tmp),
- gfc_vtable_size_get (se->expr),
+ gfc_class_vtab_size_get (se->expr),
boolean_false_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, is_final, tmp,
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- expr1->ts.u.cl->backend_decl, size);
+ lse.string_length, size);
/* Jump past the realloc if the lengths are the same. */
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label2),
/* Update the lhs character length. */
size = string_length;
- if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
- gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
- else
- gfc_add_modify (block, lse.string_length, size);
+ gfc_add_modify (block, lse.string_length, size);
}
}
{
/* F2003: Add the code for reallocation on assignment. */
if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
- alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+ alloc_scalar_allocatable_for_assignment (&block, string_length,
expr1, expr2);
/* Use the scalar assignment as is. */
arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
: null_pointer_node;
}
-
+
if (least == 2)
{
arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
else if (arg->ts.type == BT_CLASS)
{
if (arg->rank)
- byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
else
- byte_size = gfc_vtable_size_get (argse.expr);
+ byte_size = gfc_class_vtab_size_get (argse.expr);
}
else
{
gfc_conv_expr_descriptor (&argse, arg);
if (arg->ts.type == BT_CLASS)
{
- tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
tmp = fold_convert (result_type, tmp);
goto done;
}
argse.string_length);
break;
case BT_CLASS:
- tmp = gfc_vtable_size_get (argse.expr);
+ tmp = gfc_class_vtab_size_get (argse.expr);
break;
default:
source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
break;
case BT_CLASS:
- tmp = gfc_vtable_size_get (argse.expr);
+ tmp = gfc_class_vtab_size_get (argse.expr);
break;
default:
tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
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;
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. 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, al_len_needs_set;
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);
TREE_USED (label_finish) = 0;
}
- expr3 = NULL_TREE;
- slen3 = NULL_TREE;
+ /* When an expr3 is present, try to evaluate it only once. In most
+ cases expr3 is invariant for all elements of the allocation list.
+ Only exceptions are arrays. Furthermore the standards prevent a
+ dependency of expr3 on the objects in the allocate list. Therefore
+ it is safe 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; !vtab_needed && al != NULL;
+ al = al->next)
+ vtab_needed = (al->expr->ts.type == BT_CLASS);
+
+ /* A array expr3 needs the scalarizer, therefore do not process it
+ here. */
+ if (code->expr3->expr_type != EXPR_ARRAY
+ && (code->expr3->rank == 0
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ && (!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, fix it for future use. */
+ if (se.string_length)
+ expr3_len = gfc_evaluate_now (se.string_length, &block);
+ }
+ }
+
+ /* Figure how to get the _vtab entry. This also obtains the tree
+ expression 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 && (VAR_P (expr3) || !code->expr3->ref))
+ tmp = gfc_class_vptr_get (expr3);
+ else if (expr3_tmp != NULL_TREE
+ && (VAR_P (expr3_tmp) ||!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 && UNLIMITED_POLY (code->expr3))
+ {
+ /* 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_get_symbol_decl (vtab);
+ expr3_vptr = gfc_build_addr_expr (NULL_TREE,
+ expr3_vptr);
+ }
+ /* _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 _len * (elem_size = kind_size).
+ For all other get the element size in the normal 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 = gfc_get_char_type (code->ext.alloc.ts.kind);
+ tmp = TYPE_SIZE_UNIT (tmp);
+ tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
+ expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
+ 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_vtable_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;
+
+ al_len_needs_set = al_len != NULL_TREE;
+ /* 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))
+ if (expr3_len && code->expr3->ts.type == BT_CHARACTER)
+ /* When al is an array, then the element size for each element
+ in the array is needed, which is the product of the len and
+ esize for char arrays. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (expr3_esize), expr3_esize,
+ fold_convert (TREE_TYPE (expr3_esize),
+ expr3_len));
+ else
+ tmp = expr3_esize;
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
+ label_finish, tmp, &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)
+ expr3_len is set when expr3 is an unlimited polymorphic
+ object or a deferred length string. */
+ if (expr3_len != 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)
- {
- 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_convert (TREE_TYPE (expr3_esize), expr3_len);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (expr3_esize),
+ expr3_esize, tmp);
+ 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 the allocation of unlimited polymorphic
+ objects from an expr3 that is also unlimited
+ polymorphic 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 in
+ 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 computation 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)
gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
- stat, errmsg, errlen, label_finish, expr);
+ stat, errmsg, errlen, label_finish,
+ expr);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
+ else
+ {
+ if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
+ && expr3_len != NULL_TREE)
+ {
+ /* Arrays need to have a _len set before the array
+ descriptor is filled. */
+ gfc_add_modify (&block, al_len,
+ fold_convert (TREE_TYPE (al_len), expr3_len));
+ /* Prevent setting the length twice. */
+ al_len_needs_set = false;
+ }
+ }
gfc_add_block_to_block (&block, &se.pre);
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 && al_len_needs_set)
+ {
+ 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)
+ {
+ /* Cover the cases where a string length is explicitly
+ specified by a type spec for deferred length character
+ arrays or unlimited polymorphic objects without a
+ source= or mold= expression. */
+ 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
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || VAR_P (expr3))
+ && 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);
+ to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
+ tmp = gfc_copy_class_to_class (expr3, to,
+ nelems, upoly_expr);
+ }
+ else if (code->expr3->ts.type == BT_CHARACTER)
+ {
+ tmp = INDIRECT_REF_P (se.expr) ?
+ se.expr :
+ 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;
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;
}
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
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;
/* 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 lengths
+ 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_len_component (last_arg->expr);
+ /* 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
- the ALLOCATE. */
+ /* Switch off automatic reallocation since we have just
+ done the ALLOCATE. */
int realloc_lhs = flag_realloc_lhs;
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
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)
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
dlen = gfc_get_expr_charlen (code->expr2);
- slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
- slen);
+ slen = fold_build2_loc (input_location, MIN_EXPR,
+ TREE_TYPE (slen), dlen, slen);
- gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
- slen, errmsg_str, gfc_default_character_kind);
+ gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
+ code->expr2->ts.kind,
+ slen, errmsg_str,
+ gfc_default_character_kind);
dlen = gfc_finish_block (&errmsg_block);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
- build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ stat, build_int_cst (TREE_TYPE (stat), 0));
- tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+ tmp = build3_v (COND_EXPR, tmp,
+ dlen, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
last = ref;
/* Do not deallocate the components of a derived type
- ultimate pointer component. */
+ ultimate pointer component. */
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
}
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
{
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)
return build4_loc (input_location, ARRAY_REF, type, base,
offset, NULL_TREE, NULL_TREE);
- span = gfc_vtable_size_get (decl);
+ span = gfc_class_vtab_size_get (decl);
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
return false;
gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
- final_fndecl = gfc_vtable_final_get (decl);
- size = gfc_vtable_size_get (decl);
+ final_fndecl = gfc_class_vtab_final_get (decl);
+ size = gfc_class_vtab_size_get (decl);
array = gfc_class_data_get (decl);
}
gfc_wrapped_block;
/* Class API functions. */
+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);
+tree gfc_class_vtab_size_get (tree);
+tree gfc_class_vtab_extends_get (tree);
+tree gfc_class_vtab_def_init_get (tree);
+tree gfc_class_vtab_copy_get (tree);
+tree gfc_class_vtab_final_get (tree);
+/* Get an accessor to the vtab's * field, when a vptr handle is present. */
+tree gfc_vtpr_hash_get (tree);
+tree gfc_vptr_size_get (tree);
+tree gfc_vptr_extends_get (tree);
+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 *);
-tree gfc_class_set_static_fields (tree, tree, tree);
-tree gfc_vtable_hash_get (tree);
-tree gfc_vtable_size_get (tree);
-tree gfc_vtable_extends_get (tree);
-tree gfc_vtable_def_init_get (tree);
-tree gfc_vtable_copy_get (tree);
-tree gfc_vtable_final_get (tree);
+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);
+2015-03-24 Andre Vehreschild <vehre@gmx.de>
+
+ * gfortran.dg/allocate_alloc_opt_13.f90: Added tests for
+ source= and mold= expressions functionality.
+ * gfortran.dg/allocate_class_4.f90: New test.
+ * gfortran.dg/unlimited_polymorphic_20.f90: Added test whether
+ copying an unlimited polymorhpic object containing a char array
+ to another unlimited polymorphic object respects the _len
+ component.
+ * gfortran.dg/unlimited_polymorphic_22.f90: Extended to check
+ whether deferred length char array allocate works, unlimited
+ polymorphic object allocation from a string works and if
+ allocating an array of deferred length strings works.
+ * gfortran.dg/unlimited_polymorphic_24.f03: New test.
+
2015-03-24 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/65513
allocate (a, b, source=c(1))
allocate (c(4), d(6), source=e)
+allocate (a, b, mold=f())
+allocate (c(1), d(6), mold=g())
+
allocate (a, b, source=f())
allocate (c(1), d(6), source=g())
--- /dev/null
+! { dg-do compile }
+!
+! Part of PR 51946, but breaks easily, therefore introduce its own test
+! Authors: Damian Rouson <damian@sourceryinstitute.org>,
+! Dominique Pelletier <dominique.pelletier@polymtl.ca>
+! Contributed by: Andre Vehreschild <vehre@gcc.gnu.org>
+
+module integrable_model_module
+
+ implicit none
+
+ type, abstract, public :: integrable_model
+ contains
+ procedure(default_constructor), deferred :: empty_instance
+ end type
+
+ abstract interface
+ function default_constructor(this) result(blank_slate)
+ import :: integrable_model
+ class(integrable_model), intent(in) :: this
+ class(integrable_model), allocatable :: blank_slate
+ end function
+ end interface
+
+ contains
+
+ subroutine integrate(this)
+ class(integrable_model), intent(inout) :: this
+ class(integrable_model), allocatable :: residual
+ allocate(residual, source=this%empty_instance())
+ end subroutine
+
+end module integrable_model_module
+
+! { dg-final { cleanup-modules "integrable_model_module" } }
+
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)
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
+ type T
+ class(*), pointer :: content
+ end type
+ type(T) :: o1, o2
+
+ str = "string for test"
+ str4 = 4_"string for test"
+
+ 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)
- allocate(character(string_len)::P)
+ 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(P)
+ select type(A2)
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
+ 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
- deallocate(P)
+ 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(*))
+ 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(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(P1)
+ type is (character(len=*,kind=4))
+ 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
+
+ allocate(A1, source=P1)
- select type(P)
+ select type(A1)
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
+ 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
- deallocate(P)
+ 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)
+
+ allocate(o1%content, source='test string')
+ allocate(o2%content, source=o1%content)
+ select type (c => o1%content)
+ type is (character(*))
+ if (c /= 'test string') call abort ()
+ class default
+ call abort()
+ end select
+ select type (d => o2%content)
+ type is (character(*))
+ if (d /= 'test string') call abort ()
+ class default
+ end select
+
+ call AddCopy ('test string')
+
+contains
+
+ function convertType(in)
+ class(*), pointer, intent(in) :: in
+ class(*), pointer :: convertType
+
+ convertType => in
+ end function
+
+ subroutine AddCopy(C)
+ class(*), intent(in) :: C
+ class(*), pointer :: P
+ allocate(P, source=C)
+ select type (P)
+ type is (character(*))
+ if (P /= 'test string') call abort()
+ class default
+ call abort()
+ end select
+ end subroutine
end program test
--- /dev/null
+! { dg-do run }
+!
+! Test case for unlimited polymorphism that is derived from the article
+! by Mark Leair, in the 'PGI Insider':
+! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
+! Note that 'getValue' has been removed from the generic 'add' becuse
+! gfortran asserts that this is ambiguous. See
+! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
+!
+module link_mod
+ private
+ public :: link, output, index
+ character(6) :: output (14)
+ integer :: index = 0
+ type link
+ private
+ class(*), pointer :: value => null() ! value stored in link
+ type(link), pointer :: next => null()! next link in list
+ contains
+ procedure :: getValue ! return value pointer
+ procedure :: printLinks ! print linked list starting with this link
+ procedure :: nextLink ! return next pointer
+ procedure :: setNextLink ! set next pointer
+ end type link
+
+ interface link
+ procedure constructor ! construct/initialize a link
+ end interface
+
+contains
+
+ function nextLink(this)
+ class(link) :: this
+ class(link), pointer :: nextLink
+ nextLink => this%next
+ end function nextLink
+
+ subroutine setNextLink(this,next)
+ class(link) :: this
+ class(link), pointer :: next
+ this%next => next
+ end subroutine setNextLink
+
+ function getValue(this)
+ class(link) :: this
+ class(*), pointer :: getValue
+ getValue => this%value
+ end function getValue
+
+ subroutine printLink(this)
+ class(link) :: this
+
+ index = index + 1
+
+ select type(v => this%value)
+ type is (integer)
+ write (output(index), '(i6)') v
+ type is (character(*))
+ write (output(index), '(a6)') v
+ type is (real)
+ write (output(index), '(f6.2)') v
+ class default
+ stop 'printLink: unexepected type for link'
+ end select
+
+ end subroutine printLink
+
+ subroutine printLinks(this)
+ class(link) :: this
+ class(link), pointer :: curr
+
+ call printLink(this)
+ curr => this%next
+ do while(associated(curr))
+ call printLink(curr)
+ curr => curr%next
+ end do
+
+ end subroutine
+
+ function constructor(value, next)
+ class(link),pointer :: constructor
+ class(*) :: value
+ class(link), pointer :: next
+ allocate(constructor)
+ constructor%next => next
+ allocate(constructor%value, source=value)
+ end function constructor
+
+end module link_mod
+
+module list_mod
+ use link_mod
+ private
+ public :: list
+ type list
+ private
+ class(link),pointer :: firstLink => null() ! first link in list
+ class(link),pointer :: lastLink => null() ! last link in list
+ contains
+ procedure :: printValues ! print linked list
+ procedure :: addInteger ! add integer to linked list
+ procedure :: addChar ! add character to linked list
+ procedure :: addReal ! add real to linked list
+ procedure :: addValue ! add class(*) to linked list
+ procedure :: firstValue ! return value associated with firstLink
+ procedure :: isEmpty ! return true if list is empty
+ generic :: add => addInteger, addChar, addReal
+ end type list
+
+contains
+
+ subroutine printValues(this)
+ class(list) :: this
+
+ if (.not.this%isEmpty()) then
+ call this%firstLink%printLinks()
+ endif
+ end subroutine printValues
+
+ subroutine addValue(this, value)
+ class(list) :: this
+ class(*) :: value
+ class(link), pointer :: newLink
+
+ if (.not. associated(this%firstLink)) then
+ this%firstLink => link(value, this%firstLink)
+ this%lastLink => this%firstLink
+ else
+ newLink => link(value, this%lastLink%nextLink())
+ call this%lastLink%setNextLink(newLink)
+ this%lastLink => newLink
+ end if
+
+ end subroutine addValue
+
+ subroutine addInteger(this, value)
+ class(list) :: this
+ integer value
+ class(*), allocatable :: v
+ allocate(v,source=value)
+ call this%addValue(v)
+ end subroutine addInteger
+
+ subroutine addChar(this, value)
+ class(list) :: this
+ character(*) :: value
+ class(*), allocatable :: v
+
+ allocate(v,source=value)
+ call this%addValue(v)
+ end subroutine addChar
+
+ subroutine addReal(this, value)
+ class(list) :: this
+ real value
+ class(*), allocatable :: v
+
+ allocate(v,source=value)
+ call this%addValue(v)
+ end subroutine addReal
+
+ function firstValue(this)
+ class(list) :: this
+ class(*), pointer :: firstValue
+
+ firstValue => this%firstLink%getValue()
+
+ end function firstValue
+
+ function isEmpty(this)
+ class(list) :: this
+ logical isEmpty
+
+ if (associated(this%firstLink)) then
+ isEmpty = .false.
+ else
+ isEmpty = .true.
+ endif
+ end function isEmpty
+
+end module list_mod
+
+program main
+ use link_mod, only : output
+ use list_mod
+ implicit none
+ integer i, j
+ type(list) :: my_list
+
+ do i=1, 10
+ call my_list%add(i)
+ enddo
+ call my_list%add(1.23)
+ call my_list%add('A')
+ call my_list%add('BC')
+ call my_list%add('DEF')
+ call my_list%printvalues()
+ do i = 1, 14
+ select case (i)
+ case (1:10)
+ read (output(i), '(i6)') j
+ if (j .ne. i) call abort
+ case (11)
+ if (output(i) .ne. " 1.23") call abort
+ case (12)
+ if (output(i) .ne. " A") call abort
+ case (13)
+ if (output(i) .ne. " BC") call abort
+ case (14)
+ if (output(i) .ne. " DEF") call abort
+ end select
+ end do
+end program main
+
projects / gcc.git / commitdiff