Re: [Patch, fortran] PR119273 - [14/15/16 Regression] subclass can not correctly access to superclass in associate statement

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 70cea46c6b0..a2da4fe7c7d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3974,6 +3974,29 @@ 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)
+      && !gfc_implicit_pure_function (e))
+    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 +4019,17 @@ 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 to be "
+					 "PURE or is not implicitly 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..212754ae0f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119273.f90
@@ -0,0 +1,70 @@
+! { 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
+
+    integer :: ii
+
+    contains
+    function test_function1(a) result(out)
+        class(test_type_child), intent(in) :: a
+        integer :: out
+        ii = a%val  ! Make this function implicitly impure.
+        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 "is not implicitly 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 "is not implicitly 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 "is not implicitly 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" } }