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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 005c9bcf4f129335ce1d0596e87994b85328a108..8e345264ba1574d1ff4f23bdc1a7228932825112 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+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

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index bfa8740288a6d6c3731fdb7c144302b83e0e53b4..a27513646c96f6d0569f02e0c7b3f1f8dc823f53 100644 (file)
--- a/gcc/fortran/class.c
+++ b/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.  */

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a36e1068466b19b5eb7d6e37910d9336a7bff279..d764b62b7294330d21df95972634e78a3f2b5428 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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 *,

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 83e3c9c86854515f17b99c4b6b162a554a199f73..036b55bdf9673148a2a6ed62469809bedb0b75ad 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c98c6c13acb9581fbed867cd5dca70f5ece93dd3..fc4158423c4cc3211d179b36dd1fceacc9de4a14 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 b/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03
index 74c1fa04f42cfb2daa69f3aad8026b60685d2d1e..e0ed0c20d5e841d0a75c2301e9477580202e9e1c 100644 (file)
--- a/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03
+++ b/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)