From 14957629ce851d15710486d4a0bd02a74e13df03 Mon Sep 17 00:00:00 2001 From: mikael Date: Sun, 12 Feb 2012 15:46:14 +0000 Subject: [PATCH] gcc/fortran/ PR fortran/50981 * trans-stmt.c (gfc_get_proc_ifc_for_call): New function. (gfc_trans_call): Use gfc_get_proc_ifc_for_call. gcc/testsuite/ PR fortran/50981 * gfortran.dg/elemental_optional_args_5.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@184142 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/trans-stmt.c | 23 +++++- gcc/testsuite/ChangeLog | 7 +- .../gfortran.dg/elemental_optional_args_5.f03 | 86 ++++++++++++++++++++++ 4 files changed, 120 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 19db403dbf9..defca3f3512 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,11 @@ 2012-02-12 Mikael Morin + PR fortran/50981 + * trans-stmt.c (gfc_get_proc_ifc_for_call): New function. + (gfc_trans_call): Use gfc_get_proc_ifc_for_call. + +2012-02-12 Mikael Morin + * trans-array.c (gfc_walk_elemental_function_args, gfc_walk_function_expr): Move call to gfc_get_proc_ifc_for_expr out of gfc_walk_elemental_function_args. diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index bad0459d3e1..bb3a89084e0 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -348,6 +348,27 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, } +/* Get the interface symbol for the procedure corresponding to the given call. + We can't get the procedure symbol directly as we have to handle the case + of (deferred) type-bound procedures. */ + +static gfc_symbol * +get_proc_ifc_for_call (gfc_code *c) +{ + gfc_symbol *sym; + + gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL); + + sym = gfc_get_proc_ifc_for_expr (c->expr1); + + /* Fall back/last resort try. */ + if (sym == NULL) + sym = c->resolved_sym; + + return sym; +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree @@ -372,7 +393,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) ss = gfc_walk_elemental_function_args (ss, code->ext.actual, - gfc_get_proc_ifc_for_expr (code->expr1), + get_proc_ifc_for_call (code), GFC_SS_REFERENCE); /* Is not an elemental subroutine call with array valued arguments. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 348bb677ead..66abdd03564 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,9 @@ -2012-02012 Iain Sandoe +2012-02-12 Mikael Morin + + PR fortran/50981 + * gfortran.dg/elemental_optional_args_5.f03: New test. + +2012-02-12 Iain Sandoe PR testsuite/50076 * c-c++-common/cxxbitfields-3.c: Adjust scan assembler for nonpic diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 b/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 new file mode 100644 index 00000000000..70a27d80cde --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 @@ -0,0 +1,86 @@ +! { dg-do run } +! +! PR fortran/50981 +! Test the handling of optional, polymorphic and non-polymorphic arguments +! to elemental procedures. +! +! Original testcase by Tobias Burnus + +implicit none +type t + integer :: a +end type t + +type t2 + integer, allocatable :: a + integer, allocatable :: a2(:) + integer, pointer :: p => null() + integer, pointer :: p2(:) => null() +end type t2 + +type(t), allocatable :: ta, taa(:) +type(t), pointer :: tp, tpa(:) +class(t), allocatable :: ca, caa(:) +class(t), pointer :: cp, cpa(:) + +type(t2) :: x + +integer :: s, v(2) + +tp => null() +tpa => null() +cp => null() +cpa => null() + +! =============== sub1 ================== +! SCALAR COMPONENTS: Non alloc/assoc + +s = 3 +v = [9, 33] + +call sub1 (s, x%a, .false.) +call sub1 (v, x%a, .false.) +!print *, s, v +if (s /= 3) call abort() +if (any (v /= [9, 33])) call abort() + +call sub1 (s, x%p, .false.) +call sub1 (v, x%p, .false.) +!print *, s, v +if (s /= 3) call abort() +if (any (v /= [9, 33])) call abort() + + +! SCALAR COMPONENTS: alloc/assoc + +allocate (x%a, x%p) +x%a = 4 +x%p = 5 +call sub1 (s, x%a, .true.) +call sub1 (v, x%a, .true.) +!print *, s, v +if (s /= 4*2) call abort() +if (any (v /= [4*2, 4*2])) call abort() + +call sub1 (s, x%p, .true.) +call sub1 (v, x%p, .true.) +!print *, s, v +if (s /= 5*2) call abort() +if (any (v /= [5*2, 5*2])) call abort() + + + +contains + + elemental subroutine sub1 (x, y, alloc) + integer, intent(inout) :: x + integer, intent(in), optional :: y + logical, intent(in) :: alloc + if (alloc .neqv. present (y)) & + x = -99 + if (present(y)) & + x = y*2 + end subroutine sub1 + +end + -- 2.11.0