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 <pa...@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 <pa...@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" } }