This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR57530 (Part 2 of 3) Support TYPE => CLASS
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Fri, 26 Jul 2013 00:13:51 +0200
- Subject: [Patch, Fortran] PR57530 (Part 2 of 3) Support TYPE => CLASS
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.
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