Dear All,
This bug was caused by 'associate name' and 'associate entity'
expressions being incomplete when the 'selector' was an intrinsic
function result. I tried to fix this at source, in match_select _type
and gfc_get_variable_expr, but caused a vast number of breakages.
Undoubtedly, this would be the ecologically sound way to proceed but
applying fixups in resolve_select_type, gfc_conv_class_to_class and
trans_associate_var proved to be the path of least resistance.
Depending on which form of select type is used, the defective
expressions either lacked the correct value for rank, a full array
reference, a symbol with an array spec or had type BT_DERIVED for a
polymorphic symbol; these either singly or in combination depending of
the form of select type.
The patch, taken with the ChangeLogs, is fairly self-explanatory.
Please note that I have suppressed whitespace changes (suppression of
trailing blanks), so use patch with the -l option.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Best regards
Paul
2016-10-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/69566
* resolve.c (fixup_array_ref): New function.
(resolve_select_type): Gather up the rank and array reference,
if any, from the selector. Fix up the 'associate name' and the
'associate entities' as necessary.
* trans-expr.c (gfc_conv_class_to_class): If the symbol backend
decl is a FUNCTION_DECL, use the 'fake_result_decl' instead.
* trans-stmt.c (trans_associate_var): Extend 'unlimited' to
include expressions which are themsleves not unlimited
polymorphic but the symbol is.
2016-10-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/69566
* gfortran.dg/select_type_37.f03: New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 241274)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8327,8332 ****
--- 8327,8368 ----
}
+ /* Ensure that SELECT TYPE expressions have the correct rank and a full
+ array reference, where necessary. The symbols are artificial and so
+ the dimension attribute and arrayspec are also set. */
+ static void
+ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
+ int rank, gfc_ref *ref)
+ {
+ gfc_ref *nref = (*expr1)->ref;
+ gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
+ gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL;
+ (*expr1)->rank = rank;
+ if (sym1->ts.type == BT_CLASS)
+ {
+ CLASS_DATA (sym1)->attr.dimension = 1;
+ if (CLASS_DATA (sym1)->as == NULL && sym2)
+ CLASS_DATA (sym1)->as
+ = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
+ }
+ else
+ {
+ sym1->attr.dimension = 1;
+ if (sym1->as == NULL && sym2)
+ sym1->as = gfc_copy_array_spec (sym2->as);
+ }
+
+ for (; nref; nref = nref->next)
+ if (nref->next == NULL)
+ break;
+
+ if (ref && nref && nref->type != REF_ARRAY)
+ nref->next = gfc_copy_ref (ref);
+ else if (ref && !nref)
+ (*expr1)->ref = gfc_copy_ref (ref);
+ }
+
+
/* Resolve a SELECT TYPE statement. */
static void
*************** resolve_select_type (gfc_code *code, gfc
*** 8341,8346 ****
--- 8377,8384 ----
gfc_namespace *ns;
int error = 0;
int charlen = 0;
+ int rank = 0;
+ gfc_ref* ref = NULL;
ns = code->ext.block.ns;
gfc_resolve (ns);
*************** resolve_select_type (gfc_code *code, gfc
*** 8468,8473 ****
--- 8506,8536 ----
else
code->ext.block.assoc = NULL;
+ /* Ensure that the selector rank and arrayspec are available to
+ correct expressions in which they might be missing. */
+ if (code->expr2 && code->expr2->rank)
+ {
+ rank = code->expr2->rank;
+ for (ref = code->expr2->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+ if (ref && ref->type == REF_ARRAY)
+ ref = gfc_copy_ref (ref);
+
+ /* Fixup expr1 if necessary. */
+ if (rank)
+ fixup_array_ref (&code->expr1, code->expr2, rank, ref);
+ }
+ else if (code->expr1->rank)
+ {
+ rank = code->expr1->rank;
+ for (ref = code->expr1->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+ if (ref && ref->type == REF_ARRAY)
+ ref = gfc_copy_ref (ref);
+ }
+
/* Add EXEC_SELECT to switch on type. */
new_st = gfc_get_code (code->op);
new_st->expr1 = code->expr1;
*************** resolve_select_type (gfc_code *code, gfc
*** 8533,8539 ****
--- 8596,8607 ----
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
st->n.sym->assoc->target->where = code->expr1->where;
if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
+ {
gfc_add_data_component (st->n.sym->assoc->target);
+ /* Fixup the target expression if necessary. */
+ if (rank)
+ fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
+ }
new_st = gfc_get_code (EXEC_BLOCK);
new_st->ext.block.ns = gfc_build_block_ns (ns else
Index: gcc/);
*************** resolve_select_type (gfc_code *code, gfc
*** 8672,8677 ****
--- 8740,8748 ----
gfc_resolve_blocks (code->block, gfc_current_ns);
gfc_current_ns = old_ns;
+ if (ref)
+ free (ref);
+
resolve_select (code, true);
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 241273)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 1033,1040 ****
--- 1033,1045 ----
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tmp = e->symtree->n.sym->backend_decl;
+
+ if (TREE_CODE (tmp) == FUNCTION_DECL)
+ tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+
if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
slen = integer_zero_node;
}
else
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 241273)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1517,1523 ****
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
! unlimited = UNLIMITED_POLY (e);
/* Assignments to the string length need to be generated, when
( sym is a char array or
--- 1517,1526 ----
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
! unlimited = UNLIMITED_POLY (e)
! || (e->symtree && e->symtree->n.sym
! && e->symtree->n.sym->ts.type == BT_CLASS
! && UNLIMITED_POLY (e->symtree->n.sym));
/* Assignments to the string length need to be generated, when
( sym is a char array or
Index: gcc/testsuite/gfortran.dg/select_type_37.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_37.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/select_type_37.f03 (working copy)
***************
*** 0 ****
--- 1,83 ----
+ ! { dg-do run }
+ !
+ ! Checks the fix for PR69566 in which using implicit function results
+ ! in SELECT TYPE caused all sorts of problems, especially in the form
+ ! in 'return_pointer1' with "associate_name => selector". The original
+ ! PR is encapsulated in 'return_pointer'. Explicit results, such as in
+ ! 'return_pointer2' always worked.
+ !
+ ! Contributed by Janus Weil <ja...@gcc.gnu.org>
+ !
+ program pr69566
+ class(*), pointer :: ptr(:)
+ character(40) :: buffer1, buffer2
+ real :: cst1(2) = [1.0, 2.0]
+ real :: cst2(2) = [3.0, 4.0]
+ real :: cst3(2) = [5.0, 6.0]
+
+ write (buffer1, *) cst1
+ if (.not.associated(return_pointer1(cst1))) call abort
+ if (trim (buffer1) .ne. trim (buffer2)) call abort
+ select type (ptr)
+ type is (real)
+ if (any (ptr .ne. cst2)) call abort
+ end select
+ deallocate (ptr)
+
+ write (buffer1, *) cst2
+ if (.not.associated(return_pointer(cst2))) call abort
+ if (trim (buffer1) .ne. trim (buffer2)) call abort
+ select type (ptr)
+ type is (real)
+ if (any (ptr .ne. cst3)) call abort
+ end select
+ deallocate (ptr)
+
+ write (buffer1, *) cst1
+ if (.not.associated(return_pointer2(cst1))) call abort
+ if (trim (buffer1) .ne. trim (buffer2)) call abort
+ select type (ptr)
+ type is (real)
+ if (any (ptr .ne. cst2)) call abort
+ end select
+ deallocate (ptr)
+
+ contains
+
+ function return_pointer2(arg) result (res) ! Explicit result always worked.
+ class(*), pointer :: res(:)
+ real, intent(inout) :: arg(:)
+ allocate (res, source = arg)
+ ptr => res ! Check association and cleanup
+ select type (z => res)
+ type is (real(4))
+ write (buffer2, *) z ! Check associate expression is
OK.
+ z = cst2 ! Check associate is OK for
lvalue.
+ end select
+ end function
+
+ function return_pointer1(arg)
+ class(*), pointer :: return_pointer1(:)
+ real, intent(inout) :: arg(:)
+ allocate (return_pointer1, source = arg)
+ ptr => return_pointer1
+ select type (z => return_pointer1) ! This caused a segfault in
compilation.
+ type is (real(4))
+ write (buffer2, *) z
+ z = cst2
+ end select
+ end function
+
+ function return_pointer(arg) ! The form in the PR.
+ class(*), pointer :: return_pointer(:)
+ real, intent(inout) :: arg(:)
+ allocate (return_pointer, source = cst2)
+ ptr => return_pointer
+ select type (return_pointer)
+ type is (real(4)) ! Associate-name ‘__tmp_REAL_4’ at (1) is used as
array
+ write (buffer2, *) return_pointer
+ return_pointer = cst3
+ end select
+ end function
+ end program
+
