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

fortran/
	PR fortran/50981
	* gfortran.h (gfc_is_class_container_ref): New prototype.
	* class.c (gfc_is_class_container_ref): New function.
	* trans-expr.c (gfc_conv_procedure_call): Add a "_data" component
	reference to polymorphic actual arguments.

testsuite/
	PR fortran/50981
	* gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual
	argument checks.

From-SVN: r184904

gcc/fortran/ChangeLog

 2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/50981
+	* gfortran.h (gfc_is_class_container_ref): New prototype.
+	* class.c (gfc_is_class_container_ref): New function.
+	* trans-expr.c (gfc_conv_procedure_call): Add a "_data" component
+	reference to polymorphic actual arguments.
+
+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
 	* trans-expr.c (gfc_conv_procedure_call): Save se->ss's value. 
 	Handle the case of unallocated arrays passed to elemental procedures.
 

gcc/fortran/class.c

@@ -361,6 +361,39 @@ gfc_is_class_scalar_expr (gfc_expr *e)
 }
 
 
+/* Tells whether the expression E is a reference to a (scalar) class container.
+   Scalar because array class containers usually have an array reference after
+   them, and gfc_fix_class_refs will add the missing "_data" component reference
+   in that case.  */
+
+bool
+gfc_is_class_container_ref (gfc_expr *e)
+{
+  gfc_ref *ref;
+  bool result;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return e->ts.type == BT_CLASS;
+
+  if (e->symtree->n.sym->ts.type == BT_CLASS)
+    result = true;
+  else
+    result = false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type != REF_COMPONENT)
+	result = false;
+      else if (ref->u.c.component->ts.type == BT_CLASS)
+	result = true; 
+      else
+	result = false;
+    }
+
+  return result;
+}
+
+
 /* Build a NULL initializer for CLASS pointers,
    initializing the _data component to NULL and
    the _vptr component to the declared type.  */

gcc/fortran/gfortran.h

@@ -2930,6 +2930,7 @@ void gfc_add_class_array_ref (gfc_expr *);
 #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
 bool gfc_is_class_array_ref (gfc_expr *, bool *);
 bool gfc_is_class_scalar_expr (gfc_expr *);
+bool gfc_is_class_container_ref (gfc_expr *e);
 gfc_expr *gfc_class_null_initializer (gfc_typespec *);
 unsigned int gfc_hash_value (gfc_symbol *);
 gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,

gcc/fortran/trans-expr.c

@@ -3542,6 +3542,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
 
+	  if (fsym && fsym->ts.type == BT_DERIVED
+	      && gfc_is_class_container_ref (e))
+	    parmse.expr = gfc_class_data_get (parmse.expr);
+
 	  /* If we are passing an absent array as optional dummy to an
 	     elemental procedure, make sure that we pass NULL when the data
 	     pointer is NULL.  We need this extra conditional because of

gcc/testsuite/ChangeLog

+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual
+	argument checks.
+
 2012-03-04  H.J. Lu  <hongjiu.lu@intel.com>
 
 	PR target/52146

gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03

@@ -115,6 +115,111 @@ call sub_t (v, tp, .false.)
 if (s /= 3) call abort()
 if (any (v /= [9, 33])) call abort()
 
+call sub_t (s, ca, .false.)
+call sub_t (v, ca, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (s, cp, .false.)
+call sub_t (v, cp, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
+
+! SCALAR COMPONENTS: alloc/assoc
+
+allocate (ta, tp, ca, cp)
+ta%a = 4
+tp%a = 5
+ca%a = 6
+cp%a = 7
+
+call sub_t (s, ta, .true.)
+call sub_t (v, ta, .true.)
+!print *, s, v
+if (s /= 4*2) call abort()
+if (any (v /= [4*2, 4*2])) call abort()
+
+call sub_t (s, tp, .true.)
+call sub_t (v, tp, .true.)
+!print *, s, v
+if (s /= 5*2) call abort()
+if (any (v /= [5*2, 5*2])) call abort()
+
+call sub_t (s, ca, .true.)
+call sub_t (v, ca, .true.)
+!print *, s, v
+if (s /= 6*2) call abort()
+if (any (v /= [6*2, 6*2])) call abort()
+
+call sub_t (s, cp, .true.)
+call sub_t (v, cp, .true.)
+!print *, s, v
+if (s /= 7*2) call abort()
+if (any (v /= [7*2, 7*2])) call abort()
+
+! ARRAY COMPONENTS: Non alloc/assoc
+
+v = [9, 33]
+
+call sub_t (v, taa, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (v, tpa, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (v, caa, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (v, cpa, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+deallocate(ta, tp, ca, cp)
+
+
+! ARRAY COMPONENTS: alloc/assoc
+
+allocate (taa(2), tpa(2))
+taa(1:2)%a = [44, 444]
+tpa(1:2)%a = [55, 555]
+allocate (caa(2), source=[t(66), t(666)])
+allocate (cpa(2), source=[t(77), t(777)])
+
+select type (caa)
+type is (t)
+  if (any (caa(:)%a /= [66, 666])) call abort()
+end select
+
+select type (cpa)
+type is (t)
+  if (any (cpa(:)%a /= [77, 777])) call abort()
+end select
+
+call sub_t (v, taa, .true.)
+!print *, v
+if (any (v /= [44*2, 444*2])) call abort()
+
+call sub_t (v, tpa, .true.)
+!print *, v
+if (any (v /= [55*2, 555*2])) call abort()
+
+
+call sub_t (v, caa, .true.)
+!print *, v
+if (any (v /= [66*2, 666*2])) call abort()
+
+call sub_t (v, cpa, .true.)
+!print *, v
+if (any (v /= [77*2, 777*2])) call abort()
+
+deallocate (taa, tpa, caa, cpa)
+
+
 contains
 
   elemental subroutine sub1 (x, y, alloc)