===================================================================
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
sym = expr->value.function.esym;
if (!sym)
! sym = expr->symtree->n.sym;
/* A function that returns arrays. */
gfc_is_proc_ptr_comp (expr, &comp);
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
/* 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);
/* 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);
===================================================================
*************** gfc_conv_procedure_call (gfc_se * se, gf
if (se->ss != NULL)
{
! if (!sym->attr.elemental)
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
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)
===================================================================
*************** gfc_trans_deferred_vars (gfc_symbol * pr
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
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
===================================================================
***************
+ ! { 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" } }
===================================================================
*************** contains
cmp = .false.
end if
class default
! ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
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
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" } }
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" } }