re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)

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.

From-SVN: r184142

4 files changed, 120 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 19db403..defca3f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2012-02-12  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-12  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.
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index bad0459..bb3a890 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 348bb67..66abdd0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,9 @@
-2012-02012 Iain Sandoe  <iains@gcc.gnu.org>
+2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* gfortran.dg/elemental_optional_args_5.f03: New test.
+
+2012-02-12 Iain Sandoe  <iains@gcc.gnu.org>
 
 	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 0000000..70a27d8
--- /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 <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
+