[Patch, fortran] PR69566 - Failure of SELECT TYPE with unlimited polymorphic function result

Paul Richard Thomas paul.richard.thomas@gmail.com
Wed Oct 19 07:28:00 GMT 2016


Dear Andre,

Following our exchange yesterday, I have eliminated the modification
to trans_associate_var and have corrected the offending expressions in
resolve.c(fixup_array_ref).

Please find attached the corrected patch.

Cheers

Paul

2016-10-19  Paul Thomas  <pault@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.

2016-10-19  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/69566
    * gfortran.dg/select_type_37.f03: New test.

On 18 October 2016 at 18:16, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
>> For reasons I don't understand, sometimes the expression type comes
>> through as BT_DERIVED, whilst the symbol is BT_CLASS. I could repair
>> this in resolve.c(fixup_array_ref) if you think that would be cleaner.
>
> I think that I figured the rule:
>
> - when no _class-ref is present, then the type is BT_CLASS,
> - as soon as a _class-ref is present the type is BT_DERIVED.
>
> There is an attr.is_class. Would that be an alternative? I don't know how
> reliable it is set.
>
>> > I am regression testing my polymorhpic class patch at the moment, therefore
>> > I can't test.
>>
>> OK - I can wait. I have quite a few other things to do :-(
>
> I found an error in my patch that only manifests itself with an optimization
> level great than 0. Now I am searching, never having done anything there.
>
> - Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein
-------------- next part --------------
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 241326)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8327,8332 ****
--- 8327,8374 ----
  }
  
  
+ /* 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 can also be set.  In addition,
+    sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
+    This is corrected here as well.*/
+ 
+ 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)
+     {
+       if ((*expr1)->ts.type != BT_CLASS)
+ 	(*expr1)->ts = sym1->ts;
+ 
+       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 ****
--- 8383,8390 ----
    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 ****
--- 8512,8542 ----
    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 ****
        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);
  
        new_st = gfc_get_code (EXEC_BLOCK);
        new_st->ext.block.ns = gfc_build_block_ns (ns);
--- 8602,8613 ----
        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);
*************** resolve_select_type (gfc_code *code, gfc
*** 8672,8677 ****
--- 8746,8754 ----
    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 241326)
--- 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/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 PR69556 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 James Greenhalgh  <jgreenhalgh@gcc.gnu.org>
+ !
+ program pr69556
+   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
+ 


More information about the Gcc-patches mailing list