This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
- From: Tobias Burnus <burnus at net-b dot de>
- To: Dominique Dhumieres <dominiq at lps dot ens dot fr>
- Cc: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Tue, 16 Oct 2012 12:32:34 +0200
- Subject: Re: [Patch, Fortran] Fix OPTIONAL, esp. with polymorphism
- References: <20121007103940.B9EB93BABA@mailhost.lps.ens.fr>
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
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