From 5bf5fa563aea3f8763d2c49d53bf8a0d8c1bc7c2 Mon Sep 17 00:00:00 2001
From: Mikael Morin <mikael@gcc.gnu.org>
Date: Sun, 4 Mar 2012 21:50:08 +0000
Subject: [PATCH] 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 | 8 ++
gcc/fortran/class.c | 33 ++++++
gcc/fortran/gfortran.h | 1 +
gcc/fortran/trans-expr.c | 4 +
gcc/testsuite/ChangeLog | 6 +
.../gfortran.dg/elemental_optional_args_5.f03 | 105 ++++++++++++++++++
6 files changed, 157 insertions(+)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 005c9bcf4f12..8e345264ba15 100644
--- 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 bfa8740288a6..a27513646c96 100644
--- 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 a36e1068466b..d764b62b7294 100644
--- 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 83e3c9c86854..036b55bdf967 100644
--- 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 c98c6c13acb9..fc4158423c4c 100644
--- 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 74c1fa04f42c..e0ed0c20d5e8 100644
--- 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)
--
GitLab