@@ -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. */
Hello, this fixes the fairly recent PR50981 patch [http://gcc.gnu.org/ml/fortran/2011-12/msg00170.html] which didn't work for subroutine calls, as they use code->resolved_sym instead of code->expr1 to store the procedure symbol. The first patch moves gfc_walk_elemental_function_args's code to get the procedure interface into a new procedure. The second patch moves the procedure call out of gfc_walk_elemental_function_args. The third patch changes the function called in gfc_trans_call so that code->resolved_sym is used if code->expr1 fails to give the interface. I choose to try code->expr1 first for fear that in typebound calls, code->resolved_sym may point to the base object, which is obviously not the procedure interface. The testcase is Tobias' comment #13 [http://gcc.gnu.org/bugzilla/show_bug.cgi?id=50981#c13] stripped down to the working part. Regression tested on x86_64-unknown-freebsd9.0. OK for trunk? Mikael 2012-02-07 Mikael Morin <mikael@gcc.gnu.org> * trans-array.c (gfc_get_proc_ifc_for_expr): New function. (gfc_walk_elemental_function_args): Move code to gfc_get_proc_ifc_for_expr and call it. 2012-02-07 Mikael Morin <mikael@gcc.gnu.org> * 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. * trans-stmt.c (gfc_trans_call): Ditto. * trans-array.h (gfc_get_proc_ifc_for_expr): New prototype. (gfc_walk_elemental_function_args): Update prototype. 2012-02-07 Mikael Morin <mikael@gcc.gnu.org> 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-07 Mikael Morin <mikael@gcc.gnu.org> PR fortran/50981 * gfortran.dg/elemental_optional_args_5.f90: New test. ! { dg-do run } ! ! PR fortran/50981 ! Test the handling of optional, polymorphic and non-polymorphic arguments ! to elemental procedures. ! ! Original testcase by Tobias Burnus <burnus@net-b.de> 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