diff mbox

[fortran] PR50981 absent polymorphic scalar actual arguments

Message ID 4F382B16.7090005@sfr.fr
State New
Headers show

Commit Message

Mikael Morin Feb. 12, 2012, 9:11 p.m. UTC 
Hello,

this is the next PR50981 fix:
when passing polymorphic scalar actual arguments to elemental 
procedures, we were not adding the "_data" component reference.
The fix is straightforward; checking that the expression's type is 
BT_CLASS was introducing regressions, so this patch uses a helper 
function to check the type without impacting the testsuite.

Regression tested on x86_64-unknown-freebsd9.0. OK for trunk?

Mikael
2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>

	* trans-expr.c (is_class_container_ref): New function.
	(gfc_conv_procedure_call): Add a "_data" component reference to
	polymorphic actual arguments.
2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>

	* gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual
	argument checks.
--- elemental_optional_args_5.f03.old	2012-02-12 20:42:21.000000000 +0100
+++ elemental_optional_args_5.f03	2012-02-12 20:42:50.000000000 +0100
@@ -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)

Comments

Paul Richard Thomas Feb. 13, 2012, 10:38 p.m. UTC | #1 
Mikael,

This is OK for trunk with one proviso; could you move
is_class_container_ref to gfc_is_class_container_ref in class.c?

Thanks for the patch

Paul

On Sun, Feb 12, 2012 at 10:11 PM, Mikael Morin <mikael.morin@sfr.fr> wrote:
> Hello,
>
> this is the next PR50981 fix:
> when passing polymorphic scalar actual arguments to elemental procedures, we
> were not adding the "_data" component reference.
> The fix is straightforward; checking that the expression's type is BT_CLASS
> was introducing regressions, so this patch uses a helper function to check
> the type without impacting the testsuite.
>
> Regression tested on x86_64-unknown-freebsd9.0. OK for trunk?
>
> Mikael
>
>
Mikael Morin Feb. 27, 2012, 7:17 p.m. UTC | #2 
Hello, 

On Monday 13 February 2012 23:38:57 Paul Richard Thomas wrote:
> Mikael,
> 
> This is OK for trunk with one proviso; could you move
> is_class_container_ref to gfc_is_class_container_ref in class.c?
> 
> Thanks for the patch
> 
I have a small hardware issue (overheating) preventing me from bootstrapping 
and committing. I hoped to fix the problem within the next three days or so, 
but as the release candidate seems to come in that time frame, would someone 
mind doing it for me? Or should we delay to 4.8 now?

Thanks.

Mikael
diff mbox

Patch

diff --git a/trans-expr.c b/trans-expr.c
index 18ce1a7..ff4360e 100644
--- a/trans-expr.c
+++ b/trans-expr.c
@@ -3362,6 +3362,39 @@  conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 }
 
 
+/* 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.  */
+
+static bool
+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;
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -3542,6 +3575,9 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
 
+	  if (fsym && fsym->ts.type == BT_DERIVED && 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