* [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
@ 2012-10-05 7:45 Tobias Burnus
2012-10-11 21:15 ` Janus Weil
0 siblings, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2012-10-05 7:45 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1529 bytes --]
gfortran supports OPTIONAL since quite some time - also some more
complicated cases involving ELEMENTAL or the new F2008 addition, but as
testing showed, the support is still incomplete; especially with
polymorphic arguments there were several bugs.
Besides a simple absent argument, passing an absent argument on also has
to be supported. Fortran 2008 in addition added that a deallocated
allocatable and an unassociated pointer also counts as absent - if (and
only if) it is passed to a nonallocatable, nonpointer optional dummy.
As complication comes on top of it: The CLASS container; especially for
class->type, type->class, class->(parent)class and when combined with
arrays, coarrays or assumed-rank arguments. There, one needs to ensure
that one passes the NULL correctly and that a NULL pointers doesn't get
dereferenced.
On the way, I fixed some other issues like passing polymorphic coarray
scalars (i.e. changing a class container with array descriptor to a
class container without array descriptor).
There are still issues with ELEMENTAL and with creating an array
descriptor for an (absent) optional array which has no array descriptor.
In addition, for CLASS->TYPE of assumed-rank arrays, the "packaging"
(creating a contiguous array) support is also still lacking. See the 146
commented FIXME lines in the patch. However, I think the patch is large
enough and sufficiently complete to be committed without the remaining
parts.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
[-- Attachment #2: poly-optional.diff --]
[-- Type: text/x-patch, Size: 49111 bytes --]
2012-10-06 Tobias Burnus <burnus@net-b.de>
PR fortran/50981
PR fortran/54618
* trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
Update prototype.
* trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
calls to those functions.
* trans-expr.c (gfc_conv_derived_to_class, gfc_conv_class_to_class,
gfc_conv_expr_present): Handle absent polymorphic arguments.
(class_scalar_coarray_to_class): New function.
(gfc_conv_procedure_call): Update calls.
2012-10-06 Tobias Burnus <burnus@net-b.de>
PR fortran/50981
PR fortran/54618
* gfortran.dg/class_optional_1.f90: New.
* gfortran.dg/class_optional_2.f90: New.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1178e3d..8c4b8d6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -231,12 +231,16 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
- used for the temporary class object. */
+ used for the temporary class object.
+ alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's only relevant for the optional handling. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr)
+ gfc_typespec class_ts, tree vptr, bool optional,
+ bool optional_alloc_ptr)
{
gfc_symbol *vtab;
+ tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
@@ -269,13 +273,21 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Now set the data field. */
ctree = gfc_class_data_get (var);
+ if (optional)
+ cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+
if (parmse->ss && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
+
}
else
{
@@ -293,28 +305,144 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
+ if (optional)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
}
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
}
}
else
{
+ stmtblock_t block;
+ gfc_init_block (&block);
+
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e);
if (e->rank != class_ts.u.derived->components->as->rank)
- class_array_data_assign (&parmse->pre, ctree, parmse->expr, true);
+ class_array_data_assign (&block, ctree, parmse->expr, true);
+ else
+ {
+ if (gfc_expr_attr (e).codimension)
+ parmse->expr = fold_build1_loc (input_location,
+ VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree),
+ parmse->expr);
+ gfc_add_modify (&block, ctree, parmse->expr);
+ }
+
+ if (optional)
+ {
+ tmp = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+
+ tmp = build3_v (COND_EXPR, cond_optional, tmp,
+ gfc_finish_block (&block));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
else
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ gfc_add_block_to_block (&parmse->pre, &block);
}
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional && optional_alloc_ptr)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
+}
+
+
+static void
+class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts, bool optional)
+{
+ tree var, ctree, tmp;
+ stmtblock_t block;
+ gfc_ref *ref;
+ gfc_ref *class_ref;
+
+ gfc_init_block (&block);
+
+ 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;
+ }
+
+ if (class_ref == NULL
+ && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ tmp = e->symtree->n.sym->backend_decl;
+ else
+ {
+ /* Remove everything after the last class reference, convert the
+ expression and then recover its tailend once more. */
+ gfc_se tmpse;
+ ref = class_ref->next;
+ class_ref->next = NULL;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, e);
+ class_ref->next = ref;
+ tmp = tmpse.expr;
+ }
+
+ var = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (var, "class");
+
+ ctree = gfc_class_vptr_get (var);
+ gfc_add_modify (&block, ctree,
+ fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
+
+ ctree = gfc_class_data_get (var);
+ tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+ gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional)
+ {
+ tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tree tmp2;
+
+ tmp = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ tmp2 = gfc_class_data_get (var);
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+ null_pointer_node));
+ tmp2 = gfc_finish_block (&block);
+
+ tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, tmp2);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+ else
+ gfc_add_block_to_block (&parmse->pre, &block);
}
@@ -323,19 +451,26 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
- the original class expression can be passed directly. */
+ the original class expression can be passed directly.
+ alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's relevant for the optional handling. */
void
-gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, bool elemental)
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
+ bool elemental, bool copyback, bool optional,
+ bool optional_alloc_ptr)
{
tree ctree;
tree var;
tree tmp;
tree vptr;
+ tree cond = NULL_TREE;
gfc_ref *ref;
gfc_ref *class_ref;
+ stmtblock_t block;
bool full_array = false;
+ gfc_init_block (&block);
+
class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next)
{
@@ -353,7 +488,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
return;
/* Test for FULL_ARRAY. */
- gfc_is_class_array_ref (e, &full_array);
+ if (e->rank == 0 && gfc_expr_attr (e).codimension
+ && gfc_expr_attr (e).dimension)
+ full_array = true;
+ else
+ gfc_is_class_array_ref (e, &full_array);
/* The derived type needs to be converted to a temporary
CLASS object. */
@@ -369,22 +508,30 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
{
tree type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree,
- gfc_class_data_get (parmse->expr));
+ tmp = gfc_class_data_get (parmse->expr);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ gfc_conv_descriptor_data_set (&block, ctree, tmp);
}
else
- class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+ class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ {
+ if (CLASS_DATA (e)->attr.codimension)
+ parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&block, ctree, parmse->expr);
+ }
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
- if (!elemental && full_array)
+ if (!elemental && full_array && copyback)
{
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
@@ -429,17 +576,51 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
tmp = build_fold_indirect_ref_loc (input_location, tmp);
vptr = gfc_class_vptr_get (tmp);
- gfc_add_modify (&parmse->pre, ctree,
+ gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
/* Return the vptr component, except in the case of scalarized array
references, where the dynamic type cannot change. */
- if (!elemental && full_array)
+ if (!elemental && full_array && copyback)
gfc_add_modify (&parmse->post, vptr,
fold_convert (TREE_TYPE (vptr), ctree));
+ gcc_assert (!optional || (optional && !copyback));
+ if (optional)
+ {
+ tree tmp2;
+
+ cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tmp = gfc_finish_block (&block);
+
+ if (optional_alloc_ptr)
+ tmp2 = build_empty_stmt (input_location);
+ else
+ {
+ gfc_init_block (&block);
+
+ tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+ null_pointer_node));
+ tmp2 = gfc_finish_block (&block);
+ }
+
+ tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, tmp2);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+ else
+ gfc_add_block_to_block (&parmse->pre, &block);
+
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional && optional_alloc_ptr)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
}
@@ -857,19 +1038,43 @@ gfc_conv_expr_present (gfc_symbol * sym)
/* Fortran 2008 allows to pass null pointers and non-associated pointers
as actual argument to denote absent dummies. For array descriptors,
- we thus also need to check the array descriptor. */
- if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
- || sym->as->type == AS_ASSUMED_RANK)
- && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ we thus also need to check the array descriptor. For BT_CLASS, it
+ can also occur for scalars and F2003 due to type->class wrapping and
+ class->class wrapping. Note futher that BT_CLASS always uses an
+ array descriptor for arrays, also for explicit-shape/assumed-size. */
+
+ if (!sym->attr.allocatable
+ && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS
+ && !CLASS_DATA (sym)->attr.allocatable
+ && !CLASS_DATA (sym)->attr.class_pointer))
+ && ((gfc_option.allow_std & GFC_STD_F2008) != 0
+ || sym->ts.type == BT_CLASS))
{
tree tmp;
- tmp = build_fold_indirect_ref_loc (input_location, decl);
- tmp = gfc_conv_array_data (tmp);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, cond, tmp);
+
+ if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->attr.codimension))
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, decl);
+ if (sym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (tmp);
+ tmp = gfc_conv_array_data (tmp);
+ }
+ else if (sym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (decl);
+ else
+ tmp = NULL_TREE;
+
+ if (tmp != NULL_TREE)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, cond, tmp);
+ }
}
return cond;
@@ -3714,7 +3919,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && e->expr_type == EXPR_VARIABLE
&& !e->ref
&& e->ts.type == BT_CLASS
- && CLASS_DATA (e)->attr.dimension)
+ && (CLASS_DATA (e)->attr.codimension
+ || CLASS_DATA (e)->attr.dimension))
{
gfc_typespec temp_ts = e->ts;
gfc_add_class_array_ref (e);
@@ -3763,7 +3969,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else if (se->ss && se->ss->info->useflags)
{
@@ -3789,7 +4000,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (fsym && fsym->ts.type == BT_DERIVED
&& gfc_is_class_container_ref (e))
- parmse.expr = gfc_class_data_get (parmse.expr);
+ {
+ parmse.expr = gfc_class_data_get (parmse.expr);
+
+ if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+ parmse.expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse.expr),
+ cond, parmse.expr,
+ fold_convert (TREE_TYPE (parmse.expr),
+ null_pointer_node));
+ }
+ }
/* If we are passing an absent array as optional dummy to an
elemental procedure, make sure that we pass NULL when the data
@@ -3817,13 +4041,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
- gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else
{
bool scalar;
gfc_ss *argss;
+ gfc_init_se (&parmse, NULL);
+
/* Check whether the expression is a scalar or not; we cannot use
e->rank as it can be nonzero for functions arguments. */
argss = gfc_walk_expr (e);
@@ -3831,9 +4065,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (!scalar)
gfc_free_ss_chain (argss);
+ /* Special handling for passing scalar polymorphic coarrays;
+ otherwise one passes "class->_data.data" instead of "&class". */
+ if (e->rank == 0 && e->ts.type == BT_CLASS
+ && fsym && fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->attr.codimension
+ && !CLASS_DATA (fsym)->attr.dimension)
+ {
+ gfc_add_class_array_ref (e);
+ parmse.want_coarray = 1;
+ scalar = false;
+ }
+
/* A scalar or transformational function. */
- gfc_init_se (&parmse, NULL);
-
if (scalar)
{
if (e->expr_type == EXPR_VARIABLE
@@ -3888,7 +4132,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
{
- gfc_conv_expr_reference (&parmse, e);
+ if (e->ts.type == BT_CLASS && fsym
+ && fsym->ts.type == BT_CLASS
+ && (!CLASS_DATA (fsym)->as
+ || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
+ && CLASS_DATA (e)->attr.codimension)
+ {
+ gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
+ gcc_assert (!CLASS_DATA (fsym)->as);
+ gfc_add_class_array_ref (e);
+ parmse.want_coarray = 1;
+ gfc_conv_expr_reference (&parmse, e);
+ class_scalar_coarray_to_class (&parmse, e, fsym->ts,
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE);
+ }
+ else
+ gfc_conv_expr_reference (&parmse, e);
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
@@ -3904,7 +4164,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((CLASS_DATA (fsym)->as
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (e)->attr.dimension))
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
if (fsym && (fsym->ts.type == BT_DERIVED
|| fsym->ts.type == BT_ASSUMED)
@@ -4005,14 +4273,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else if (e->ts.type == BT_CLASS
&& fsym && fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.dimension)
+ && (CLASS_DATA (fsym)->attr.dimension
+ || CLASS_DATA (fsym)->attr.codimension))
{
/* Pass a class array. */
- gfc_init_se (&parmse, se);
gfc_conv_expr_descriptor (&parmse, e);
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else
{
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 204f069..9205950 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_conv_expr_descriptor (&se, e);
/* Obtain a temporary class container for the result. */
- gfc_conv_class_to_class (&se, e, sym->ts, false);
+ gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
/* Set the offset. */
@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
- gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
+ gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
else
@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code)
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);
+ 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,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9818ceb..7e6d58c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -351,8 +351,10 @@ tree gfc_vtable_copy_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);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
-void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
+ bool);
+void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
+ bool, bool);
/* Initialize an init/cleanup block. */
void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
--- /dev/null 2012-10-04 07:54:15.859706324 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_optional_1.f90 2012-09-29 22:02:09.000000000 +0200
@@ -0,0 +1,41 @@
+! { dg-do run }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+ implicit none
+ type t
+ integer :: a
+ end type t
+ type(t), allocatable :: var1, var2(:)
+ call sub_ct2(null()) ! << SEGFAULT
+ call sub_ct(var1)
+ call sub_ct(var2)
+ call sub_cta2(null())
+ call sub_cta(var2)
+ allocate(var1, var2(2))
+ call sub_ct(var1)
+ call sub_ct(var2)
+ if (var1%a /= 5 .or. any (var2%a /= 5)) call abort()
+ call sub_cta(var2)
+ if (any (var2%a /= 7)) call abort()
+
+contains
+ elemental subroutine sub_ct2(y)
+ class(t), intent(in), optional :: y
+ if (present(y)) i = 5
+ end subroutine sub_ct2
+ elemental subroutine sub_ct(y)
+ class(t), intent(inout), optional :: y
+ if (present(y)) y%a = 5
+ end subroutine sub_ct
+ subroutine sub_cta2(y)
+ class(t), intent(in), optional :: y(:)
+ if (present(y)) i = 7
+ end subroutine sub_cta2
+ subroutine sub_cta(y)
+ class(t), intent(inout), optional :: y(:)
+ if (present(y)) y%a = 7
+ if (present(y)) i = 7
+ end subroutine sub_cta
+end
--- /dev/null 2012-10-04 07:54:15.859706324 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_optional_2.f90 2012-10-04 22:20:26.000000000 +0200
@@ -0,0 +1,959 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+ implicit none
+ type t
+ integer, allocatable :: i
+ end type t
+ type, extends (t):: t2
+ integer, allocatable :: j
+ end type t2
+
+ class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
+ class(t), pointer :: xp, xp2(:)
+
+ xp => null()
+ xp2 => null()
+
+ call s1a1()
+ call s1a()
+ call s1ac1()
+ call s1ac()
+ call s2()
+ call s2p(psnt=.false.)
+ call s2caf()
+ call s2elem()
+ call s2elem_t()
+ call s2elem_t2()
+ call s2t()
+ call s2tp(psnt=.false.)
+ call s2t2()
+ call s2t2p(psnt=.false.)
+
+ call a1a1()
+ call a1a()
+ call a1ac1()
+ call a1ac()
+ call a2()
+ call a2p(psnt=.false.)
+ call a2caf()
+
+ call a3a1()
+ call a3a()
+ call a3ac1()
+ call a3ac()
+ call a4()
+ call a4p(psnt=.false.)
+ call a4caf()
+
+ call ar1a1()
+ call ar1a()
+ call ar1ac1()
+ call ar1ac()
+ call ar()
+ call art()
+ call arp(psnt=.false.)
+ call artp(psnt=.false.)
+
+ call suba(alloc=.false., prsnt=.false.)
+ call suba(xa, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa)) call abort ()
+ if (.not. allocated (xa%i)) call abort ()
+ if (xa%i /= 5) call abort ()
+ xa%i = -3
+ call suba(xa, alloc=.true., prsnt=.true.)
+ if (allocated (xa)) call abort ()
+
+ call suba2(alloc=.false., prsnt=.false.)
+ call suba2(xa2, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa2)) call abort ()
+ if (size (xa2) /= 1) call abort ()
+ if (.not. allocated (xa2(1)%i)) call abort ()
+ if (xa2(1)%i /= 5) call abort ()
+ xa2(1)%i = -3
+ call suba2(xa2, alloc=.true., prsnt=.true.)
+ if (allocated (xa2)) call abort ()
+
+ call subp(alloc=.false., prsnt=.false.)
+ call subp(xp, alloc=.false., prsnt=.true.)
+ if (.not. associated (xp)) call abort ()
+ if (.not. allocated (xp%i)) call abort ()
+ if (xp%i /= 5) call abort ()
+ xp%i = -3
+ call subp(xp, alloc=.true., prsnt=.true.)
+ if (associated (xp)) call abort ()
+
+ call subp2(alloc=.false., prsnt=.false.)
+ call subp2(xp2, alloc=.false., prsnt=.true.)
+ if (.not. associated (xp2)) call abort ()
+ if (size (xp2) /= 1) call abort ()
+ if (.not. allocated (xp2(1)%i)) call abort ()
+ if (xp2(1)%i /= 5) call abort ()
+ xp2(1)%i = -3
+ call subp2(xp2, alloc=.true., prsnt=.true.)
+ if (associated (xp2)) call abort ()
+
+ call subac(alloc=.false., prsnt=.false.)
+ call subac(xac, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xac)) call abort ()
+ if (.not. allocated (xac%i)) call abort ()
+ if (xac%i /= 5) call abort ()
+ xac%i = -3
+ call subac(xac, alloc=.true., prsnt=.true.)
+ if (allocated (xac)) call abort ()
+
+ call suba2c(alloc=.false., prsnt=.false.)
+ call suba2c(xa2c, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa2c)) call abort ()
+ if (size (xa2c) /= 1) call abort ()
+ if (.not. allocated (xa2c(1)%i)) call abort ()
+ if (xa2c(1)%i /= 5) call abort ()
+ xa2c(1)%i = -3
+ call suba2c(xa2c, alloc=.true., prsnt=.true.)
+ if (allocated (xa2c)) call abort ()
+
+contains
+ subroutine suba2c(x, prsnt, alloc)
+ class(t), optional, allocatable :: x(:)[:]
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (prsnt) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x(1)[*])
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba2c
+
+ subroutine subac(x, prsnt, alloc)
+ class(t), optional, allocatable :: x[:]
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x[*])
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subac
+
+ subroutine suba2(x, prsnt, alloc)
+ class(t), optional, allocatable :: x(:)
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (prsnt) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x(1))
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba2
+
+ subroutine suba(x, prsnt, alloc)
+ class(t), optional, allocatable :: x
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x)
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba
+
+ subroutine subp2(x, prsnt, alloc)
+ class(t), optional, pointer :: x(:)
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. associated(x)) call abort ()
+ if (.not. associated (x)) then
+ allocate (x(1))
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subp2
+
+ subroutine subp(x, prsnt, alloc)
+ class(t), optional, pointer :: x
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. associated(x)) call abort ()
+ if (.not. associated (x)) then
+ allocate (x)
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subp
+
+
+ subroutine s1a1(z, z2, z3, z4, z5)
+ type(t), optional :: z, z4[*]
+ type(t), pointer, optional :: z2
+ type(t), allocatable, optional :: z3, z5[:]
+ type(t), allocatable :: x
+ type(t), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t(x)
+ call s2elem_t(y)
+ call s2elem_t(z)
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t(x)
+ call s2t(y)
+ call s2t(z)
+! call s2t(z2) ! FIXME: Segfault
+! call s2t(z3) ! FIXME: Segfault
+! call s2t(z4) ! FIXME: Segfault
+! call s2t(z5) ! FIXME: Segfault
+ call s2tp(y,psnt=.true.)
+ call s2tp(z2,psnt=.false.)
+ end subroutine s1a1
+ subroutine s1a(z, z2, z3, z4, z5)
+ type(t2), optional :: z, z4[*]
+ type(t2), optional, pointer :: z2
+ type(t2), optional, allocatable :: z3, z5[:]
+ type(t2), allocatable :: x
+ type(t2), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t2(x)
+ call s2elem_t2(y)
+ call s2elem_t2(z)
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t2(x)
+ call s2t2(y)
+ call s2t2(z)
+! call s2t2(z2) ! FIXME: Segfault
+! call s2t2(z3) ! FIXME: Segfault
+ call s2t2(z4)
+! call s2t2(z5) ! FIXME: Segfault
+ call s2t2p(y,psnt=.true.)
+ call s2t2p(z2,psnt=.false.)
+ end subroutine s1a
+ subroutine s1ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z, z4[*]
+ class(t), optional, pointer :: z2
+ class(t), optional, allocatable :: z3, z5[:]
+ class(t), allocatable :: x
+ class(t), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t(x)
+ call s2elem_t(y)
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t(x)
+ call s2t(y)
+! call s2t(z) ! FIXME: Segfault
+! call s2t(z2) ! FIXME: Segfault
+! call s2t(z3) ! FIXME: Segfault
+! call s2t(z4) ! FIXME: Segfault
+! call s2t(z5) ! FIXME: Segfault
+ call s2tp(y,psnt=.true.)
+ call s2tp(z2,psnt=.false.)
+ end subroutine s1ac1
+ subroutine s1ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z, z4[*]
+ class(t2), optional, pointer :: z2
+ class(t2), optional, allocatable :: z3, z5[:]
+ class(t2), allocatable :: x
+ class(t2), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t2(x)
+! call s2elem_t2(y) ! FIXME: Segfault
+! call s2elem_t2(z) ! FIXME: Segfault
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t2(x)
+ call s2t2(y)
+! call s2t2(z) ! FIXME: Segfault
+! call s2t2(z2) ! FIXME: Segfault
+! call s2t2(z3) ! FIXME: Segfault
+! call s2t2(z4) ! FIXME: Segfault
+! call s2t2(z5) ! FIXME: Segfault
+ call s2t2p(y,psnt=.true.)
+ call s2t2p(z2,psnt=.false.)
+ end subroutine s1ac
+
+ subroutine s2(x)
+ class(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2
+ subroutine s2p(x,psnt)
+ class(t), intent(in), pointer, optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2p
+ subroutine s2caf(x)
+ class(t), intent(in), optional :: x[*]
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2caf
+ subroutine s2t(x)
+ type(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2t
+ subroutine s2t2(x)
+ type(t2), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2t2
+ subroutine s2tp(x, psnt)
+ type(t), pointer, intent(in), optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2tp
+ subroutine s2t2p(x, psnt)
+ type(t2), pointer, intent(in), optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2t2p
+ impure elemental subroutine s2elem(x)
+ class(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem
+ impure elemental subroutine s2elem_t(x)
+ type(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem_t
+ impure elemental subroutine s2elem_t2(x)
+ type(t2), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem_t2
+
+
+ subroutine a1a1(z, z2, z3, z4, z5)
+ type(t), optional :: z(:), z4(:)[*]
+ type(t), optional, pointer :: z2(:)
+ type(t), optional, allocatable :: z3(:), z5(:)[:]
+ type(t), allocatable :: x(:)
+ type(t), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+ call s2elem_t(x)
+ call s2elem_t(y)
+ call s2elem_t(z)
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1a1
+ subroutine a1a(z, z2, z3, z4, z5)
+ type(t2), optional :: z(:), z4(:)[*]
+ type(t2), optional, pointer :: z2(:)
+ type(t2), optional, allocatable :: z3(:), z5(:)[:]
+ type(t2), allocatable :: x(:)
+ type(t2), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+ call s2elem_t2(x)
+ call s2elem_t2(y)
+ call s2elem_t2(z)
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1a
+ subroutine a1ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z(:), z4(:)[*]
+ class(t), optional, pointer :: z2(:)
+ class(t), optional, allocatable :: z3(:), z5(:)[:]
+ class(t), allocatable :: x(:)
+ class(t), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t(x) ! FIXME: Segfault
+! call s2elem_t(y) ! FIXME: Segfault
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1ac1
+ subroutine a1ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z(:), z4(:)[*]
+ class(t2), optional, pointer :: z2(:)
+ class(t2), optional, allocatable :: z3(:), z5(:)[:]
+ class(t2), allocatable :: x(:)
+ class(t2), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t2(x) ! FIXME: Segfault
+! call s2elem_t2(y) ! FIXME: Segfault
+! call s2elem_t2(z) ! FIXME: Segfault
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1ac
+
+ subroutine a2(x)
+ class(t), intent(in), optional :: x(:)
+ if (present (x)) call abort ()
+ ! print *, present(x)
+ end subroutine a2
+ subroutine a2p(x, psnt)
+ class(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ ! print *, present(x)
+ end subroutine a2p
+ subroutine a2caf(x)
+ class(t), intent(in), optional :: x(:)[*]
+ if (present (x)) call abort ()
+ ! print *, present(x)
+ end subroutine a2caf
+
+
+ subroutine a3a1(z, z2, z3, z4, z5)
+ type(t), optional :: z(4), z4(4)[*]
+ type(t), optional, pointer :: z2(:)
+ type(t), optional, allocatable :: z3(:), z5(:)[:]
+ type(t), allocatable :: x(:)
+ type(t), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+ call a4t(x)
+ call a4t(y)
+ call a4t(z)
+! call a4t(z2) ! FIXME: Segfault
+! call a4t(z3) ! FIXME: Segfault
+! call a4t(z4) ! FIXME: Segfault
+! call a4t(z5) ! FIXME: Segfault
+ call a4tp(y,psnt=.true.)
+ call a4tp(z2,psnt=.false.)
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+ call s2elem_t(x)
+ call s2elem_t(y)
+ call s2elem_t(z)
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3a1
+ subroutine a3a(z, z2, z3)
+ type(t2), optional :: z(4)
+ type(t2), optional, pointer :: z2(:)
+ type(t2), optional, allocatable :: z3(:)
+ type(t2), allocatable :: x(:)
+ type(t2), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+ call a4t2(x)
+ call a4t2(y)
+ call a4t2(z)
+! call a4t2(z2) ! FIXME: Segfault
+! call a4t2(z3) ! FIXME: Segfault
+ call a4t2p(y,psnt=.true.)
+ call a4t2p(z2,psnt=.false.)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+ call s2elem_t2(x)
+ call s2elem_t2(y)
+ call s2elem_t2(z)
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a3a
+ subroutine a3ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z(4), z4(4)[*]
+ class(t), optional, pointer :: z2(:)
+ class(t), optional, allocatable :: z3(:), z5(:)[:]
+ class(t), allocatable :: x(:)
+ class(t), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+! call a4t(x) ! FIXME: Segfault
+! call a4t(y) ! FIXME: Segfault
+! call a4t(z) ! FIXME: Segfault
+! call a4t(z2) ! FIXME: Segfault
+! call a4t(z3) ! FIXME: Segfault
+! call a4t(z4) ! FIXME: Segfault
+! call a4t(z5) ! FIXME: Segfault
+! call a4tp(y,psnt=.true.) ! FIXME: Segfault
+! call a4tp(z2,psnt=.false.) ! FIXME: Segfault
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+ call s2elem_t(x)
+ call s2elem_t(y)
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3ac1
+ subroutine a3ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z(4), z4(4)[*]
+ class(t2), optional, pointer :: z2(:)
+ class(t2), optional, allocatable :: z3(:), z5(:)[:]
+ class(t2), allocatable :: x(:)
+ class(t2), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+! call a4t2(x) ! FIXME: Segfault
+! call a4t2(y) ! FIXME: Segfault
+! call a4t2(z) ! FIXME: Segfault
+! call a4t2(z2) ! FIXME: Segfault
+! call a4t2(z3) ! FIXME: Segfault
+! call a4t2(z4) ! FIXME: Segfault
+! call a4t2(z5) ! FIXME: Segfault
+! call a4t2p(y,psnt=.true.) ! FIXME: Segfault
+! call a4t2p(z2,psnt=.false.) ! FIXME: Segfault
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ end subroutine a3ac
+
+ subroutine a4(x)
+ class(t), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4
+ subroutine a4p(x, psnt)
+ class(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4p
+ subroutine a4caf(x)
+ class(t), intent(in), optional :: x(4)[*]
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4caf
+ subroutine a4t(x)
+ type(t), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4t
+ subroutine a4t2(x)
+ type(t2), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4t2
+ subroutine a4tp(x, psnt)
+ type(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4tp
+ subroutine a4t2p(x, psnt)
+ type(t2), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4t2p
+
+
+ subroutine ar(x)
+ class(t), intent(in), optional :: x(..)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine ar
+
+ subroutine art(x)
+ type(t), intent(in), optional :: x(..)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine art
+
+ subroutine arp(x, psnt)
+ class(t), pointer, intent(in), optional :: x(..)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine arp
+
+ subroutine artp(x, psnt)
+ type(t), intent(in), pointer, optional :: x(..)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine artp
+
+
+
+ subroutine ar1a1(z, z2, z3)
+ type(t), optional :: z(..)
+ type(t), pointer, optional :: z2(..)
+ type(t), allocatable, optional :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call art(z)
+ call art(z2)
+ call art(z3)
+ call arp(z2, .false.)
+ call artp(z2, .false.)
+ end subroutine ar1a1
+ subroutine ar1a(z, z2, z3)
+ type(t2), optional :: z(..)
+ type(t2), optional, pointer :: z2(..)
+ type(t2), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(z2, .false.)
+ end subroutine ar1a
+ subroutine ar1ac1(z, z2, z3)
+ class(t), optional :: z(..)
+ class(t), optional, pointer :: z2(..)
+ class(t), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+! call art(z) ! FIXME: ICE - This requires packing support for assumed-rank
+! call art(z2)! FIXME: ICE - This requires packing support for assumed-rank
+! call art(z3)! FIXME: ICE - This requires packing support for assumed-rank
+ call arp(z2, .false.)
+! call artp(z2, .false.) ! FIXME: ICE
+ end subroutine ar1ac1
+ subroutine ar1ac(z, z2, z3)
+ class(t2), optional :: z(..)
+ class(t2), optional, pointer :: z2(..)
+ class(t2), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(z2, .false.)
+ end subroutine ar1ac
+end
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-05 7:45 [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism Tobias Burnus
@ 2012-10-11 21:15 ` Janus Weil
0 siblings, 0 replies; 9+ messages in thread
From: Janus Weil @ 2012-10-11 21:15 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Hi Tobias,
> gfortran supports OPTIONAL since quite some time - also some more
> complicated cases involving ELEMENTAL or the new F2008 addition, but as
> testing showed, the support is still incomplete; especially with polymorphic
> arguments there were several bugs.
>
> Besides a simple absent argument, passing an absent argument on also has to
> be supported. Fortran 2008 in addition added that a deallocated allocatable
> and an unassociated pointer also counts as absent - if (and only if) it is
> passed to a nonallocatable, nonpointer optional dummy.
>
> As complication comes on top of it: The CLASS container; especially for
> class->type, type->class, class->(parent)class and when combined with
> arrays, coarrays or assumed-rank arguments. There, one needs to ensure that
> one passes the NULL correctly and that a NULL pointers doesn't get
> dereferenced.
>
> On the way, I fixed some other issues like passing polymorphic coarray
> scalars (i.e. changing a class container with array descriptor to a class
> container without array descriptor).
>
> There are still issues with ELEMENTAL and with creating an array descriptor
> for an (absent) optional array which has no array descriptor. In addition,
> for CLASS->TYPE of assumed-rank arrays, the "packaging" (creating a
> contiguous array) support is also still lacking. See the 146 commented FIXME
> lines in the patch. However, I think the patch is large enough and
> sufficiently complete to be committed without the remaining parts.
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
thanks for this patch. It looks mostly ok to me. Since Dominique has
already inspected the test cases, I only looked at the patch itself. A
few minor comments:
@@ -231,12 +231,16 @@ class_array_data_assign (stmtblock_t *block,
tree lhs_desc, tree rhs_desc,
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
- used for the temporary class object. */
+ used for the temporary class object.
+ alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's only relevant for the optional handling. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr)
+ gfc_typespec class_ts, tree vptr, bool optional,
+ bool optional_alloc_ptr)
In the comment, 'alloc_ptr' should be 'optional_alloc_ptr'.
+
+static void
+class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts, bool optional)
+{
How about a small comment preceding this function, to shortly describe
its functionality and arguments? And then inside ...
+ 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;
+ }
... I guess the last if statement is not needed, since this condition
is already checked by the for loop.
@@ -323,19 +451,26 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
- the original class expression can be passed directly. */
+ the original class expression can be passed directly.
+ alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's relevant for the optional handling. */
void
-gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, bool elemental)
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
+ bool elemental, bool copyback, bool optional,
+ bool optional_alloc_ptr)
Again: 'alloc_ptr' -> 'optional_alloc_ptr' in the comment. And how
about a short comment on the 'copyback' argument?
That's pretty much all I found. Ok for trunk with the above ...
Cheers,
Janus
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-16 18:35 ` Tobias Burnus
@ 2012-10-16 19:35 ` Dominique Dhumieres
0 siblings, 0 replies; 9+ messages in thread
From: Dominique Dhumieres @ 2012-10-16 19:35 UTC (permalink / raw)
To: dominiq, burnus; +Cc: gcc-patches, fortran
> Can you confirm that the class_optional_1.f90 of the trunk works correctly?
Yes: I have regtested with
make -k check-gfortran RUNTESTFLAGS="dg.exp=class_optional* --target_board=unix'{-m32,-m64}'"
without failures.
The profile I have posted was for the former version of class_optional_2.f90.
The profiler I have to use on darwin monitors the codes running, it looks
like it missed all the routines which took only a tiny time.
Dominique
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-16 17:40 ` Dominique Dhumieres
@ 2012-10-16 18:35 ` Tobias Burnus
2012-10-16 19:35 ` Dominique Dhumieres
0 siblings, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2012-10-16 18:35 UTC (permalink / raw)
To: Dominique Dhumieres; +Cc: gcc-patches, fortran
Dominique,
Dominique Dhumieres wrote:
> The previous class_optional_2.f90 runs after your commit, but it takes
> ~168s (so it may have run with the previous patch also, but I was not
> patient enough to see it).
Here, it takes (current version) < 2s to compile and 0.150s to run the
program. If I look at your profile output, the new class_optional_1.f90
should be okay as it doesn't get listed with your profile.
The problems seem to occur with elemental calls, which means that
probably some additional elemental bugs exist, even if they do not show
up in valgrind.
Can you confirm that the class_optional_1.f90 of the trunk works correctly?
For class_optional_2.f90, we might have to comment some additional
elemental calls. I wonder what goes wrong there. (But given that other
elemental calls don't work, I do not wonder that much.)
Tobias
> The culprits are given by the following
> profile:
>
> + 100.0%, start, a.out
> | + 100.0%, main, a.out
> | | + 100.0%, MAIN__, a.out
> | | | + 25.5%, a3ac1.2085, a.out
> | | | | 7.2%, s2elem_t.2178, a.out
> | | | | 7.0%, s2elem.2184, a.out
> | | | + 25.5%, a1a.2151, a.out
> | | | | 15.3%, s2elem_t2.2175, a.out
> | | | + 24.5%, a1a1.2168, a.out
> | | | | 14.2%, s2elem_t.2178, a.out
> | | | + 12.2%, a3a.2097, a.out
> | | | | 7.1%, s2elem_t2.2175, a.out
> | | | + 12.2%, a3a1.2110, a.out
> | | | | 7.1%, s2elem_t.2178, a.out
>
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-16 10:47 ` Tobias Burnus
2012-10-16 11:16 ` Janus Weil
2012-10-16 13:18 ` Dominique Dhumieres
@ 2012-10-16 17:40 ` Dominique Dhumieres
2012-10-16 18:35 ` Tobias Burnus
2 siblings, 1 reply; 9+ messages in thread
From: Dominique Dhumieres @ 2012-10-16 17:40 UTC (permalink / raw)
To: dominiq, burnus; +Cc: gcc-patches, fortran
Tobias,
The previous class_optional_2.f90 runs after your commit, but it takes
~168s (so it may have run with the previous patch also, but I was not
patient enough to see it). The culprits are given by the following
profile:
+ 100.0%, start, a.out
| + 100.0%, main, a.out
| | + 100.0%, MAIN__, a.out
| | | + 25.5%, a3ac1.2085, a.out
| | | | 7.2%, s2elem_t.2178, a.out
| | | | 7.0%, s2elem.2184, a.out
| | | + 25.5%, a1a.2151, a.out
| | | | 15.3%, s2elem_t2.2175, a.out
| | | + 24.5%, a1a1.2168, a.out
| | | | 14.2%, s2elem_t.2178, a.out
| | | + 12.2%, a3a.2097, a.out
| | | | 7.1%, s2elem_t2.2175, a.out
| | | + 12.2%, a3a1.2110, a.out
| | | | 7.1%, s2elem_t.2178, a.out
Dominique
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-16 10:47 ` Tobias Burnus
2012-10-16 11:16 ` Janus Weil
@ 2012-10-16 13:18 ` Dominique Dhumieres
2012-10-16 17:40 ` Dominique Dhumieres
2 siblings, 0 replies; 9+ messages in thread
From: Dominique Dhumieres @ 2012-10-16 13:18 UTC (permalink / raw)
To: dominiq, burnus; +Cc: gcc-patches, fortran
Hi Tobias,
I did not yet appied you latest patch to gfortran, but I ran the new tests
with gfortran patched with the previous patch and both pass (manual
testing without option, but -fcoarray=single). Note that for
class_optional_1.f90, valgrind --leak-check=full gives
==45665== 4 bytes in 1 blocks are definitely lost in loss record 1 of 5
==45665== at 0x100014679: malloc (vg_replace_malloc.c:266)
==45665== by 0x1000023A7: suba2.1920 (class_optional_1_orig_2.f90:120)
==45665== by 0x100000F49: MAIN__ (class_optional_1_orig_2.f90:32)
==45665== by 0x100002A3A: main (class_optional_1_orig_2.f90:77)
==45665==
==45665== 4 bytes in 1 blocks are definitely lost in loss record 2 of 5
==45665== at 0x100014679: malloc (vg_replace_malloc.c:266)
==45665== by 0x100001E79: subp2.1897 (class_optional_1_orig_2.f90:152)
==45665== by 0x10000132D: MAIN__ (class_optional_1_orig_2.f90:51)
==45665== by 0x100002A3A: main (class_optional_1_orig_2.f90:77)
==45665==
==45665== 4 bytes in 1 blocks are definitely lost in loss record 3 of 5
==45665== at 0x100014679: malloc (vg_replace_malloc.c:266)
==45665== by 0x1000025D8: subac.1929 (class_optional_1_orig_2.f90:104)
==45665== by 0x1000015F6: MAIN__ (class_optional_1_orig_2.f90:61)
==45665== by 0x100002A3A: main (class_optional_1_orig_2.f90:77)
==45665==
==45665== 4 bytes in 1 blocks are definitely lost in loss record 4 of 5
==45665== at 0x100014679: malloc (vg_replace_malloc.c:266)
==45665== by 0x1000028A8: suba2c.1949 (class_optional_1_orig_2.f90:88)
==45665== by 0x100001878: MAIN__ (class_optional_1_orig_2.f90:70)
==45665== by 0x100002A3A: main (class_optional_1_orig_2.f90:77)
I dont really understand why this test was failing when included in
class_optional_2.f90. The only explanation I have is that it was run
after call s2elem(x) and call s2elem(y), that is no longer run:
635,636c794,795
< ! call s2elem(x) ! FIXME: Conditional jump or move depends on uninitialised value
< ! call s2elem(y) ! FIXME: Conditional jump or move depends on uninitialised value
---
> call s2elem(x)
> call s2elem(y)
These calls may have corrupted the memory(?).
Thanks for your work on the problem,
Dominique
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-16 10:47 ` Tobias Burnus
@ 2012-10-16 11:16 ` Janus Weil
2012-10-16 13:18 ` Dominique Dhumieres
2012-10-16 17:40 ` Dominique Dhumieres
2 siblings, 0 replies; 9+ messages in thread
From: Janus Weil @ 2012-10-16 11:16 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Dominique Dhumieres, fortran, gcc-patches
Hi Tobias,
>> + 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;
>> + }
>>
>> ... I guess the last if statement is not needed, since this condition
>> is already checked by the for loop.
>
>
> No, it's not the same: As written, "ref" might be non-NULL after the loop,
> without, it will be always NULL.
That's true. However, it seems you don't use the value of 'ref' after
the loop exits ...
Thanks for the updated patch,
Janus
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
2012-10-07 10:39 Dominique Dhumieres
@ 2012-10-16 10:47 ` Tobias Burnus
2012-10-16 11:16 ` Janus Weil
` (2 more replies)
0 siblings, 3 replies; 9+ messages in thread
From: Tobias Burnus @ 2012-10-16 10:47 UTC (permalink / raw)
To: Dominique Dhumieres; +Cc: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2290 bytes --]
Hi Dominique,
Dominique Dhumieres wrote:
> the test gfortran.dg/class_optional_1.f90 does not compile
...
> but the code seems weird.
I concur – and believe that it is already covered by the other test
cases. Thus, I removed it.
> The code gfortran.dg/class_optional_2.f90 compiles, but
> the runtime does not exit (at least after more than 30s).
> Finally I have applied the following changes in order
> to make it works:
>
> - call suba2(xa2, alloc=.false., prsnt=.true.)
> - if (.not. allocated (xa2)) call abort ()
> - if (size (xa2) /= 1) call abort ()
> - if (.not. allocated (xa2(1)%i)) call abort ()
> - if (xa2(1)%i /= 5) call abort ()
> - xa2(1)%i = -3
> - call suba2(xa2, alloc=.true., prsnt=.true.)
> - if (allocated (xa2)) call abort ()
This change and the next one, I do not understand; it works here with
-m32 and -m64 and shows no issues in valgrind. (Contrary to the
elemental test cases, which show up in valgrind; there it makes sense
that they fail for you, given that similar test cases also fail for me.)
I have split the sub* test cases into a new file. I think it makes sense
to understand why they fail - and how.
How do those test cases fail for you? Does this depend on the used
flags? And can you create a minimal failing test case?
* * *
On October 11, 2012 23:07, Janus Weil wrote:
> In the comment, 'alloc_ptr' should be 'optional_alloc_ptr'.
Fixed (twice).
> +class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
> + gfc_typespec class_ts, bool optional)
>
> How about a small comment preceding this function, to shortly describe
> its functionality and arguments? And then inside ...
Done.
> + 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;
> + }
>
> ... I guess the last if statement is not needed, since this condition
> is already checked by the for loop.
No, it's not the same: As written, "ref" might be non-NULL after the
loop, without, it will be always NULL.
> Again: 'alloc_ptr' -> 'optional_alloc_ptr' in the comment. And how
> about a short comment on the 'copyback' argument?
Done.
Build and regtested on x86-64-Linux.
Tobias
[-- Attachment #2: poly-optional-v2.diff --]
[-- Type: text/x-patch, Size: 49716 bytes --]
2012-10-16 Tobias Burnus <burnus@net-b.de>
PR fortran/50981
PR fortran/54618
* trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
Update prototype.
* trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
calls to those functions.
* trans-expr.c (gfc_conv_derived_to_class, gfc_conv_class_to_class,
gfc_conv_expr_present): Handle absent polymorphic arguments.
(class_scalar_coarray_to_class): New function.
(gfc_conv_procedure_call): Update calls.
2012-10-16 Tobias Burnus <burnus@net-b.de>
PR fortran/50981
PR fortran/54618
* gfortran.dg/class_optional_1.f90: New.
* gfortran.dg/class_optional_2.f90: New.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1178e3d..7532ec7 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -231,12 +231,16 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
- used for the temporary class object. */
+ used for the temporary class object.
+ optional_alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's only relevant for the optional handling. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr)
+ gfc_typespec class_ts, tree vptr, bool optional,
+ bool optional_alloc_ptr)
{
gfc_symbol *vtab;
+ tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
@@ -269,13 +273,21 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Now set the data field. */
ctree = gfc_class_data_get (var);
+ if (optional)
+ cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+
if (parmse->ss && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
+
}
else
{
@@ -293,28 +305,148 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
+ if (optional)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
}
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
}
}
else
{
+ stmtblock_t block;
+ gfc_init_block (&block);
+
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e);
if (e->rank != class_ts.u.derived->components->as->rank)
- class_array_data_assign (&parmse->pre, ctree, parmse->expr, true);
+ class_array_data_assign (&block, ctree, parmse->expr, true);
+ else
+ {
+ if (gfc_expr_attr (e).codimension)
+ parmse->expr = fold_build1_loc (input_location,
+ VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree),
+ parmse->expr);
+ gfc_add_modify (&block, ctree, parmse->expr);
+ }
+
+ if (optional)
+ {
+ tmp = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+
+ tmp = build3_v (COND_EXPR, cond_optional, tmp,
+ gfc_finish_block (&block));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
else
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ gfc_add_block_to_block (&parmse->pre, &block);
}
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional && optional_alloc_ptr)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
+}
+
+
+/* Create a new class container, which is required as scalar coarrays
+ have an array descriptor while normal scalars haven't. Optionally,
+ NULL pointer checks are added if the argument is OPTIONAL. */
+
+static void
+class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts, bool optional)
+{
+ tree var, ctree, tmp;
+ stmtblock_t block;
+ gfc_ref *ref;
+ gfc_ref *class_ref;
+
+ gfc_init_block (&block);
+
+ 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;
+ }
+
+ if (class_ref == NULL
+ && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ tmp = e->symtree->n.sym->backend_decl;
+ else
+ {
+ /* Remove everything after the last class reference, convert the
+ expression and then recover its tailend once more. */
+ gfc_se tmpse;
+ ref = class_ref->next;
+ class_ref->next = NULL;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, e);
+ class_ref->next = ref;
+ tmp = tmpse.expr;
+ }
+
+ var = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (var, "class");
+
+ ctree = gfc_class_vptr_get (var);
+ gfc_add_modify (&block, ctree,
+ fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
+
+ ctree = gfc_class_data_get (var);
+ tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+ gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional)
+ {
+ tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tree tmp2;
+
+ tmp = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ tmp2 = gfc_class_data_get (var);
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+ null_pointer_node));
+ tmp2 = gfc_finish_block (&block);
+
+ tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, tmp2);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+ else
+ gfc_add_block_to_block (&parmse->pre, &block);
}
@@ -323,19 +455,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
- the original class expression can be passed directly. */
+ the original class expression can be passed directly.
+ optional_alloc_ptr is false when the dummy is neither allocatable
+ nor a pointer; that's relevant for the optional handling.
+ Set copyback to true if class container's _data and _vtab pointers
+ might get modified. */
+
void
-gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, bool elemental)
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
+ bool elemental, bool copyback, bool optional,
+ bool optional_alloc_ptr)
{
tree ctree;
tree var;
tree tmp;
tree vptr;
+ tree cond = NULL_TREE;
gfc_ref *ref;
gfc_ref *class_ref;
+ stmtblock_t block;
bool full_array = false;
+ gfc_init_block (&block);
+
class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next)
{
@@ -353,7 +495,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
return;
/* Test for FULL_ARRAY. */
- gfc_is_class_array_ref (e, &full_array);
+ if (e->rank == 0 && gfc_expr_attr (e).codimension
+ && gfc_expr_attr (e).dimension)
+ full_array = true;
+ else
+ gfc_is_class_array_ref (e, &full_array);
/* The derived type needs to be converted to a temporary
CLASS object. */
@@ -369,22 +515,30 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
{
tree type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree,
- gfc_class_data_get (parmse->expr));
+ tmp = gfc_class_data_get (parmse->expr);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ gfc_conv_descriptor_data_set (&block, ctree, tmp);
}
else
- class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+ class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ {
+ if (CLASS_DATA (e)->attr.codimension)
+ parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&block, ctree, parmse->expr);
+ }
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
- if (!elemental && full_array)
+ if (!elemental && full_array && copyback)
{
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
@@ -429,17 +583,51 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
tmp = build_fold_indirect_ref_loc (input_location, tmp);
vptr = gfc_class_vptr_get (tmp);
- gfc_add_modify (&parmse->pre, ctree,
+ gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
/* Return the vptr component, except in the case of scalarized array
references, where the dynamic type cannot change. */
- if (!elemental && full_array)
+ if (!elemental && full_array && copyback)
gfc_add_modify (&parmse->post, vptr,
fold_convert (TREE_TYPE (vptr), ctree));
+ gcc_assert (!optional || (optional && !copyback));
+ if (optional)
+ {
+ tree tmp2;
+
+ cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tmp = gfc_finish_block (&block);
+
+ if (optional_alloc_ptr)
+ tmp2 = build_empty_stmt (input_location);
+ else
+ {
+ gfc_init_block (&block);
+
+ tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+ null_pointer_node));
+ tmp2 = gfc_finish_block (&block);
+ }
+
+ tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, tmp2);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+ else
+ gfc_add_block_to_block (&parmse->pre, &block);
+
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+ if (optional && optional_alloc_ptr)
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
}
@@ -857,19 +1045,43 @@ gfc_conv_expr_present (gfc_symbol * sym)
/* Fortran 2008 allows to pass null pointers and non-associated pointers
as actual argument to denote absent dummies. For array descriptors,
- we thus also need to check the array descriptor. */
- if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
- || sym->as->type == AS_ASSUMED_RANK)
- && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ we thus also need to check the array descriptor. For BT_CLASS, it
+ can also occur for scalars and F2003 due to type->class wrapping and
+ class->class wrapping. Note futher that BT_CLASS always uses an
+ array descriptor for arrays, also for explicit-shape/assumed-size. */
+
+ if (!sym->attr.allocatable
+ && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS
+ && !CLASS_DATA (sym)->attr.allocatable
+ && !CLASS_DATA (sym)->attr.class_pointer))
+ && ((gfc_option.allow_std & GFC_STD_F2008) != 0
+ || sym->ts.type == BT_CLASS))
{
tree tmp;
- tmp = build_fold_indirect_ref_loc (input_location, decl);
- tmp = gfc_conv_array_data (tmp);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, cond, tmp);
+
+ if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->attr.codimension))
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, decl);
+ if (sym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (tmp);
+ tmp = gfc_conv_array_data (tmp);
+ }
+ else if (sym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (decl);
+ else
+ tmp = NULL_TREE;
+
+ if (tmp != NULL_TREE)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, cond, tmp);
+ }
}
return cond;
@@ -3714,7 +3926,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && e->expr_type == EXPR_VARIABLE
&& !e->ref
&& e->ts.type == BT_CLASS
- && CLASS_DATA (e)->attr.dimension)
+ && (CLASS_DATA (e)->attr.codimension
+ || CLASS_DATA (e)->attr.dimension))
{
gfc_typespec temp_ts = e->ts;
gfc_add_class_array_ref (e);
@@ -3763,7 +3976,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else if (se->ss && se->ss->info->useflags)
{
@@ -3789,7 +4007,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (fsym && fsym->ts.type == BT_DERIVED
&& gfc_is_class_container_ref (e))
- parmse.expr = gfc_class_data_get (parmse.expr);
+ {
+ parmse.expr = gfc_class_data_get (parmse.expr);
+
+ if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+ parmse.expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse.expr),
+ cond, parmse.expr,
+ fold_convert (TREE_TYPE (parmse.expr),
+ null_pointer_node));
+ }
+ }
/* If we are passing an absent array as optional dummy to an
elemental procedure, make sure that we pass NULL when the data
@@ -3817,13 +4048,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
- gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else
{
bool scalar;
gfc_ss *argss;
+ gfc_init_se (&parmse, NULL);
+
/* Check whether the expression is a scalar or not; we cannot use
e->rank as it can be nonzero for functions arguments. */
argss = gfc_walk_expr (e);
@@ -3831,9 +4072,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (!scalar)
gfc_free_ss_chain (argss);
+ /* Special handling for passing scalar polymorphic coarrays;
+ otherwise one passes "class->_data.data" instead of "&class". */
+ if (e->rank == 0 && e->ts.type == BT_CLASS
+ && fsym && fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->attr.codimension
+ && !CLASS_DATA (fsym)->attr.dimension)
+ {
+ gfc_add_class_array_ref (e);
+ parmse.want_coarray = 1;
+ scalar = false;
+ }
+
/* A scalar or transformational function. */
- gfc_init_se (&parmse, NULL);
-
if (scalar)
{
if (e->expr_type == EXPR_VARIABLE
@@ -3888,7 +4139,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
{
- gfc_conv_expr_reference (&parmse, e);
+ if (e->ts.type == BT_CLASS && fsym
+ && fsym->ts.type == BT_CLASS
+ && (!CLASS_DATA (fsym)->as
+ || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
+ && CLASS_DATA (e)->attr.codimension)
+ {
+ gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
+ gcc_assert (!CLASS_DATA (fsym)->as);
+ gfc_add_class_array_ref (e);
+ parmse.want_coarray = 1;
+ gfc_conv_expr_reference (&parmse, e);
+ class_scalar_coarray_to_class (&parmse, e, fsym->ts,
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE);
+ }
+ else
+ gfc_conv_expr_reference (&parmse, e);
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
@@ -3904,7 +4171,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((CLASS_DATA (fsym)->as
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (e)->attr.dimension))
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
if (fsym && (fsym->ts.type == BT_DERIVED
|| fsym->ts.type == BT_ASSUMED)
@@ -4005,14 +4280,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else if (e->ts.type == BT_CLASS
&& fsym && fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.dimension)
+ && (CLASS_DATA (fsym)->attr.dimension
+ || CLASS_DATA (fsym)->attr.codimension))
{
/* Pass a class array. */
- gfc_init_se (&parmse, se);
gfc_conv_expr_descriptor (&parmse, e);
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+ gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+ fsym->attr.intent != INTENT_IN
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable),
+ fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
+ CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable);
}
else
{
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index bfcb686..b95c8da 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_conv_expr_descriptor (&se, e);
/* Obtain a temporary class container for the result. */
- gfc_conv_class_to_class (&se, e, sym->ts, false);
+ gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
/* Set the offset. */
@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
- gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
+ gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
else
@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code)
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);
+ 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,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9818ceb..7e6d58c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -351,8 +351,10 @@ tree gfc_vtable_copy_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);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
-void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
+ bool);
+void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
+ bool, bool);
/* Initialize an init/cleanup block. */
void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
--- /dev/null 2012-10-13 09:40:10.367750224 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_optional_1.f90 2012-10-16 11:16:27.000000000 +0200
@@ -0,0 +1,175 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+ implicit none
+ type t
+ integer, allocatable :: i
+ end type t
+ type, extends (t):: t2
+ integer, allocatable :: j
+ end type t2
+
+ class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
+ class(t), pointer :: xp, xp2(:)
+
+ xp => null()
+ xp2 => null()
+
+ call suba(alloc=.false., prsnt=.false.)
+ call suba(xa, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa)) call abort ()
+ if (.not. allocated (xa%i)) call abort ()
+ if (xa%i /= 5) call abort ()
+ xa%i = -3
+ call suba(xa, alloc=.true., prsnt=.true.)
+ if (allocated (xa)) call abort ()
+
+ call suba2(alloc=.false., prsnt=.false.)
+ call suba2(xa2, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa2)) call abort ()
+ if (size (xa2) /= 1) call abort ()
+ if (.not. allocated (xa2(1)%i)) call abort ()
+ if (xa2(1)%i /= 5) call abort ()
+ xa2(1)%i = -3
+ call suba2(xa2, alloc=.true., prsnt=.true.)
+ if (allocated (xa2)) call abort ()
+
+ call subp(alloc=.false., prsnt=.false.)
+ call subp(xp, alloc=.false., prsnt=.true.)
+ if (.not. associated (xp)) call abort ()
+ if (.not. allocated (xp%i)) call abort ()
+ if (xp%i /= 5) call abort ()
+ xp%i = -3
+ call subp(xp, alloc=.true., prsnt=.true.)
+ if (associated (xp)) call abort ()
+
+ call subp2(alloc=.false., prsnt=.false.)
+ call subp2(xp2, alloc=.false., prsnt=.true.)
+ if (.not. associated (xp2)) call abort ()
+ if (size (xp2) /= 1) call abort ()
+ if (.not. allocated (xp2(1)%i)) call abort ()
+ if (xp2(1)%i /= 5) call abort ()
+ xp2(1)%i = -3
+ call subp2(xp2, alloc=.true., prsnt=.true.)
+ if (associated (xp2)) call abort ()
+
+ call subac(alloc=.false., prsnt=.false.)
+ call subac(xac, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xac)) call abort ()
+ if (.not. allocated (xac%i)) call abort ()
+ if (xac%i /= 5) call abort ()
+ xac%i = -3
+ call subac(xac, alloc=.true., prsnt=.true.)
+ if (allocated (xac)) call abort ()
+
+ call suba2c(alloc=.false., prsnt=.false.)
+ call suba2c(xa2c, alloc=.false., prsnt=.true.)
+ if (.not. allocated (xa2c)) call abort ()
+ if (size (xa2c) /= 1) call abort ()
+ if (.not. allocated (xa2c(1)%i)) call abort ()
+ if (xa2c(1)%i /= 5) call abort ()
+ xa2c(1)%i = -3
+ call suba2c(xa2c, alloc=.true., prsnt=.true.)
+ if (allocated (xa2c)) call abort ()
+
+contains
+ subroutine suba2c(x, prsnt, alloc)
+ class(t), optional, allocatable :: x(:)[:]
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (prsnt) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x(1)[*])
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba2c
+
+ subroutine subac(x, prsnt, alloc)
+ class(t), optional, allocatable :: x[:]
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x[*])
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subac
+
+ subroutine suba2(x, prsnt, alloc)
+ class(t), optional, allocatable :: x(:)
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (prsnt) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x(1))
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba2
+
+ subroutine suba(x, prsnt, alloc)
+ class(t), optional, allocatable :: x
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. allocated(x)) call abort ()
+ if (.not. allocated (x)) then
+ allocate (x)
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine suba
+
+ subroutine subp2(x, prsnt, alloc)
+ class(t), optional, pointer :: x(:)
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. associated(x)) call abort ()
+ if (.not. associated (x)) then
+ allocate (x(1))
+ x(1)%i = 5
+ else
+ if (x(1)%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subp2
+
+ subroutine subp(x, prsnt, alloc)
+ class(t), optional, pointer :: x
+ logical prsnt, alloc
+ if (present (x) .neqv. prsnt) call abort ()
+ if (present (x)) then
+ if (alloc .neqv. associated(x)) call abort ()
+ if (.not. associated (x)) then
+ allocate (x)
+ x%i = 5
+ else
+ if (x%i /= -3) call abort()
+ deallocate (x)
+ end if
+ end if
+ end subroutine subp
+end
--- /dev/null 2012-10-13 09:40:10.367750224 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_optional_2.f90 2012-10-16 11:16:55.000000000 +0200
@@ -0,0 +1,800 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+ implicit none
+ type t
+ integer, allocatable :: i
+ end type t
+ type, extends (t):: t2
+ integer, allocatable :: j
+ end type t2
+
+ call s1a1()
+ call s1a()
+ call s1ac1()
+ call s1ac()
+ call s2()
+ call s2p(psnt=.false.)
+ call s2caf()
+ call s2elem()
+ call s2elem_t()
+ call s2elem_t2()
+ call s2t()
+ call s2tp(psnt=.false.)
+ call s2t2()
+ call s2t2p(psnt=.false.)
+
+ call a1a1()
+ call a1a()
+ call a1ac1()
+ call a1ac()
+ call a2()
+ call a2p(psnt=.false.)
+ call a2caf()
+
+ call a3a1()
+ call a3a()
+ call a3ac1()
+ call a3ac()
+ call a4()
+ call a4p(psnt=.false.)
+ call a4caf()
+
+ call ar1a1()
+ call ar1a()
+ call ar1ac1()
+ call ar1ac()
+ call ar()
+ call art()
+ call arp(psnt=.false.)
+ call artp(psnt=.false.)
+
+contains
+
+ subroutine s1a1(z, z2, z3, z4, z5)
+ type(t), optional :: z, z4[*]
+ type(t), pointer, optional :: z2
+ type(t), allocatable, optional :: z3, z5[:]
+ type(t), allocatable :: x
+ type(t), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t(x)
+ call s2elem_t(y)
+ call s2elem_t(z)
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t(x)
+ call s2t(y)
+ call s2t(z)
+! call s2t(z2) ! FIXME: Segfault
+! call s2t(z3) ! FIXME: Segfault
+! call s2t(z4) ! FIXME: Segfault
+! call s2t(z5) ! FIXME: Segfault
+ call s2tp(y,psnt=.true.)
+ call s2tp(z2,psnt=.false.)
+ end subroutine s1a1
+ subroutine s1a(z, z2, z3, z4, z5)
+ type(t2), optional :: z, z4[*]
+ type(t2), optional, pointer :: z2
+ type(t2), optional, allocatable :: z3, z5[:]
+ type(t2), allocatable :: x
+ type(t2), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t2(x)
+ call s2elem_t2(y)
+ call s2elem_t2(z)
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t2(x)
+ call s2t2(y)
+ call s2t2(z)
+! call s2t2(z2) ! FIXME: Segfault
+! call s2t2(z3) ! FIXME: Segfault
+ call s2t2(z4)
+! call s2t2(z5) ! FIXME: Segfault
+ call s2t2p(y,psnt=.true.)
+ call s2t2p(z2,psnt=.false.)
+ end subroutine s1a
+ subroutine s1ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z, z4[*]
+ class(t), optional, pointer :: z2
+ class(t), optional, allocatable :: z3, z5[:]
+ class(t), allocatable :: x
+ class(t), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t(x)
+ call s2elem_t(y)
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t(x)
+ call s2t(y)
+! call s2t(z) ! FIXME: Segfault
+! call s2t(z2) ! FIXME: Segfault
+! call s2t(z3) ! FIXME: Segfault
+! call s2t(z4) ! FIXME: Segfault
+! call s2t(z5) ! FIXME: Segfault
+ call s2tp(y,psnt=.true.)
+ call s2tp(z2,psnt=.false.)
+ end subroutine s1ac1
+ subroutine s1ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z, z4[*]
+ class(t2), optional, pointer :: z2
+ class(t2), optional, allocatable :: z3, z5[:]
+ class(t2), allocatable :: x
+ class(t2), pointer :: y
+ y => null()
+ call s2(x)
+ call s2(y)
+ call s2(z)
+ call s2(z2)
+ call s2(z3)
+ call s2(z4)
+ call s2(z5)
+ call s2p(y,psnt=.true.)
+ call s2p(z2,psnt=.false.)
+ call s2elem(x)
+ call s2elem(y)
+ call s2elem(z)
+ call s2elem(z2)
+ call s2elem(z3)
+ call s2elem(z4)
+ call s2elem(z5)
+ call s2elem_t2(x)
+! call s2elem_t2(y) ! FIXME: Segfault
+! call s2elem_t2(z) ! FIXME: Segfault
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ call s2caf(z4)
+ call s2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ call s2t2(x)
+ call s2t2(y)
+! call s2t2(z) ! FIXME: Segfault
+! call s2t2(z2) ! FIXME: Segfault
+! call s2t2(z3) ! FIXME: Segfault
+! call s2t2(z4) ! FIXME: Segfault
+! call s2t2(z5) ! FIXME: Segfault
+ call s2t2p(y,psnt=.true.)
+ call s2t2p(z2,psnt=.false.)
+ end subroutine s1ac
+
+ subroutine s2(x)
+ class(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2
+ subroutine s2p(x,psnt)
+ class(t), intent(in), pointer, optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2p
+ subroutine s2caf(x)
+ class(t), intent(in), optional :: x[*]
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2caf
+ subroutine s2t(x)
+ type(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2t
+ subroutine s2t2(x)
+ type(t2), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2t2
+ subroutine s2tp(x, psnt)
+ type(t), pointer, intent(in), optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2tp
+ subroutine s2t2p(x, psnt)
+ type(t2), pointer, intent(in), optional :: x
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine s2t2p
+ impure elemental subroutine s2elem(x)
+ class(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem
+ impure elemental subroutine s2elem_t(x)
+ type(t), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem_t
+ impure elemental subroutine s2elem_t2(x)
+ type(t2), intent(in), optional :: x
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine s2elem_t2
+
+
+ subroutine a1a1(z, z2, z3, z4, z5)
+ type(t), optional :: z(:), z4(:)[*]
+ type(t), optional, pointer :: z2(:)
+ type(t), optional, allocatable :: z3(:), z5(:)[:]
+ type(t), allocatable :: x(:)
+ type(t), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(z) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1a1
+ subroutine a1a(z, z2, z3, z4, z5)
+ type(t2), optional :: z(:), z4(:)[*]
+ type(t2), optional, pointer :: z2(:)
+ type(t2), optional, allocatable :: z3(:), z5(:)[:]
+ type(t2), allocatable :: x(:)
+ type(t2), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(z) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1a
+ subroutine a1ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z(:), z4(:)[*]
+ class(t), optional, pointer :: z2(:)
+ class(t), optional, allocatable :: z3(:), z5(:)[:]
+ class(t), allocatable :: x(:)
+ class(t), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t(x) ! FIXME: Segfault
+! call s2elem_t(y) ! FIXME: Segfault
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1ac1
+ subroutine a1ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z(:), z4(:)[*]
+ class(t2), optional, pointer :: z2(:)
+ class(t2), optional, allocatable :: z3(:), z5(:)[:]
+ class(t2), allocatable :: x(:)
+ class(t2), pointer :: y(:)
+ y => null()
+ call a2(x)
+ call a2(y)
+ call a2(z)
+ call a2(z2)
+ call a2(z3)
+ call a2(z4)
+ call a2(z5)
+ call a2p(y,psnt=.true.)
+ call a2p(z2,psnt=.false.)
+ call a2caf(z4)
+ call a2caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t2(x) ! FIXME: Segfault
+! call s2elem_t2(y) ! FIXME: Segfault
+! call s2elem_t2(z) ! FIXME: Segfault
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1ac
+
+ subroutine a2(x)
+ class(t), intent(in), optional :: x(:)
+ if (present (x)) call abort ()
+ ! print *, present(x)
+ end subroutine a2
+ subroutine a2p(x, psnt)
+ class(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ ! print *, present(x)
+ end subroutine a2p
+ subroutine a2caf(x)
+ class(t), intent(in), optional :: x(:)[*]
+ if (present (x)) call abort ()
+ ! print *, present(x)
+ end subroutine a2caf
+
+
+ subroutine a3a1(z, z2, z3, z4, z5)
+ type(t), optional :: z(4), z4(4)[*]
+ type(t), optional, pointer :: z2(:)
+ type(t), optional, allocatable :: z3(:), z5(:)[:]
+ type(t), allocatable :: x(:)
+ type(t), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+ call a4t(x)
+ call a4t(y)
+ call a4t(z)
+! call a4t(z2) ! FIXME: Segfault
+! call a4t(z3) ! FIXME: Segfault
+! call a4t(z4) ! FIXME: Segfault
+! call a4t(z5) ! FIXME: Segfault
+ call a4tp(y,psnt=.true.)
+ call a4tp(z2,psnt=.false.)
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(z) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3a1
+ subroutine a3a(z, z2, z3)
+ type(t2), optional :: z(4)
+ type(t2), optional, pointer :: z2(:)
+ type(t2), optional, allocatable :: z3(:)
+ type(t2), allocatable :: x(:)
+ type(t2), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+ call a4t2(x)
+ call a4t2(y)
+ call a4t2(z)
+! call a4t2(z2) ! FIXME: Segfault
+! call a4t2(z3) ! FIXME: Segfault
+ call a4t2p(y,psnt=.true.)
+ call a4t2p(z2,psnt=.false.)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Segfault
+! call s2elem(y) ! FIXME: Segfault
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(z) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t2(z2) ! FIXME: Segfault
+! call s2elem_t2(z3) ! FIXME: Segfault
+! call s2elem_t2(z4) ! FIXME: Segfault
+! call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a3a
+ subroutine a3ac1(z, z2, z3, z4, z5)
+ class(t), optional :: z(4), z4(4)[*]
+ class(t), optional, pointer :: z2(:)
+ class(t), optional, allocatable :: z3(:), z5(:)[:]
+ class(t), allocatable :: x(:)
+ class(t), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+! call a4t(x) ! FIXME: Segfault
+! call a4t(y) ! FIXME: Segfault
+! call a4t(z) ! FIXME: Segfault
+! call a4t(z2) ! FIXME: Segfault
+! call a4t(z3) ! FIXME: Segfault
+! call a4t(z4) ! FIXME: Segfault
+! call a4t(z5) ! FIXME: Segfault
+! call a4tp(y,psnt=.true.) ! FIXME: Segfault
+! call a4tp(z2,psnt=.false.) ! FIXME: Segfault
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+! call s2elem(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem(z) ! FIXME: Segfault
+! call s2elem(z2) ! FIXME: Segfault
+! call s2elem(z3) ! FIXME: Segfault
+! call s2elem(z4) ! FIXME: Segfault
+! call s2elem(z5) ! FIXME: Segfault
+! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+! call s2elem_t(z) ! FIXME: Segfault
+! call s2elem_t(z2) ! FIXME: Segfault
+! call s2elem_t(z3) ! FIXME: Segfault
+! call s2elem_t(z4) ! FIXME: Segfault
+! call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3ac1
+ subroutine a3ac(z, z2, z3, z4, z5)
+ class(t2), optional :: z(4), z4(4)[*]
+ class(t2), optional, pointer :: z2(:)
+ class(t2), optional, allocatable :: z3(:), z5(:)[:]
+ class(t2), allocatable :: x(:)
+ class(t2), pointer :: y(:)
+ y => null()
+ call a4(x)
+ call a4(y)
+ call a4(z)
+ call a4(z2)
+ call a4(z3)
+ call a4(z4)
+ call a4(z5)
+ call a4p(y,psnt=.true.)
+ call a4p(z2,psnt=.false.)
+! call a4t2(x) ! FIXME: Segfault
+! call a4t2(y) ! FIXME: Segfault
+! call a4t2(z) ! FIXME: Segfault
+! call a4t2(z2) ! FIXME: Segfault
+! call a4t2(z3) ! FIXME: Segfault
+! call a4t2(z4) ! FIXME: Segfault
+! call a4t2(z5) ! FIXME: Segfault
+! call a4t2p(y,psnt=.true.) ! FIXME: Segfault
+! call a4t2p(z2,psnt=.false.) ! FIXME: Segfault
+ call a4caf(z4)
+ call a4caf(z5)
+ call ar(x)
+ call ar(y)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call ar(z4)
+ call ar(z5)
+ call arp(y,psnt=.true.)
+ call arp(z2,psnt=.false.)
+ end subroutine a3ac
+
+ subroutine a4(x)
+ class(t), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4
+ subroutine a4p(x, psnt)
+ class(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4p
+ subroutine a4caf(x)
+ class(t), intent(in), optional :: x(4)[*]
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4caf
+ subroutine a4t(x)
+ type(t), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4t
+ subroutine a4t2(x)
+ type(t2), intent(in), optional :: x(4)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine a4t2
+ subroutine a4tp(x, psnt)
+ type(t), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4tp
+ subroutine a4t2p(x, psnt)
+ type(t2), pointer, intent(in), optional :: x(:)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine a4t2p
+
+
+ subroutine ar(x)
+ class(t), intent(in), optional :: x(..)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine ar
+
+ subroutine art(x)
+ type(t), intent(in), optional :: x(..)
+ if (present (x)) call abort ()
+ !print *, present(x)
+ end subroutine art
+
+ subroutine arp(x, psnt)
+ class(t), pointer, intent(in), optional :: x(..)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine arp
+
+ subroutine artp(x, psnt)
+ type(t), intent(in), pointer, optional :: x(..)
+ logical psnt
+ if (present (x).neqv. psnt) call abort ()
+ !print *, present(x)
+ end subroutine artp
+
+
+
+ subroutine ar1a1(z, z2, z3)
+ type(t), optional :: z(..)
+ type(t), pointer, optional :: z2(..)
+ type(t), allocatable, optional :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call art(z)
+ call art(z2)
+ call art(z3)
+ call arp(z2, .false.)
+ call artp(z2, .false.)
+ end subroutine ar1a1
+ subroutine ar1a(z, z2, z3)
+ type(t2), optional :: z(..)
+ type(t2), optional, pointer :: z2(..)
+ type(t2), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(z2, .false.)
+ end subroutine ar1a
+ subroutine ar1ac1(z, z2, z3)
+ class(t), optional :: z(..)
+ class(t), optional, pointer :: z2(..)
+ class(t), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+! call art(z) ! FIXME: ICE - This requires packing support for assumed-rank
+! call art(z2)! FIXME: ICE - This requires packing support for assumed-rank
+! call art(z3)! FIXME: ICE - This requires packing support for assumed-rank
+ call arp(z2, .false.)
+! call artp(z2, .false.) ! FIXME: ICE
+ end subroutine ar1ac1
+ subroutine ar1ac(z, z2, z3)
+ class(t2), optional :: z(..)
+ class(t2), optional, pointer :: z2(..)
+ class(t2), optional, allocatable :: z3(..)
+ call ar(z)
+ call ar(z2)
+ call ar(z3)
+ call arp(z2, .false.)
+ end subroutine ar1ac
+end
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
@ 2012-10-07 10:39 Dominique Dhumieres
2012-10-16 10:47 ` Tobias Burnus
0 siblings, 1 reply; 9+ messages in thread
From: Dominique Dhumieres @ 2012-10-07 10:39 UTC (permalink / raw)
To: fortran; +Cc: burnus, gcc-patches
Hi Tobias,
I have tested your patch, mostly the added test cases.
I think the test gfortran.dg/class_optional_2.f90 should be split:
it has too much tests lumped together. In addition
the test gfortran.dg/class_optional_1.f90 does not compile
because "symbol 'i' at (1) has no IMPLICIT type" (three times),
this is fixed with something such as
elemental subroutine sub_ct2(y)
+ integer :: i
class(t), intent(in), optional :: y
if (present(y)) i = 5
end subroutine sub_ct2
but the code seems weird.
The code gfortran.dg/class_optional_2.f90 compiles, but
the runtime does not exit (at least after more than 30s).
Finally I have applied the following changes in order
to make it works:
--- /opt/gcc/p_work/gcc/testsuite/gfortran.dg/class_optional_2.f90 2012-10-06 19:10:08.000000000 +0200
+++ class_optional_2_db_2.f90 2012-10-05 22:11:23.000000000 +0200
@@ -69,14 +69,14 @@
if (allocated (xa)) call abort ()
call suba2(alloc=.false., prsnt=.false.)
- call suba2(xa2, alloc=.false., prsnt=.true.)
- if (.not. allocated (xa2)) call abort ()
- if (size (xa2) /= 1) call abort ()
- if (.not. allocated (xa2(1)%i)) call abort ()
- if (xa2(1)%i /= 5) call abort ()
- xa2(1)%i = -3
- call suba2(xa2, alloc=.true., prsnt=.true.)
- if (allocated (xa2)) call abort ()
+! call suba2(xa2, alloc=.false., prsnt=.true.)
+! if (.not. allocated (xa2)) call abort ()
+! if (size (xa2) /= 1) call abort ()
+! if (.not. allocated (xa2(1)%i)) call abort ()
+! if (xa2(1)%i /= 5) call abort ()
+! xa2(1)%i = -3
+! call suba2(xa2, alloc=.true., prsnt=.true.)
+! if (allocated (xa2)) call abort ()
call subp(alloc=.false., prsnt=.false.)
call subp(xp, alloc=.false., prsnt=.true.)
@@ -88,14 +88,14 @@
if (associated (xp)) call abort ()
call subp2(alloc=.false., prsnt=.false.)
- call subp2(xp2, alloc=.false., prsnt=.true.)
- if (.not. associated (xp2)) call abort ()
- if (size (xp2) /= 1) call abort ()
- if (.not. allocated (xp2(1)%i)) call abort ()
- if (xp2(1)%i /= 5) call abort ()
- xp2(1)%i = -3
- call subp2(xp2, alloc=.true., prsnt=.true.)
- if (associated (xp2)) call abort ()
+! call subp2(xp2, alloc=.false., prsnt=.true.)
+! if (.not. associated (xp2)) call abort ()
+! if (size (xp2) /= 1) call abort ()
+! if (.not. allocated (xp2(1)%i)) call abort ()
+! if (xp2(1)%i /= 5) call abort ()
+! xp2(1)%i = -3
+! call subp2(xp2, alloc=.true., prsnt=.true.)
+! if (associated (xp2)) call abort ()
call subac(alloc=.false., prsnt=.false.)
call subac(xac, alloc=.false., prsnt=.true.)
@@ -107,14 +107,14 @@
if (allocated (xac)) call abort ()
call suba2c(alloc=.false., prsnt=.false.)
- call suba2c(xa2c, alloc=.false., prsnt=.true.)
- if (.not. allocated (xa2c)) call abort ()
- if (size (xa2c) /= 1) call abort ()
- if (.not. allocated (xa2c(1)%i)) call abort ()
- if (xa2c(1)%i /= 5) call abort ()
- xa2c(1)%i = -3
- call suba2c(xa2c, alloc=.true., prsnt=.true.)
- if (allocated (xa2c)) call abort ()
+! call suba2c(xa2c, alloc=.false., prsnt=.true.)
+! if (.not. allocated (xa2c)) call abort ()
+! if (size (xa2c) /= 1) call abort ()
+! if (.not. allocated (xa2c(1)%i)) call abort ()
+! if (xa2c(1)%i /= 5) call abort ()
+! xa2c(1)%i = -3
+! call suba2c(xa2c, alloc=.true., prsnt=.true.)
+! if (allocated (xa2c)) call abort ()
contains
subroutine suba2c(x, prsnt, alloc)
@@ -508,9 +508,9 @@ contains
! call s2elem(z3) ! FIXME: Segfault
! call s2elem(z4) ! FIXME: Segfault
! call s2elem(z5) ! FIXME: Segfault
- call s2elem_t(x)
- call s2elem_t(y)
- call s2elem_t(z)
+! call s2elem_t(x)
+! call s2elem_t(y)
+! call s2elem_t(z)
! call s2elem_t(z2) ! FIXME: Segfault
! call s2elem_t(z3) ! FIXME: Segfault
! call s2elem_t(z4) ! FIXME: Segfault
@@ -550,9 +550,9 @@ contains
! call s2elem(z3) ! FIXME: Segfault
! call s2elem(z4) ! FIXME: Segfault
! call s2elem(z5) ! FIXME: Segfault
- call s2elem_t2(x)
- call s2elem_t2(y)
- call s2elem_t2(z)
+! call s2elem_t2(x)
+! call s2elem_t2(y)
+! call s2elem_t2(z)
! call s2elem_t2(z2) ! FIXME: Segfault
! call s2elem_t2(z3) ! FIXME: Segfault
! call s2elem_t2(z4) ! FIXME: Segfault
@@ -704,9 +704,9 @@ contains
! call s2elem(z3) ! FIXME: Segfault
! call s2elem(z4) ! FIXME: Segfault
! call s2elem(z5) ! FIXME: Segfault
- call s2elem_t(x)
- call s2elem_t(y)
- call s2elem_t(z)
+! call s2elem_t(x)
+! call s2elem_t(y)
+! call s2elem_t(z)
! call s2elem_t(z2) ! FIXME: Segfault
! call s2elem_t(z3) ! FIXME: Segfault
! call s2elem_t(z4) ! FIXME: Segfault
@@ -747,9 +747,9 @@ contains
! call s2elem(z3) ! FIXME: Segfault
! call s2elem(z4) ! FIXME: Segfault
! call s2elem(z5) ! FIXME: Segfault
- call s2elem_t2(x)
- call s2elem_t2(y)
- call s2elem_t2(z)
+! call s2elem_t2(x)
+! call s2elem_t2(y)
+! call s2elem_t2(z)
! call s2elem_t2(z2) ! FIXME: Segfault
! call s2elem_t2(z3) ! FIXME: Segfault
! call s2elem_t2(z4) ! FIXME: Segfault
@@ -798,8 +798,8 @@ contains
! call s2elem(z3) ! FIXME: Segfault
! call s2elem(z4) ! FIXME: Segfault
! call s2elem(z5) ! FIXME: Segfault
- call s2elem_t(x)
- call s2elem_t(y)
+! call s2elem_t(x)
+! call s2elem_t(y)
! call s2elem_t(z) ! FIXME: Segfault
! call s2elem_t(z2) ! FIXME: Segfault
! call s2elem_t(z3) ! FIXME: Segfault
Thanks for the work,
Dominique
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2012-10-16 18:35 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-10-05 7:45 [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism Tobias Burnus
2012-10-11 21:15 ` Janus Weil
2012-10-07 10:39 Dominique Dhumieres
2012-10-16 10:47 ` Tobias Burnus
2012-10-16 11:16 ` Janus Weil
2012-10-16 13:18 ` Dominique Dhumieres
2012-10-16 17:40 ` Dominique Dhumieres
2012-10-16 18:35 ` Tobias Burnus
2012-10-16 19:35 ` Dominique Dhumieres
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).