From 16e82b2535b1dce10bd48175b11350b3301e6064 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 16 Oct 2012 15:02:02 +0200 Subject: [PATCH] re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument) 2012-10-16 Tobias Burnus 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 PR fortran/50981 PR fortran/54618 * gfortran.dg/class_optional_1.f90: New. * gfortran.dg/class_optional_2.f90: New. From-SVN: r192495 --- gcc/fortran/ChangeLog | 13 + gcc/fortran/trans-expr.c | 356 +++++++++-- gcc/fortran/trans-stmt.c | 6 +- gcc/fortran/trans.h | 6 +- gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/class_optional_1.f90 | 175 ++++++ gcc/testsuite/gfortran.dg/class_optional_2.f90 | 800 +++++++++++++++++++++++++ 7 files changed, 1320 insertions(+), 43 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_optional_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/class_optional_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ad70186..e1b1740 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2012-10-16 Tobias Burnus + + 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 PR fortran/40453 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1178e3d..cf9f346 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,145 @@ 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 (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, 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 +492,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 +512,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 +580,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 +1042,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 +3923,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 +3973,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 +4004,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 +4045,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 +4069,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 +4136,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 +4168,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 +4277,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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ea1e5ca..5ebe169 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-10-16 Tobias Burnus + + 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 PR debug/54796 diff --git a/gcc/testsuite/gfortran.dg/class_optional_1.f90 b/gcc/testsuite/gfortran.dg/class_optional_1.f90 new file mode 100644 index 0000000..2b408db --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_optional_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/class_optional_2.f90 b/gcc/testsuite/gfortran.dg/class_optional_2.f90 new file mode 100644 index 0000000..90b1719 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_optional_2.f90 @@ -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 -- 2.7.4