FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/57530 ([OOP] Wrongly rejects type_pointer => class_target (which have identical declared type))

Browse source 
2013-07-30  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-30  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.

From-SVN: r201328
This commit is contained in:
Tobias Burnus 2013-07-30 09:18:54 +02:00 • committed by Tobias Burnus
parent 14a8763670
commit b882aaa84d
7 changed files with 281 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View file

@ -1,3 +1,11 @@
2013-07-30 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-22 Po Chang <pchang9@cs.wisc.edu>
* match.c (gfc_match_call): Exit loop after setting i.

103
gcc/fortran/trans-expr.c
View file

@ -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,15 @@ 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);
/* 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;
}
if (scalar)
{
/* Scalar pointers. */
@ -6485,8 +6496,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0));
}
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
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 +6522,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 +6544,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 +6612,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 +6650,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);

8
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,11 @@
2013-07-30 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.
2013-07-30 Zhenqiang Chen <zhenqiang.chen@linaro.org>
* gcc.target/arm/pr57637.c: New testcase.

36
gcc/testsuite/gfortran.dg/pointer_assign_10.f90 Normal file
View file

@ -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

51
gcc/testsuite/gfortran.dg/pointer_assign_11.f90 Normal file
View file

@ -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

46
gcc/testsuite/gfortran.dg/pointer_assign_8.f90 Normal file
View file

@ -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

36
gcc/testsuite/gfortran.dg/pointer_assign_9.f90 Normal file
View file

@ -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