Patchwork [fortran] Fix scalarization of overridable typebound elemental procedures.

login
register
mail settings
Submitter Paul Richard Thomas
Date Dec. 14, 2011, 9:17 p.m.
Message ID <CAGkQGiKh8NamU=XPLizUhBy69RcRbkn+r5Y7FErModERMQQFbQ@mail.gmail.com>
Download mbox | patch
Permalink /patch/131480/
State New
Headers show

Comments

Paul Richard Thomas - Dec. 14, 2011, 9:17 p.m.
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.
Steve Kargl - Dec. 14, 2011, 9:25 p.m.
On Wed, Dec 14, 2011 at 10:17:11PM +0100, Paul Richard Thomas wrote:
> 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?
> 

OK

Patch

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" } }