[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction actual_array_offset_1.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:098eab32781a92843d5485e9b8a25b440fef8ddf

commit 098eab32781a92843d5485e9b8a25b440fef8ddf
Author: Mikael Morin <mik...@gcc.gnu.org>
Date:   Fri Mar 7 13:24:23 2025 +0100

    Correction actual_array_offset_1.f90

Diff:
---
 gcc/fortran/trans-array.cc | 75 +++++++++++++++++++++++++++++++++++-----------
 1 file changed, 57 insertions(+), 18 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 480df9829dec..b8fc0c4bea3e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5692,6 +5692,35 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, 
bool subscript,
 }
 
 
+/* A simple reference can be accessed with a pointer and
+   a constant offset.  */
+bool
+simple_reference_p (tree data_ref)
+{
+  bool seen_dereference = false;
+  while (true)
+    {
+      if (DECL_P (data_ref))
+       return true;
+
+      if (TREE_CODE (data_ref) == INDIRECT_REF)
+       {
+         if (seen_dereference)
+           return false;
+
+         seen_dereference = true;
+         data_ref = TREE_OPERAND (data_ref, 0);
+       }
+      else if (TREE_CODE (data_ref) == COMPONENT_REF)
+       data_ref = TREE_OPERAND (data_ref, 0);
+      else if (TREE_CODE (data_ref) == NOP_EXPR)
+       data_ref = TREE_OPERAND (data_ref, 0);
+      else
+       return false;
+    }
+}
+
+
 /* Translate expressions for the descriptor and data pointer of a SS.  */
 /*GCC ARRAYS*/
 
@@ -5712,24 +5741,34 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * 
ss, int base)
   se.descriptor_only = 1;
   gfc_conv_expr_lhs (&se, ss_info->expr);
   gfc_add_block_to_block (block, &se.pre);
-  info->descriptor = se.expr;
-  if (TREE_CODE (info->descriptor) == INDIRECT_REF)
-    {
-      tree ptr = TREE_OPERAND (info->descriptor, 0);
-      ptr = gfc_evaluate_now (ptr, block);
-      TREE_OPERAND (info->descriptor, 0) = ptr;
-    }
-  else if (TREE_CODE (info->descriptor) == COMPONENT_REF)
-    {
-      tree parent_ref = TREE_OPERAND (info->descriptor, 0);
-      tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref));
-      tree ptr = fold_build1_loc (input_location, ADDR_EXPR,
-                                 parent_ptr_type, parent_ref);
-      ptr = gfc_evaluate_now (ptr, block);
-      tree deref = fold_build1_loc (input_location, INDIRECT_REF,
-                                   TREE_TYPE (parent_ref),
-                                   ptr);
-      TREE_OPERAND (info->descriptor, 0) = deref;
+  if (simple_reference_p (se.expr))
+    info->descriptor = se.expr;
+  else
+    {
+      tree desc = se.expr;
+      STRIP_NOPS (desc);
+      if (TREE_CODE (desc) == INDIRECT_REF)
+       {
+         tree ptr = TREE_OPERAND (desc, 0);
+         ptr = gfc_evaluate_now (ptr, block);
+         TREE_OPERAND (desc, 0) = ptr;
+         info->descriptor = se.expr;
+       }
+      else if (TREE_CODE (desc) == COMPONENT_REF)
+       {
+         tree parent_ref = TREE_OPERAND (desc, 0);
+         tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref));
+         tree ptr = fold_build1_loc (input_location, ADDR_EXPR,
+                                     parent_ptr_type, parent_ref);
+         ptr = gfc_evaluate_now (ptr, block);
+         tree deref = fold_build1_loc (input_location, INDIRECT_REF,
+                                       TREE_TYPE (parent_ref),
+                                       ptr);
+         TREE_OPERAND (desc, 0) = deref;
+         info->descriptor = se.expr;
+       }
+      else
+       info->descriptor = gfc_evaluate_now (se.expr, block);
     }
   ss_info->string_length = se.string_length;
   ss_info->class_container = se.class_container;