[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction partielle régression reduce_1

[Mikael Morin]

https://gcc.gnu.org/g:7631c35989bd70dc13dbd1d0f645a839a17d9248

commit 7631c35989bd70dc13dbd1d0f645a839a17d9248
Author: Mikael Morin <mikael@gcc.gnu.org>
Date:   Mon Jun 9 11:07:30 2025 +0200

    Correction partielle régression reduce_1

Diff:
---
 libgfortran/intrinsics/reduce.c | 59 ++++++++++++++++++++++++++---------------
 1 file changed, 38 insertions(+), 21 deletions(-)

diff --git a/libgfortran/intrinsics/reduce.c b/libgfortran/intrinsics/reduce.c
index 8e1ab3b8c2f7..de0c264323d4 100644
--- a/libgfortran/intrinsics/reduce.c
+++ b/libgfortran/intrinsics/reduce.c
@@ -50,11 +50,12 @@ reduce (parray *ret,
   void *buffer;
   void *res;
   index_type ext0, ext1, ext2;
-  index_type spc0, spc1, spc2;
+  index_type aspc0, aspc1, aspc2;
+  index_type rspc0, rspc2;
+  index_type mspc0, mspc1, mspc2;
   index_type idx0, idx1, idx2;
-  index_type dimen, dimen_m1, off, ext, spc;
+  index_type dimen, dimen_m1, moff, ext, spc;
   bool started;
-  bool masked = false;
   bool dim_present = dim != NULL;
   bool mask_present = mask != NULL;
   bool identity_present = identity != NULL;
@@ -95,18 +96,20 @@ reduce (parray *ret,
      painless by the use of pointer arithmetic throughout (except for MASK,
      whose type is known.  */
   ext0 = ext1 = ext2 = 1;
-  spc0 = spc1 = spc2 = elem_len;
+  aspc0 = aspc1 = aspc2 = elem_len;
+  rspc0 = rspc2 = elem_len;
+  mspc0 = mspc1 = mspc2 = sizeof (GFC_LOGICAL_4);
 
   scalar_result = (!dim_present && array_rank > 1) || array_rank == 1;
 
+  spc = elem_len;
   j = 0;
   for (i = 0; i < array_rank; i++)
     {
       /* Obtain the shape of the reshaped ARRAY.  */
       ext = GFC_DESCRIPTOR_EXTENT (array,i);
-      spc = GFC_DESCRIPTOR_SPACING (array,i);
 
-      if (masked && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
+      if (mask_present && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
 	{
 	  int mext = (int)GFC_DESCRIPTOR_EXTENT (mask, i);
 	  runtime_error ("shape mismatch between ARRAY and MASK in the REDUCE "
@@ -126,28 +129,39 @@ reduce (parray *ret,
 	ext2 *= ext;
 
       /* The dimensions of the return array.  */
-      if (i != (int)dimen_m1)
+      if (!scalar_result && ret->base_addr == NULL && i != (int)dimen_m1)
 	{
-	  spc = GFC_DESCRIPTOR_SPACING (array, j);
 	  GFC_DESCRIPTOR_DIMENSION_SET (ret, j, 0, ext - 1, spc);
+	  spc *= ext;
 	  j++;
 	}
     }
 
   if (!scalar_result)
     {
-      spc1 = GFC_DESCRIPTOR_SPACING (array, dimen_m1);
+      aspc1 = GFC_DESCRIPTOR_SPACING (array, dimen_m1);
+      if (mask_present)
+	mspc1 = GFC_DESCRIPTOR_SPACING (mask, dimen_m1);
       if (dimen < array_rank)
-	spc2 = GFC_DESCRIPTOR_SPACING (array, dimen);
+	{
+	  aspc2 = GFC_DESCRIPTOR_SPACING (array, dimen);
+	  rspc2 = GFC_DESCRIPTOR_SPACING (ret, dimen_m1);
+	  if (mask_present)
+	    mspc2 = GFC_DESCRIPTOR_SPACING (mask, dimen);
+	}
       else
-	spc2 = elem_len;
+	{
+	  aspc2 = 1;
+	  rspc2 = 1;
+	  mspc2 = 1;
+	}
     }
 
   /* Allocate the result data, the result buffer and zero.  */
   if (ret->base_addr == NULL)
     {
       ret->base_addr = calloc ((size_t)(ext0 * ext2), elem_len);
-      GFC_DESCRIPTOR_SPAN (ret) = GFC_DESCRIPTOR_SIZE (ret);
+      GFC_DESCRIPTOR_SPAN (ret) = GFC_DESCRIPTOR_SIZE (ret) = elem_len;
     }
 
   buffer = calloc (1, elem_len);
@@ -158,14 +172,16 @@ reduce (parray *ret,
     {
       for (idx2 = 0; idx2 < ext2; idx2++)
 	{
-	  off = idx0 * spc0  + idx2 * spc2;
 	  if (mask_present)
-	    maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t) off));
+	    {
+	      moff = idx0 * mspc0  + idx2 * mspc2;
+	      maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t) moff));
+	    }
 
 	  started = (mask_present && maskR) || !mask_present;
 
 	  buffer_ptr = array->base_addr
-		       + (size_t)(idx0 * spc0 + idx2 * spc2);
+		       + (size_t)(idx0 * aspc0 + idx2 * aspc2);
 
 	  /* Start the iteration over the second dimension of ARRAY.  */
 	  for (idx1 = 1; idx1 < ext1; idx1++)
@@ -173,12 +189,14 @@ reduce (parray *ret,
 	      /* If masked, cycle until after first element that is not masked
 		 out. Then set 'started' and cycle so that this becomes the
 		 first element in the reduction.  */
-	      off = idx0 * spc0 + idx1 * spc1 + idx2 * spc2;
 	      if (mask_present)
-		maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t) off));
+		{
+		  moff = idx0 * mspc0 + idx1 * mspc1 + idx2 * mspc2;
+		  maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t) moff));
+		}
 
 	      array_ptr = array->base_addr
-			  + (size_t)(idx0 * spc0 + idx1 * spc1 + idx2 * spc2);
+			  + (size_t)(idx0 * aspc0 + idx1 * aspc1 + idx2 * aspc2);
 	      if (!started)
 		{
 		  if (mask_present && maskR)
@@ -200,9 +218,8 @@ reduce (parray *ret,
 
 	  /* Now the result of the iteration is transferred to the returned
 	     result. If this result element is empty emit an error or, if
-	     available, set to identity. Note that str1 is paired with idx2
-	     here because the result skips a dimension.  */
-	  res = ret->base_addr + (size_t)(idx0 * spc0 + idx2 * spc1);
+	     available, set to identity.  */
+	  res = ret->base_addr + (size_t)(idx0 * rspc0 + idx2 * rspc2);
 	  if (started)
 	    {
 	      operation (buffer_ptr, NULL, res);