This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] Fix scalarization of overridable typebound elemental procedures.
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Cc: Jakub Jelinek <jakub at redhat dot com>, Tobias Burnus <burnus at net-b dot de>
- Date: Wed, 14 Dec 2011 22:17:11 +0100
- Subject: [Patch, fortran] Fix scalarization of overridable typebound elemental procedures.
Dear All,
This patch combines the trivial correction of an error in
trans-decl.c, spotted by Jakub (thanks!), with a trivial fix for the
scalarization of elemental typebound procedures. Neither needs
explanation!
Boostrapped and regtested on x86_64/FC9 - OK for trunk?
Cheers
Paul
2011-12-14 Paul Thomas <pault@gcc.gnu.org>
* trans-expr.c (gfc_walk_function_expr): Detect elemental
procedure components as well as elemental procedures.
* trans-array.c (gfc_conv_procedure_call): Ditto.
* trans-decl.c (gfc_trans_deferred_vars): Correct erroneous
'break' for class pointers to 'continue'.
2011-12-14 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/class_array_3.f03: Remove explicit indexing of
A%disp() to use scalarizer.
* gfortran.dg/class_array_9.f03: New.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 182210)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
*** 8358,8364 ****
sym = expr->value.function.esym;
if (!sym)
! sym = expr->symtree->n.sym;
/* A function that returns arrays. */
gfc_is_proc_ptr_comp (expr, &comp);
--- 8358,8364 ----
sym = expr->value.function.esym;
if (!sym)
! sym = expr->symtree->n.sym;
/* A function that returns arrays. */
gfc_is_proc_ptr_comp (expr, &comp);
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
*** 8368,8374 ****
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
! if (sym->attr.elemental)
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
GFC_SS_REFERENCE);
--- 8368,8374 ----
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
! if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
GFC_SS_REFERENCE);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 182210)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3115,3121 ****
if (se->ss != NULL)
{
! if (!sym->attr.elemental)
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
--- 3115,3121 ----
if (se->ss != NULL)
{
! if (!sym->attr.elemental && !(comp && comp->attr.elemental))
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 182210)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3670,3676 ****
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.pointer))
! break;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
--- 3670,3676 ----
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.pointer))
! continue;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
Index: gcc/testsuite/gfortran.dg/class_array_9.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_9.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/class_array_9.f03 (revision 0)
***************
*** 0 ****
--- 1,46 ----
+ ! { dg-do run }
+ ! Test typebound elemental functions on class arrays
+ !
+ module m
+ type :: t1
+ integer :: i
+ contains
+ procedure, pass :: disp => disp_t1
+ end type t1
+
+ type, extends(t1) :: t2
+ real :: r
+ contains
+ procedure, pass :: disp => disp_t2
+ end type t2
+
+ contains
+ integer elemental function disp_t1 (q)
+ class(t1), intent(in) :: q
+ disp_t1 = q%i
+ end function
+
+ integer elemental function disp_t2 (q)
+ class(t2), intent(in) :: q
+ disp_t2 = int (q%r)
+ end function
+ end module
+
+ use m
+ class(t1), allocatable :: x(:)
+ allocate (x(4), source = [(t1 (i), i=1,4)])
+ if (any (x%disp () .ne. [1,2,3,4])) call abort
+ if (any (x(2:3)%disp () .ne. [2,3])) call abort
+ if (any (x(4:3:-1)%disp () .ne. [4,3])) call abort
+ if (x(4)%disp () .ne. 4) call abort
+
+ deallocate (x)
+ allocate (x(4), source = [(t2 (2 * i, real (i) + 0.333), i=1,4)])
+ if (any (x%disp () .ne. [1,2,3,4])) call abort
+ if (any (x(2:3)%disp () .ne. [2,3])) call abort
+ if (any (x(4:3:-1)%disp () .ne. [4,3])) call abort
+ if (x(4)%disp () .ne. 4) call abort
+
+ end
+
+ ! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/class_array_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_3.f03 (revision 182210)
--- gcc/testsuite/gfortran.dg/class_array_3.f03 (working copy)
*************** contains
*** 124,130 ****
cmp = .false.
end if
class default
! ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
--- 124,130 ----
cmp = .false.
end if
class default
! ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
*************** program main
*** 134,143 ****
class(sort_t), allocatable :: A(:)
integer :: i, m(5)= [7 , 4, 5, 2, 3]
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
! ! print *, "Before qsort: ", (A(i)%disp(), i = 1, size(a,1))
call qsort(A)
! ! print *, "After qsort: ", (A(i)%disp(), i = 1, size(a,1))
! if (any ([(A(i)%disp(), i = 1, size(a,1))] .ne. [2,3,4,5,7])) call abort
end program main
! { dg-final { cleanup-modules "m_qsort test" } }
--- 134,143 ----
class(sort_t), allocatable :: A(:)
integer :: i, m(5)= [7 , 4, 5, 2, 3]
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
! ! print *, "Before qsort: ", A%disp()
call qsort(A)
! ! print *, "After qsort: ", A%disp()
! if (any (A%disp() .ne. [2,3,4,5,7])) call abort
end program main
! { dg-final { cleanup-modules "m_qsort test" } }