* [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
@ 2015-03-19 15:13 Andre Vehreschild
2015-03-21 14:12 ` Paul Richard Thomas
0 siblings, 1 reply; 8+ messages in thread
From: Andre Vehreschild @ 2015-03-19 15:13 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 654 bytes --]
Hi all,
please find attached the parts missing to stop valgrind's complaining about the
use of uninitialized memory. The issue was, that when constructing a temporary
class-object to call a routine with unlimited polymorphic arguments, the _len
component was never set. This is fixed by this patch now.
Note, the patch is based on all these preliminary patches:
https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Please review!
- Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr55901_v1.clog --]
[-- Type: application/octet-stream, Size: 277 bytes --]
gcc/fortran/ChangeLog:
2015-03-19 Andre Vehreschild <vehre@gmx.de>
* trans-expr.c (gfc_conv_derived_to_class): Add handling
of _len component, i.e., when the rhs has a string_length
then assign that to class' _len, else assign 0.
(gfc_conv_intrinsic_to_class): Same.
[-- Attachment #3: pr55901_v1.patch --]
[-- Type: text/x-patch, Size: 4660 bytes --]
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d3f3be..a30c391 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -578,6 +578,34 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
}
}
+ if (class_ts.u.derived->components->ts.type == BT_DERIVED
+ && class_ts.u.derived->components->ts.u.derived
+ ->attr.unlimited_polymorphic)
+ {
+ /* Take care about initializing the _len component correctly. */
+ ctree = gfc_class_len_get (var);
+ if (UNLIMITED_POLY (e))
+ {
+ gfc_expr *len;
+ gfc_se se;
+
+ len = gfc_copy_expr (e);
+ gfc_add_len_component (len);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, len);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
+ cond_optional, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ else
+ tmp = se.expr;
+ }
+ else
+ tmp = integer_zero_node;
+ gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
+ tmp));
+ }
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
@@ -736,44 +764,54 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
}
}
- /* When the actual arg is a char array, then set the _len component of the
- unlimited polymorphic entity, too. */
- if (e->ts.type == BT_CHARACTER)
+ gcc_assert (class_ts.type == BT_CLASS);
+ if (class_ts.u.derived->components->ts.type == BT_DERIVED
+ && class_ts.u.derived->components->ts.u.derived
+ ->attr.unlimited_polymorphic)
{
ctree = gfc_class_len_get (var);
- /* Start with parmse->string_length because this seems to be set to a
- correct value more often. */
- if (parmse->string_length)
- gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
- /* When the string_length is not yet set, then try the backend_decl of
- the cl. */
- else if (e->ts.u.cl->backend_decl)
- gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
- /* If both of the above approaches fail, then try to generate an
- expression from the input, which is only feasible currently, when the
- expression can be evaluated to a constant one. */
- else
- {
- /* Try to simplify the expression. */
- gfc_simplify_expr (e, 0);
- if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
- {
- /* Amazingly all data is present to compute the length of a
- constant string, but the expression is not yet there. */
- e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
- &e->where);
- mpz_set_ui (e->ts.u.cl->length->value.integer,
- e->value.character.length);
- gfc_conv_const_charlen (e->ts.u.cl);
- e->ts.u.cl->resolved = 1;
- gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
- }
+ /* When the actual arg is a char array, then set the _len component of the
+ unlimited polymorphic entity, too. */
+ if (e->ts.type == BT_CHARACTER)
+ {
+ /* Start with parmse->string_length because this seems to be set to a
+ correct value more often. */
+ if (parmse->string_length)
+ tmp = parmse->string_length;
+ /* When the string_length is not yet set, then try the backend_decl of
+ the cl. */
+ else if (e->ts.u.cl->backend_decl)
+ tmp = e->ts.u.cl->backend_decl;
+ /* If both of the above approaches fail, then try to generate an
+ expression from the input, which is only feasible currently, when the
+ expression can be evaluated to a constant one. */
else
{
- gfc_error ("Can't compute the length of the char array at %L.",
- &e->where);
+ /* Try to simplify the expression. */
+ gfc_simplify_expr (e, 0);
+ if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+ {
+ /* Amazingly all data is present to compute the length of a
+ constant string, but the expression is not yet there. */
+ e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
+ &e->where);
+ mpz_set_ui (e->ts.u.cl->length->value.integer,
+ e->value.character.length);
+ gfc_conv_const_charlen (e->ts.u.cl);
+ e->ts.u.cl->resolved = 1;
+ tmp = e->ts.u.cl->backend_decl;
+ }
+ else
+ {
+ gfc_error ("Can't compute the length of the char array at %L.",
+ &e->where);
+ }
}
}
+ else
+ tmp = integer_zero_node;
+
+ gfc_add_modify (&parmse->pre, ctree, tmp);
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
2015-03-19 15:13 [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array Andre Vehreschild
@ 2015-03-21 14:12 ` Paul Richard Thomas
2015-03-21 15:05 ` Jerry DeLisle
2015-03-23 7:33 ` Paul Richard Thomas
0 siblings, 2 replies; 8+ messages in thread
From: Paul Richard Thomas @ 2015-03-21 14:12 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 2059 bytes --]
Dear Andre,
I have applied the three preliminary patches but have not yet applied
the attached one for PR55901. As advertised the composite patch
bootstraps and regtests on FC21,x86_64.
I went through gfc_trans_allocate and cleaned up the formatting and
some of the text in the comments. You did a heroic job to tidy up this
function and so I thought that I should do my bit - one of the
feature, previously, was that the line length often went well in
excess of the gcc style guide limit of 72 and this tended to make it
somewhat unreadable. I have not been rigorous about this, especially
when readability would be impaired thereby, but it does look a lot
better now. The composite diff is attached.
Not only does the Metcalf example run correctly but also the PGI
Insider linked list example. I have attached a version of this
modified to function as a gfortran.dg testcase. With the attributions
in there, I do not think that there are any copyright issues. The
article itself has no copyright notice.
I would very much like to say that this is OK for trunk but we are
hard up against the end of stage 4 and so it should really wait for
backporting to 5.2.
Thanks for the patches
Paul
On 19 March 2015 at 16:13, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> please find attached the parts missing to stop valgrind's complaining about the
> use of uninitialized memory. The issue was, that when constructing a temporary
> class-object to call a routine with unlimited polymorphic arguments, the _len
> component was never set. This is fixed by this patch now.
>
> Note, the patch is based on all these preliminary patches:
>
> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
>
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>
> Please review!
>
> - Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 79862 bytes --]
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c (revision 221500)
--- gcc/fortran/class.c (working copy)
*************** gfc_add_component_ref (gfc_expr *e, cons
*** 234,239 ****
--- 234,242 ----
}
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;
*************** find_intrinsic_vtab (gfc_typespec *ts)
*** 2562,2574 ****
c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of
! target-memory.c/gfc_element_size for 'size'. */
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));
gfc_free_expr (e);
/* Add component _extends. */
--- 2565,2583 ----
c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of
! 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,
! ts->type == BT_CHARACTER
! && charlen == 0 ?
! ts->kind :
! (int)gfc_element_size (e));
gfc_free_expr (e);
/* Add component _extends. */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 221500)
--- gcc/fortran/gfortran.h (working copy)
*************** void gfc_add_component_ref (gfc_expr *,
*** 3168,3173 ****
--- 3168,3174 ----
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")
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 221500)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_trans_create_temp_array (stmtblock_t
*** 1196,1202 ****
elemsize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
else
! elemsize = gfc_vtable_size_get (class_expr);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
--- 1196,1202 ----
elemsize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
else
! elemsize = gfc_class_vtab_size_get (class_expr);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
*************** build_class_array_ref (gfc_se *se, tree
*** 3066,3072 ****
if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
return false;
! size = gfc_vtable_size_get (decl);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
--- 3066,3072 ----
if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
return false;
! size = gfc_class_vtab_size_get (decl);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
*************** static tree
*** 4950,4957 ****
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 type;
tree tmp;
--- 4950,4956 ----
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)
{
tree type;
tree tmp;
*************** gfc_array_init_size (tree descriptor, in
*** 4977,4983 ****
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
! gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = boolean_false_node;
--- 4976,4982 ----
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
! gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
or_expr = boolean_false_node;
*************** gfc_array_init_size (tree descriptor, in
*** 5131,5139 ****
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));
--- 5130,5135 ----
*************** gfc_array_init_size (tree descriptor, in
*** 5205,5211 ****
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 tmp;
tree pointer;
--- 5201,5207 ----
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)
{
tree tmp;
tree pointer;
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5290,5296 ****
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);
if (dimension)
{
--- 5286,5292 ----
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);
if (dimension)
{
*************** structure_alloc_comps (gfc_symbol * der_
*** 7936,7942 ****
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));
if (CLASS_DATA (c)->attr.dimension)
{
--- 7932,7939 ----
dst_data = gfc_class_data_get (dcmp);
src_data = gfc_class_data_get (comp);
! size = fold_convert (size_type_node,
! gfc_class_vtab_size_get (comp));
if (CLASS_DATA (c)->attr.dimension)
{
*************** structure_alloc_comps (gfc_symbol * der_
*** 7971,7977 ****
fold_convert (TREE_TYPE (dst_data), tmp));
}
! tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_finish_block (&tmpblock);
--- 7968,7975 ----
fold_convert (TREE_TYPE (dst_data), tmp));
}
! tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
! UNLIMITED_POLY (c));
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_finish_block (&tmpblock);
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 221500)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_array_deallocate (tree, tree, t
*** 24,30 ****
/* 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 *);
/* 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 *,
--- 24,30 ----
/* 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 *);
/* 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 *,
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 221500)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_class_len_get (tree decl)
*** 166,237 ****
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);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len,
NULL_TREE);
}
static tree
! gfc_vtable_field_get (tree decl, int field)
{
! tree size;
! tree vptr;
! vptr = gfc_class_vptr_get (decl);
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;
}
! tree
! gfc_vtable_hash_get (tree decl)
! {
! return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
! }
!
! tree
! gfc_vtable_size_get (tree decl)
{
! return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
}
! tree
! gfc_vtable_extends_get (tree decl)
! {
! return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
}
- tree
- gfc_vtable_def_init_get (tree decl)
- {
- return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
- }
tree
! gfc_vtable_copy_get (tree decl)
{
! return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
}
-
tree
! gfc_vtable_final_get (tree decl)
{
! return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
}
--- 166,250 ----
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);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len,
NULL_TREE);
}
+ /* Get the specified FIELD from the VPTR. */
+
static tree
! vptr_field_get (tree vptr, int fieldno)
{
! tree field;
vptr = build_fold_indirect_ref_loc (input_location, vptr);
! 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;
}
! /* Get the field from the class' vptr. */
! static tree
! class_vtab_field_get (tree decl, int fieldno)
{
! tree vptr;
! vptr = gfc_class_vptr_get (decl);
! return vptr_field_get (vptr, fieldno);
}
! /* 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)
+ /* The size field is returned as an array index. Therefore treat it and only
+ it specially. */
tree
! gfc_class_vtab_size_get (tree cl)
{
! 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_vptr_size_get (tree vptr)
{
! 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;
}
*************** gfc_vtable_final_get (tree decl)
*** 245,250 ****
--- 258,318 ----
#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
*************** gfc_reset_vptr (stmtblock_t *block, gfc_
*** 294,299 ****
--- 362,383 ----
}
+ /* 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. */
*************** tree
*** 873,879 ****
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 offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
--- 957,963 ----
gfc_get_class_array_ref (tree index, tree class_decl)
{
tree data = gfc_class_data_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);
*************** gfc_get_class_array_ref (tree index, tre
*** 891,929 ****
that the _vptr is set. */
tree
! gfc_copy_class_to_class (tree from, tree to, tree nelems)
{
tree fcn;
tree fcn_type;
tree from_data;
tree to_data;
tree to_ref;
tree from_ref;
vec<tree, va_gc> *args;
tree tmp;
tree index;
- stmtblock_t loopbody;
- stmtblock_t body;
- gfc_loopinfo loop;
args = NULL;
if (from != NULL_TREE)
! fcn = gfc_vtable_copy_get (from);
else
! fcn = gfc_vtable_copy_get (to);
fcn_type = TREE_TYPE (TREE_TYPE (fcn));
if (from != NULL_TREE)
! from_data = gfc_class_data_get (from);
else
! from_data = gfc_vtable_def_init_get (to);
to_data = gfc_class_data_get (to);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
{
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, nelems,
--- 975,1031 ----
that the _vptr is set. */
tree
! 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;
args = NULL;
+ /* To prevent warnings on uninitialized variables. */
+ from_len = to_len = NULL_TREE;
if (from != NULL_TREE)
! fcn = gfc_class_vtab_copy_get (from);
else
! 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);
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
! 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,
*************** gfc_copy_class_to_class (tree from, tree
*** 955,962 ****
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_cleanup_loop (&loop);
}
else
--- 1057,1097 ----
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);
! 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
*************** gfc_copy_class_to_class (tree from, tree
*** 964,970 ****
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);
}
return tmp;
--- 1099,1118 ----
gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
vec_safe_push (args, from_data);
vec_safe_push (args, to_data);
! 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;
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5638,5644 ****
CLASS_DATA (expr->value.function.esym->result)->attr);
}
! final_fndecl = gfc_vtable_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
final_fndecl,
--- 5786,5792 ----
CLASS_DATA (expr->value.function.esym->result)->attr);
}
! final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
final_fndecl,
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5649,5655 ****
tmp = build_call_expr_loc (input_location,
final_fndecl, 3,
gfc_build_addr_expr (NULL, tmp),
! gfc_vtable_size_get (se->expr),
boolean_false_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, is_final, tmp,
--- 5797,5803 ----
tmp = build_call_expr_loc (input_location,
final_fndecl, 3,
gfc_build_addr_expr (NULL, tmp),
! gfc_class_vtab_size_get (se->expr),
boolean_false_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, is_final, tmp,
*************** alloc_scalar_allocatable_for_assignment
*** 8474,8480 ****
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);
/* Jump past the realloc if the lengths are the same. */
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label2),
--- 8622,8628 ----
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
! 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),
*************** alloc_scalar_allocatable_for_assignment
*** 8491,8500 ****
/* 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);
}
}
--- 8639,8645 ----
/* Update the lhs character length. */
size = string_length;
! gfc_add_modify (block, lse.string_length, size);
}
}
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 8784,8790 ****
{
/* 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,
expr1, expr2);
/* Use the scalar assignment as is. */
--- 8929,8935 ----
{
/* F2003: Add the code for reallocation on assignment. */
if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
! alloc_scalar_allocatable_for_assignment (&block, string_length,
expr1, expr2);
/* Use the scalar assignment as is. */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 221500)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** if (least <= 2)
*** 2755,2761 ****
arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
: null_pointer_node;
}
!
if (least == 2)
{
arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
--- 2755,2761 ----
arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
: null_pointer_node;
}
!
if (least == 2)
{
arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
*************** gfc_conv_intrinsic_sizeof (gfc_se *se, g
*** 5922,5930 ****
else if (arg->ts.type == BT_CLASS)
{
if (arg->rank)
! byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
else
! byte_size = gfc_vtable_size_get (argse.expr);
}
else
{
--- 5922,5930 ----
else if (arg->ts.type == BT_CLASS)
{
if (arg->rank)
! byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
else
! byte_size = gfc_class_vtab_size_get (argse.expr);
}
else
{
*************** gfc_conv_intrinsic_storage_size (gfc_se
*** 6053,6059 ****
gfc_conv_expr_descriptor (&argse, arg);
if (arg->ts.type == BT_CLASS)
{
! tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
tmp = fold_convert (result_type, tmp);
goto done;
}
--- 6053,6059 ----
gfc_conv_expr_descriptor (&argse, arg);
if (arg->ts.type == BT_CLASS)
{
! tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
tmp = fold_convert (result_type, tmp);
goto done;
}
*************** gfc_conv_intrinsic_transfer (gfc_se * se
*** 6198,6204 ****
argse.string_length);
break;
case BT_CLASS:
! tmp = gfc_vtable_size_get (argse.expr);
break;
default:
source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
--- 6198,6204 ----
argse.string_length);
break;
case BT_CLASS:
! tmp = gfc_class_vtab_size_get (argse.expr);
break;
default:
source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
*************** gfc_conv_intrinsic_transfer (gfc_se * se
*** 6322,6328 ****
mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
break;
case BT_CLASS:
! tmp = gfc_vtable_size_get (argse.expr);
break;
default:
tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
--- 6322,6328 ----
mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
break;
case BT_CLASS:
! tmp = gfc_class_vtab_size_get (argse.expr);
break;
default:
tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 221500)
--- gcc/fortran/trans-stmt.c (working copy)
*************** tree
*** 4932,4940 ****
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *e;
gfc_expr *expr;
! gfc_se se;
tree tmp;
tree parm;
tree stat;
--- 4932,4939 ----
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
gfc_expr *expr;
! gfc_se se, se_sz;
tree tmp;
tree parm;
tree stat;
*************** gfc_trans_allocate (gfc_code * code)
*** 4943,4963 ****
tree label_errmsg;
tree label_finish;
tree memsz;
! tree expr3;
! tree slen3;
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;
if (!code->ext.alloc.list)
return NULL_TREE;
! stat = tmp = memsz = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
gfc_init_block (&block);
--- 4942,4965 ----
tree label_errmsg;
tree label_finish;
tree memsz;
! 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;
tree nelems;
! bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
if (!code->ext.alloc.list)
return 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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4991,5196 ****
TREE_USED (label_finish) = 0;
}
! expr3 = NULL_TREE;
! slen3 = NULL_TREE;
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = gfc_copy_expr (al->expr);
if (expr->ts.type == BT_CLASS)
! gfc_add_data_component (expr);
!
! gfc_init_se (&se, NULL);
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;
!
nelems = NULL_TREE;
! if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
! memsz, &nelems, code->expr3, &code->ext.alloc.ts))
! {
! 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. */
!
! /* 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)
- {
- 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;
! }
}
- 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));
- }
-
- /* 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)
! {
! gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
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);
memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
! fold_convert (TREE_TYPE (se_sz.expr),
! se_sz.expr));
}
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)
! {
! 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);
! memsz = fold_build2_loc (input_location, MULT_EXPR,
! TREE_TYPE (tmp), tmp,
! fold_convert (TREE_TYPE (tmp), memsz));
! }
/* 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);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
--- 4993,5356 ----
TREE_USED (label_finish) = 0;
}
! /* 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_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);
! 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 (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))
! {
! /* A scalar or derived type. First compute the size to
! allocate.
!
! expr3_len is set when expr3 is unlimited polymorphic object
! or a deferred length string. */
! if (expr3_len != NULL_TREE)
! {
! 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
{
! /* 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);
}
}
! 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))
! {
! /* 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);
! 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),
! fold_convert (TREE_TYPE (tmp),
! expr3_len),
! tmp);
! }
! else if (expr->ts.type == BT_CHARACTER)
! {
! /* 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),
! 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);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
*************** gfc_trans_allocate (gfc_code * code)
*** 5202,5207 ****
--- 5362,5380 ----
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_trans_allocate (gfc_code * code)
*** 5218,5341 ****
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)
{
! 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);
! }
else
{
/* VPTR is fixed at compile time. */
gfc_symbol *vtab;
gfc_typespec *ts;
if (code->expr3)
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))
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));
! }
}
- gfc_free_expr (lhs);
}
! gfc_free_expr (e);
!
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)
{
tree to;
! to = TREE_OPERAND (se.expr, 0);
!
! tmp = gfc_copy_class_to_class (class_expr, to, nelems);
}
else if (al->expr->ts.type == BT_CLASS)
{
! gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
--- 5391,5504 ----
gfc_add_expr_to_block (&block, tmp);
}
! /* Set the vptr. */
! if (al_vptr != NULL_TREE)
{
! 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 (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
! /* 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));
}
}
! /* 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 if it is used 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 (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 = 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, *last_arg;
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
*************** gfc_trans_allocate (gfc_code * code)
*** 5345,5359 ****
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);
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)
if (ref->type == REF_COMPONENT
&& strcmp (ref->u.c.component->name, "_data") == 0)
dataref = ref;
--- 5508,5522 ----
actual->expr = gfc_copy_expr (rhs);
if (rhs->ts.type == BT_CLASS)
gfc_add_data_component (actual->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 = last_arg->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT
&& strcmp (ref->u.c.component->name, "_data") == 0)
dataref = ref;
*************** gfc_trans_allocate (gfc_code * code)
*** 5387,5393 ****
}
if (rhs->ts.type == BT_CLASS)
{
! ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
--- 5550,5559 ----
}
if (rhs->ts.type == BT_CLASS)
{
! 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
*************** gfc_trans_allocate (gfc_code * code)
*** 5396,5401 ****
--- 5562,5568 ----
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;
*************** gfc_trans_allocate (gfc_code * code)
*** 5404,5422 ****
/* 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);
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. */
int realloc_lhs = flag_realloc_lhs;
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
--- 5571,5623 ----
/* 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
{
! /* 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),
*************** gfc_trans_allocate (gfc_code * code)
*** 5433,5444 ****
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);
gfc_add_expr_to_block (&block, tmp);
}
gfc_free_expr (expr);
! }
/* STAT. */
if (code->expr1)
--- 5634,5646 ----
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,
! upoly_expr);
gfc_add_expr_to_block (&block, tmp);
}
gfc_free_expr (expr);
! } // for-loop
/* STAT. */
if (code->expr1)
*************** gfc_trans_allocate (gfc_code * code)
*** 5463,5479 ****
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);
! 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 = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
--- 5665,5684 ----
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);
! 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 = build3_v (COND_EXPR, tmp,
! dlen, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
*************** gfc_trans_deallocate (gfc_code *code)
*** 5616,5622 ****
}
if (al->expr->ts.type == BT_CLASS)
! gfc_reset_vptr (&se.pre, al->expr);
}
else
{
--- 5821,5834 ----
}
if (al->expr->ts.type == BT_CLASS)
! {
! 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_trans_deallocate (gfc_code *code)
*** 5631,5637 ****
gfc_add_expr_to_block (&se.pre, tmp);
if (al->expr->ts.type == BT_CLASS)
! gfc_reset_vptr (&se.pre, al->expr);
}
if (code->expr1)
--- 5843,5856 ----
gfc_add_expr_to_block (&se.pre, tmp);
if (al->expr->ts.type == BT_CLASS)
! {
! 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)
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 221500)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 373,379 ****
return build4_loc (input_location, ARRAY_REF, type, base,
offset, NULL_TREE, NULL_TREE);
! span = gfc_vtable_size_get (decl);
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
--- 373,379 ----
return build4_loc (input_location, ARRAY_REF, type, base,
offset, NULL_TREE, NULL_TREE);
! span = gfc_class_vtab_size_get (decl);
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
*************** gfc_add_comp_finalizer_call (stmtblock_t
*** 1015,1022 ****
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);
array = gfc_class_data_get (decl);
}
--- 1015,1022 ----
return false;
gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
! final_fndecl = gfc_class_vtab_final_get (decl);
! size = gfc_class_vtab_size_get (decl);
array = gfc_class_data_get (decl);
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 221500)
--- gcc/fortran/trans.h (working copy)
*************** typedef struct
*** 346,365 ****
gfc_wrapped_block;
/* Class API functions. */
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_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);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
! tree gfc_copy_class_to_class (tree, tree, tree);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
--- 346,376 ----
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 *);
! 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, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (revision 221500)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (working copy)
*************** program test
*** 23,34 ****
implicit none
character(LEN=:), allocatable, target :: S
character(LEN=100) :: res
! class(*), pointer :: ucp
call sub1 ("long test string", 16)
call sub2 ()
S = "test"
ucp => S
call sub3 (ucp)
call sub4 (S, 4)
call sub4 ("This is a longer string.", 24)
call bar (S, res)
--- 23,36 ----
implicit none
character(LEN=:), allocatable, target :: S
character(LEN=100) :: res
! 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)
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 (revision 221500)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 (working copy)
***************
*** 5,56 ****
program test
implicit none
! class(*), pointer :: P
integer :: string_len = 10 *2
! allocate(character(string_len)::P)
! select type(P)
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
class default
call abort ()
end select
! deallocate(P)
! Now for kind=4 chars.
! allocate(character(len=20,kind=4)::P)
! select type(P)
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
type is (character(len=*,kind=1))
call abort ()
class default
call abort ()
end select
! deallocate(P)
end program test
--- 5,215 ----
program test
implicit none
! 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)
! 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(*))
! 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)::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(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)
+
+ 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
[-- Attachment #3: linked_list.f90 --]
[-- Type: text/plain, Size: 5306 bytes --]
! { 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
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
2015-03-21 14:12 ` Paul Richard Thomas
@ 2015-03-21 15:05 ` Jerry DeLisle
2015-03-23 7:33 ` Paul Richard Thomas
1 sibling, 0 replies; 8+ messages in thread
From: Jerry DeLisle @ 2015-03-21 15:05 UTC (permalink / raw)
To: Paul Richard Thomas, Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
On 03/21/2015 07:11 AM, Paul Richard Thomas wrote:
--- snip ---
> I would very much like to say that this is OK for trunk but we are
> hard up against the end of stage 4 and so it should really wait for
> backporting to 5.2.
>
IMHO, since gfortran is not release critical, we should consider, in the
interest of progress, committing this to trunk now. It will give much needed
exposure to OOP features and allow users to exercise the code. (Subject to
release manager approval)
Regards,
Jerry
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
2015-03-21 14:12 ` Paul Richard Thomas
2015-03-21 15:05 ` Jerry DeLisle
@ 2015-03-23 7:33 ` Paul Richard Thomas
2015-03-23 9:45 ` Andre Vehreschild
1 sibling, 1 reply; 8+ messages in thread
From: Paul Richard Thomas @ 2015-03-23 7:33 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Dear Andre,
I am persuaded by the arguments of Jerry and Dominique that this is
good for trunk. Please commit as early as possible in order that any
regressions can be caught, if possible, before release.
Thanks
Paul
On 21 March 2015 at 15:11, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear Andre,
>
> I have applied the three preliminary patches but have not yet applied
> the attached one for PR55901. As advertised the composite patch
> bootstraps and regtests on FC21,x86_64.
>
> I went through gfc_trans_allocate and cleaned up the formatting and
> some of the text in the comments. You did a heroic job to tidy up this
> function and so I thought that I should do my bit - one of the
> feature, previously, was that the line length often went well in
> excess of the gcc style guide limit of 72 and this tended to make it
> somewhat unreadable. I have not been rigorous about this, especially
> when readability would be impaired thereby, but it does look a lot
> better now. The composite diff is attached.
>
> Not only does the Metcalf example run correctly but also the PGI
> Insider linked list example. I have attached a version of this
> modified to function as a gfortran.dg testcase. With the attributions
> in there, I do not think that there are any copyright issues. The
> article itself has no copyright notice.
>
> I would very much like to say that this is OK for trunk but we are
> hard up against the end of stage 4 and so it should really wait for
> backporting to 5.2.
>
> Thanks for the patches
>
> Paul
>
> On 19 March 2015 at 16:13, Andre Vehreschild <vehre@gmx.de> wrote:
>> Hi all,
>>
>> please find attached the parts missing to stop valgrind's complaining about the
>> use of uninitialized memory. The issue was, that when constructing a temporary
>> class-object to call a routine with unlimited polymorphic arguments, the _len
>> component was never set. This is fixed by this patch now.
>>
>> Note, the patch is based on all these preliminary patches:
>>
>> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
>> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
>> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
>>
>> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>>
>> Please review!
>>
>> - Andre
>> --
>> Andre Vehreschild * Email: vehre ad gmx dot de
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
2015-03-23 7:33 ` Paul Richard Thomas
@ 2015-03-23 9:45 ` Andre Vehreschild
2015-03-23 11:28 ` Paul Richard Thomas
0 siblings, 1 reply; 8+ messages in thread
From: Andre Vehreschild @ 2015-03-23 9:45 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Hi Paul,
thanks for the reviews. Let me ask one questions before I do something wrong.
You have reviewed and approved (with changes) the patches:
- vtab_access_rework1_v1.patch
https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
- vtab_access_rework2_v1.patch
https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
- pr64787_v2.patch
https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
and
- pr55901_v1.patch
https://gcc.gnu.org/ml/fortran/2015-03/msg00086.html
, right?
I am asking so explicitly, because there are four more patches from me in the
wild, that await review (not necessarily from you, Paul), namely:
- pr60322_base_1.patch
https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html
- pr60322_3.patch
https://gcc.gnu.org/ml/fortran/2015-03/msg00032.html
- crashfix2_v1.patch (small patch, ~100 loc))
https://gcc.gnu.org/ml/fortran/2015-03/msg00063.html
and
- cosm_simp.patch (tiny patch, ~20 loc)
https://gcc.gnu.org/ml/fortran/2015-03/msg00088.html
Please don't get me wrong on this. I just want to prevent misunderstandings
here. The latter four patches are not yet approved, right?
I will now apply the 4.9-trunk patch and wait for your answer before applying
the above four on vtab_rework pr64787 and pr55901.
Regards,
Andre
On Mon, 23 Mar 2015 08:33:51 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> Dear Andre,
>
> I am persuaded by the arguments of Jerry and Dominique that this is
> good for trunk. Please commit as early as possible in order that any
> regressions can be caught, if possible, before release.
>
> Thanks
>
> Paul
>
> On 21 March 2015 at 15:11, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
> > Dear Andre,
> >
> > I have applied the three preliminary patches but have not yet applied
> > the attached one for PR55901. As advertised the composite patch
> > bootstraps and regtests on FC21,x86_64.
> >
> > I went through gfc_trans_allocate and cleaned up the formatting and
> > some of the text in the comments. You did a heroic job to tidy up this
> > function and so I thought that I should do my bit - one of the
> > feature, previously, was that the line length often went well in
> > excess of the gcc style guide limit of 72 and this tended to make it
> > somewhat unreadable. I have not been rigorous about this, especially
> > when readability would be impaired thereby, but it does look a lot
> > better now. The composite diff is attached.
> >
> > Not only does the Metcalf example run correctly but also the PGI
> > Insider linked list example. I have attached a version of this
> > modified to function as a gfortran.dg testcase. With the attributions
> > in there, I do not think that there are any copyright issues. The
> > article itself has no copyright notice.
> >
> > I would very much like to say that this is OK for trunk but we are
> > hard up against the end of stage 4 and so it should really wait for
> > backporting to 5.2.
> >
> > Thanks for the patches
> >
> > Paul
> >
> > On 19 March 2015 at 16:13, Andre Vehreschild <vehre@gmx.de> wrote:
> >> Hi all,
> >>
> >> please find attached the parts missing to stop valgrind's complaining
> >> about the use of uninitialized memory. The issue was, that when
> >> constructing a temporary class-object to call a routine with unlimited
> >> polymorphic arguments, the _len component was never set. This is fixed by
> >> this patch now.
> >>
> >> Note, the patch is based on all these preliminary patches:
> >>
> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
> >>
> >> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> >>
> >> Please review!
> >>
> >> - Andre
> >> --
> >> Andre Vehreschild * Email: vehre ad gmx dot de
> >
> >
> >
> > --
> > Outside of a dog, a book is a man's best friend. Inside of a dog it's
> > too dark to read.
> >
> > Groucho Marx
>
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array
2015-03-23 9:45 ` Andre Vehreschild
@ 2015-03-23 11:28 ` Paul Richard Thomas
2015-03-24 10:32 ` [commited, Fortran, pr64787 a.o., v1] Invalid code on sourced allocation of class(*) character string Andre Vehreschild
2015-03-24 11:51 ` [committed, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array and Re: [Patch, Fortran, v1] Cosmetics and code simplify Andre Vehreschild
0 siblings, 2 replies; 8+ messages in thread
From: Paul Richard Thomas @ 2015-03-23 11:28 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Dear Andre,
Yes, that's right. The first three (vtab rework 1/2 and pr64787) are
combined and reformatted in the .diff file that I sent you. Please use
that and then apply the pr55901 patch. This is what I am okaying.
Cheers
Paul
On 23 March 2015 at 10:45, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
> thanks for the reviews. Let me ask one questions before I do something wrong.
> You have reviewed and approved (with changes) the patches:
>
> - vtab_access_rework1_v1.patch
> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
> - vtab_access_rework2_v1.patch
> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
> - pr64787_v2.patch
> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
> and
> - pr55901_v1.patch
> https://gcc.gnu.org/ml/fortran/2015-03/msg00086.html
> , right?
>
> I am asking so explicitly, because there are four more patches from me in the
> wild, that await review (not necessarily from you, Paul), namely:
>
> - pr60322_base_1.patch
> https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html
> - pr60322_3.patch
> https://gcc.gnu.org/ml/fortran/2015-03/msg00032.html
> - crashfix2_v1.patch (small patch, ~100 loc))
> https://gcc.gnu.org/ml/fortran/2015-03/msg00063.html
> and
> - cosm_simp.patch (tiny patch, ~20 loc)
> https://gcc.gnu.org/ml/fortran/2015-03/msg00088.html
>
> Please don't get me wrong on this. I just want to prevent misunderstandings
> here. The latter four patches are not yet approved, right?
>
> I will now apply the 4.9-trunk patch and wait for your answer before applying
> the above four on vtab_rework pr64787 and pr55901.
>
> Regards,
> Andre
>
>
>
> On Mon, 23 Mar 2015 08:33:51 +0100
> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
>
>> Dear Andre,
>>
>> I am persuaded by the arguments of Jerry and Dominique that this is
>> good for trunk. Please commit as early as possible in order that any
>> regressions can be caught, if possible, before release.
>>
>> Thanks
>>
>> Paul
>>
>> On 21 March 2015 at 15:11, Paul Richard Thomas
>> <paul.richard.thomas@gmail.com> wrote:
>> > Dear Andre,
>> >
>> > I have applied the three preliminary patches but have not yet applied
>> > the attached one for PR55901. As advertised the composite patch
>> > bootstraps and regtests on FC21,x86_64.
>> >
>> > I went through gfc_trans_allocate and cleaned up the formatting and
>> > some of the text in the comments. You did a heroic job to tidy up this
>> > function and so I thought that I should do my bit - one of the
>> > feature, previously, was that the line length often went well in
>> > excess of the gcc style guide limit of 72 and this tended to make it
>> > somewhat unreadable. I have not been rigorous about this, especially
>> > when readability would be impaired thereby, but it does look a lot
>> > better now. The composite diff is attached.
>> >
>> > Not only does the Metcalf example run correctly but also the PGI
>> > Insider linked list example. I have attached a version of this
>> > modified to function as a gfortran.dg testcase. With the attributions
>> > in there, I do not think that there are any copyright issues. The
>> > article itself has no copyright notice.
>> >
>> > I would very much like to say that this is OK for trunk but we are
>> > hard up against the end of stage 4 and so it should really wait for
>> > backporting to 5.2.
>> >
>> > Thanks for the patches
>> >
>> > Paul
>> >
>> > On 19 March 2015 at 16:13, Andre Vehreschild <vehre@gmx.de> wrote:
>> >> Hi all,
>> >>
>> >> please find attached the parts missing to stop valgrind's complaining
>> >> about the use of uninitialized memory. The issue was, that when
>> >> constructing a temporary class-object to call a routine with unlimited
>> >> polymorphic arguments, the _len component was never set. This is fixed by
>> >> this patch now.
>> >>
>> >> Note, the patch is based on all these preliminary patches:
>> >>
>> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
>> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
>> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
>> >>
>> >> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>> >>
>> >> Please review!
>> >>
>> >> - Andre
>> >> --
>> >> Andre Vehreschild * Email: vehre ad gmx dot de
>> >
>> >
>> >
>> > --
>> > Outside of a dog, a book is a man's best friend. Inside of a dog it's
>> > too dark to read.
>> >
>> > Groucho Marx
>>
>>
>>
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [commited, Fortran, pr64787 a.o., v1] Invalid code on sourced allocation of class(*) character string
2015-03-23 11:28 ` Paul Richard Thomas
@ 2015-03-24 10:32 ` Andre Vehreschild
2015-03-24 11:51 ` [committed, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array and Re: [Patch, Fortran, v1] Cosmetics and code simplify Andre Vehreschild
1 sibling, 0 replies; 8+ messages in thread
From: Andre Vehreschild @ 2015-03-24 10:32 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 4203 bytes --]
Hi Paul, hi all,
Paul, thanks for the review. I have commited the patch for 64787 as r221621.
Regards,
Andre
gcc/fortran/ChangeLog
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.
gcc/testsuite/ChangeLog
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.
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr64787_f.patch --]
[-- Type: text/x-patch, Size: 76228 bytes --]
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 221620)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,62 @@
+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>
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 221620)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -3175,6 +3175,7 @@
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")
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c (Revision 221620)
+++ gcc/fortran/class.c (Arbeitskopie)
@@ -234,6 +234,9 @@
}
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;
@@ -2562,13 +2565,19 @@
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. */
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 221620)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -166,7 +166,7 @@
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);
@@ -173,65 +173,78 @@
}
+/* 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;
}
@@ -245,6 +258,61 @@
#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
@@ -294,6 +362,23 @@
}
+/* 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. */
@@ -873,7 +958,7 @@
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);
@@ -891,39 +976,57 @@
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,
@@ -955,8 +1058,42 @@
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
@@ -964,12 +1101,27 @@
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)
{
@@ -5693,7 +5845,7 @@
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,
@@ -5704,7 +5856,7 @@
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,
@@ -8529,7 +8681,7 @@
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),
@@ -8546,10 +8698,7 @@
/* 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);
}
}
@@ -8839,7 +8988,7 @@
{
/* 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. */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 221620)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -2755,7 +2755,7 @@
arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
: null_pointer_node;
}
-
+
if (least == 2)
{
arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
@@ -5922,9 +5922,9 @@
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
{
@@ -6053,7 +6053,7 @@
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;
}
@@ -6198,7 +6198,7 @@
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,
@@ -6322,7 +6322,7 @@
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));
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (Revision 221620)
+++ gcc/fortran/trans.c (Arbeitskopie)
@@ -373,7 +373,7 @@
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);
@@ -1015,8 +1015,8 @@
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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 221620)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -350,20 +350,31 @@
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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 221620)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -1196,7 +1196,7 @@
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);
@@ -3066,7 +3066,7 @@
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));
@@ -4956,8 +4956,7 @@
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;
@@ -4983,7 +4982,7 @@
/* 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;
@@ -5137,9 +5136,6 @@
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));
@@ -5211,7 +5207,7 @@
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;
@@ -5296,7 +5292,7 @@
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)
{
@@ -7942,7 +7938,8 @@
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)
{
@@ -7977,7 +7974,8 @@
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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (Revision 221620)
+++ gcc/fortran/trans-array.h (Arbeitskopie)
@@ -24,7 +24,7 @@
/* 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 *,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 221620)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -4932,9 +4932,8 @@
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;
@@ -4943,21 +4942,23 @@
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);
@@ -4991,206 +4992,364 @@
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_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;
- gfc_init_se (&se, NULL);
-
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ 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;
- /* 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;
-
+ 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;
+ /* A scalar or derived type. First compute the size to
+ allocate.
- 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. */
-
- /* 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;
- }
+ 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
- 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;
- }
+ /* 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);
}
- 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));
- }
-
- /* 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);
@@ -5202,6 +5361,19 @@
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);
@@ -5218,124 +5390,114 @@
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;
- }
+ 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
{
- 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);
- }
- 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;
+ /* Prepare for setting the vtab as declared. */
+ ts = &expr->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));
- }
+ 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;
@@ -5345,15 +5507,15 @@
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;
@@ -5387,7 +5549,10 @@
}
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
@@ -5396,6 +5561,7 @@
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;
@@ -5404,19 +5570,53 @@
/* 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),
@@ -5433,12 +5633,13 @@
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)
@@ -5463,17 +5664,20 @@
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);
}
@@ -5571,7 +5775,7 @@
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))
{
@@ -5616,7 +5820,14 @@
}
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
{
@@ -5631,7 +5842,14 @@
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)
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 (Revision 221620)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 (Arbeitskopie)
@@ -5,45 +5,106 @@
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
- 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(*))
- 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
+ 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
- deallocate(P)
+ 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(*))
+ 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(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
@@ -50,7 +111,105 @@
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)
+
+ 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
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 (Revision 221620)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 (Arbeitskopie)
@@ -12,6 +12,9 @@
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())
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (Revision 221620)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (Arbeitskopie)
@@ -23,12 +23,14 @@
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)
Index: gcc/testsuite/gfortran.dg/allocate_class_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_class_4.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_class_4.f90 (Revision 221621)
@@ -0,0 +1,36 @@
+! { 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" } }
+
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 (Revision 0)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03 (Revision 221621)
@@ -0,0 +1,215 @@
+! { 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
+
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 221620)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,18 @@
+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
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [committed, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array and Re: [Patch, Fortran, v1] Cosmetics and code simplify
2015-03-23 11:28 ` Paul Richard Thomas
2015-03-24 10:32 ` [commited, Fortran, pr64787 a.o., v1] Invalid code on sourced allocation of class(*) character string Andre Vehreschild
@ 2015-03-24 11:51 ` Andre Vehreschild
1 sibling, 0 replies; 8+ messages in thread
From: Andre Vehreschild @ 2015-03-24 11:51 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Mikael Morin
[-- Attachment #1: Type: text/plain, Size: 5677 bytes --]
Dear Paul, Dear Mikael, hi all,
thanks for reviewing. I have just committed the patches for:
[Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted
as array, and
[Patch, Fortran, v1] Cosmetics and code simplify
as r221627.
Regards,
Andre
2015-03-24 Andre Vehreschild <vehre@gmx.de>
PR fortran/55901
* trans-expr.c (gfc_conv_structure): Fixed indendation.
Using integer_zero_node now instead of explicitly
constructing a integer constant zero node.
(gfc_conv_derived_to_class): Add handling of _len component,
i.e., when the rhs has a string_length then assign that to
class' _len, else assign 0.
(gfc_conv_intrinsic_to_class): Likewise.
On Mon, 23 Mar 2015 12:28:03 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> Dear Andre,
>
> Yes, that's right. The first three (vtab rework 1/2 and pr64787) are
> combined and reformatted in the .diff file that I sent you. Please use
> that and then apply the pr55901 patch. This is what I am okaying.
>
> Cheers
>
> Paul
>
> On 23 March 2015 at 10:45, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi Paul,
> >
> > thanks for the reviews. Let me ask one questions before I do something
> > wrong. You have reviewed and approved (with changes) the patches:
> >
> > - vtab_access_rework1_v1.patch
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
> > - vtab_access_rework2_v1.patch
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
> > - pr64787_v2.patch
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
> > and
> > - pr55901_v1.patch
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00086.html
> > , right?
> >
> > I am asking so explicitly, because there are four more patches from me in
> > the wild, that await review (not necessarily from you, Paul), namely:
> >
> > - pr60322_base_1.patch
> > https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html
> > - pr60322_3.patch
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00032.html
> > - crashfix2_v1.patch (small patch, ~100 loc))
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00063.html
> > and
> > - cosm_simp.patch (tiny patch, ~20 loc)
> > https://gcc.gnu.org/ml/fortran/2015-03/msg00088.html
> >
> > Please don't get me wrong on this. I just want to prevent misunderstandings
> > here. The latter four patches are not yet approved, right?
> >
> > I will now apply the 4.9-trunk patch and wait for your answer before
> > applying the above four on vtab_rework pr64787 and pr55901.
> >
> > Regards,
> > Andre
> >
> >
> >
> > On Mon, 23 Mar 2015 08:33:51 +0100
> > Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> >
> >> Dear Andre,
> >>
> >> I am persuaded by the arguments of Jerry and Dominique that this is
> >> good for trunk. Please commit as early as possible in order that any
> >> regressions can be caught, if possible, before release.
> >>
> >> Thanks
> >>
> >> Paul
> >>
> >> On 21 March 2015 at 15:11, Paul Richard Thomas
> >> <paul.richard.thomas@gmail.com> wrote:
> >> > Dear Andre,
> >> >
> >> > I have applied the three preliminary patches but have not yet applied
> >> > the attached one for PR55901. As advertised the composite patch
> >> > bootstraps and regtests on FC21,x86_64.
> >> >
> >> > I went through gfc_trans_allocate and cleaned up the formatting and
> >> > some of the text in the comments. You did a heroic job to tidy up this
> >> > function and so I thought that I should do my bit - one of the
> >> > feature, previously, was that the line length often went well in
> >> > excess of the gcc style guide limit of 72 and this tended to make it
> >> > somewhat unreadable. I have not been rigorous about this, especially
> >> > when readability would be impaired thereby, but it does look a lot
> >> > better now. The composite diff is attached.
> >> >
> >> > Not only does the Metcalf example run correctly but also the PGI
> >> > Insider linked list example. I have attached a version of this
> >> > modified to function as a gfortran.dg testcase. With the attributions
> >> > in there, I do not think that there are any copyright issues. The
> >> > article itself has no copyright notice.
> >> >
> >> > I would very much like to say that this is OK for trunk but we are
> >> > hard up against the end of stage 4 and so it should really wait for
> >> > backporting to 5.2.
> >> >
> >> > Thanks for the patches
> >> >
> >> > Paul
> >> >
> >> > On 19 March 2015 at 16:13, Andre Vehreschild <vehre@gmx.de> wrote:
> >> >> Hi all,
> >> >>
> >> >> please find attached the parts missing to stop valgrind's complaining
> >> >> about the use of uninitialized memory. The issue was, that when
> >> >> constructing a temporary class-object to call a routine with unlimited
> >> >> polymorphic arguments, the _len component was never set. This is fixed
> >> >> by this patch now.
> >> >>
> >> >> Note, the patch is based on all these preliminary patches:
> >> >>
> >> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00074.html
> >> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00075.html
> >> >> https://gcc.gnu.org/ml/fortran/2015-03/msg00085.html
> >> >>
> >> >> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> >> >>
> >> >> Please review!
> >> >>
> >> >> - Andre
> >> >> --
> >> >> Andre Vehreschild * Email: vehre ad gmx dot de
> >> >
> >> >
> >> >
> >> > --
> >> > Outside of a dog, a book is a man's best friend. Inside of a dog it's
> >> > too dark to read.
> >> >
> >> > Groucho Marx
> >>
> >>
> >>
> >
> >
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
>
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr55901_cosm_simp.patch --]
[-- Type: text/x-patch, Size: 6331 bytes --]
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 221626)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,5 +1,16 @@
2015-03-24 Andre Vehreschild <vehre@gmx.de>
+ PR fortran/55901
+ * trans-expr.c (gfc_conv_structure): Fixed indendation.
+ Using integer_zero_node now instead of explicitly
+ constructing a integer constant zero node.
+ (gfc_conv_derived_to_class): Add handling of _len component,
+ i.e., when the rhs has a string_length then assign that to
+ class' _len, else assign 0.
+ (gfc_conv_intrinsic_to_class): Likewise.
+
+2015-03-24 Andre Vehreschild <vehre@gmx.de>
+
PR fortran/64787
PR fortran/57456
PR fortran/63230
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 221626)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -569,6 +569,34 @@
}
}
+ if (class_ts.u.derived->components->ts.type == BT_DERIVED
+ && class_ts.u.derived->components->ts.u.derived
+ ->attr.unlimited_polymorphic)
+ {
+ /* Take care about initializing the _len component correctly. */
+ ctree = gfc_class_len_get (var);
+ if (UNLIMITED_POLY (e))
+ {
+ gfc_expr *len;
+ gfc_se se;
+
+ len = gfc_copy_expr (e);
+ gfc_add_len_component (len);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, len);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
+ cond_optional, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ else
+ tmp = se.expr;
+ }
+ else
+ tmp = integer_zero_node;
+ gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
+ tmp));
+ }
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
@@ -727,44 +755,54 @@
}
}
- /* When the actual arg is a char array, then set the _len component of the
- unlimited polymorphic entity, too. */
- if (e->ts.type == BT_CHARACTER)
+ gcc_assert (class_ts.type == BT_CLASS);
+ if (class_ts.u.derived->components->ts.type == BT_DERIVED
+ && class_ts.u.derived->components->ts.u.derived
+ ->attr.unlimited_polymorphic)
{
ctree = gfc_class_len_get (var);
- /* Start with parmse->string_length because this seems to be set to a
- correct value more often. */
- if (parmse->string_length)
- gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
- /* When the string_length is not yet set, then try the backend_decl of
- the cl. */
- else if (e->ts.u.cl->backend_decl)
- gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
- /* If both of the above approaches fail, then try to generate an
- expression from the input, which is only feasible currently, when the
- expression can be evaluated to a constant one. */
- else
- {
- /* Try to simplify the expression. */
- gfc_simplify_expr (e, 0);
- if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
- {
- /* Amazingly all data is present to compute the length of a
- constant string, but the expression is not yet there. */
- e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
- &e->where);
- mpz_set_ui (e->ts.u.cl->length->value.integer,
- e->value.character.length);
- gfc_conv_const_charlen (e->ts.u.cl);
- e->ts.u.cl->resolved = 1;
- gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
- }
+ /* When the actual arg is a char array, then set the _len component of the
+ unlimited polymorphic entity, too. */
+ if (e->ts.type == BT_CHARACTER)
+ {
+ /* Start with parmse->string_length because this seems to be set to a
+ correct value more often. */
+ if (parmse->string_length)
+ tmp = parmse->string_length;
+ /* When the string_length is not yet set, then try the backend_decl of
+ the cl. */
+ else if (e->ts.u.cl->backend_decl)
+ tmp = e->ts.u.cl->backend_decl;
+ /* If both of the above approaches fail, then try to generate an
+ expression from the input, which is only feasible currently, when the
+ expression can be evaluated to a constant one. */
else
{
- gfc_error ("Can't compute the length of the char array at %L.",
- &e->where);
+ /* Try to simplify the expression. */
+ gfc_simplify_expr (e, 0);
+ if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+ {
+ /* Amazingly all data is present to compute the length of a
+ constant string, but the expression is not yet there. */
+ e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
+ &e->where);
+ mpz_set_ui (e->ts.u.cl->length->value.integer,
+ e->value.character.length);
+ gfc_conv_const_charlen (e->ts.u.cl);
+ e->ts.u.cl->resolved = 1;
+ tmp = e->ts.u.cl->backend_decl;
+ }
+ else
+ {
+ gfc_error ("Can't compute the length of the char array at %L.",
+ &e->where);
+ }
}
}
+ else
+ tmp = integer_zero_node;
+
+ gfc_add_modify (&parmse->pre, ctree, tmp);
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
@@ -7039,7 +7077,7 @@
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
- continue;
+ continue;
if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "_extends") == 0
@@ -7060,13 +7098,9 @@
val));
}
else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
- {
- gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- val = gfc_conv_constant_to_tree (e);
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
- fold_convert (TREE_TYPE (cm->backend_decl),
- val));
- }
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+ fold_convert (TREE_TYPE (cm->backend_decl),
+ integer_zero_node));
else
{
val = gfc_conv_initializer (c->expr, &cm->ts,
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2015-03-24 11:51 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-03-19 15:13 [Patch, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array Andre Vehreschild
2015-03-21 14:12 ` Paul Richard Thomas
2015-03-21 15:05 ` Jerry DeLisle
2015-03-23 7:33 ` Paul Richard Thomas
2015-03-23 9:45 ` Andre Vehreschild
2015-03-23 11:28 ` Paul Richard Thomas
2015-03-24 10:32 ` [commited, Fortran, pr64787 a.o., v1] Invalid code on sourced allocation of class(*) character string Andre Vehreschild
2015-03-24 11:51 ` [committed, Fortran, pr55901, v1] [OOP] type is (character(len=*)) misinterpreted as array and Re: [Patch, Fortran, v1] Cosmetics and code simplify Andre Vehreschild
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).