Skip to content

R
riscv-gcc-1
Commit 16e82b25 by Tobias Burnus Committed by Tobias Burnus
Options

re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument) 

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.

From-SVN: r192495
parent 0fe03ac3
Showing with 1320 additions and 43 deletions
gcc/fortran/ChangeLog
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-12 Janus Weil <janus@gcc.gnu.org> 2012-10-12 Janus Weil <janus@gcc.gnu.org>
PR fortran/40453 PR fortran/40453
......
gcc/fortran/trans-expr.c
...@@ -231,12 +231,16 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, ...@@ -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 /* 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 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 void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 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; gfc_symbol *vtab;
tree cond_optional = NULL_TREE;
gfc_ss *ss; gfc_ss *ss;
tree ctree; tree ctree;
tree var; tree var;
...@@ -269,13 +273,21 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -269,13 +273,21 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Now set the data field. */ /* Now set the data field. */
ctree = gfc_class_data_get (var); 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) if (parmse->ss && parmse->ss->info->useflags)
{ {
/* For an array reference in an elemental procedure call we need /* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */ to retain the ss to provide the scalarized array reference. */
gfc_conv_expr_reference (parmse, e); gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 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); gfc_add_modify (&parmse->pre, ctree, tmp);
} }
else else
{ {
...@@ -293,28 +305,145 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -293,28 +305,145 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_expr_attr (e)); gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type)); 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); gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
} }
else else
{ {
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 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); gfc_add_modify (&parmse->pre, ctree, tmp);
} }
} }
else else
{ {
stmtblock_t block;
gfc_init_block (&block);
parmse->ss = ss; parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e); gfc_conv_expr_descriptor (parmse, e);
if (e->rank != class_ts.u.derived->components->as->rank) 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 else
gfc_add_modify (&parmse->pre, ctree, parmse->expr); gfc_add_block_to_block (&parmse->pre, &block);
} }
} }
/* Pass the address of the class object. */ /* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 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 (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 +452,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -323,19 +452,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
type. type.
OOP-TODO: This could be improved by adding code that branched on 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 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 void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_typespec class_ts, bool elemental) bool elemental, bool copyback, bool optional,
bool optional_alloc_ptr)
{ {
tree ctree; tree ctree;
tree var; tree var;
tree tmp; tree tmp;
tree vptr; tree vptr;
tree cond = NULL_TREE;
gfc_ref *ref; gfc_ref *ref;
gfc_ref *class_ref; gfc_ref *class_ref;
stmtblock_t block;
bool full_array = false; bool full_array = false;
gfc_init_block (&block);
class_ref = NULL; class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next) for (ref = e->ref; ref; ref = ref->next)
{ {
...@@ -353,7 +492,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -353,7 +492,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
return; return;
/* Test for FULL_ARRAY. */ /* 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 /* The derived type needs to be converted to a temporary
CLASS object. */ CLASS object. */
...@@ -369,22 +512,30 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -369,22 +512,30 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
{ {
tree type = get_scalar_to_descriptor_type (parmse->expr, tree type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e)); 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_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 else
class_array_data_assign (&parmse->pre, ctree, parmse->expr, false); class_array_data_assign (&block, ctree, parmse->expr, false);
} }
else 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 /* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there references, where nullification of the cannot occur and so there
is no need. */ is no need. */
if (!elemental && full_array) if (!elemental && full_array && copyback)
{ {
if (class_ts.u.derived->components->as if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank) && e->rank != class_ts.u.derived->components->as->rank)
...@@ -429,17 +580,51 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, ...@@ -429,17 +580,51 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp);
vptr = gfc_class_vptr_get (tmp); vptr = gfc_class_vptr_get (tmp);
gfc_add_modify (&parmse->pre, ctree, gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr)); fold_convert (TREE_TYPE (ctree), vptr));
/* Return the vptr component, except in the case of scalarized array /* Return the vptr component, except in the case of scalarized array
references, where the dynamic type cannot change. */ references, where the dynamic type cannot change. */
if (!elemental && full_array) if (!elemental && full_array && copyback)
gfc_add_modify (&parmse->post, vptr, gfc_add_modify (&parmse->post, vptr,
fold_convert (TREE_TYPE (vptr), ctree)); 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. */ /* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 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 +1042,43 @@ gfc_conv_expr_present (gfc_symbol * sym) ...@@ -857,19 +1042,43 @@ gfc_conv_expr_present (gfc_symbol * sym)
/* Fortran 2008 allows to pass null pointers and non-associated pointers /* Fortran 2008 allows to pass null pointers and non-associated pointers
as actual argument to denote absent dummies. For array descriptors, as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. */ we thus also need to check the array descriptor. For BT_CLASS, it
if (!sym->attr.pointer && !sym->attr.allocatable can also occur for scalars and F2003 due to type->class wrapping and
&& sym->as && (sym->as->type == AS_ASSUMED_SHAPE class->class wrapping. Note futher that BT_CLASS always uses an
|| sym->as->type == AS_ASSUMED_RANK) array descriptor for arrays, also for explicit-shape/assumed-size. */
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
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; tree tmp;
tmp = build_fold_indirect_ref_loc (input_location, decl);
tmp = gfc_conv_array_data (tmp); if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, || sym->as->type == AS_ASSUMED_RANK
fold_convert (TREE_TYPE (tmp), null_pointer_node)); || sym->attr.codimension))
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
boolean_type_node, cond, tmp); {
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; return cond;
...@@ -3714,7 +3923,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3714,7 +3923,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && e->expr_type == EXPR_VARIABLE if (e && e->expr_type == EXPR_VARIABLE
&& !e->ref && !e->ref
&& e->ts.type == BT_CLASS && 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_typespec temp_ts = e->ts;
gfc_add_class_array_ref (e); gfc_add_class_array_ref (e);
...@@ -3763,7 +3973,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3763,7 +3973,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary /* The derived type needs to be converted to a temporary
CLASS object. */ CLASS object. */
gfc_init_se (&parmse, se); 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) else if (se->ss && se->ss->info->useflags)
{ {
...@@ -3789,7 +4004,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3789,7 +4004,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (fsym && fsym->ts.type == BT_DERIVED if (fsym && fsym->ts.type == BT_DERIVED
&& gfc_is_class_container_ref (e)) && 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 /* If we are passing an absent array as optional dummy to an
elemental procedure, make sure that we pass NULL when the data elemental procedure, make sure that we pass NULL when the data
...@@ -3817,13 +4045,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3817,13 +4045,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The scalarizer does not repackage the reference to a class /* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */ array - instead it returns a pointer to the data element. */
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS) 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 else
{ {
bool scalar; bool scalar;
gfc_ss *argss; gfc_ss *argss;
gfc_init_se (&parmse, NULL);
/* Check whether the expression is a scalar or not; we cannot use /* Check whether the expression is a scalar or not; we cannot use
e->rank as it can be nonzero for functions arguments. */ e->rank as it can be nonzero for functions arguments. */
argss = gfc_walk_expr (e); argss = gfc_walk_expr (e);
...@@ -3831,9 +4069,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3831,9 +4069,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (!scalar) if (!scalar)
gfc_free_ss_chain (argss); 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. */ /* A scalar or transformational function. */
gfc_init_se (&parmse, NULL);
if (scalar) if (scalar)
{ {
if (e->expr_type == EXPR_VARIABLE if (e->expr_type == EXPR_VARIABLE
...@@ -3888,7 +4136,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3888,7 +4136,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
} }
else 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. */ /* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS if (e->ts.type == BT_CLASS
...@@ -3904,7 +4168,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -3904,7 +4168,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((CLASS_DATA (fsym)->as && ((CLASS_DATA (fsym)->as
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (e)->attr.dimension)) || 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 if (fsym && (fsym->ts.type == BT_DERIVED
|| fsym->ts.type == BT_ASSUMED) || fsym->ts.type == BT_ASSUMED)
...@@ -4005,14 +4277,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4005,14 +4277,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
} }
else if (e->ts.type == BT_CLASS else if (e->ts.type == BT_CLASS
&& fsym && fsym->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. */ /* Pass a class array. */
gfc_init_se (&parmse, se);
gfc_conv_expr_descriptor (&parmse, e); gfc_conv_expr_descriptor (&parmse, e);
/* The conversion does not repackage the reference to a class /* The conversion does not repackage the reference to a class
array - _data descriptor. */ 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 else
{ {
......
gcc/fortran/trans-stmt.c
...@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) ...@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_conv_expr_descriptor (&se, e); gfc_conv_expr_descriptor (&se, e);
/* Obtain a temporary class container for the result. */ /* 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); se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
/* Set the offset. */ /* Set the offset. */
...@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) ...@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* Get the _vptr component of the class object. */ /* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr); tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */ /* 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); se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
} }
else else
...@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code) ...@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_init_se (&se_sz, NULL); gfc_init_se (&se_sz, NULL);
gfc_conv_expr_reference (&se_sz, code->expr3); gfc_conv_expr_reference (&se_sz, code->expr3);
gfc_conv_class_to_class (&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.pre, &se_sz.pre);
gfc_add_block_to_block (&se.post, &se_sz.post); gfc_add_block_to_block (&se.post, &se_sz.post);
classexpr = build_fold_indirect_ref_loc (input_location, classexpr = build_fold_indirect_ref_loc (input_location,
......
gcc/fortran/trans.h
...@@ -351,8 +351,10 @@ tree gfc_vtable_copy_get (tree); ...@@ -351,8 +351,10 @@ tree gfc_vtable_copy_get (tree);
tree gfc_get_vptr_from_expr (tree); tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree); tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree); tree gfc_copy_class_to_class (tree, tree, tree);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree); void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool); bool);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
bool, bool);
/* Initialize an init/cleanup block. */ /* Initialize an init/cleanup block. */
void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
......
gcc/testsuite/ChangeLog
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.
2012-10-16 Jakub Jelinek <jakub@redhat.com> 2012-10-16 Jakub Jelinek <jakub@redhat.com>
PR debug/54796 PR debug/54796
......
gcc/testsuite/gfortran.dg/class_optional_1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/class_optional_2.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment