diff mbox

[Fortran] PR57530 (Part 2 of 3) Support TYPE => CLASS

Message ID 51F1A31F.3040404@net-b.de
State New
Headers show

Commit Message

Tobias Burnus July 25, 2013, 10:13 p.m. UTC 
This patch is a follow up to the resolve part, which permits 
TYPE=>CLASS. That approved patch is at 
http://gcc.gnu.org/ml/fortran/2013-06/msg00049.html  (I didn't want to 
commit it without this trans*.c patch.)

The attached patch adds support for:
    TYPE => CLASS
additionally, it fixes some issues with
    CLASS => CLASS
where the RHS is a polymorphic array function. Plus an issue with
    TYPE => TYPE
where the LHS does rank remapping and the RHS is a function. 
Unfortunately, the patch is a bit messier than I had hoped for.

Built and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: Part 3 of this series will add "TYPE = CLASS" support.

Comments

Janus Weil July 26, 2013, 8:45 p.m. UTC | #1 
Hi Tobias,

> This patch is a follow up to the resolve part, which permits TYPE=>CLASS.
> That approved patch is at
> http://gcc.gnu.org/ml/fortran/2013-06/msg00049.html  (I didn't want to
> commit it without this trans*.c patch.)
>
> The attached patch adds support for:
>    TYPE => CLASS
> additionally, it fixes some issues with
>    CLASS => CLASS
> where the RHS is a polymorphic array function. Plus an issue with
>    TYPE => TYPE
> where the LHS does rank remapping and the RHS is a function. Unfortunately,
> the patch is a bit messier than I had hoped for.
>
> Built and regtested on x86-64-gnu-linux.
> OK for the trunk?


yes, the patch looks basically ok to me. Just one thing I did not
quite understand:


@@ -6485,8 +6491,14 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
                 build_int_cst (gfc_charlen_type_node, 0));
     }

+      /* It can happen that the LHS has BT_DERIVED but it is in reality
+     a polymorphic variable.  */
+      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+      && !gfc_is_class_scalar_expr (expr1))
+    rse.expr = gfc_class_data_get (rse.expr);
+
       gfc_add_modify (&block, lse.expr,
-               fold_convert (TREE_TYPE (lse.expr), rse.expr));
+              fold_convert (TREE_TYPE (lse.expr), rse.expr));

       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);



How exactly can it happen that a polymorphic variable is BT_DERIVED?

Cheers,
Janus
Tobias Burnus July 27, 2013, 9:51 a.m. UTC | #2 
Hi Janus,

Janus Weil wrote:
>> OK for the trunk?
>
> yes, the patch looks basically ok to me. Just one thing I did not
> quite understand:
>
> +      /* It can happen that the LHS has BT_DERIVED but it is in reality
> +     a polymorphic variable.  */
>
> How exactly can it happen that a polymorphic variable is BT_DERIVED?

I don't know. I commented it and it still works with the new test cases 
- it failed with one of them before. Probably some other change in this 
patch fixed the issue. As I cannot reproduce it anymore - and as I 
didn't like it either, I will remove it.

OK for the trunk without that bit?

Tobias
Janus Weil July 27, 2013, 10:04 a.m. UTC | #3 
Hi,

>>> OK for the trunk?
>>
>> yes, the patch looks basically ok to me. Just one thing I did not
>> quite understand:
>>
>> +      /* It can happen that the LHS has BT_DERIVED but it is in reality
>> +     a polymorphic variable.  */
>>
>> How exactly can it happen that a polymorphic variable is BT_DERIVED?
>
> I don't know. I commented it and it still works with the new test cases - it
> failed with one of them before. Probably some other change in this patch
> fixed the issue. As I cannot reproduce it anymore - and as I didn't like it
> either, I will remove it.

To me that sounds like a bug - if the symbol is BT_CLASS, then the
expr should be BT_CLASS (unless there is further decoration). By
chance I also just noticed one such case when debugging PR 57285.

If you happen to find out when this occurs or where the problem
originates from, that would be very helpful.


> OK for the trunk without that bit?

Yes, ok.

Thanks for the patch,
Janus
Tobias Burnus July 27, 2013, 12:18 p.m. UTC | #4 
Tobias Burnus wrote:
> Janus Weil wrote:
>> yes, the patch looks basically ok to me. Just one thing I did not
>> quite understand:
>>
>> +      /* It can happen that the LHS has BT_DERIVED but it is in reality
>> +     a polymorphic variable.  */
>>
>> How exactly can it happen that a polymorphic variable is BT_DERIVED?

I miss remembered (too hot here!) - the problem wasn't for one of my 
newly added test cases but for an existing one. Without that bit, the 
following test case is failing:


class_array_12.f03 (and class_array_15.f03):

It fails via gfc_trans_class_assign -> gfc_trans_pointer_assignment:
1075        tmp = gfc_trans_pointer_assignment (expr1, expr2);


Namely for the line
         BGet => self%componentB(1)

There:
   expr1->ts.type ==  BT_DERIVED
   expr1->symtree->n.sym->ts.type == BT_CLASS
   expr1->ref->type == REF_COMPONENT
   expr1->ref->u.c.component->name == "_data"
and
   expr2->ts.type == BT_CLASS
   expr2->ref->type  == REF_COMPONENT
   expr2->ref->u.c.component->name == "componentb"
   expr2->ref->u.c.component->ts.type == BT_CLASS
   expr2->ref->next->u.ar.type == AR_ELEMENT

Both is kind of okay, but inconsistent. My newly added code does:

+  if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+      && expr2->expr_type != EXPR_FUNCTION)
+    gfc_add_data_component (expr2);

which adds a "_data" ref to expr2 - but expr2->ts.type remains BT_CLASS. 
Thus, the code later runs into:

+      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+         /*&& !gfc_is_class_scalar_expr (expr1)*/)
+       rse.expr = gfc_class_data_get (rse.expr);

which fails without the "gfc_is_class_scalar_expr" as one then adds a 
"_data" ref to the existing "_data" ref.

I think my changed check is bogus (even if it solved the problem) and 
the real problem is that gfc_add_data_component doesn't update 
expr->ts.type to BT_DERIVED. -  I will try that - and see what else will 
break.

Tobias
Tobias Burnus July 27, 2013, 2:30 p.m. UTC | #5 
Tobias Burnus wrote:
> Tobias Burnus wrote:
>> Janus Weil wrote:
>>> yes, the patch looks basically ok to me. Just one thing I did not
>>> quite understand:
>>>
>>> +      /* It can happen that the LHS has BT_DERIVED but it is in 
>>> reality
>>> +     a polymorphic variable.  */
>>>
>>> How exactly can it happen that a polymorphic variable is BT_DERIVED?
>
> I miss remembered (too hot here!) - the problem wasn't for one of my 
> newly added test cases but for an existing one. Without that bit, the 
> following test case is failing:

When I remove the "if" in class.c's gfc_add_component_ref's
   if (!next)
     e->ts = (*tail)->u.c.component->ts;

I get several failures, e.g.:

gfortran.dg/finalize_12.f90
gfortran.dg/finalize_13.f90
gfortran.dg/select_type_26.f03
gfortran.dg/select_type_27.f03
gfortran.dg/class_array_1.f03
gfortran.dg/class_array_15.f03
etc.

> My newly added code does:
>
> +  if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
> +      && expr2->expr_type != EXPR_FUNCTION)
> +    gfc_add_data_component (expr2);
>
> which adds a "_data" ref to expr2 - but expr2->ts.type remains BT_CLASS.

Giving up on the class.c version, would be the following change okay?

+  if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+      && expr2->expr_type != EXPR_FUNCTION)
+    {
+      gfc_add_data_component (expr2);
+      /* The following is required as gfc_add_data_component doesn't
+        update ts.type if there is a tailing REF_ARRAY.  */
+      expr2->ts.type = BT_DERIVED;
+    }
+

[together with the removal of gfc_is_class_scalar_expr:

+      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+         /*&& !gfc_is_class_scalar_expr (expr1)*/)
+       rse.expr = gfc_class_data_get (rse.expr);
]

It still feels a bit like a hack - but it is definitely much cleaner 
than my previous band aid.

Built and regtested on x86-64-gnu-linux.
OK?

Tobias
diff mbox

Patch

2013-07-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57530
	* trans-expr.c (gfc_trans_class_assign): Handle CLASS array
	functions.
	(gfc_trans_pointer_assign): Ditto and support pointer assignment of
	a polymorphic var to a nonpolymorphic var.

2013-07-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57530
	* gfortran.dg/pointer_assign_8.f90: New.
	* gfortran.dg/pointer_assign_9.f90: New.
	* gfortran.dg/pointer_assign_10.f90: New.
	* gfortran.dg/pointer_assign_11.f90: New.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e0cdd49..ac2fdb0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1043,7 +1043,7 @@  assign_vptr:
       gfc_add_data_component (expr2);
       goto assign;
     }
-  else if (CLASS_DATA (expr2)->attr.dimension)
+  else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
     {
       /* Insert an additional assignment which sets the '_vptr' field.  */
       lhs = gfc_copy_expr (expr1);
@@ -1061,9 +1061,10 @@  assign_vptr:
 
   /* Do the actual CLASS assignment.  */
   if (expr2->ts.type == BT_CLASS
-	&& !CLASS_DATA (expr2)->attr.dimension)
+      && !CLASS_DATA (expr2)->attr.dimension)
     op = EXEC_ASSIGN;
-  else
+  else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
+	   || !CLASS_DATA (expr2)->attr.dimension)
     gfc_add_data_component (expr1);
 
 assign:
@@ -6417,6 +6418,7 @@  gfc_trans_pointer_assign (gfc_code * code)
 tree
 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 {
+  gfc_expr *expr1_vptr = NULL;
   gfc_se lse;
   gfc_se rse;
   stmtblock_t block;
@@ -6437,6 +6439,10 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   if (!scalar)
     gfc_free_ss_chain (ss);
 
+  if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+      && expr2->expr_type != EXPR_FUNCTION)
+    gfc_add_data_component (expr2);
+
   if (scalar)
     {
       /* Scalar pointers.  */
@@ -6485,8 +6491,14 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 			    build_int_cst (gfc_charlen_type_node, 0));
 	}
 
+      /* It can happen that the LHS has BT_DERIVED but it is in reality
+	 a polymorphic variable.  */
+      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+	  && !gfc_is_class_scalar_expr (expr1))
+	rse.expr = gfc_class_data_get (rse.expr);
+
       gfc_add_modify (&block, lse.expr,
-			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
+		      fold_convert (TREE_TYPE (lse.expr), rse.expr));
 
       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);
@@ -6508,8 +6520,12 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  break;
       rank_remap = (remap && remap->u.ar.end[0]);
 
+      gfc_init_se (&lse, NULL);
       if (remap)
 	lse.descriptor_only = 1;
+      if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
+	  && expr1->ts.type == BT_CLASS)
+	expr1_vptr = gfc_copy_expr (expr1);
       gfc_conv_expr_descriptor (&lse, expr1);
       strlen_lhs = lse.string_length;
       desc = lse.expr;
@@ -6526,8 +6542,51 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_init_se (&rse, NULL);
 	  rse.direct_byref = 1;
 	  rse.byref_noassign = 1;
-	  gfc_conv_expr_descriptor (&rse, expr2);
-	  strlen_rhs = rse.string_length;
+
+	  if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+	    {
+	      gfc_conv_function_expr (&rse, expr2);
+
+	      if (expr1->ts.type != BT_CLASS)
+		rse.expr = gfc_class_data_get (rse.expr);
+	      else
+		{
+		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+		  gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+		  gfc_add_vptr_component (expr1_vptr);
+		  gfc_init_se (&rse, NULL);
+		  rse.want_pointer = 1;
+		  gfc_conv_expr (&rse, expr1_vptr);
+		  gfc_add_modify (&lse.pre, rse.expr,
+				  fold_convert (TREE_TYPE (rse.expr),
+						gfc_class_vptr_get (tmp)));
+		  rse.expr = gfc_class_data_get (tmp);
+		}
+	    }
+	  else if (expr2->expr_type == EXPR_FUNCTION)
+	    {
+	      tree bound[GFC_MAX_DIMENSIONS];
+	      int i;
+
+	      for (i = 0; i < expr2->rank; i++)
+		bound[i] = NULL_TREE;
+	      tmp = gfc_typenode_for_spec (&expr2->ts);
+	      tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
+					       bound, bound, 0,
+					       GFC_ARRAY_POINTER_CONT, false);
+	      tmp = gfc_create_var (tmp, "ptrtemp");
+	      lse.expr = tmp;
+	      lse.direct_byref = 1;
+	      gfc_conv_expr_descriptor (&lse, expr2);
+	      strlen_rhs = lse.string_length;
+	      rse.expr = tmp;
+	    }
+	  else
+	    {
+	      gfc_conv_expr_descriptor (&rse, expr2);
+	      strlen_rhs = rse.string_length;
+	    }
 	}
       else if (expr2->expr_type == EXPR_VARIABLE)
 	{
@@ -6551,12 +6610,37 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
 	    }
 	}
+      else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+	{
+	  gfc_init_se (&rse, NULL);
+	  rse.want_pointer = 1;
+	  gfc_conv_function_expr (&rse, expr2);
+	  if (expr1->ts.type != BT_CLASS)
+	    {
+	      rse.expr = gfc_class_data_get (rse.expr);
+	      gfc_add_modify (&lse.pre, desc, rse.expr);
+	    }
+	  else
+	    {
+	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+	      gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+	      gfc_add_vptr_component (expr1_vptr);
+	      gfc_init_se (&rse, NULL);
+	      rse.want_pointer = 1;
+	      gfc_conv_expr (&rse, expr1_vptr);
+	      gfc_add_modify (&lse.pre, rse.expr,
+			      fold_convert (TREE_TYPE (rse.expr),
+					gfc_class_vptr_get (tmp)));
+	      rse.expr = gfc_class_data_get (tmp);
+	      gfc_add_modify (&lse.pre, desc, rse.expr);
+	    }
+	}
       else
 	{
 	  /* Assign to a temporary descriptor and then copy that
 	     temporary to the pointer.  */
 	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
-
 	  lse.expr = tmp;
 	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2);
@@ -6564,6 +6648,9 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_add_modify (&lse.pre, desc, tmp);
 	}
 
+      if (expr1_vptr)
+	gfc_free_expr (expr1_vptr);
+
       gfc_add_block_to_block (&block, &lse.pre);
       if (rank_remap)
 	gfc_add_block_to_block (&block, &rse.pre);

--- /dev/null	2013-07-25 08:57:59.308780984 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_8.f90	2013-06-20 22:42:28.356836418 +0200
@@ -0,0 +1,46 @@ 
+! { dg-do run }
+!
+! PR fortran/57530
+!
+!
+! TYPE => CLASS pointer assignment for variables
+!
+module m
+  implicit none
+  type t
+    integer :: ii = 55
+  end type t
+contains
+  subroutine sub (tgt, tgt2)
+    class(t), target :: tgt, tgt2(:)
+    type(t), pointer :: ptr, ptr2(:), ptr3(:,:)
+
+    if (tgt%ii /= 43) call abort()
+    if (size (tgt2) /= 3) call abort()
+    if (any (tgt2(:)%ii /= [11,22,33])) call abort()
+
+    ptr => tgt  ! TYPE => CLASS
+    ptr2 => tgt2  ! TYPE => CLASS
+    ptr3(-3:-3,1:3) => tgt2  ! TYPE => CLASS
+
+    if (.not. associated(ptr)) call abort()
+    if (.not. associated(ptr2)) call abort()
+    if (.not. associated(ptr3)) call abort()
+    if (.not. associated(ptr,tgt)) call abort()
+    if (.not. associated(ptr2,tgt2)) call abort()
+    if (ptr%ii /= 43) call abort()
+    if (size (ptr2) /= 3) call abort()
+    if (size (ptr3) /= 3) call abort()
+    if (any (ptr2(:)%ii /= [11,22,33])) call abort()
+    if (any (shape (ptr3) /= [1,3])) call abort()
+    if (any (ptr3(-3,:)%ii /= [11,22,33])) call abort()
+  end subroutine sub
+end module m
+
+use m
+type(t), target :: x
+type(t), target :: y(3)
+x%ii = 43
+y(:)%ii = [11,22,33]
+call sub(x,y)
+end
--- /dev/null	2013-07-25 08:57:59.308780984 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_9.f90	2013-07-25 12:52:22.811020919 +0200
@@ -0,0 +1,36 @@ 
+! { dg-do run }
+!
+! PR fortran/57530
+!
+!
+! TYPE => CLASS pointer assignment for functions
+!
+module m
+  implicit none
+  type t
+    integer :: ii = 55
+  end type t
+contains
+  function f1()
+    class(t), pointer :: f1
+    allocate (f1)
+    f1%ii = 123
+  end function f1
+  function f2()
+    class(t), pointer :: f2(:)
+    allocate (f2(3))
+    f2(:)%ii = [-11,-22,-33]
+  end function f2
+end module m
+
+program test
+  use m
+  implicit none
+  type(t), pointer :: p1, p2(:),p3(:,:)
+  p1 => f1()
+  if (p1%ii /= 123) call abort ()
+  p2 => f2()
+  if (any (p2%ii /= [-11,-22,-33])) call abort ()
+  p3(2:2,1:3) => f2()
+  if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort ()
+end program test
--- /dev/null	2013-07-25 08:57:59.308780984 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_10.f90	2013-07-25 23:40:34.033925340 +0200
@@ -0,0 +1,36 @@ 
+! { dg-do run }
+!
+! PR fortran/57530
+!
+!
+! TYPE => TYPE pointer assignment for functions
+!
+module m
+  implicit none
+  type t
+    integer :: ii = 55
+  end type t
+contains
+  function f1()
+    type(t), pointer :: f1
+    allocate (f1)
+    f1%ii = 123
+  end function f1
+  function f2()
+    type(t), pointer :: f2(:)
+    allocate (f2(3))
+    f2(:)%ii = [-11,-22,-33]
+  end function f2
+end module m
+
+program test
+  use m
+  implicit none
+  type(t), pointer :: p1, p2(:), p3(:,:)
+  p1 => f1()
+  if (p1%ii /= 123) call abort ()
+  p2 => f2()
+  if (any (p2%ii /= [-11,-22,-33])) call abort ()
+  p3(2:2,1:3) => f2()
+  if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort ()
+end program test
--- /dev/null	2013-07-25 08:57:59.308780984 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_11.f90	2013-07-25 22:28:35.930346080 +0200
@@ -0,0 +1,51 @@ 
+! { dg-do run }
+!
+! PR fortran/57530
+!
+!
+! CLASS => CLASS pointer assignment for function results
+!
+module m
+  implicit none
+  type t
+    integer :: ii = 55
+  end type t
+  type, extends(t) :: t2
+  end type t2
+contains
+  function f1()
+    class(t), pointer :: f1
+    allocate (f1)
+    f1%ii = 123
+  end function f1
+  function f2()
+    class(t), pointer :: f2(:)
+    allocate (f2(3))
+    f2(:)%ii = [-11,-22,-33]
+  end function f2
+end module m
+
+program test
+  use m
+  implicit none
+  class(t), pointer :: p1, p2(:), p3(:,:)
+  type(t) :: my_t
+  type(t2) :: my_t2
+
+  allocate (t2 :: p1, p2(1), p3(1,1))
+  if (.not. same_type_as (p1, my_t2)) call abort()
+  if (.not. same_type_as (p2, my_t2)) call abort()
+  if (.not. same_type_as (p3, my_t2)) call abort()
+
+  p1 => f1()
+  if (p1%ii /= 123) call abort ()
+  if (.not. same_type_as (p1, my_t)) call abort()
+
+  p2 => f2()
+  if (any (p2%ii /= [-11,-22,-33])) call abort ()
+  if (.not. same_type_as (p2, my_t)) call abort()
+
+  p3(2:2,1:3) => f2()
+  if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort ()
+  if (.not. same_type_as (p3, my_t)) call abort()
+end program test