Hello all, The attached fixes the above regression. I would have pushed it as obvious were it not for my decision to warn for index expressions containing functions not declared to be pure. If the warning is thought to be OTT, I can remove it.
Also, note the pointer assignment at the end, which demonstrates that this regression is not specific to the associate statement but to pointer expressions in general. Regtests with FC43/x86_64 - OK for all the affected branches? Cheers Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 70cea46c6b0..81bc1d35e07 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3974,6 +3974,28 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
}
+/* Helper functions to detect impure functions in an expression. */
+
+static const char *impure_name = NULL;
+static bool
+expr_contains_impure_fcn (gfc_expr *e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* g ATTRIBUTE_UNUSED)
+{
+ if (e && e->expr_type == EXPR_FUNCTION
+ && !gfc_pure_function (e, &impure_name))
+ return true;
+
+ return false;
+}
+
+static bool
+gfc_expr_contains_impure_fcn (gfc_expr *e)
+{
+ impure_name = NULL;
+ return gfc_traverse_expr (e, NULL, &expr_contains_impure_fcn, 0);
+}
+
+
/* Generate code for bounds checking for elemental dimensions. */
static void
@@ -3996,10 +4018,16 @@ array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
{
if (ar->dimen_type[dim] == DIMEN_ELEMENT)
{
+ if (gfc_expr_contains_impure_fcn (ar->start[dim]))
+ gfc_warning_now (0, "Bounds checking of the elemental "
+ "index at %L will cause two calls to "
+ "%qs, which is not declared PURE",
+ &ar->start[dim]->where, impure_name);
gfc_se indexse;
gfc_init_se (&indexse, NULL);
gfc_conv_expr_type (&indexse, ar->start[dim],
gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &indexse.pre);
trans_array_bound_check (se, ss, indexse.expr, dim,
&ar->where,
ar->as->type != AS_ASSUMED_SIZE
diff --git a/gcc/testsuite/gfortran.dg/pr119273.f90 b/gcc/testsuite/gfortran.dg/pr119273.f90
new file mode 100644
index 00000000000..4ba437f9af9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119273.f90
@@ -0,0 +1,65 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcheck=bounds" }
+!
+! Test the fix forPR119273, which caused false bounds check errors.
+!
+! Contributed by Jingwei Xing <[email protected]>
+!
+module test_module
+ type :: test_type_father
+ integer :: val
+ contains
+ procedure :: test_function3
+ end type test_type_father
+
+ type, extends(test_type_father) :: test_type_child
+ contains
+ procedure :: test_function1
+ end type test_type_child
+
+ contains
+ function test_function1(a) result(out)
+ class(test_type_child), intent(in) :: a
+ integer :: out
+ out = a%val
+ end function
+ pure function test_function2(a) result(out)
+ type(test_type_child), intent(in) :: a
+ integer :: out
+ out = a%val
+ end function
+ pure function test_function3(a) result(out)
+ class(test_type_father), intent(in) :: a
+ integer :: out
+ out = a%val
+ end function
+end module
+
+program test
+ use test_module
+ implicit none
+ type(test_type_child) :: a
+ type(test_type_father) :: b
+ class(test_type_child), allocatable :: c
+ integer, target :: temp_int(1,1)
+ integer, pointer :: d(:)
+ a%val = 0
+ associate(temp => temp_int(:,a%test_function1() + 1)) ! { dg-warning "which is not declared PURE" }
+ end associate
+ a%val = 1
+ associate(temp => temp_int(:,test_function2(a)))
+ end associate
+ b%val = 1
+ associate(temp => temp_int(:,b%test_function3()))
+ end associate
+ associate(temp => temp_int(:,test_function3(b)))
+ end associate
+ allocate (c, source = a)
+ associate(temp => temp_int(:,c%test_function1())) ! { dg-warning "which is not declared PURE" }
+ end associate
+! Demonstrate that this bug was not specific to the ASSOCIATE statement but,
+! rather to it being a pointer assignment, when the selector is a variable.
+ d => temp_int(:,a%test_function1()) ! { dg-warning "which is not declared PURE" }
+end program test
+! Test for the missing vptr assignments to the class actual temporaries.
+! { dg-final { scan-tree-dump-times "class..._vptr =" 8 "original" } }
