Re: [PATCH, REPOST] Fix PR fortran/60718

Re: [PATCH, REPOST] Fix PR fortran/60718

[Tobias Burnus]

Hi Bernd,

On Tue, 2 Dec 2014 11:25:42, Bernd Edlinger wrote:
> a long time ago, I posted this patch, but it got forgotten.

Sorry, but persistent pinging helps...

> However the described problem is still unsolved,
> so I thought my patch should be re-posted now.
> 
> 
> Boot-strapped and regression-tested on arm-linux-gnueabihf.
> OK for trunk?

OK. Thanks for the patch!

Tobias

[PATCH, REPOST] Fix PR fortran/60718

[Bernd Edlinger]

[-- Attachment #1: Type: text/plain, Size: 2353 bytes --]

Hello Tobias,

a long time ago, I posted this patch, but it got forgotten.
However the described problem is still unsolved,
so I thought my patch should be re-posted now.


Boot-strapped and regression-tested on arm-linux-gnueabihf.
OK for trunk?


Thanks
Bernd.



On Tue, 15 Apr 2014 13:49:37, Bernd Edlinger wrote:
>
> Hi Tobias,
>
> On Fri, 11 Apr 2014 16:04:51, Tobias Burnus wrote:
>>
>> Hi Tobias,
>>
>> On Fri, Apr 11, 2014 at 02:39:57PM +0200, Bernd Edlinger wrote:
>>> On Fri, 11 Apr 2014 13:37:46, Tobias Burnus wrote:
>>> Hmm,
>>>
>>> I was hoping somehow that only that test case is broken,
>>> and needs to be fixed. The target attribute is somehow simple,
>>> it implies intent(in) and the actual value will in most cases
>>> be a pointer, as in the example.
>>
>> I think that passing another nonpointer TARGET to a dummy argument
>> which has a TARGET attribute is at least as common as passing a
>> POINTER to a TARGET.
>>
>> TARGET is roughtly the opposite to the restrict qualifier. By default
>> any nonpointer variable does not alias with something else, unless
>> it has the TARGET attribute; if it has, it (its address) can then
>> be assigned to a pointer. POINTER intrinsically alias and cannot
>> have the TARGET attribute.
>>
>>>> Pointer -> Nonalloc
>>>> Allocatable -> Noalloc
>>>> Nonallocatable*/Allocatable* -> Pointer with intent(in)
>>>
>>> Well, this approach does not handle intent(inout) at all.
>>
>>
>
> Now I have created a test case for the different aliasing issues
> with may arise with scalar objects.
>
> As you pointed out, also conversions of allocatable -> nonalloc,
> allocatable -> pointer and nonalloc -> pointer  turn out to
> violate the strict aliasing rules. However, conversions of
> arrays of objects with different attributes seem to be safe.
>
> I have not been able to find an example where it would be
> necessary to write the modified class object back to the original
> location. But I am not really a Fortran expert.
>
> Unfortunately there are also conversions of optional allocatable ->
> optional pointer, which complicate the whole thing quite a lot.
> I have found these in class_optional_2.f90.
>
> Boot-strapped and regression-tested on x86_64-linux-gnu.
> OK for trunk?
>
>
> Thanks
> Bernd.
>
 		 	   		  

[-- Attachment #2: changelog-pr60718.txt --]
[-- Type: text/plain, Size: 382 bytes --]

2014-04-15  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	PR fortran/60718
	* trans-expr.c (gfc_conv_procedure_call): Fix a strict aliasing
	violation when passing a class object to a formal parameter which has
	different pointer or allocatable attributes.

testsuite:
2014-04-14  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	PR fortran/60718
	* gfortran.dg/class_alias.f90: New.


[-- Attachment #3: patch-pr60718.diff --]
[-- Type: application/octet-stream, Size: 5245 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 209307)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -4244,6 +4244,55 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 				     fsym->attr.optional
 				     && e->expr_type == EXPR_VARIABLE);
 		    }
+		  else if (e->ts.type == BT_CLASS && fsym
+			   && fsym->ts.type == BT_CLASS
+			   && !CLASS_DATA (fsym)->as
+			   && !CLASS_DATA (e)->as
+			   && (CLASS_DATA (fsym)->attr.class_pointer
+			       != CLASS_DATA (e)->attr.class_pointer
+			       || CLASS_DATA (fsym)->attr.allocatable
+				  != CLASS_DATA (e)->attr.allocatable))
+		    {
+		      type = gfc_typenode_for_spec (&fsym->ts);
+		      var = gfc_create_var (type, fsym->name);
+		      gfc_conv_expr (&parmse, e);
+		      if (fsym->attr.optional
+			  && e->expr_type == EXPR_VARIABLE
+			  && e->symtree->n.sym->attr.optional)
+			{
+			  stmtblock_t block;
+			  tree cond;
+			  tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+			  cond = fold_build2_loc (input_location, NE_EXPR,
+						  boolean_type_node, tmp,
+						  fold_convert (TREE_TYPE (tmp),
+							    null_pointer_node));
+			  gfc_start_block (&block);
+			  gfc_add_modify (&block, var,
+					  fold_build1_loc (input_location,
+							   VIEW_CONVERT_EXPR,
+							   type, parmse.expr));
+			  gfc_add_expr_to_block (&parmse.pre,
+				 fold_build3_loc (input_location,
+					 COND_EXPR, void_type_node,
+					 cond, gfc_finish_block (&block),
+					 build_empty_stmt (input_location)));
+			  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+			  parmse.expr = build3_loc (input_location, COND_EXPR,
+					 TREE_TYPE (parmse.expr),
+					 cond, parmse.expr,
+					 fold_convert (TREE_TYPE (parmse.expr),
+						       null_pointer_node));
+			}
+		      else
+			{
+			  gfc_add_modify (&parmse.pre, var,
+					  fold_build1_loc (input_location,
+							   VIEW_CONVERT_EXPR,
+							   type, parmse.expr));
+			  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+			}
+		    }
 		  else
 		    gfc_conv_expr_reference (&parmse, e);
 
Index: gcc/testsuite/gfortran.dg/class_alias.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_alias.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/class_alias.f90	(revision 0)
@@ -0,0 +1,95 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! test for aliasing violations when converting class objects with
+! different target and pointer attributes.
+!
+module test_module
+
+  implicit none
+
+  type, public :: test
+    integer :: x
+  end type test
+
+contains
+
+  subroutine do_it6 (par2_t)
+    class (test), target :: par2_t
+    par2_t%x = par2_t%x + 1
+  end subroutine do_it6
+   
+  subroutine do_it5 (par1_p)
+    class (test), pointer, intent(in) :: par1_p
+    ! pointer -> target
+    ! { dg-final { scan-tree-dump "par2_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_p" "original" } }
+    call do_it6 (par1_p)
+  end subroutine do_it5
+
+  subroutine do_it4 (par_p)
+    class (test), pointer, intent(in) :: par_p
+    ! pointer -> pointer
+    ! { dg-final { scan-tree-dump-not "par1_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_p" "original" } }
+    call do_it5 (par_p)
+  end subroutine do_it4
+
+  subroutine do_it3 (par1_t)
+    class (test), target :: par1_t
+    ! target -> pointer
+    ! { dg-final { scan-tree-dump "par_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_t" "original" } }
+    call do_it4 (par1_t)
+  end subroutine do_it3
+
+  subroutine do_it2 (par_t)
+    class (test), target :: par_t
+    ! target -> target
+    ! { dg-final { scan-tree-dump-not "par1_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_t" "original" } }
+    call do_it3 (par_t)
+  end subroutine do_it2
+
+  subroutine do_it1 (par1_a)
+    class (test), allocatable :: par1_a
+    ! allocatable -> target
+    ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_a" "original" } }
+    call do_it2 (par1_a)
+  end subroutine do_it1
+
+  subroutine do_it (par_a)
+    class (test), allocatable :: par_a
+    ! allocatable -> allocatable
+    ! { dg-final { scan-tree-dump-not "par1_a\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_a" "original" } }
+    call do_it1 (par_a)
+  end subroutine do_it
+
+end module test_module
+
+use test_module
+
+  implicit none
+  class (test), allocatable :: var_a
+  class (test), pointer :: var_p
+
+
+  allocate (var_a)
+  allocate (var_p)
+  var_a%x = 0
+  var_p%x = 0
+  
+  ! allocatable -> allocatable
+  ! { dg-final { scan-tree-dump-not "par_a\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_a" "original" } }
+  call do_it (var_a)
+  ! allocatable -> target
+  ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_a" "original" } }
+  call do_it2 (var_a)
+  ! pointer -> target
+  ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_p" "original" } }
+  call do_it2 (var_p)
+  ! pointer -> pointer
+  ! { dg-final { scan-tree-dump-not "par_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_p" "original" } }
+  call do_it4 (var_p)
+  if (var_a%x .ne. 2) call abort()
+  if (var_p%x .ne. 2) call abort()
+  deallocate (var_a)
+  deallocate (var_p)
+end
+! { dg-final { cleanup-tree-dump "original" } }