From 8b59af5c6af6e67e151b72e48074f58b677b2e42 Mon Sep 17 00:00:00 2001
From: Mikael Morin <mikael@gcc.gnu.org>
Date: Sun, 4 Mar 2012 21:05:32 +0000
Subject: [PATCH] re PR fortran/50981 ([OOP] Wrong-code for scalarizing
ELEMENTAL call with absent OPTIONAL argument)
fortran/
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.
testsuite/
PR fortran/50981
* gfortran.dg/elemental_optional_args_5.f03: Add array checks.
From-SVN: r184896
---
gcc/fortran/ChangeLog | 6 ++
gcc/fortran/trans-expr.c | 31 ++++++++++-
gcc/testsuite/ChangeLog | 5 ++
.../gfortran.dg/elemental_optional_args_5.f03 | 55 +++++++++++++++++++
4 files changed, 95 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 961bd4e18f29..005c9bcf4f12 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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.
+
2012-03-04 Mikael Morin <mikael@gcc.gnu.org>
* trans.h (struct gfc_ss_info): Move can_be_null_ref component from
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5fb95b176532..83e3c9c86854 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3522,12 +3522,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else if (se->ss && se->ss->info->useflags)
{
+ gfc_ss *ss;
+
+ ss = se->ss;
+
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
parm_kind = ELEMENTAL;
- if (se->ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
- && se->ss->info->data.array.ref == NULL)
+ if (ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
+ && ss->info->data.array.ref == NULL)
{
gfc_conv_tmp_array_ref (&parmse);
if (e->ts.type == BT_CHARACTER)
@@ -3538,6 +3542,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
gfc_conv_expr_reference (&parmse, e);
+ /* 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
+ scalarization which passes arrays elements to the procedure,
+ ignoring the fact that the array can be absent/unallocated/... */
+ if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
+ {
+ tree descriptor_data;
+
+ descriptor_data = ss->info->data.array.data;
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ descriptor_data,
+ fold_convert (TREE_TYPE (descriptor_data),
+ null_pointer_node));
+ parmse.expr
+ = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse.expr),
+ gfc_unlikely (tmp),
+ fold_convert (TREE_TYPE (parmse.expr),
+ null_pointer_node),
+ parmse.expr);
+ }
+
/* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 826f0f007f96..80ce63f02587 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-03-04 Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/50981
+ * gfortran.dg/elemental_optional_args_5.f03: Add array checks.
+
2012-03-04 Georg-Johann Lay <avr@gjlay.de>
* gcc.dg/torture/pr52402.c: Add dg-require-effective-target
diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03 b/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03
index 70a27d80cdee..74c1fa04f42c 100644
--- a/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03
+++ b/gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03
@@ -69,6 +69,51 @@ if (s /= 5*2) call abort()
if (any (v /= [5*2, 5*2])) call abort()
+! ARRAY COMPONENTS: Non alloc/assoc
+
+v = [9, 33]
+
+call sub1 (v, x%a2, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+call sub1 (v, x%p2, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+
+! ARRAY COMPONENTS: alloc/assoc
+
+allocate (x%a2(2), x%p2(2))
+x%a2(:) = [84, 82]
+x%p2 = [35, 58]
+
+call sub1 (v, x%a2, .true.)
+!print *, v
+if (any (v /= [84*2, 82*2])) call abort()
+
+call sub1 (v, x%p2, .true.)
+!print *, v
+if (any (v /= [35*2, 58*2])) call abort()
+
+
+! =============== sub_t ==================
+! SCALAR DT: Non alloc/assoc
+
+s = 3
+v = [9, 33]
+
+call sub_t (s, ta, .false.)
+call sub_t (v, ta, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (s, tp, .false.)
+call sub_t (v, tp, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
contains
@@ -82,5 +127,15 @@ contains
x = y*2
end subroutine sub1
+ elemental subroutine sub_t(x, y, alloc)
+ integer, intent(inout) :: x
+ type(t), intent(in), optional :: y
+ logical, intent(in) :: alloc
+ if (alloc .neqv. present (y)) &
+ x = -99
+ if (present(y)) &
+ x = y%a*2
+ end subroutine sub_t
+
end
--
GitLab