[gcc r16-756] libgcc: Small bitint_reduce_prec big-endian fixes

[Jakub Jelinek via Gcc-cvs]

https://gcc.gnu.org/g:092dcef93d40ff3dfed6c35001325bf522785c25

commit r16-756-g092dcef93d40ff3dfed6c35001325bf522785c25
Author: Jakub Jelinek 
Date:   Tue May 20 08:20:16 2025 +0200

libgcc: Small bitint_reduce_prec big-endian fixes

The big-endian _BitInt support in libgcc was written without any
testing and so I haven't discovered I've made one mistake in it
(in multiple places).
The bitint_reduce_prec function attempts to optimize inputs
which have some larger precision but at runtime they are found
to need smaller number of limbs.
For little-endian that is handled just by returning smaller
precision (or negative precision for signed), but for
big-endian we need to adjust the passed in limb pointer so that
when it returns smaller precision the argument still contains
the least significant limbs for the returned precision.

2025-05-20  Jakub Jelinek  

* libgcc2.c (bitint_reduce_prec): For big endian
__LIBGCC_BITINT_ORDER__ use ++*p and --*p instead of
++p and --p.
* soft-fp/bitint.h (bitint_reduce_prec): Likewise.

Diff:
---
 libgcc/libgcc2.c| 10 +-
 libgcc/soft-fp/bitint.h | 10 +-
 2 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/libgcc/libgcc2.c b/libgcc/libgcc2.c
index 92cb79dc8f8d..faefff3730ca 100644
--- a/libgcc/libgcc2.c
+++ b/libgcc/libgcc2.c
@@ -1333,7 +1333,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec >= -1)
return -2;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -1347,7 +1347,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec >= -1)
return -2;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -1358,7 +1358,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if ((Wtype) mslimb >= 0)
{
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- --p;
+ --*p;
 #endif
  return prec - 1;
}
@@ -1387,7 +1387,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec == 0)
return 1;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -1400,7 +1400,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
   if (prec == 0)
return 1;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
-  ++p;
+  ++*p;
 #else
   --i;
 #endif
diff --git a/libgcc/soft-fp/bitint.h b/libgcc/soft-fp/bitint.h
index 07a7bcbb0b99..8d489e65a622 100644
--- a/libgcc/soft-fp/bitint.h
+++ b/libgcc/soft-fp/bitint.h
@@ -76,7 +76,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec >= -1)
return -2;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -90,7 +90,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec >= -1)
return -2;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -101,7 +101,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if ((BILtype) mslimb >= 0)
{
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- --p;
+ --*p;
 #endif
  return prec - 1;
}
@@ -130,7 +130,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
  if (prec == 0)
return 1;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
- ++p;
+ ++*p;
 #else
  --i;
 #endif
@@ -143,7 +143,7 @@ bitint_reduce_prec (const UBILtype **p, SItype prec)
   if (prec == 0)
return 1;
 #if __LIBGCC_BITINT_ORDER__ == __ORDER_BIG_ENDIAN__
-  ++p;
+  ++*p;
 #else
   --i;
 #endif

[gcc r16-757] tree-chrec: Use signed_type_for in convert_affine_scev

[Jakub Jelinek via Gcc-cvs]

https://gcc.gnu.org/g:e38027c8ff449ffadaca449004bb891b9094ad00

commit r16-757-ge38027c8ff449ffadaca449004bb891b9094ad00
Author: Jakub Jelinek 
Date:   Tue May 20 08:21:14 2025 +0200

tree-chrec: Use signed_type_for in convert_affine_scev

On s390x-linux I've run into the gcc.dg/torture/bitint-27.c test ICEing in
build_nonstandard_integer_type called from convert_affine_scev (not sure
why it doesn't trigger on x86_64/aarch64).
The problem is clear, when ct is a BITINT_TYPE with some large
TYPE_PRECISION, build_nonstandard_integer_type won't really work on it.

The patch fixes it similarly what has been done for GCC 14 in various
other spots.

2025-05-20  Jakub Jelinek  

* tree-chrec.cc (convert_affine_scev): Use signed_type_for instead 
of
build_nonstandard_integer_type.

Diff:
---
 gcc/tree-chrec.cc | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/tree-chrec.cc b/gcc/tree-chrec.cc
index 38eb32916b86..a7c2f8de0d51 100644
--- a/gcc/tree-chrec.cc
+++ b/gcc/tree-chrec.cc
@@ -1490,7 +1490,7 @@ convert_affine_scev (class loop *loop, tree type,
   new_step = *step;
   if (TYPE_PRECISION (step_type) > TYPE_PRECISION (ct) && TYPE_UNSIGNED (ct))
 {
-  tree signed_ct = build_nonstandard_integer_type (TYPE_PRECISION (ct), 0);
+  tree signed_ct = signed_type_for (ct);
   new_step = chrec_convert (signed_ct, new_step, at_stmt,
 use_overflow_semantics);
 }

[gcc(refs/users/omachota/heads/rtl-ssa-dce)] rtl-ssa-dce: detect phi loop when deleting, enable debugizing

[Ondrej Machota via Gcc-cvs]

https://gcc.gnu.org/g:9728f377ae6a1092aba53166a8e67e6eff641412

commit 9728f377ae6a1092aba53166a8e67e6eff641412
Author: Ondřej Machota 
Date:   Tue May 20 08:37:19 2025 +0200

rtl-ssa-dce: detect phi loop when deleting, enable debugizing

Diff:
---
 gcc/dce.cc | 20 ++--
 gcc/rtl-ssa/changes.cc | 19 +++
 2 files changed, 29 insertions(+), 10 deletions(-)

diff --git a/gcc/dce.cc b/gcc/dce.cc
index 520202f0462e..46806f18db80 100644
--- a/gcc/dce.cc
+++ b/gcc/dce.cc
@@ -17,7 +17,6 @@ You should have received a copy of the GNU General Public 
License
 along with GCC; see the file COPYING3.  If not see
 .  */
 
-#include "sbitmap.h"
 #include 
 #include 
 #define INCLUDE_ALGORITHM
@@ -1343,7 +1342,7 @@ public:
 
   void resize(size_t size, int offset)
   {
-sbitmap_resize(m_bitmap, size, 0); 
+m_bitmap = sbitmap_resize(m_bitmap, (unsigned int)size, 0); 
 m_offset = offset; 
   }
 
@@ -1381,7 +1380,7 @@ private:
 
   void debugize_insn (insn_info *);
 
-  void unmark_debugizable(insn_info &, sbitmap &);
+  void unmark_debugizable(insn_info &, sbitmap);
   sbitmap find_debugizable(const std::unordered_set &);
   void debugize_insns (const sbitmap);
 
@@ -1748,7 +1747,7 @@ rtl_ssa_dce::execute (function *fn)
 count++;
   }
 
-  m_marked.resize(artificial_min, real_max);
+  m_marked.resize(artificial_min, real_max + 1);
   // std::cout << "real_max: " << real_max << '\n';
   // std::cout << "artificial_min: " << artificial_min << '\n';
   // std::cout << "total: " << real_max - artificial_min + 3 << '\n';
@@ -1783,9 +1782,14 @@ rtl_ssa_dce::execute (function *fn)
   // frame_pointer_needed << '\n';
 
   mark ();
-  // propagate_dead_phis();
   if (MAY_HAVE_DEBUG_BIND_INSNS)
+   {
+auto dead_phis = propagate_dead_phis();
+auto debugizable = find_debugizable(dead_phis);
+debugize_insns(debugizable);
+
 reset_dead_debug ();
+   }
   sweep ();
 
   free_dominance_info (CDI_DOMINATORS);
@@ -1902,9 +1906,13 @@ replace_dead_reg(rtx x, const_rtx old_rtx 
ATTRIBUTE_UNUSED, void *data)
 
 // visit every marked instruction in INSN dependency tree and unmark it
 void
-rtl_ssa_dce::unmark_debugizable(insn_info &insn, sbitmap &debugizable) 
+rtl_ssa_dce::unmark_debugizable(insn_info &insn, sbitmap debugizable) 
 {
   auto_vec worklist;
+  gcc_assert(!insn.is_artificial());
+  if (insn.uid () < 0)
+std::cerr << "WTF" << insn.uid() << '\n';
+  std::cout << insn.uid () << '\n';
   bitmap_set_bit (debugizable, insn.uid ());
   worklist.safe_push (&insn);
 
diff --git a/gcc/rtl-ssa/changes.cc b/gcc/rtl-ssa/changes.cc
index 62518c515c92..aab6251d2bb1 100644
--- a/gcc/rtl-ssa/changes.cc
+++ b/gcc/rtl-ssa/changes.cc
@@ -256,20 +256,30 @@ rtl_ssa::changes_are_worthwhile (array_slice changes,
 // SET has been deleted.  Clean up all remaining uses.  Such uses are
 // either dead phis or now-redundant live-out uses.
 void
-function_info::process_uses_of_deleted_def (set_info *set, auto_sbitmap 
&visited_phis)
+function_info::process_uses_of_deleted_def (set_info *set, auto_sbitmap 
&visited_phi_nodes)
 {
   if (!set->has_any_uses ())
 return;
 
+  insn_info *set_insn = set->insn ();
+  if (set_insn && set_insn->is_phi()) {
+   auto *phi = static_cast (set);
+   bitmap_set_bit (visited_phi_nodes, phi->uid ());
+  } 
+
   auto *use = *set->all_uses ().begin ();
   do
 {
   auto *next_use = use->next_use ();
   if (use->is_in_phi ())
{
- // This call will not recurse.
- process_uses_of_deleted_def (use->phi (), visited_phis);
- delete_phi (use->phi ());
+ phi_info *phi = use->phi ();
+ if (bitmap_bit_p(visited_phi_nodes, phi->uid ())) {
+   remove_use (use);
+ } else {
+   process_uses_of_deleted_def (phi, visited_phi_nodes);
+   delete_phi (phi);
+ }
}
   else
{
@@ -862,6 +872,7 @@ function_info::change_insns (array_slice 
changes)
  if (set && set->has_any_uses ())
{
auto_sbitmap visited_phis(m_next_phi_uid);
+   bitmap_clear(visited_phis);
process_uses_of_deleted_def (set, visited_phis);
}
  remove_def (def);

[gcc r16-730] RISC-V: Fix the warning of temporary object dangling references.

[Kito Cheng via Gcc-cvs]

https://gcc.gnu.org/g:7fabbf3562812f648bb49d0a7ea6b74e88defd4b

commit r16-730-g7fabbf3562812f648bb49d0a7ea6b74e88defd4b
Author: Dongyan Chen 
Date:   Mon May 19 15:17:12 2025 +0800

RISC-V: Fix the warning of temporary object dangling references.

During the GCC compilation, some warnings about temporary object dangling
references emerged. They appeared in these code lines in riscv-common.cc:
const riscv_ext_info_t &implied_ext_info, const riscv_ext_info_t &ext_info 
= get_riscv_ext_info (ext) and auto &ext_info = get_riscv_ext_info (search_ext).
The issue arose because the local variable types were not used in a 
standardized
way, causing their references to dangle once the function ended.
To fix this, the patch changes the argument type of get_riscv_ext_info to
`const char *`, thereby eliminating the warnings.

Changes for v2:
- Change the argument type of get_riscv_ext_info to `const char *` to 
eliminate the warnings.

gcc/ChangeLog:

* common/config/riscv/riscv-common.cc (get_riscv_ext_info): Fix 
argument type.
(riscv_subset_list::check_implied_ext): Type conversion.

Diff:
---
 gcc/common/config/riscv/riscv-common.cc | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/common/config/riscv/riscv-common.cc 
b/gcc/common/config/riscv/riscv-common.cc
index 53ca03910b38..c843393998cb 100644
--- a/gcc/common/config/riscv/riscv-common.cc
+++ b/gcc/common/config/riscv/riscv-common.cc
@@ -215,7 +215,7 @@ static const std::unordered_map riscv_ext_infos
 };
 
 static const riscv_ext_info_t &
-get_riscv_ext_info (const std::string &ext)
+get_riscv_ext_info (const char * ext)
 {
   auto itr = riscv_ext_infos.find (ext);
   if (itr == riscv_ext_infos.end ())
@@ -1112,7 +1112,7 @@ riscv_subset_list::check_implied_ext ()
   for (itr = m_head; itr != NULL; itr = itr->next)
 {
   auto &ext = *itr;
-  auto &ext_info = get_riscv_ext_info (ext.name);
+  auto &ext_info = get_riscv_ext_info (ext.name.c_str ());
   for (auto &implied_ext : ext_info.implied_exts ())
{
  if (!implied_ext.match (this))

[gcc r15-9701] OpenMP, GCN: Add interop-hsa testcase

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:c37fa5f8e5d2f9296f4207f430a4ac69ecab54fa

commit r15-9701-gc37fa5f8e5d2f9296f4207f430a4ac69ecab54fa
Author: Andrew Stubbs 
Date:   Thu Apr 24 16:50:08 2025 +

OpenMP, GCN: Add interop-hsa testcase

This testcase ensures that the interop HSA support is sufficient to run
a kernel manually on the same device.

libgomp/ChangeLog:

* testsuite/libgomp.c/interop-hsa.c: New test.

(cherry picked from commit 8d84ea28510054fbbb8a2b7441916bd75e29163f)

Diff:
---
 libgomp/testsuite/libgomp.c/interop-hsa.c | 203 ++
 1 file changed, 203 insertions(+)

diff --git a/libgomp/testsuite/libgomp.c/interop-hsa.c 
b/libgomp/testsuite/libgomp.c/interop-hsa.c
new file mode 100644
index ..cf8bc90bb9c0
--- /dev/null
+++ b/libgomp/testsuite/libgomp.c/interop-hsa.c
@@ -0,0 +1,203 @@
+/* { dg-additional-options "-ldl" } */
+/* { dg-require-effective-target offload_device_gcn } */
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include "../../../include/hsa.h"
+#include "../../config/gcn/libgomp-gcn.h"
+
+#define STACKSIZE (100 * 1024)
+#define HEAPSIZE (10 * 1024 * 1024)
+#define ARENASIZE HEAPSIZE
+
+/* This code fragment must be optimized or else the host-fallback kernel has
+ * invalid ASM inserts.  The rest of the file can be compiled safely at -O0.  
*/
+#pragma omp declare target
+uintptr_t __attribute__((optimize("O1")))
+get_kernel_ptr ()
+{
+  uintptr_t val;
+  if (!omp_is_initial_device ())
+/* "main._omp_fn.0" is the name GCC gives the first OpenMP target
+ * region in the "main" function.
+ * The ".kd" suffix is added by the LLVM assembler when it creates the
+ * kernel meta-data, and this is what we need to launch a kernel.  */
+asm ("s_getpc_b64 %0\n\t"
+"s_add_u32 %L0, %L0, main._omp_fn.0.kd@rel32@lo+4\n\t"
+"s_addc_u32 %H0, %H0, main._omp_fn.0.kd@rel32@hi+4"
+: "=Sg"(val));
+  return val;
+}
+#pragma omp end declare target
+
+int
+main(int argc, char** argv)
+{
+
+  /* Load the HSA runtime DLL.  */
+  void *hsalib = dlopen ("libhsa-runtime64.so.1", RTLD_LAZY);
+  assert (hsalib);
+
+  hsa_status_t (*hsa_signal_create) (hsa_signal_value_t initial_value,
+uint32_t num_consumers,
+const hsa_agent_t *consumers,
+hsa_signal_t *signal)
+= dlsym (hsalib, "hsa_signal_create");
+  assert (hsa_signal_create);
+
+  uint64_t (*hsa_queue_load_write_index_relaxed) (const hsa_queue_t *queue)
+= dlsym (hsalib, "hsa_queue_load_write_index_relaxed");
+  assert (hsa_queue_load_write_index_relaxed);
+
+  void (*hsa_signal_store_relaxed) (hsa_signal_t signal,
+   hsa_signal_value_t value)
+= dlsym (hsalib, "hsa_signal_store_relaxed");
+  assert (hsa_signal_store_relaxed);
+
+  hsa_signal_value_t (*hsa_signal_wait_relaxed) (hsa_signal_t signal,
+hsa_signal_condition_t 
condition,
+hsa_signal_value_t 
compare_value,
+uint64_t timeout_hint,
+hsa_wait_state_t 
wait_state_hint)
+= dlsym (hsalib, "hsa_signal_wait_relaxed");
+  assert (hsa_signal_wait_relaxed);
+
+  void (*hsa_queue_store_write_index_relaxed) (const hsa_queue_t *queue,
+  uint64_t value)
+= dlsym (hsalib, "hsa_queue_store_write_index_relaxed");
+  assert (hsa_queue_store_write_index_relaxed);
+
+  hsa_status_t (*hsa_signal_destroy) (hsa_signal_t signal)
+= dlsym (hsalib, "hsa_signal_destroy");
+  assert (hsa_signal_destroy);
+
+  /* Set up the device data environment.  */
+  int test_data_value = 0;
+#pragma omp target enter data map(test_data_value)
+
+  /* Get the interop details.  */
+  int device_num = omp_get_default_device();
+  hsa_agent_t *gpu_agent;
+  hsa_queue_t *hsa_queue = NULL;
+
+  omp_interop_t interop = omp_interop_none;
+#pragma omp interop init(target, targetsync, prefer_type("hsa"): interop) 
device(device_num)
+  assert (interop != omp_interop_none);
+
+  omp_interop_rc_t retcode;
+  omp_interop_fr_t fr = omp_get_interop_int (interop, omp_ipr_fr_id, &retcode);
+  assert (retcode == omp_irc_success);
+  assert (fr == omp_ifr_hsa);
+
+  gpu_agent = omp_get_interop_ptr(interop, omp_ipr_device, &retcode);
+  assert (retcode == omp_irc_success);
+
+  hsa_queue = omp_get_interop_ptr(interop, omp_ipr_targetsync, &retcode);
+  assert (retcode == omp_irc_success);
+  assert (hsa_queue);
+
+  /* Call an offload kernel via OpenMP/libgomp.
+   *
+   * This kernel serves two purposes:
+   *   1) Lookup the device-side load-address of itself (thus avoiding the
+   *   need to access the libgomp internals).
+   *   2) Count how many times it is called.
+   * We then call it once using OpenMP, and once ma

[gcc r15-9700] libgomp/testsuite: Fix hip_header_nvidia check, add workaround to test

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:e8b69eeb1c3d217f344fe92e758a30851883ab08

commit r15-9700-ge8b69eeb1c3d217f344fe92e758a30851883ab08
Author: Tobias Burnus 
Date:   Thu Apr 24 18:26:30 2025 +0200

libgomp/testsuite: Fix hip_header_nvidia check, add workaround to test

This is all about using the AMD's HIP header files with
__HIP_PLATFORM_NVIDIA__ defined, i.e. HIP with Nvidia/CUDA; in that case,
HIP is a thin layer on top of CUDA.

First, the check_effective_target_gomp_hip_header_nvidia check failed;
to fix it, -Wno-deprecated-declarations was added - and likewise to the
two affected testcases that actually used the HIP headers on Nvidia.

Doing so, the HIP tested was successful but the HIP-BLAS one showed two
issues:

* One seems to be related to include search paths as the HIP header uses
  #include "library_types.h" to include that CUDA header. Seemingly, it
  tried to included (again) the HIP header hip/library_types.h, not the
  CUDA one. I guess, some tweaking of -isystem vs. -I could have
  prevented this, but the simpler workaround was to just explicitly
  include the CUDA one before the HIP header files.

* Once done, everything compiled but linking failed as the association
  between three HIP-BLAS functions and their CUDA-BLAS ones did not
  work. Solution: Just add three #define for mapping them.

libgomp/ChangeLog:

* testsuite/lib/libgomp.exp
(check_effective_target_gomp_hip_header_nvidia): Compile with
"-Wno-deprecated-declarations".
* testsuite/libgomp.c/interop-hip-nvidia-full.c: Likewise.
* testsuite/libgomp.c/interop-hipblas-nvidia-full.c: Likewise.
* testsuite/libgomp.c/interop-hipblas.h: Add workarounds
when using the HIP headers with __HIP_PLATFORM_NVIDIA__.

(cherry picked from commit 8ef0518bce489c4c0c252a0e0c44193c5f7cf777)

Diff:
---
 libgomp/testsuite/lib/libgomp.exp |  2 +-
 libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c |  2 +-
 libgomp/testsuite/libgomp.c/interop-hipblas-nvidia-full.c |  2 +-
 libgomp/testsuite/libgomp.c/interop-hipblas.h | 14 +-
 4 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/libgomp/testsuite/lib/libgomp.exp 
b/libgomp/testsuite/lib/libgomp.exp
index a057394ca13f..54f2f708b1ba 100644
--- a/libgomp/testsuite/lib/libgomp.exp
+++ b/libgomp/testsuite/lib/libgomp.exp
@@ -671,7 +671,7 @@ int main() {
 if (r != hipSuccess)
return 1;
 return 0;
-} }]
+} } "-Wno-deprecated-declarations"]
 }
 
 # Return 1 if the Fortran hipfort module is available (no link check)
diff --git a/libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c 
b/libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c
index 324504feb228..79af47dc0765 100644
--- a/libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c
+++ b/libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c
@@ -1,7 +1,7 @@
 /* { dg-require-effective-target openacc_cudart } */
 /* { dg-require-effective-target openacc_cuda } */
 /* { dg-require-effective-target gomp_hip_header_nvidia } */
-/* { dg-additional-options "-lcuda -lcudart" } */
+/* { dg-additional-options "-lcuda -lcudart -Wno-deprecated-declarations" } */
 
 #define __HIP_PLATFORM_NVIDIA__ 1
 
diff --git a/libgomp/testsuite/libgomp.c/interop-hipblas-nvidia-full.c 
b/libgomp/testsuite/libgomp.c/interop-hipblas-nvidia-full.c
index c195d2486f69..ed428c6c7608 100644
--- a/libgomp/testsuite/libgomp.c/interop-hipblas-nvidia-full.c
+++ b/libgomp/testsuite/libgomp.c/interop-hipblas-nvidia-full.c
@@ -1,6 +1,6 @@
 /* { dg-require-effective-target openacc_cublas } */
 /* { dg-require-effective-target gomp_hip_header_nvidia } */
-/* { dg-additional-options "-lcublas" } */
+/* { dg-additional-options "-lcublas -Wno-deprecated-declarations" } */
 
 #define __HIP_PLATFORM_NVIDIA__ 1
 
diff --git a/libgomp/testsuite/libgomp.c/interop-hipblas.h 
b/libgomp/testsuite/libgomp.c/interop-hipblas.h
index 11cb4d280309..d7cb174b9e15 100644
--- a/libgomp/testsuite/libgomp.c/interop-hipblas.h
+++ b/libgomp/testsuite/libgomp.c/interop-hipblas.h
@@ -24,7 +24,19 @@ Based on the interop example in OpenMP's example document  */
 #include "../libgomp.c-c++-common/on_device_arch.h"
 
 
-#if __has_include() && !defined(USE_HIP_FALLBACK_HEADER)
+#if __has_include() && (__has_include() || 
!defined(__HIP_PLATFORM_NVIDIA__)) && !defined(USE_HIP_FALLBACK_HEADER)
+  #ifdef __HIP_PLATFORM_NVIDIA__
+/* There seems to be an issue with hip/library_types.h including
+   CUDA's "library_types.h". Include CUDA's one explicitly here.
+   Could possibly worked around by using -isystem vs. -I.  */
+#include 
+
+/* For some reasons, the following symbols do not seem to get
+   mapped from HIP to CUDA, causing link errors.  */
+#define hipblasSetStream cublasSetStream_v2
+#define hipblasDaxpy cublasDaxpy_v2
+#define 

[gcc r15-9698] OpenMP: Add libgomp.fortran/target-enter-data-8.f90

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:f251e2748a9c6dd90ed4df796da0a0ad6c8a377a

commit r15-9698-gf251e2748a9c6dd90ed4df796da0a0ad6c8a377a
Author: Tobias Burnus 
Date:   Wed Apr 23 09:03:00 2025 +0200

OpenMP: Add libgomp.fortran/target-enter-data-8.f90

Add another testcase for Fortran deep mapping of allocatable components.

libgomp/ChangeLog:

* testsuite/libgomp.fortran/target-enter-data-8.f90: New test.

(cherry picked from commit c9a8f2f9d39a317ed67fb47157a995ea03c182d4)

Diff:
---
 .../libgomp.fortran/target-enter-data-8.f90| 532 +
 1 file changed, 532 insertions(+)

diff --git a/libgomp/testsuite/libgomp.fortran/target-enter-data-8.f90 
b/libgomp/testsuite/libgomp.fortran/target-enter-data-8.f90
new file mode 100644
index ..c6d671c1306b
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-enter-data-8.f90
@@ -0,0 +1,532 @@
+! { dg-additional-options "-cpp" }
+
+! FIXME: Some tests do not work yet. Those are for now in '#if 0'
+
+! Check that 'map(alloc:' properly works with
+! - deferred-length character strings
+! - arrays with array descriptors
+! For those, the array descriptor / string length must be mapped with 'to:'
+
+program main
+implicit none
+
+type t
+  integer :: ic(2:5), ic2
+  character(len=11) :: ccstr(3:4), ccstr2
+  character(len=11,kind=4) :: cc4str(3:7), cc4str2
+  integer, pointer :: pc(:), pc2
+  character(len=:), pointer :: pcstr(:), pcstr2
+  character(len=:,kind=4), pointer :: pc4str(:), pc4str2
+end type t
+
+type(t) :: dt
+
+integer :: ii(5), ii2
+character(len=11) :: clstr(-1:1), clstr2
+character(len=11,kind=4) :: cl4str(0:3), cl4str2
+integer, pointer :: ip(:), ip2
+integer, allocatable :: ia(:), ia2
+character(len=:), pointer :: pstr(:), pstr2
+character(len=:), allocatable :: astr(:), astr2
+character(len=:,kind=4), pointer :: p4str(:), p4str2
+character(len=:,kind=4), allocatable :: a4str(:), a4str2
+
+
+allocate(dt%pc(5), dt%pc2)
+allocate(character(len=2) :: dt%pcstr(2))
+allocate(character(len=4) :: dt%pcstr2)
+
+allocate(character(len=3,kind=4) :: dt%pc4str(2:3))
+allocate(character(len=5,kind=4) :: dt%pc4str2)
+
+allocate(ip(5), ip2, ia(8), ia2)
+allocate(character(len=2) :: pstr(-2:0))
+allocate(character(len=4) :: pstr2)
+allocate(character(len=6) :: astr(3:5))
+allocate(character(len=8) :: astr2)
+
+allocate(character(len=3,kind=4) :: p4str(2:4))
+allocate(character(len=5,kind=4) :: p4str2)
+allocate(character(len=7,kind=4) :: a4str(-2:3))
+allocate(character(len=9,kind=4) :: a4str2)
+
+
+! integer :: ic(2:5), ic2
+
+!$omp target enter data map(alloc: dt%ic)
+!$omp target map(alloc: dt%ic)
+  if (size(dt%ic) /= 4) error stop
+  if (lbound(dt%ic, 1) /= 2) error stop
+  if (ubound(dt%ic, 1) /= 5) error stop
+  dt%ic = [22, 33, 44, 55]
+!$omp end target
+!$omp target exit data map(from: dt%ic)
+if (size(dt%ic) /= 4) error stop
+if (lbound(dt%ic, 1) /= 2) error stop
+if (ubound(dt%ic, 1) /= 5) error stop
+if (any (dt%ic /= [22, 33, 44, 55])) error stop
+
+!$omp target enter data map(alloc: dt%ic2)
+!$omp target map(alloc: dt%ic2)
+  dt%ic2 = 42
+!$omp end target
+!$omp target exit data map(from: dt%ic2)
+if (dt%ic2 /= 42) error stop
+
+
+! character(len=11) :: ccstr(3:4), ccstr2
+
+!$omp target enter data map(alloc: dt%ccstr)
+!$omp target map(alloc: dt%ccstr)
+  if (len(dt%ccstr) /= 11) error stop
+  if (size(dt%ccstr) /= 2) error stop
+  if (lbound(dt%ccstr, 1) /= 3) error stop
+  if (ubound(dt%ccstr, 1) /= 4) error stop
+  dt%ccstr = ["12345678901", "abcdefghijk"]
+!$omp end target
+!$omp target exit data map(from: dt%ccstr)
+if (len(dt%ccstr) /= 11) error stop
+if (size(dt%ccstr) /= 2) error stop
+if (lbound(dt%ccstr, 1) /= 3) error stop
+if (ubound(dt%ccstr, 1) /= 4) error stop
+if (any (dt%ccstr /= ["12345678901", "abcdefghijk"])) error stop
+
+!$omp target enter data map(alloc: dt%ccstr2)
+!$omp target map(alloc: dt%ccstr2)
+  if (len(dt%ccstr2) /= 11) error stop
+  dt%ccstr2 = "ABCDEFGHIJK"
+!$omp end target
+!$omp target exit data map(from: dt%ccstr2)
+if (len(dt%ccstr2) /= 11) error stop
+if (dt%ccstr2 /= "ABCDEFGHIJK") error stop
+
+
+! character(len=11,kind=4) :: cc4str(3:7), cc4str2
+
+#if 0
+! Value check fails
+!$omp target map(alloc: dt%cc4str)
+  if (len(dt%cc4str) /= 11) error stop
+  if (size(dt%cc4str) /= 5) error stop
+  if (lbound(dt%cc4str, 1) /= 3) error stop
+  if (ubound(dt%cc4str, 1) /= 7) error stop
+  dt%cc4str = [4_"12345678901", 4_"abcdefghijk", &
+   4_"qerftcea6ds", 4_"a1f9g37ga4.", &
+   4_"45ngwj56sj2"]
+!$omp end target
+!$omp target exit data map(from: dt%cc4str)
+if (len(dt%cc4str) /= 11) error stop
+if (size(dt%cc4str) /= 5) error stop
+if (lbound(dt%cc4str, 1) /= 3) error stop
+if (ubound(dt%cc4str, 1) /= 7) error stop
+if (dt%cc4str(3) /= 4_"12345678901") error stop
+if (dt%cc4str(4) /= 4_"abcdefghijk") error stop
+if (dt%cc4str(5) /= 4_"qerftcea6ds") error stop
+if (dt%cc4str(6) /= 4_"a1f9g37ga4.") error stop
+if (dt%cc4str

[gcc r15-9699] libgomp: Add additional OpenMP interop runtime tests

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:951d02dde2b86cbc999ef8c6c2256c2cde21735f

commit r15-9699-g951d02dde2b86cbc999ef8c6c2256c2cde21735f
Author: Tobias Burnus 
Date:   Thu Apr 24 14:36:37 2025 +0200

libgomp: Add additional OpenMP interop runtime tests

Add checks for nowait/depend and for checks that the returned
CUDA, CUDA_DRIVER and HIP interop objects actually work.

While the CUDA/CUDA_DRIVER ones are only for Nvidia GPUs, HIP
works on both AMD and Nvidia GPUs; on Nvidia GPUs, it is a
very thin wrapper around CUDA.

For Fortran, only a HIP test has been added - using hipfort.

While libgomp.c-c++-common/interop-2.c always works - even without
GPU - and checks for depend / nowait, all others require that
runtime libraries are found at link (and execution) time:
For Nvidia GPUs, libcuda + libcudart or libcublas,
For AMD GPUs, libamdhip64 or libhipblas.

The header files and hipfort modules do not need to be present as a
fallback has been implemented, but if they are, they get used.

Due to the combinations, the basic 1x C/C++, 4x C and 1x Fortran tests
yield 1x C/C++, 14x C and 4 Fortran run-test files.

libgomp/ChangeLog:

* testsuite/lib/libgomp.exp (check_effective_target_openacc_cublas,
check_effective_target_openacc_cudart): Update description as
the check requires more.
(check_effective_target_openacc_libcuda,
check_effective_target_openacc_libcublas,
check_effective_target_openacc_libcudart,
check_effective_target_gomp_hip_header_amd,
check_effective_target_gomp_hip_header_nvidia,
check_effective_target_gomp_hipfort_module,
check_effective_target_gomp_libamdhip64,
check_effective_target_gomp_libhipblas): New.
* testsuite/libgomp.c-c++-common/interop-2.c: New test.
* testsuite/libgomp.c/interop-cublas-full.c: New test.
* testsuite/libgomp.c/interop-cublas-libonly.c: New test.
* testsuite/libgomp.c/interop-cuda-full.c: New test.
* testsuite/libgomp.c/interop-cuda-libonly.c: New test.
* testsuite/libgomp.c/interop-hip-amd-full.c: New test.
* testsuite/libgomp.c/interop-hip-amd-no-hip-header.c: New test.
* testsuite/libgomp.c/interop-hip-nvidia-full.c: New test.
* testsuite/libgomp.c/interop-hip-nvidia-no-headers.c: New test.
* testsuite/libgomp.c/interop-hip-nvidia-no-hip-header.c: New test.
* testsuite/libgomp.c/interop-hip.h: New test.
* testsuite/libgomp.c/interop-hipblas-amd-full.c: New test.
* testsuite/libgomp.c/interop-hipblas-amd-no-hip-header.c: New test.
* testsuite/libgomp.c/interop-hipblas-nvidia-full.c: New test.
* testsuite/libgomp.c/interop-hipblas-nvidia-no-headers.c: New test.
* testsuite/libgomp.c/interop-hipblas-nvidia-no-hip-header.c: New 
test.
* testsuite/libgomp.c/interop-hipblas.h: New test.
* testsuite/libgomp.fortran/interop-hip-amd-full.F90: New test.
* testsuite/libgomp.fortran/interop-hip-amd-no-module.F90: New test.
* testsuite/libgomp.fortran/interop-hip-nvidia-full.F90: New test.
* testsuite/libgomp.fortran/interop-hip-nvidia-no-module.F90: New 
test.
* testsuite/libgomp.fortran/interop-hip.h: New test.

(cherry picked from commit 515d9be7944e89f5ec4363f9816ad4031ab6394b)

Diff:
---
 libgomp/testsuite/lib/libgomp.exp  | 133 +++-
 libgomp/testsuite/libgomp.c-c++-common/interop-2.c | 129 
 libgomp/testsuite/libgomp.c/interop-cublas-full.c  | 176 
 .../testsuite/libgomp.c/interop-cublas-libonly.c   |   7 +
 libgomp/testsuite/libgomp.c/interop-cuda-full.c| 159 ++
 libgomp/testsuite/libgomp.c/interop-cuda-libonly.c |   8 +
 libgomp/testsuite/libgomp.c/interop-hip-amd-full.c |   7 +
 .../libgomp.c/interop-hip-amd-no-hip-header.c  |   8 +
 .../testsuite/libgomp.c/interop-hip-nvidia-full.c  |   8 +
 .../libgomp.c/interop-hip-nvidia-no-headers.c  |  10 +
 .../libgomp.c/interop-hip-nvidia-no-hip-header.c   |   9 +
 libgomp/testsuite/libgomp.c/interop-hip.h  | 234 +
 .../testsuite/libgomp.c/interop-hipblas-amd-full.c |   7 +
 .../libgomp.c/interop-hipblas-amd-no-hip-header.c  |   8 +
 .../libgomp.c/interop-hipblas-nvidia-full.c|   7 +
 .../libgomp.c/interop-hipblas-nvidia-no-headers.c  |   9 +
 .../interop-hipblas-nvidia-no-hip-header.c |   8 +
 libgomp/testsuite/libgomp.c/interop-hipblas.h  | 228 
 .../libgomp.fortran/interop-hip-amd-full.F90   |   7 +
 .../libgomp.fortran/interop-hip-amd-no-module.F90  |   6 +
 .../libgomp.fortran/interop-hip-nvidia-full.F90|   9 +
 .../interop-hip-nvidia-no-module.F90   |   8 +
 libgomp/testsuite/libgo

[gcc r15-9702] OpenMP: Restore lost Fortran testcase for 'omp allocate'

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:6ae29e2c1cab22b971a96a1523dfd6e407e051a0

commit r15-9702-g6ae29e2c1cab22b971a96a1523dfd6e407e051a0
Author: Tobias Burnus 
Date:   Thu May 1 15:39:42 2025 +

OpenMP: Restore lost Fortran testcase for 'omp allocate'

This testcase, which is present on the OG13 and OG14 branches, was
overlooked when the Fortran support for 'omp allocate' was added to
mainline (commit d4b6d147920b93297e621124a99ed01e7e310d92 from
December 2023).

libgomp/ChangeLog

* testsuite/libgomp.fortran/allocate-8a.f90: New test.

(cherry picked from commit 08ce1b9f6707e00089c4d77d2bb82963d531bb1d)

Diff:
---
 libgomp/testsuite/libgomp.fortran/allocate-8a.f90 | 45 +++
 1 file changed, 45 insertions(+)

diff --git a/libgomp/testsuite/libgomp.fortran/allocate-8a.f90 
b/libgomp/testsuite/libgomp.fortran/allocate-8a.f90
new file mode 100644
index ..5f6c8c1e2717
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-8a.f90
@@ -0,0 +1,45 @@
+! { dg-additional-options "-fopenmp-allocators" }
+! { dg-additional-options "-fdump-tree-omplower" }
+program main
+  use iso_c_binding
+  use omp_lib
+  implicit none (type, external)
+  integer(omp_allocator_handle_kind):: alloc_h
+  integer :: i, N
+  integer(c_intptr_t) :: intptr
+  integer, allocatable :: A(:)
+  type(omp_alloctrait):: traits(1) = [omp_alloctrait(omp_atk_alignment, 128)]
+
+  N = 10
+  alloc_h = omp_init_allocator(omp_default_mem_space, 1, traits)
+
+  !$omp allocate(A) allocator(alloc_h)
+  allocate(A(N))
+  a(:) = [(i, i=1,N)]
+  if (mod (transfer (loc(a), intptr),128) /= 0) &
+stop 1
+  if (any (a /= [(i, i=1,N)])) &
+stop 2
+  deallocate(A)
+  !$omp allocate(A) allocator(alloc_h) align(512)
+  allocate(A(N))
+  block
+integer, allocatable :: B(:)
+!$omp allocators allocate(allocator(alloc_h), align(256) : B)
+allocate(B(N))
+B(:) = [(2*i, i=1,N)]
+A(:) = B
+if (mod (transfer (loc(B), intptr), 256) /= 0) &
+  stop 1
+! end of scope deallocation
+  end block
+  if (mod (transfer (loc(a), intptr),512) /= 0) &
+stop 1
+  if (any (a /= [(2*i, i=1,N)])) &
+stop 2
+  deallocate(A) ! Must deallocate here - before deallocator is destroyed
+  call omp_destroy_allocator(alloc_h)
+  ! No auto dealloc of A because it is SAVE
+end
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 3 "omplower" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 3 "omplower" } }

[gcc r15-9706] OpenMP: Fix mapping of zero-sized arrays with non-literal size: map(var[:n]), n = 0

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:ab9ca3a8b1af4119b5849f3615a94e5f1fd4e5a7

commit r15-9706-gab9ca3a8b1af4119b5849f3615a94e5f1fd4e5a7
Author: Tobias Burnus 
Date:   Wed May 14 20:06:49 2025 +0200

OpenMP: Fix mapping of zero-sized arrays with non-literal size: 
map(var[:n]), n = 0

For map(ptr[:0]), the used map kind is 
GOMP_MAP_ATTACH_ZERO_LENGTH_ARRAY_SECTION
and it is permitted that 'ptr' does not exist. 'ptr' is set to the device
pointee if it exists or to the host value otherwise.

For map(ptr[:3]), the variable is first mapped and then ptr is updated to 
point
to the just-mapped device data; the attachment uses GOMP_MAP_ATTACH.

For map(ptr[:n]), generates always a GOMP_MAP_ATTACH, but when n == 0, it
was failing with:
   "pointer target not mapped for attach"

The solution is not to fail but first to check whether it was mapped before.
It turned out that for the mapping part, GCC adds a run-time check whether
n == 0 - and uses GOMP_MAP_ZERO_LEN_ARRAY_SECTION for the mapping.
Thus, we just have to check whether there such a mapping for the address
for which the GOMP_MAP_ATTACH. was requested. And, if there was, the
error diagnostic can be skipped.

Unsurprisingly, this issue occurs in real-world code; it was detected in
a code that distributes work via MPI and for some processes, some bounds
ended up to be zero.

libgomp/ChangeLog:

* target.c (gomp_attach_pointer): Return bool; accept additional
bool to optionally silence the fatal pointee-not-found error.
(gomp_map_vars_internal): If the pointee could not be found,
check whether it was mapped as GOMP_MAP_ZERO_LEN_ARRAY_SECTION.
* libgomp.h (gomp_attach_pointer): Update prototype.
* oacc-mem.c (acc_attach_async, goacc_enter_data_internal): Update
calls.
* testsuite/libgomp.c/target-map-zero-sized.c: New test.
* testsuite/libgomp.c/target-map-zero-sized-2.c: New test.
* testsuite/libgomp.c/target-map-zero-sized-3.c: New test.

(cherry picked from commit 814e29e390b1e9253f9a38e0d84f5ebe5de0c13e)

Diff:
---
 libgomp/libgomp.h  |   4 +-
 libgomp/oacc-mem.c |   6 +-
 libgomp/target.c   |  64 +---
 .../testsuite/libgomp.c/target-map-zero-sized-2.c  |  74 ++
 .../testsuite/libgomp.c/target-map-zero-sized-3.c  |  49 ++
 .../testsuite/libgomp.c/target-map-zero-sized.c| 107 +
 6 files changed, 288 insertions(+), 16 deletions(-)

diff --git a/libgomp/libgomp.h b/libgomp/libgomp.h
index d97768f5125d..6030f9d0a2cb 100644
--- a/libgomp/libgomp.h
+++ b/libgomp/libgomp.h
@@ -1468,10 +1468,10 @@ extern void gomp_copy_dev2host (struct 
gomp_device_descr *,
struct goacc_asyncqueue *, void *, const void *,
size_t);
 extern uintptr_t gomp_map_val (struct target_mem_desc *, void **, size_t);
-extern void gomp_attach_pointer (struct gomp_device_descr *,
+extern bool gomp_attach_pointer (struct gomp_device_descr *,
 struct goacc_asyncqueue *, splay_tree,
 splay_tree_key, uintptr_t, size_t,
-struct gomp_coalesce_buf *, bool);
+struct gomp_coalesce_buf *, bool, bool);
 extern void gomp_detach_pointer (struct gomp_device_descr *,
 struct goacc_asyncqueue *, splay_tree_key,
 uintptr_t, bool, struct gomp_coalesce_buf *);
diff --git a/libgomp/oacc-mem.c b/libgomp/oacc-mem.c
index 718252b44ba7..0482ed37d950 100644
--- a/libgomp/oacc-mem.c
+++ b/libgomp/oacc-mem.c
@@ -951,7 +951,7 @@ acc_attach_async (void **hostaddr, int async)
 }
 
   gomp_attach_pointer (acc_dev, aq, &acc_dev->mem_map, n, (uintptr_t) hostaddr,
-  0, NULL, false);
+  0, NULL, false, true);
 
   gomp_mutex_unlock (&acc_dev->lock);
 }
@@ -1158,7 +1158,7 @@ goacc_enter_data_internal (struct gomp_device_descr 
*acc_dev, size_t mapnum,
  if ((kinds[i] & 0xff) == GOMP_MAP_ATTACH)
{
  gomp_attach_pointer (acc_dev, aq, &acc_dev->mem_map, n,
-  (uintptr_t) h, s, NULL, false);
+  (uintptr_t) h, s, NULL, false, true);
  /* OpenACC 'attach'/'detach' doesn't affect structured/dynamic
 reference counts ('n->refcount', 'n->dynamic_refcount').  */
}
@@ -1176,7 +1176,7 @@ goacc_enter_data_internal (struct gomp_device_descr 
*acc_dev, size_t mapnum,
  = lookup_host (acc_dev, hostaddrs[j], sizeof (void *));
gomp_attach_pointer (acc_dev, aq, &acc_dev->mem_map, m,
 (uintptr_t)

[gcc r15-9707] OpenMP/Fortran: Fix allocatable-component mapping of derived-type array comps

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:57f73c3956572f30f3e0f7a350d958985b11daa5

commit r15-9707-g57f73c3956572f30f3e0f7a350d958985b11daa5
Author: Tobias Burnus 
Date:   Thu May 15 09:15:21 2025 +0200

OpenMP/Fortran: Fix allocatable-component mapping of derived-type array 
comps

The check whether the location expression in map clause has allocatable
components was failing for some derived-type array expressions such as
  map(var%tiles(1))
as the compiler produced
  _4 = var.tiles;
  MEMREF(_4, _5);
This commit now also handles this case.

gcc/fortran/ChangeLog:

* trans-openmp.cc (gfc_omp_deep_mapping_do): Handle SSA_NAME if
a def_stmt is available.

libgomp/ChangeLog:

* testsuite/libgomp.fortran/alloc-comp-4.f90: New test.

(cherry picked from commit f99017c3125f4400cf6a098cf5b33d32fe3e6645)

Diff:
---
 gcc/fortran/trans-openmp.cc| 20 ++
 libgomp/testsuite/libgomp.fortran/alloc-comp-4.f90 | 75 ++
 2 files changed, 95 insertions(+)

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 0b8150fb9777..2a48d4af5276 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2478,6 +2478,26 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, 
tree clause,
   else
 while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
   tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+  if (TREE_CODE (tmp) == MEM_REF)
+tmp = TREE_OPERAND (tmp, 0);
+  if (TREE_CODE (tmp) == SSA_NAME)
+{
+  gimple *def_stmt = SSA_NAME_DEF_STMT (tmp);
+  if (gimple_code (def_stmt) == GIMPLE_ASSIGN)
+   {
+ tmp = gimple_assign_rhs1 (def_stmt);
+ if (poly)
+   {
+ tmp = TYPE_FIELDS (type);
+ type = TREE_TYPE (tmp);
+   }
+ else
+   while (TREE_CODE (tmp) == COMPONENT_REF
+  || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp,
+ TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+   }
+}
   /* If the clause argument is nonallocatable, skip is-allocate check. */
   if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
   || GFC_DECL_GET_SCALAR_POINTER (tmp)
diff --git a/libgomp/testsuite/libgomp.fortran/alloc-comp-4.f90 
b/libgomp/testsuite/libgomp.fortran/alloc-comp-4.f90
new file mode 100644
index ..d5e982ba1a81
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/alloc-comp-4.f90
@@ -0,0 +1,75 @@
+!
+! Check that mapping with map(var%tiles(1)) works.
+!
+! This uses deep mapping to handle the allocatable
+! derived-type components
+!
+! The tricky part is that GCC generates intermittently
+! an SSA_NAME that needs to be resolved.
+!
+module m
+type t
+ integer, allocatable :: den1(:,:), den2(:,:)
+end type t
+
+type t2
+ type(t), allocatable :: tiles(:)
+end type t2
+end
+
+use m
+use iso_c_binding
+implicit none (type, external)
+type(t2), target :: var
+logical :: is_self_map
+type(C_ptr) :: pden1, pden2, ptiles, ptiles1
+
+allocate(var%tiles(1))
+var%tiles(1)%den1 = reshape([1,2,3,4],[2,2])
+var%tiles(1)%den2 = reshape([11,22,33,44],[2,2])
+
+ptiles = c_loc(var%tiles)
+ptiles1 = c_loc(var%tiles(1))
+pden1 = c_loc(var%tiles(1)%den1)
+pden2 = c_loc(var%tiles(1)%den2)
+
+
+is_self_map = .false.
+!$omp target map(to: is_self_map)
+  is_self_map = .true.
+!$omp end target
+
+!$omp target enter data map(var%tiles(1))
+
+!$omp target firstprivate(ptiles, ptiles1, pden1, pden2)
+ if (any (var%tiles(1)%den1 /= reshape([1,2,3,4],[2,2]))) stop 1
+ if (any (var%tiles(1)%den2 /= reshape([11,22,33,44],[2,2]))) stop 2
+ var%tiles(1)%den1 = var%tiles(1)%den1 + 5
+ var%tiles(1)%den2 = var%tiles(1)%den2 + 7
+
+ if (is_self_map) then
+   if (.not. c_associated (ptiles, c_loc(var%tiles))) stop 3
+   if (.not. c_associated (ptiles1, c_loc(var%tiles(1 stop 4
+   if (.not. c_associated (pden1, c_loc(var%tiles(1)%den1))) stop 5
+   if (.not. c_associated (pden2, c_loc(var%tiles(1)%den2))) stop 6
+ else
+   if (c_associated (ptiles, c_loc(var%tiles))) stop 3
+   if (c_associated (ptiles1, c_loc(var%tiles(1 stop 4
+   if (c_associated (pden1, c_loc(var%tiles(1)%den1))) stop 5
+   if (c_associated (pden2, c_loc(var%tiles(1)%den2))) stop 6
+ endif
+!$omp end target
+
+if (is_self_map) then
+  if (any (var%tiles(1)%den1 /= 5 + reshape([1,2,3,4],[2,2]))) stop 7
+  if (any (var%tiles(1)%den2 /= 7 + reshape([11,22,33,44],[2,2]))) stop 8
+else
+  if (any (var%tiles(1)%den1 /= reshape([1,2,3,4],[2,2]))) stop 7
+  if (any (var%tiles(1)%den2 /= reshape([11,22,33,44],[2,2]))) stop 8
+endif
+
+!$omp target exit data map(var%tiles(1))
+
+if (any (var%tiles(1)%den1 /= 5 + reshape([1,2,3,4],[2,2]))) stop 7
+if (any (var%tiles(1)%den2 /= 7 + reshape([11,22,33,44],[2,2]))) stop 8
+end

[gcc r15-9703] 'libgomp.c/interop-hsa.c': GCN offloading only

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:e71170dc97caf1c6582e4ca1a6416c56160adea9

commit r15-9703-ge71170dc97caf1c6582e4ca1a6416c56160adea9
Author: Thomas Schwinge 
Date:   Mon May 5 10:19:30 2025 +0200

'libgomp.c/interop-hsa.c': GCN offloading only

Fix-up for commit 8d84ea28510054fbbb8a2b7441916bd75e29163f
"OpenMP, GCN: Add interop-hsa testcase", which added 
'libgomp.c/interop-hsa.c'.
If nvptx offloading compilation is enabled in addition to GCN, the former 
ICEs:

during RTL pass: final
[...]/libgomp.c/interop-hsa.c: In function 'get_kernel_ptr':
[...]/libgomp.c/interop-hsa.c:34:1: internal compiler error: RTL check: 
expected code 'subreg', have 'reg' in nvptx_print_operand, at 
config/nvptx/nvptx.cc:3082
0x1ccdb96 internal_error(char const*, ...)
[...]/gcc/diagnostic-global-context.cc:517
0x7446c3 rtl_check_failed_code1(rtx_def const*, rtx_code, char const*, 
int, char const*)
[...]/gcc/rtl.cc:770
0x7fa533 nvptx_print_operand
[...]/gcc/config/nvptx/nvptx.cc:3082
0xb25f34 output_operand(rtx_def*, int)
[...]/gcc/final.cc:3641
0xb26f07 output_asm_insn(char const*, rtx_def**)
[...]/gcc/final.cc:3534
0xb29d91 output_asm_insn(char const*, rtx_def**)
[...]/gcc/final.cc:2639
0xb29d91 final_scan_insn_1
[...]/gcc/final.cc:2642
0xb2a59f final_scan_insn(rtx_insn*, _IO_FILE*, int, int, int*)
[...]/gcc/final.cc:2892
0xb2a68c final_1
[...]/gcc/final.cc:1983
0xb2b378 rest_of_handle_final
[...]/gcc/final.cc:4250
0xb2b378 execute
[...]/gcc/final.cc:4328

Regardless of the issue that nvptx offloading compilation probably shouldn't
ICE, the 'asm' insert clearly is valid for GCN only.

libgomp/
* testsuite/libgomp.c/interop-hsa.c: GCN offloading only.

(cherry picked from commit 85ad0d84fcec720c1d94b9bda9a617ced70ba5d2)

Diff:
---
 libgomp/testsuite/libgomp.c/interop-hsa.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/libgomp/testsuite/libgomp.c/interop-hsa.c 
b/libgomp/testsuite/libgomp.c/interop-hsa.c
index cf8bc90bb9c0..21ac91c1b58c 100644
--- a/libgomp/testsuite/libgomp.c/interop-hsa.c
+++ b/libgomp/testsuite/libgomp.c/interop-hsa.c
@@ -1,5 +1,7 @@
 /* { dg-additional-options "-ldl" } */
-/* { dg-require-effective-target offload_device_gcn } */
+/* { dg-require-effective-target offload_device_gcn }
+   The 'asm' insert is valid for GCN only:
+   { dg-additional-options -foffload=amdgcn-amdhsa } */
 
 #include 
 #include 

[gcc r15-9704] libgomp.fortran/map-alloc-comp-9{, -usm}.f90: Add unified_shared_memory variant

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:24edffe147a7e550821e482498ef18719368255b

commit r15-9704-g24edffe147a7e550821e482498ef18719368255b
Author: Tobias Burnus 
Date:   Wed May 7 13:46:51 2025 +0200

libgomp.fortran/map-alloc-comp-9{,-usm}.f90: Add unified_shared_memory 
variant

When host memory is device accessible - independent whether mapping is done 
or
not (i.e. self map), the 'vtab' pointer becomes accessible, which stores the
dynamic type's type and size information.

In principle, we want to test: USM available but mapping is still done, but
as there is no simple + reliable not-crashing way to test for this, those
checks are skipped in the (pre)existing test file map-alloc-comp-9.f90.

Or rather: those are only active with self-maps, which is currently only 
true
for the host.

This commit adds map-alloc-comp-9-usm.f90 which runs the same test with
'omp requires unified_shared_memory'.  While OpenMP permits both actual
mapping and self maps with this flag, it in theory covers the missing cases.
However, currently, GCC always uses self maps with USM. Still, having a
device-run self-maps check is better than nothing, even if it misses the
most interesting case.

libgomp/ChangeLog:

* testsuite/libgomp.fortran/map-alloc-comp-9.f90: Process 
differently
when USE_USM_REQUIREMENT is set.
* testsuite/libgomp.fortran/map-alloc-comp-9-usm.f90: New test.

(cherry picked from commit 9565076f9b810541aeb63cb621d694326aa12216)

Diff:
---
 .../libgomp.fortran/map-alloc-comp-9-usm.f90  | 11 +++
 .../testsuite/libgomp.fortran/map-alloc-comp-9.f90| 19 +++
 2 files changed, 30 insertions(+)

diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9-usm.f90 
b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9-usm.f90
new file mode 100644
index ..90378c0e42a2
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9-usm.f90
@@ -0,0 +1,11 @@
+! { dg-additional-options "-cpp -DUSE_USM_REQUIREMENT=1 -Wno-openmp" }
+!
+! We silence the warning:
+!  Mapping of polymorphic list item '...' is unspecified behavior [-Wopenmp]
+!
+! Ensure that polymorphic mapping is diagnosed as undefined behavior
+! Ensure that static access to polymorphic variables works
+
+! Run map-alloc-comp-9.f90 in unified-shared-memory mode
+
+#include "map-alloc-comp-9.f90"
diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9.f90 
b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9.f90
index 3cec39218f56..26c73d75c09b 100644
--- a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9.f90
+++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-9.f90
@@ -1,8 +1,19 @@
+! { dg-additional-options "-cpp" }
+!
 ! Ensure that polymorphic mapping is diagnosed as undefined behavior
 ! Ensure that static access to polymorphic variables works
 
+! Some extended tests are only run with shared memory
+! To enforce this (where possible) on the device side:
+!   #define USE_USM_REQUIREMENT
+! which is done in map-alloc-comp-9-usm.f90
+
 subroutine test(case)
 implicit none(type, external)
+#ifdef USE_USM_REQUIREMENT
+  !$omp requires unified_shared_memory
+#endif
+
 type t
   integer :: x(4)
 end type t
@@ -73,10 +84,14 @@ var4%y2(2)%y%x%x = -7 * [,,,]
 var4%y2(2)%y%x2(1)%x = -8 * [,,,]
 var4%y2(2)%y%x2(2)%x = -9 * [,,,]
 
+#ifdef USE_USM_REQUIREMENT
+is_shared_mem = .true.
+#else
 is_shared_mem = .false.
 !$omp target map(to: is_shared_mem)
   is_shared_mem = .true.
 !$omp end target
+#endif
 
 if (case == 1) then
   ! implicit mapping
@@ -532,6 +547,10 @@ end subroutine test
 program main
   use omp_lib
   implicit none(type, external)
+#ifdef USE_USM_REQUIREMENT
+  !$omp requires unified_shared_memory
+#endif
+
   interface
 subroutine test(case)
   integer, value :: case

[gcc r16-731] libstdc++: Fix std::format of chrono::local_days with {} [PR120293]

[Jonathan Wakely via Gcc-cvs]

https://gcc.gnu.org/g:1ed7585bf60ba9940ca5dc6d2c72dba86eea7b4d

commit r16-731-g1ed7585bf60ba9940ca5dc6d2c72dba86eea7b4d
Author: Jonathan Wakely 
Date:   Thu May 15 19:32:01 2025 +0100

libstdc++: Fix std::format of chrono::local_days with {} [PR120293]

Formatting of chrono::local_days with an empty chrono-specs should be
equivalent to inserting it into an ostream, which should use the
overload for inserting chrono::sys_days into an ostream. The
implementation of empty chrono-specs in _M_format_to_ostream takes some
short cuts, and that wasn't being done correctly for chrono::local_days.

libstdc++-v3/ChangeLog:

PR libstdc++/120293
* include/bits/chrono_io.h (_M_format_to_ostream): Add special
case for local_time convertible to local_days.
* testsuite/std/time/clock/local/io.cc: Check formatting of
chrono::local_days.

Reviewed-by: Tomasz Kamiński 

Diff:
---
 libstdc++-v3/include/bits/chrono_io.h | 3 +++
 libstdc++-v3/testsuite/std/time/clock/local/io.cc | 3 +++
 2 files changed, 6 insertions(+)

diff --git a/libstdc++-v3/include/bits/chrono_io.h 
b/libstdc++-v3/include/bits/chrono_io.h
index ace8b9f26292..92a3098e808c 100644
--- a/libstdc++-v3/include/bits/chrono_io.h
+++ b/libstdc++-v3/include/bits/chrono_io.h
@@ -766,6 +766,9 @@ namespace __format
  // sys_time with period greater or equal to days:
  if constexpr (is_convertible_v<_Tp, chrono::sys_days>)
__os << _S_date(__t);
+ // Or a local_time with period greater or equal to days:
+ else if constexpr (is_convertible_v<_Tp, chrono::local_days>)
+   __os << _S_date(__t);
  else // Or it's formatted as "{:L%F %T}":
{
  auto __days = chrono::floor(__t);
diff --git a/libstdc++-v3/testsuite/std/time/clock/local/io.cc 
b/libstdc++-v3/testsuite/std/time/clock/local/io.cc
index b4d562f36d12..67818e876497 100644
--- a/libstdc++-v3/testsuite/std/time/clock/local/io.cc
+++ b/libstdc++-v3/testsuite/std/time/clock/local/io.cc
@@ -89,6 +89,9 @@ test_format()
 
   s = std::format("{}", local_seconds{});
   VERIFY( s == "1970-01-01 00:00:00" );
+
+  s = std::format("{}", local_days{}); // PR libstdc++/120293
+  VERIFY( s == "1970-01-01" );
 }
 
 void

[gcc r16-732] libstdc++: Fix some Clang -Wsystem-headers warnings in

[Jonathan Wakely via Libstdc++-cvs]

https://gcc.gnu.org/g:1197f896ae5558f27baa929a10f66447aaafb681

commit r16-732-g1197f896ae5558f27baa929a10f66447aaafb681
Author: Jonathan Wakely 
Date:   Fri May 16 11:54:46 2025 +0100

libstdc++: Fix some Clang -Wsystem-headers warnings in 

libstdc++-v3/ChangeLog:

* include/std/ranges (_ZipTransform::operator()): Remove name of
unused parameter.
(chunk_view::_Iterator, stride_view::_Iterator): Likewise.
(join_with_view): Declare _Iterator and _Sentinel as class
instead of struct.
(repeat_view): Declare _Iterator as class instead of struct.

Reviewed-by: Tomasz Kamiński 

Diff:
---
 libstdc++-v3/include/std/ranges | 12 ++--
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/libstdc++-v3/include/std/ranges b/libstdc++-v3/include/std/ranges
index 9300c364a165..210ac8274fc1 100644
--- a/libstdc++-v3/include/std/ranges
+++ b/libstdc++-v3/include/std/ranges
@@ -5336,7 +5336,7 @@ namespace views::__adaptor
requires move_constructible> && 
regular_invocable&>
  && is_object_v&>>>
constexpr auto
-   operator() [[nodiscard]] (_Fp&& __f) const
+   operator() [[nodiscard]] (_Fp&&) const
{
  return views::empty&>>>;
}
@@ -6598,7 +6598,7 @@ namespace views::__adaptor
 }
 
 friend constexpr difference_type
-operator-(default_sentinel_t __y, const _Iterator& __x)
+operator-(default_sentinel_t, const _Iterator& __x)
   requires sized_sentinel_for, iterator_t<_Base>>
 { return __detail::__div_ceil(__x._M_end - __x._M_current, __x._M_n); }
 
@@ -7287,8 +7287,8 @@ namespace views::__adaptor
using iterator_category = decltype(_S_iter_cat());
 };
 
-template struct _Iterator;
-template struct _Sentinel;
+template class _Iterator;
+template class _Sentinel;
 
   public:
 join_with_view() requires (default_initializable<_Vp>
@@ -7743,7 +7743,7 @@ namespace views::__adaptor
 __detail::__box<_Tp> _M_value;
 [[no_unique_address]] _Bound _M_bound = _Bound();
 
-struct _Iterator;
+class _Iterator;
 
 template
 friend constexpr auto
@@ -8303,7 +8303,7 @@ namespace views::__adaptor
 }
 
 friend constexpr difference_type
-operator-(default_sentinel_t __y, const _Iterator& __x)
+operator-(default_sentinel_t, const _Iterator& __x)
   requires sized_sentinel_for, iterator_t<_Base>>
 { return __detail::__div_ceil(__x._M_end - __x._M_current, __x._M_stride); 
}

[gcc r16-729] RISC-V: Rename conflicting variables in gen-riscv-ext-texi.cc

[Kito Cheng via Gcc-cvs]

https://gcc.gnu.org/g:11936041970a45e5cf9a75110f365398451be6b5

commit r16-729-g11936041970a45e5cf9a75110f365398451be6b5
Author: zhusonghe 
Date:   Mon May 19 10:43:48 2025 +0800

RISC-V: Rename conflicting variables in gen-riscv-ext-texi.cc

The variables `major` and `minor` in `gen-riscv-ext-texi.cc`
conflict with the macros of the same name defined in ``,
which are exposed when building with newer versions of GCC on older
Linux distributions (e.g., Ubuntu 18.04). To resolve this, we rename them
to `major_version` and `minor_version` respectively. This aligns with the
GCC community's recommended practice [1] and improves code clarity.

[1] https://gcc.gnu.org/pipermail/gcc-patches/2025-May/683881.html

gcc/ChangeLog:

* config/riscv/gen-riscv-ext-texi.cc (struct version_t):rename
major/minor to major_version/minor_version.

Signed-off-by: Songhe Zhu 

Diff:
---
 gcc/config/riscv/gen-riscv-ext-texi.cc | 16 
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/gcc/config/riscv/gen-riscv-ext-texi.cc 
b/gcc/config/riscv/gen-riscv-ext-texi.cc
index e15fdbf36f6e..c29a375d56c4 100644
--- a/gcc/config/riscv/gen-riscv-ext-texi.cc
+++ b/gcc/config/riscv/gen-riscv-ext-texi.cc
@@ -6,22 +6,22 @@
 
 struct version_t
 {
-  int major;
-  int minor;
+  int major_version;
+  int minor_version;
   version_t (int major, int minor,
 enum riscv_isa_spec_class spec = ISA_SPEC_CLASS_NONE)
-: major (major), minor (minor)
+: major_version (major), minor_version (minor)
   {}
   bool operator<(const version_t &other) const
   {
-if (major != other.major)
-  return major < other.major;
-return minor < other.minor;
+if (major_version != other.major_version)
+  return major_version < other.major_version;
+return minor_version < other.minor_version;
   }
 
   bool operator== (const version_t &other) const
   {
-return major == other.major && minor == other.minor;
+return major_version == other.major_version && minor_version == 
other.minor_version;
   }
 };
 
@@ -39,7 +39,7 @@ print_ext_doc_entry (const std::string &ext_name, const 
std::string &full_name,
   printf ("@tab");
   for (const auto &version : unique_versions)
 {
-  printf (" %d.%d", version.major, version.minor);
+  printf (" %d.%d", version.major_version, version.minor_version);
 }
   printf ("\n");
   printf ("@tab %s", full_name.c_str ());

[gcc r15-9705] libgomp.{c, fortran}/interop-{hip, cuda}: Fix dg-run target selection

[Tobias Burnus via Gcc-cvs]

https://gcc.gnu.org/g:6f607c9174ea8cc257b5d2f82fe1fe1e26ddbbf2

commit r15-9705-g6f607c9174ea8cc257b5d2f82fe1fe1e26ddbbf2
Author: Tobias Burnus 
Date:   Fri May 9 10:57:44 2025 +0200

libgomp.{c,fortran}/interop-{hip,cuda}: Fix dg-run target selection

While the tests checked whether the CUDA/HIP runtime is available
before processing them, the execution was then done unconditionally,
leading to FAIL when the default device was the host (or the wrong
offload device).

Now the test is only executed ('run') when the default device is an
Nvidia or AMD GPU (depending on the test case, cf. the test file name).
Otherwise, only a 'link' test is done. (Except when the effective-target
check cannot find the runtime lib - then the test is skipped [as before].)

Note: The cublas/hipblas tests use variant functions and iterate over
all devices, such that the cublas or hipblas, respectively, is only
called when the active device is an AMD or Nvidia device, respectively,
while for the host and other device types the fallback is called.

libgomp/ChangeLog:

* testsuite/libgomp.c/interop-cuda-full.c: Use 'link' instead
of 'run' when the default device is "! offload_device_nvptx".
* testsuite/libgomp.c/interop-cuda-libonly.c: Likewise.
* testsuite/libgomp.c/interop-hip-nvidia-full.c: Likewise.
* testsuite/libgomp.c/interop-hip-nvidia-no-headers.c: Likewise.
* testsuite/libgomp.c/interop-hip-nvidia-no-hip-header.c: Likewise.
* testsuite/libgomp.fortran/interop-hip-nvidia-full.F90: Likewise.
* testsuite/libgomp.fortran/interop-hip-nvidia-no-module.F90: 
Likewise.
* testsuite/libgomp.c/interop-hip-amd-full.c: Use 'link' instead
of 'run' when the default device is "! offload_device_gcn".
* testsuite/libgomp.c/interop-hip-amd-no-hip-header.c: Likewise.
* testsuite/libgomp.fortran/interop-hip-amd-full.F90: Likewise.
* testsuite/libgomp.fortran/interop-hip-amd-no-module.F90: Likewise.

(cherry picked from commit 94e63410474a36655e1800387eabd73a6f930048)

Diff:
---
 libgomp/testsuite/libgomp.c/interop-cuda-full.c| 3 +++
 libgomp/testsuite/libgomp.c/interop-cuda-libonly.c | 3 +++
 libgomp/testsuite/libgomp.c/interop-hip-amd-full.c | 3 +++
 libgomp/testsuite/libgomp.c/interop-hip-amd-no-hip-header.c| 3 +++
 libgomp/testsuite/libgomp.c/interop-hip-nvidia-full.c  | 3 +++
 libgomp/testsuite/libgomp.c/interop-hip-nvidia-no-headers.c| 3 +++
 libgomp/testsuite/libgomp.c/interop-hip-nvidia-no-hip-header.c | 3 +++
 libgomp/testsuite/libgomp.fortran/interop-hip-amd-full.F90 | 3 +++
 libgomp/testsuite/libgomp.fortran/interop-hip-amd-no-module.F90| 3 +++
 libgomp/testsuite/libgomp.fortran/interop-hip-nvidia-full.F90  | 3 +++
 libgomp/testsuite/libgomp.fortran/interop-hip-nvidia-no-module.F90 | 3 +++
 11 files changed, 33 insertions(+)

diff --git a/libgomp/testsuite/libgomp.c/interop-cuda-full.c 
b/libgomp/testsuite/libgomp.c/interop-cuda-full.c
index 38aa6b130bb7..c48a934978d9 100644
--- a/libgomp/testsuite/libgomp.c/interop-cuda-full.c
+++ b/libgomp/testsuite/libgomp.c/interop-cuda-full.c
@@ -1,3 +1,6 @@
+/* { dg-do run { target { offload_device_nvptx } } } */
+/* { dg-do link { target { ! offload_device_nvptx } } } */
+
 /* { dg-require-effective-target openacc_cuda } */
 /* { dg-require-effective-target openacc_cudart } */
 /* { dg-additional-options "-lcuda -lcudart" } */
diff --git a/libgomp/testsuite/libgomp.c/interop-cuda-libonly.c 
b/libgomp/testsuite/libgomp.c/interop-cuda-libonly.c
index 17cbb1591838..bc257a24ee89 100644
--- a/libgomp/testsuite/libgomp.c/interop-cuda-libonly.c
+++ b/libgomp/testsuite/libgomp.c/interop-cuda-libonly.c
@@ -1,3 +1,6 @@
+/* { dg-do run { target { offload_device_nvptx } } } */
+/* { dg-do link { target { ! offload_device_nvptx } } } */
+
 /* { dg-require-effective-target openacc_libcudart } */
 /* { dg-require-effective-target openacc_libcuda } */
 /* { dg-additional-options "-lcuda -lcudart" } */
diff --git a/libgomp/testsuite/libgomp.c/interop-hip-amd-full.c 
b/libgomp/testsuite/libgomp.c/interop-hip-amd-full.c
index d7725fc8e349..bd44f442210d 100644
--- a/libgomp/testsuite/libgomp.c/interop-hip-amd-full.c
+++ b/libgomp/testsuite/libgomp.c/interop-hip-amd-full.c
@@ -1,3 +1,6 @@
+/* { dg-do run { target { offload_device_gcn } } } */
+/* { dg-do link { target { ! offload_device_gcn } } } */
+
 /* { dg-require-effective-target gomp_hip_header_amd } */
 /* { dg-require-effective-target gomp_libamdhip64 } */
 /* { dg-additional-options "-lamdhip64" } */
diff --git a/libgomp/testsuite/libgomp.c/interop-hip-amd-no-hip-header.c 
b/libgomp/testsuite/libgomp.c/interop-hip-amd-no-hip-header.c
index 25845379fcc1..91ad987631f5 100644
--- a/libgomp/testsuite/libgomp.c/interop-hip-amd

[gcc r15-9709] libstdc++: Fix dangling pointer in fs::path::operator+=(*this) [PR120029]

[Jonathan Wakely via Libstdc++-cvs]

https://gcc.gnu.org/g:beb0ffd36eedf0542d7f408e87efee4bee3150f8

commit r15-9709-gbeb0ffd36eedf0542d7f408e87efee4bee3150f8
Author: Jonathan Wakely 
Date:   Wed Apr 30 17:31:01 2025 +0100

libstdc++: Fix dangling pointer in fs::path::operator+=(*this) [PR120029]

When concatenating a path we reallocate the left operand's storage to
make room for the new components being added. When the two operands are
the same object, or the right operand is one of the components of the
left operand, the reallocation invalidates the pointers that refer
into the right operand's storage.

The solution in this commit is to detect these aliasing cases and just
do the concatenation in terms of the contained string, as that code
already handles the case where the string aliases the path. The standard
specifies the concatenation in terms of the native() string, so all this
change does is disable the optimized implementation of concatenation for
path objects which attempts to avoid re-parsing the path from the
concatenated string.

The potential loss of performance for this case isn't likely to be an
issue, because concatenating a path with itself (or one of its existing
components) probably isn't a common use case.

The Filesystem TS implementation doesn't have the optimized form of
concatenation and always does it in terms of the native string and
reparsing the whole thing, so doesn't have this bug. A test is added to
confirm that anyway (that test has some slightly different results due
to different behaviour for trailing slashes and implicit "." filenames
in the TS spec).

libstdc++-v3/ChangeLog:

PR libstdc++/120029
* src/c++17/fs_path.cc (path::operator+=(const path&)): Handle
parameters that alias the path or one of its components.
* testsuite/27_io/filesystem/path/concat/120029.cc: New test.
* testsuite/experimental/filesystem/path/concat/120029.cc: New
test.

(cherry picked from commit a067cbcdcc5f599a2b7d607e89674533d23c652d)

Diff:
---
 libstdc++-v3/src/c++17/fs_path.cc  | 10 +++
 .../27_io/filesystem/path/concat/120029.cc | 72 +
 .../experimental/filesystem/path/concat/120029.cc  | 74 ++
 3 files changed, 156 insertions(+)

diff --git a/libstdc++-v3/src/c++17/fs_path.cc 
b/libstdc++-v3/src/c++17/fs_path.cc
index 6582f10209a0..215afa08ad25 100644
--- a/libstdc++-v3/src/c++17/fs_path.cc
+++ b/libstdc++-v3/src/c++17/fs_path.cc
@@ -880,6 +880,16 @@ path::operator+=(const path& p)
   return *this;
 }
 
+  // Handle p += p which would otherwise access dangling pointers after
+  // reallocating _M_cmpts and _M_pathname.
+  if (&p == this) [[unlikely]]
+return *this += p.native();
+  // Handle p += *i where i is in [p.begin(),p.end()), for the same reason.
+  if (_M_type() == _Type::_Multi && p._M_type() != _Type::_Multi)
+for (const path& cmpt : *this)
+  if (&cmpt == &p) [[unlikely]]
+   return *this += p.native();
+
 #if _GLIBCXX_FILESYSTEM_IS_WINDOWS
   if (_M_type() == _Type::_Root_name
   || (_M_type() == _Type::_Filename && _M_pathname.size() == 1))
diff --git a/libstdc++-v3/testsuite/27_io/filesystem/path/concat/120029.cc 
b/libstdc++-v3/testsuite/27_io/filesystem/path/concat/120029.cc
new file mode 100644
index ..5153d594b50f
--- /dev/null
+++ b/libstdc++-v3/testsuite/27_io/filesystem/path/concat/120029.cc
@@ -0,0 +1,72 @@
+// { dg-do run { target c++17 } }
+
+// Bug libstdc++/120029
+// Dangling iterator usage in path::operator+=(const path& p) when this == p
+
+#include 
+#include 
+
+namespace fs = std::filesystem;
+
+void
+test_root_dir()
+{
+  fs::path p = "/";
+  p += p;
+  p += p;
+  VERIFY( p == "" );
+  p += p.filename();
+  VERIFY( p == "" );
+  p += *std::prev(p.end());
+  VERIFY( p == "" );
+}
+
+void
+test_root_name()
+{
+  fs::path p = "C:/";
+  p += p;
+  p += p;
+  VERIFY( p == "C:/C:/C:/C:/" );
+  p += p.filename();
+  VERIFY( p == "C:/C:/C:/C:/" );
+  p += *std::prev(p.end());
+  VERIFY( p == "C:/C:/C:/C:/" );
+}
+
+void
+test_filename()
+{
+  fs::path p = "file";
+  p += p;
+  p += p;
+  VERIFY( p == "filefilefilefile" );
+  p += p.filename();
+  VERIFY( p == "filefilefilefilefilefilefilefile" );
+  p += *std::prev(p.end());
+  VERIFY( p == 
"filefilefilefilefilefilefilefilefilefilefilefilefilefilefilefile" );
+}
+
+void
+test_multi()
+{
+  fs::path p = "/home/username/Documents/mu";
+  p += p;
+  p += p;
+  VERIFY( p == 
"/home/username/Documents/mu/home/username/Documents/mu/home/username/Documents/mu/home/username/Documents/mu"
 );
+  p += p.filename();
+  VERIFY( p == 
"/home/username/Documents/mu/home/username/Documents/mu/home/username/Documents/mu/home/username/Documents/mumu"
 );
+  p += *std::prev(p.end());
+  VERIFY( p == 
"/home/username/Documents/mu/home/username/Documents/mu/home/u

[gcc r15-9711] libstdc++: Fix some Clang -Wsystem-headers warnings in

[Jonathan Wakely via Gcc-cvs]

https://gcc.gnu.org/g:06a10db2211615e193b5fbe12aa72128b8b0a366

commit r15-9711-g06a10db2211615e193b5fbe12aa72128b8b0a366
Author: Jonathan Wakely 
Date:   Fri May 16 11:54:46 2025 +0100

libstdc++: Fix some Clang -Wsystem-headers warnings in 

libstdc++-v3/ChangeLog:

* include/std/ranges (_ZipTransform::operator()): Remove name of
unused parameter.
(chunk_view::_Iterator, stride_view::_Iterator): Likewise.
(join_with_view): Declare _Iterator and _Sentinel as class
instead of struct.
(repeat_view): Declare _Iterator as class instead of struct.

Reviewed-by: Tomasz Kamiński 
(cherry picked from commit 1197f896ae5558f27baa929a10f66447aaafb681)

Diff:
---
 libstdc++-v3/include/std/ranges | 12 ++--
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/libstdc++-v3/include/std/ranges b/libstdc++-v3/include/std/ranges
index 9300c364a165..210ac8274fc1 100644
--- a/libstdc++-v3/include/std/ranges
+++ b/libstdc++-v3/include/std/ranges
@@ -5336,7 +5336,7 @@ namespace views::__adaptor
requires move_constructible> && 
regular_invocable&>
  && is_object_v&>>>
constexpr auto
-   operator() [[nodiscard]] (_Fp&& __f) const
+   operator() [[nodiscard]] (_Fp&&) const
{
  return views::empty&>>>;
}
@@ -6598,7 +6598,7 @@ namespace views::__adaptor
 }
 
 friend constexpr difference_type
-operator-(default_sentinel_t __y, const _Iterator& __x)
+operator-(default_sentinel_t, const _Iterator& __x)
   requires sized_sentinel_for, iterator_t<_Base>>
 { return __detail::__div_ceil(__x._M_end - __x._M_current, __x._M_n); }
 
@@ -7287,8 +7287,8 @@ namespace views::__adaptor
using iterator_category = decltype(_S_iter_cat());
 };
 
-template struct _Iterator;
-template struct _Sentinel;
+template class _Iterator;
+template class _Sentinel;
 
   public:
 join_with_view() requires (default_initializable<_Vp>
@@ -7743,7 +7743,7 @@ namespace views::__adaptor
 __detail::__box<_Tp> _M_value;
 [[no_unique_address]] _Bound _M_bound = _Bound();
 
-struct _Iterator;
+class _Iterator;
 
 template
 friend constexpr auto
@@ -8303,7 +8303,7 @@ namespace views::__adaptor
 }
 
 friend constexpr difference_type
-operator-(default_sentinel_t __y, const _Iterator& __x)
+operator-(default_sentinel_t, const _Iterator& __x)
   requires sized_sentinel_for, iterator_t<_Base>>
 { return __detail::__div_ceil(__x._M_end - __x._M_current, __x._M_stride); 
}

[gcc r15-9710] libstdc++: Fix std::format of chrono::local_days with {} [PR120293]

[Jonathan Wakely via Gcc-cvs]

https://gcc.gnu.org/g:4bc5697341f1eda3b20c16dcf173948b2d1bd5c8

commit r15-9710-g4bc5697341f1eda3b20c16dcf173948b2d1bd5c8
Author: Jonathan Wakely 
Date:   Thu May 15 19:32:01 2025 +0100

libstdc++: Fix std::format of chrono::local_days with {} [PR120293]

Formatting of chrono::local_days with an empty chrono-specs should be
equivalent to inserting it into an ostream, which should use the
overload for inserting chrono::sys_days into an ostream. The
implementation of empty chrono-specs in _M_format_to_ostream takes some
short cuts, and that wasn't being done correctly for chrono::local_days.

libstdc++-v3/ChangeLog:

PR libstdc++/120293
* include/bits/chrono_io.h (_M_format_to_ostream): Add special
case for local_time convertible to local_days.
* testsuite/std/time/clock/local/io.cc: Check formatting of
chrono::local_days.

Reviewed-by: Tomasz Kamiński 
(cherry picked from commit 1ed7585bf60ba9940ca5dc6d2c72dba86eea7b4d)

Diff:
---
 libstdc++-v3/include/bits/chrono_io.h | 3 +++
 libstdc++-v3/testsuite/std/time/clock/local/io.cc | 3 +++
 2 files changed, 6 insertions(+)

diff --git a/libstdc++-v3/include/bits/chrono_io.h 
b/libstdc++-v3/include/bits/chrono_io.h
index f5aa8a3e18af..7ab989f59a1c 100644
--- a/libstdc++-v3/include/bits/chrono_io.h
+++ b/libstdc++-v3/include/bits/chrono_io.h
@@ -782,6 +782,9 @@ namespace __format
  // sys_time with period greater or equal to days:
  if constexpr (is_convertible_v<_Tp, chrono::sys_days>)
__os << _S_date(__t);
+ // Or a local_time with period greater or equal to days:
+ else if constexpr (is_convertible_v<_Tp, chrono::local_days>)
+   __os << _S_date(__t);
  else // Or it's formatted as "{:L%F %T}":
{
  auto __days = chrono::floor(__t);
diff --git a/libstdc++-v3/testsuite/std/time/clock/local/io.cc 
b/libstdc++-v3/testsuite/std/time/clock/local/io.cc
index b4d562f36d12..67818e876497 100644
--- a/libstdc++-v3/testsuite/std/time/clock/local/io.cc
+++ b/libstdc++-v3/testsuite/std/time/clock/local/io.cc
@@ -89,6 +89,9 @@ test_format()
 
   s = std::format("{}", local_seconds{});
   VERIFY( s == "1970-01-01 00:00:00" );
+
+  s = std::format("{}", local_days{}); // PR libstdc++/120293
+  VERIFY( s == "1970-01-01" );
 }
 
 void

[gcc r15-9708] libstdc++: Fix std::format_kind primary template for Clang [PR120190]

[Jonathan Wakely via Gcc-cvs]

https://gcc.gnu.org/g:53680c1aa92d9f78e8255fbf696c0ed36f160650

commit r15-9708-g53680c1aa92d9f78e8255fbf696c0ed36f160650
Author: Jonathan Wakely 
Date:   Thu May 15 11:01:05 2025 +0100

libstdc++: Fix std::format_kind primary template for Clang [PR120190]

Although Clang trunk has been adjusted to handle our std::format_kind
definition (because they need to be able to compile the GCC 15.1.0
release), it's probably better to not rely on something that they might
start diagnosing again in future.

Define the primary template in terms of an immediately invoked function
expression, so that we can put a static_assert(false) in the body.

libstdc++-v3/ChangeLog:

PR libstdc++/120190
* include/std/format (format_kind): Adjust primary template to
not depend on itself.
* testsuite/std/format/ranges/format_kind_neg.cc: Adjust
expected errors. Check more invalid specializations.

Reviewed-by: Tomasz Kamiński 
Reviewed-by: Daniel Krügler 
(cherry picked from commit c65725eccbabf3b9b5965f27fff2d3b9f6c75930)

Diff:
---
 libstdc++-v3/include/std/format   | 19 ++-
 .../testsuite/std/format/ranges/format_kind_neg.cc| 15 ++-
 2 files changed, 24 insertions(+), 10 deletions(-)

diff --git a/libstdc++-v3/include/std/format b/libstdc++-v3/include/std/format
index 7d3067098bef..8beef93c7809 100644
--- a/libstdc++-v3/include/std/format
+++ b/libstdc++-v3/include/std/format
@@ -5111,13 +5111,22 @@ namespace __format
 debug_string
   };
 
-  /// @cond undocumented
+  /** @brief A constant determining how a range should be formatted.
+   *
+   * The primary template of `std::format_kind` cannot be instantiated.
+   * There is a partial specialization for input ranges and you can
+   * specialize the variable template for your own cv-unqualified types
+   * that satisfy the `ranges::input_range` concept.
+   *
+   * @since C++23
+   */
   template
-constexpr auto format_kind =
-__primary_template_not_defined(
-  format_kind<_Rg> // you can specialize this for non-const input ranges
-);
+constexpr auto format_kind = []{
+  static_assert(false, "cannot use primary template of 
'std::format_kind'");
+  return type_identity<_Rg>{};
+}();
 
+  /// @cond undocumented
   template
 consteval range_format
 __fmt_kind()
diff --git a/libstdc++-v3/testsuite/std/format/ranges/format_kind_neg.cc 
b/libstdc++-v3/testsuite/std/format/ranges/format_kind_neg.cc
index bf8619d3d276..0d761ae11185 100644
--- a/libstdc++-v3/testsuite/std/format/ranges/format_kind_neg.cc
+++ b/libstdc++-v3/testsuite/std/format/ranges/format_kind_neg.cc
@@ -5,9 +5,14 @@
 
 #include 
 
-template struct Tester { };
+void test()
+{
+  (void) std::format_kind; // { dg-error "here" }
+  (void) std::format_kind; // { dg-error "here" }
+  (void) std::format_kind; // { dg-error "here" }
+  (void) std::format_kind; // { dg-error "here" }
+  (void) std::format_kind; // { dg-error "here" }
+  (void) std::format_kind; // { dg-error "here" }
+}
 
-Tester> t; // { dg-error "here" }
-
-// { dg-error "use of 'std::format_kind" "" { target *-*-* } 0 }
-// { dg-error "primary_template_not_defined" "" { target *-*-* } 0 }
+// { dg-error "cannot use primary template of 'std::format_kind'" "" { target 
*-*-* } 0 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Creation méthode initialisation descripteur

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:c622acde6c26fede4f195828be483df8ea13ebb1

commit c622acde6c26fede4f195828be483df8ea13ebb1
Author: Mikael Morin 
Date:   Thu Dec 5 20:30:08 2024 +0100

Creation méthode initialisation descripteur

Utilisation méthode initialisation descripteur gfc_trans_deferred_array

Correction variable inutilisée

Correction segmentation fault

Correction regression allocatable attribute

Ajout conversion elem_len

conversion type longueur chaine

Initialisation descripteur champ par champ

Silence uninitialized warning.

Diff:
---
 gcc/fortran/expr.cc|  25 +++-
 gcc/fortran/gfortran.h |   1 +
 gcc/fortran/primary.cc |  84 +++-
 gcc/fortran/trans-array.cc | 283 +
 gcc/fortran/trans-intrinsic.cc |   2 +-
 5 files changed, 331 insertions(+), 64 deletions(-)

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 0753667e061d..cc55e019e071 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5421,27 +5421,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
   gfc_ref *ref;
 
   if (expr->rank == 0)
-return NULL;
+return nullptr;
 
   /* Follow any component references.  */
   if (expr->expr_type == EXPR_VARIABLE
   || expr->expr_type == EXPR_CONSTANT)
 {
-  if (expr->symtree)
-   as = expr->symtree->n.sym->as;
+  gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+  if (sym
+ && sym->ts.type == BT_CLASS)
+   as = CLASS_DATA (sym)->as;
+  else if (sym)
+   as = sym->as;
   else
-   as = NULL;
+   as = nullptr;
 
   for (ref = expr->ref; ref; ref = ref->next)
{
  switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+   gfc_component *comp = ref->u.c.component;
+   if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+   else
+ as = comp->as;
+ }
  continue;
 
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
  continue;
 
case REF_ARRAY:
@@ -5451,7 +5462,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
  case AR_ELEMENT:
  case AR_SECTION:
  case AR_UNKNOWN:
-   as = NULL;
+   as = nullptr;
continue;
 
  case AR_FULL:
@@ -5463,7 +5474,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
 }
   else
-as = NULL;
+as = nullptr;
 
   return as;
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5ef70378b1b5..b480992d144a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4095,6 +4095,7 @@ const char *gfc_dt_lower_string (const char *);
 const char *gfc_dt_upper_string (const char *);
 
 /* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
 symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 161d4c269648..7c96d5c68757 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2867,42 +2867,14 @@ check_substring:
 }
 
 
-/* Given an expression that is a variable, figure out what the
-   ultimate variable's type and attribute is, traversing the reference
-   structures if necessary.
-
-   This subroutine is trickier than it looks.  We start at the base
-   symbol and store the attribute.  Component references load a
-   completely new attribute.
-
-   A couple of rules come into play.  Subobjects of targets are always
-   targets themselves.  If we see a component that goes through a
-   pointer, then the expression must also be a target, since the
-   pointer is associated with something (if it isn't core will soon be
-   dumped).  If we see a full part or section of an array, the
-   expression is also an array.
-
-   We can have at most one full array reference.  */
-
 symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
 {
-  int dimension, codimension, pointer, allocatable, target, optional;
+  int dimension, codimension, pointer, allocatable, target;
   symbol_attribute attr;
-  gfc_ref *ref;
-  gfc_symbol *sym;
-  gfc_component *comp;
-  bool has_inquiry_part;
-
-  if (expr->expr_type != EXPR_VARIABLE
-  && expr->expr_type != EXPR_FUNCTION
-  && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
-gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
-  sym = expr->symtree->n.sym;
   attr = sym->attr;
 
-  optional = attr.optional;
   if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
 {
 

[gcc/mikael/heads/refactor_descriptor_v05] (1665 commits) Correction assumed_type_2

[Mikael Morin via Gcc-cvs]

The branch 'mikael/heads/refactor_descriptor_v05' was updated to point to:

 01bd6e39c64f... Correction assumed_type_2

It previously pointed to:

 482194f182ad... Correction régressions {maxloc,minloc}_nan_2

Diff:

!!! WARNING: THE FOLLOWING COMMITS ARE NO LONGER ACCESSIBLE (LOST):
---

  482194f... Correction régressions {maxloc,minloc}_nan_2
  f288b88... Correction régression {minloc,maxloc}_nan_1
  551a0e2... Correction régression allocate_with_source_11
  051482b... Correction partielle allocate_with_source_11
  cb16a9e... Correction régression class_67
  d2dd4bf... gimple-exec: Prise en charge TARGET_MEM_REF sans index ni s
  6c4ebec... Correction régression class_dummy_7
  d8822da... gimple-exec: prise en charge memcpy
  c48991d... Correction régression select_type_50
  ca8f3f1... Correction régression PR100103
  a6453e6... Correction régression char_allocation_1
  3a432b1... Correction régression bind_c_char_9
  640cd6a... Correction régression alloc_comp_auto_array_1
  adc44bd... Correction régression pr117797
  08630b0... Mise à jour dump coarray_lib_this_image_1
  1512e84... Mise à jour motif dump pr32921.f
  5616ecf... Mise à jour motif dump c_loc_test_22.f90
  447e2b8... Correction régression findloc_2
  e267889... Mise à jour dump char_cast_1 et char_cast_2
  bf4bdad... Mise à jour dump unconstrained_commons.f
  796fa83... Correction régression unsigned_23
  8ff38c8... gimple-exec: Prise en charge VIEW_CONVERT_EXPR
  a2338c4... Revert "Correction régression power_4"
  6b8a682... gimple-exec: Prise en charge label
  c8fc50b... gimple-exec: Ajout/modifications traces exécution
  1ee62e7... Suppression vérif dump ipcp-array-2.f90
  7d6690e... Correction motif dump pr48636.f90
  a42bca3... Correction régressions loop versioning
  81743d3... Mise à jour dump goacc/array-with-dt-3
  15e1361... Correction régression loop_versioning_1
  26a850f... Correction régression affinity-clause-5.f90
  75d789c... Correction régression power_4
  1d88438... Correction allocatable_uninitialized_1
  907b5fe... Correction régression reassoc_6
  3423330... Correction régression id-24.f
  93b2a15... Correction régression pr85938
  3085cee... Correction régression pr33074
  0b83091... Ajout warnings supplémentaires array-with-dt-4
  f7d8d1e... Correction régression parloops-exit-first-loop-alt.f95
  47f336f... Mise à jour motif dumps kernels-alias-4.f95
  5df9615... Suppression borne supérieure type si dynamique
  3146f6e... Modif dump c_f_pointer_tests_3
  55a8162... Correction régression pr83149
  88879d1... Correction régression pr66251
  129921d... Correction régression pr93671
  570be3a... Correction régression intrinsic_mmloc_2
  1b73c19... Correction régression loop_versioning_8
  76bee02... Correction régression oldstyle_1
  708eb59... Correction régression guality/arg1
  5fcd9bb... Correction régression pr77973
  b5c4c48... Correction regression class_result_9
  a8aae29... gimple-exec: évaluation comparaison adresse avec NULL
  783f446... gimple-exec: implémentation initiale memcpy
  35402be... gimple-exec: support get_at mixed values
  b76cd05... gimple-exec prise en charge set undefined
  cc687fb... Correction régression ISO_Fortran_binding_4
  54cd73b... Correction régression class_allocate_19
  388f4ef... Correction régression char_pack_2
  39a90d2... Correction régressions realloc_on_assign_{10,11}
  7ec5f15... Revert "Correction régression realloc_on_assign_10"
  0d8c1cf... Correction régression secnds
  2b847cd... Correction régression maxval_char_2
  a49f29d... Correction régression scalar_mask_2
  e5551d0... Correction régression char_unpack_2
  72dab60... Correction régression pr61775
  df1d679... Correction régression pointer_function_result_1
  211046c... Correction régression assumed_size.f90
  406b515... Correction régression class_array_23
  84b20be... Correction régression array_temporaries_3
  31853d6... Correction régression array_assignment_5
  5d3ebfb... Correction régression strarray_4
  6696b3e... Restauration intrinsic stride (correction régression final
  03f62c0... Correction régression pack_generic
  86b472e... Correction régression alloc_comp_result_1
  dc0220b... Correction régression realloc_on_assign_10
  fb23bc7... Correction régression matmul_bounds_20
  46c4906... Sauvegarde simplification MEM_REF.
  9a35569... Correction partielle matmul_bounds_6
  10e06bd... Correction test matmul_bounds_6
  48bbb4d... gimple-exec: prise en charge négation fp
  b02ba33... gimple-exec: Implémentation calloc et fp+
  6eab554... Correction régression matmul_bounds_12 (renseignement span
  f47246a... Correction régression intent_out_14
  8c1fb2f... Correction régression pdt_7
  e25b835... Correction régression pr59586.f
  c1f4971... Correction régression derived_comp_array_ref_7
  83eb50a... Correction régression matmul_4
  e2cf3a9... Correction régression repack_arrays_1
  20f2e28... Correction régression auto_char_dummy_array_3
 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:8da6025bc60c71d1432fabb919da5a0d0885520c

commit 8da6025bc60c71d1432fabb919da5a0d0885520c
Author: Mikael Morin 
Date:   Wed Dec 11 16:03:10 2024 +0100

Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class

essai suppression

Suppression fonction inutilisée

Sauvegarde compilation OK

Correction régression

Sauvegarde correction null_actual_6

Commentage fonction inutilisée

Correction bornes descripteur null

Diff:
---
 gcc/fortran/trans-array.cc | 339 +++--
 gcc/fortran/trans-array.h  |   4 +-
 gcc/fortran/trans-expr.cc  |  87 ++--
 3 files changed, 373 insertions(+), 57 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 81fc2182c86c..9eb0784ab7ca 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -594,10 +594,10 @@ get_size_info (gfc_typespec &ts)
if (POINTER_TYPE_P (type))
  type = TREE_TYPE (type);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
-   tree elt_type = TREE_TYPE (type);
+   tree char_type = TREE_TYPE (type);
tree len = ts.u.cl->backend_decl;
return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
-   size_in_bytes (elt_type),
+   size_in_bytes (char_type),
fold_convert (size_type_node, len));
   }
 
@@ -615,8 +615,61 @@ get_size_info (gfc_typespec &ts)
 }
 
 
+class init_info
+{
+public:
+  virtual bool initialize_data () const { return false; }
+  virtual tree get_data_value () const { return NULL_TREE; }
+  virtual gfc_typespec *get_type () const { return nullptr; }
+};
+
+
+class default_init : public init_info
+{
+private:
+  const symbol_attribute &attr; 
+
+public:
+  default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
+  virtual bool initialize_data () const { return !attr.pointer; }
+  virtual tree get_data_value () const {
+if (!initialize_data ())
+  return NULL_TREE;
+
+return null_pointer_node;
+  }
+};
+
+class nullification : public init_info
+{
+private:
+  gfc_typespec &ts;
+
+public:
+  nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+  virtual bool initialize_data () const { return true; }
+  virtual tree get_data_value () const { return null_pointer_node; }
+  virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+class scalar_value : public init_info
+{
+private:
+  gfc_typespec &ts;
+  tree value;
+
+public:
+  scalar_value(gfc_typespec &arg_ts, tree arg_value)
+: ts(arg_ts), value(arg_value) { }
+  virtual bool initialize_data () const { return true; }
+  virtual tree get_data_value () const { return value; }
+  virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+
 static tree
-build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &)
+build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &,
+const init_info &init)
 {
   vec *v = nullptr;
 
@@ -624,11 +677,17 @@ build_dtype (gfc_typespec &ts, int rank, const 
symbol_attribute &)
 
   tree fields = TYPE_FIELDS (type);
 
-  if (ts.type != BT_CLASS)
+  gfc_typespec *type_info = init.get_type ();
+  if (type_info == nullptr)
+type_info = &ts;
+
+  if (!(type_info->type == BT_CLASS
+   || (type_info->type == BT_CHARACTER
+   && type_info->deferred)))
 {
   tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
   tree elem_len_val = fold_convert (TREE_TYPE (elem_len_field),
-   get_size_info (ts));
+   get_size_info (*type_info));
   CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
 }
 
@@ -643,11 +702,11 @@ build_dtype (gfc_typespec &ts, int rank, const 
symbol_attribute &)
   CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
 }
 
-  if (ts.type != BT_CLASS)
+  if (type_info->type != BT_CLASS)
 {
   tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
   tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (ts));
+ get_type_info (*type_info));
   CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
 }
 
@@ -658,8 +717,8 @@ build_dtype (gfc_typespec &ts, int rank, const 
symbol_attribute &)
 /* Build a null array descriptor constructor.  */
 
 vec *
-get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr)
+get_descriptor_init (tree type, gfc_typespec &ts, int rank,
+const symbol_attribute &attr, const init_info &init)
 {
   vec *v = nullptr;
 
@@ -668,15 +727,15 @@ get_default_descriptor_init (tree type, gfc_typespec &ts, 
int rank,
   tree fields = TYPE_FIELDS (type);
 
   /* Don't init pointers by default.  */
-  if 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Déplacement shift descriptor vers gfc_conv_array_parameter

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:37d98507c22fcc0ff6fd4d1e5d4c2ea832e37864

commit 37d98507c22fcc0ff6fd4d1e5d4c2ea832e37864
Author: Mikael Morin 
Date:   Tue Dec 17 17:27:24 2024 +0100

Déplacement shift descriptor vers gfc_conv_array_parameter

Suppression variables inutilisées

Diff:
---
 gcc/fortran/trans-array.cc | 49 ++
 gcc/fortran/trans-array.h  |  2 +-
 gcc/fortran/trans-expr.cc  | 20 +--
 3 files changed, 43 insertions(+), 28 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9eb0784ab7ca..22ec1fc05a14 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1153,6 +1153,43 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, 
tree desc,
 }
 
 
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+  /* Apply a shift of the lbound when supplied.  */
+  for (int dim = 0; dim < rank; ++dim)
+gfc_conv_shift_descriptor_lbound (block, desc, dim,
+ gfc_index_one_node);
+}
+
+
+static bool
+keep_descriptor_lower_bound (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  /* Detect any array references with vector subscripts.  */
+  for (ref = e->ref; ref; ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
+   && ref->u.ar.type != AR_FULL)
+  {
+   int dim;
+   for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+   break;
+   if (dim < ref->u.ar.dimen)
+ break;
+  }
+
+  /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor.  */
+  if (ref || e->expr_type != EXPR_VARIABLE)
+return false;
+
+  return true;
+}
+
+
 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
 
 void
@@ -9466,7 +9503,7 @@ is_pointer (gfc_expr *e)
 void
 gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
  const gfc_symbol *fsym, const char *proc_name,
- tree *size, tree *lbshift, tree *packed)
+ tree *size, bool maybe_shift, tree *packed)
 {
   tree ptr;
   tree desc;
@@ -9703,13 +9740,9 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, 
bool g77,
  stmtblock_t block;
 
  gfc_init_block (&block);
- if (lbshift && *lbshift)
-   {
- /* Apply a shift of the lbound when supplied.  */
- for (int dim = 0; dim < expr->rank; ++dim)
-   gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
- *lbshift);
-   }
+ if (maybe_shift && !keep_descriptor_lower_bound (expr))
+   conv_shift_descriptor (&block, se->expr, expr->rank);
+
  tmp = gfc_class_data_get (ctree);
  if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
  && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 78646275b4ec..17e3d08fdba0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -158,7 +158,7 @@ tree gfc_get_array_span (tree, gfc_expr *);
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
 /* Convert an array for passing as an actual function parameter.  */
 void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
-  const char *, tree *, tree * = nullptr,
+  const char *, tree *, bool = false,
   tree * = nullptr);
 
 /* These work with both descriptors and descriptorless arrays.  */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 667a44aced5d..ea84f4657f29 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -991,8 +991,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_symbol *fsym,
  stmtblock_t block;
  gfc_init_block (&block);
  gfc_ref *ref;
- int dim;
- tree lbshift = NULL_TREE;
 
  /* Array refs with sections indicate, that a for a formal argument
 expecting contiguous repacking needs to be done.  */
@@ -1005,25 +1003,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_symbol *fsym,
  && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
fsym->attr.contiguous = 1;
 
- /* Detect any array references with vector subscripts.  */
- for (ref = e->ref; ref; ref = ref->next)
-   if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
-   && ref->u.ar.type != AR_FULL)
- {
-   for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
-   break;
-   if (dim < ref->u.ar.dimen)
- break;
- }
-

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Utilisation de la méthode de nullification pour nullifier un pointeur

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:cba2c61eab3232721838fda6ce13d041c972a48b

commit cba2c61eab3232721838fda6ce13d041c972a48b
Author: Mikael Morin 
Date:   Wed Dec 18 19:04:41 2024 +0100

Utilisation de la méthode de nullification pour nullifier un pointeur

Correction régression modifiable_p

Correction dump

Ajout assertion

Correction assertion même type

Diff:
---
 gcc/fortran/trans-array.cc  | 96 ++---
 gcc/fortran/trans-array.h   |  1 +
 gcc/fortran/trans-expr.cc   | 35 -
 gcc/testsuite/gfortran.dg/class_allocate_14.f90 |  2 +-
 4 files changed, 106 insertions(+), 28 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8f0dff10fd81..0560c7482ee5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -547,9 +547,9 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree 
desc,
 
 
 static int
-get_type_info (const gfc_typespec &ts)
+get_type_info (const bt &type)
 {
-  switch (ts.type)
+  switch (type)
 {
 case BT_INTEGER:
 case BT_LOGICAL:
@@ -560,7 +560,7 @@ get_type_info (const gfc_typespec &ts)
 case BT_CLASS:
 case BT_VOID:
 case BT_UNSIGNED:
-  return ts.type;
+  return type;
 
 case BT_PROCEDURE:
 case BT_ASSUMED:
@@ -615,11 +615,34 @@ get_size_info (gfc_typespec &ts)
 }
 
 
-class init_info
+class modify_info
 {
 public:
+  virtual bool is_initialization () const { return false; }
   virtual bool initialize_data () const { return false; }
   virtual tree get_data_value () const { return NULL_TREE; }
+};
+
+class nullification : public modify_info
+{
+  virtual bool initialize_data () const { return true; }
+  virtual tree get_data_value () const { return null_pointer_node; }
+  /*
+private:
+  gfc_typespec &ts;
+
+public:
+  null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
+  virtual bool initialize_data () const { return true; }
+  virtual tree get_data_value () const { return null_pointer_node; }
+  virtual gfc_typespec *get_type () const { return &ts; }
+  */
+};
+
+class init_info : public modify_info
+{
+public:
+  virtual bool is_initialization () const { return true; }
   virtual gfc_typespec *get_type () const { return nullptr; }
 };
 
@@ -640,13 +663,13 @@ public:
   }
 };
 
-class nullification : public init_info
+class null_init : public init_info
 {
 private:
   gfc_typespec &ts;
 
 public:
-  nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+  null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
   virtual bool initialize_data () const { return true; }
   virtual tree get_data_value () const { return null_pointer_node; }
   virtual gfc_typespec *get_type () const { return &ts; }
@@ -702,13 +725,12 @@ build_dtype (gfc_typespec &ts, int rank, const 
symbol_attribute &,
   CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
 }
 
-  if (type_info->type != BT_CLASS)
-{
-  tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
-  tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (*type_info));
-  CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
-}
+  tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
+  tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
+ get_type_info (type_info->type == BT_CLASS
+? BT_DERIVED
+: type_info->type));
+  CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
 
   return build_constructor (type, v);
 }
@@ -717,8 +739,8 @@ build_dtype (gfc_typespec &ts, int rank, const 
symbol_attribute &,
 /* Build a null array descriptor constructor.  */
 
 vec *
-get_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr, const init_info &init)
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+const symbol_attribute *attr, const modify_info &init)
 {
   vec *v = nullptr;
 
@@ -734,11 +756,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int 
rank,
   CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
 }
 
-  tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
-  tree dtype_value = build_dtype (ts, rank, attr, init);
-  CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+  if (init.is_initialization ())
+{
+  tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+  tree dtype_value = build_dtype (*ts, rank, *attr,
+ static_cast (init));
+  CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+}
 
-  if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+  if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
 {
   /* Declare the variable static so its array descriptor stays present

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Extraction fonction fcncall_realloc_result

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:4c5667421e180351f4a5fe236040733f8a172cb7

commit 4c5667421e180351f4a5fe236040733f8a172cb7
Author: Mikael Morin 
Date:   Thu Jan 9 21:38:39 2025 +0100

Extraction fonction fcncall_realloc_result

Correction variable inutilisée

Correction régression coarray dummy_3

Correction régression dummy_3

Diff:
---
 gcc/fortran/trans-array.cc | 64 ++
 gcc/fortran/trans-array.h  |  1 +
 gcc/fortran/trans-expr.cc  | 52 +++--
 3 files changed, 80 insertions(+), 37 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 55e53132e088..e8ceb53e8080 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1453,6 +1453,70 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree 
dest, tree src,
 }
 
 
+class conditional_lb
+{
+  tree cond;
+public:
+  conditional_lb (tree arg_cond)
+: cond (arg_cond) { }
+
+  tree lower_bound (tree src, int n) const {
+tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+return lbound;
+  }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+  int rank, const conditional_lb &lb)
+{
+  tree tmp = gfc_conv_descriptor_data_get (src);
+  gfc_conv_descriptor_data_set (block, dest, tmp);
+
+  tree offset = gfc_index_zero_node;
+  for (int n = 0 ; n < rank; n++)
+{
+  tree lbound;
+
+  lbound = lb.lower_bound (dest, n);
+  lbound = gfc_evaluate_now (lbound, block);
+
+  tmp = gfc_conv_descriptor_ubound_get (src, gfc_rank_cst[n]);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp, lbound);
+  gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], lbound);
+  gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], tmp);
+
+  /* Set stride and accumulate the offset.  */
+  tmp = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[n]);
+  gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[n], tmp);
+  tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, tmp);
+  offset = fold_build2_loc (input_location, MINUS_EXPR,
+   gfc_array_index_type, offset, tmp);
+  offset = gfc_evaluate_now (offset, block);
+}
+
+  gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+  int rank, tree zero_cond)
+{
+  gfc_conv_shift_descriptor (block, dest, src, rank,
+conditional_lb (zero_cond));
+}
+
+
 static bool
 keep_descriptor_lower_bound (gfc_expr *e)
 {
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8df55c2c00a5..571322ae11ff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
 /* Shift lower bound of descriptor, updating ubound and offset.  */
 void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
 
 /* Add pre-loop scalarization code for intrinsic functions which require
special handling.  */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2605a8e423c7..5c3bcd157b44 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -832,6 +832,9 @@ gfc_get_vptr_from_expr (tree expr)
 int
 gfc_descriptor_rank (tree descriptor)
 {
+  if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
   tree dim = gfc_get_descriptor_dimension (descriptor);
   tree dim_type = TREE_TYPE (dim);
   gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
@@ -916,8 +919,17 @@ gfc_class_array_data_assign (stmtblock_t *block, tree 
lhs_desc, tree rhs_desc,
 type = TREE_TYPE (tmp);
   else
 {
-  gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
-  type = TREE_TYPE (tmp);
+  int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+  int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+  if (corank > 0 && corank2 == 0)
+   type = TREE_TYPE (tmp2);
+  else if (corank2 > 0 && corank == 0)
+   type = TREE_TYPE (tmp);
+  else
+   {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+   }
 }
 
   tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
@@ -11789,7 +11801,6 @@ fcncall_realloc_result (g

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation shift descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:8bf185db41da04b8607d8c1db3eb1dd25bd96956

commit 8bf185db41da04b8607d8c1db3eb1dd25bd96956
Author: Mikael Morin 
Date:   Thu Jan 16 14:35:14 2025 +0100

Factorisation shift descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 6 +++---
 gcc/fortran/trans-array.h  | 1 +
 gcc/fortran/trans-stmt.cc  | 6 +-
 3 files changed, 5 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 1f96d813ca22..d11d656258a8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1259,8 +1259,8 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, int 
rank,
 }
 
 
-static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+void
+gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
 {
   conv_shift_descriptor (block, desc, rank, unset_lb ());
 }
@@ -10121,7 +10121,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, 
bool g77,
 
  gfc_init_block (&block);
  if (maybe_shift && !keep_descriptor_lower_bound (expr))
-   conv_shift_descriptor (&block, se->expr, expr->rank);
+   gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
 
  bool assumed_rank_fsym;
  if (fsym
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 571322ae11ff..378afb9617a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
 /* Shift lower bound of descriptor, updating ubound and offset.  */
 void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
 
 /* Add pre-loop scalarization code for intrinsic functions which require
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 37f8acaea3f6..cb6592d3870a 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2007,16 +2007,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block 
*block)
   if ((!sym->assoc->variable && !cst_array_ctor)
  || !whole_array)
{
- int dim;
-
  if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
 
  /* The generated descriptor has lower bound zero (as array
 temporary), shift bounds so we get lower bounds of 1.  */
- for (dim = 0; dim < e->rank; ++dim)
-   gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
+ gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
 
   /* If this is a subreference array pointer associate name use the

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation gfc_conv_remap_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:887b7810e5b9eb9317936ca963f55f3327e2626b

commit 887b7810e5b9eb9317936ca963f55f3327e2626b
Author: Mikael Morin 
Date:   Sat Jan 4 21:36:13 2025 +0100

Factorisation gfc_conv_remap_descriptor

Correction régression pointer_remapping_5

Diff:
---
 gcc/fortran/trans-array.cc | 119 +++
 gcc/fortran/trans-expr.cc  | 124 +++--
 gcc/fortran/trans.h|   2 +
 3 files changed, 129 insertions(+), 116 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cdf7383164d6..55e53132e088 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1334,6 +1334,125 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree 
desc,
 }
 
 
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+  int src_rank, const gfc_array_spec &as)
+{
+  int dest_rank = gfc_descriptor_rank (dest);
+
+  /* Set dtype.  */
+  tree dtype = gfc_conv_descriptor_dtype (dest);
+  tree tmp = gfc_get_dtype (TREE_TYPE (src));
+  gfc_add_modify (block, dtype, tmp);
+
+  /* Copy data pointer.  */
+  tree data = gfc_conv_descriptor_data_get (src);
+  gfc_conv_descriptor_data_set (block, dest, data);
+
+  /* Copy the span.  */
+  tree span;
+  if (VAR_P (src)
+  && GFC_DECL_PTR_ARRAY_P (src))
+span = gfc_conv_descriptor_span_get (src);
+  else
+{
+  tmp = TREE_TYPE (src);
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+  span = fold_convert (gfc_array_index_type, tmp);
+}
+  gfc_conv_descriptor_span_set (block, dest, span);
+
+  /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero.  */
+  if (src_rank == -1)
+gfc_conv_descriptor_offset_set (block, dest,
+   gfc_index_zero_node);
+  else
+{
+  tree offs = gfc_conv_descriptor_offset_get (src);
+  for (int dim = 0; dim < src_rank; ++dim)
+   {
+ tree stride = gfc_conv_descriptor_stride_get (src,
+   gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src,
+   gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, stride,
+lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+   }
+  gfc_conv_descriptor_offset_set (block, dest, offs);
+}
+  /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly.  */
+  tree stride = gfc_conv_descriptor_stride_get (src,
+  gfc_rank_cst[0]);
+  for (int dim = 0; dim < dest_rank; ++dim)
+{
+  gfc_se lower_se;
+  gfc_se upper_se;
+
+  gcc_assert (as.lower[dim] && as.upper[dim]);
+
+  /* Convert declared bounds.  */
+  gfc_init_se (&lower_se, NULL);
+  gfc_init_se (&upper_se, NULL);
+  gfc_conv_expr (&lower_se, as.lower[dim]);
+  gfc_conv_expr (&upper_se, as.upper[dim]);
+
+  gfc_add_block_to_block (block, &lower_se.pre);
+  gfc_add_block_to_block (block, &upper_se.pre);
+
+  tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+  tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+  lbound = gfc_evaluate_now (lbound, block);
+  ubound = gfc_evaluate_now (ubound, block);
+
+  gfc_add_block_to_block (block, &lower_se.post);
+  gfc_add_block_to_block (block, &upper_se.post);
+
+  /* Set bounds in descriptor.  */
+  gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], lbound);
+  gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], ubound);
+
+  /* Set stride.  */
+  stride = gfc_evaluate_now (stride, block);
+  gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+
+  /* Update offset.  */
+  tree offs = gfc_conv_descriptor_offset_get (dest);
+  tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, stride);
+  offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+  offs = gfc_evaluate_now (offs, block);
+  gfc_conv_descriptor_offset_set (block, dest, offs);
+
+  /* Update stride.  */
+  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  stride = fold_build2_loc (input_location, MULT_EXPR,
+   gfc_array_index_type, stride, tmp);
+}
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+  int src_rank, const gfc_array_ref &ar)
+{
+  g

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation gfc_conv_expr_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:73951e7dc4c8a0ce0a9a2893a83a9382461ba28f

commit 73951e7dc4c8a0ce0a9a2893a83a9382461ba28f
Author: Mikael Morin 
Date:   Thu Jan 16 14:00:20 2025 +0100

Factorisation gfc_conv_expr_descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 380 +++--
 1 file changed, 197 insertions(+), 183 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5527e99ecc01..1f96d813ca22 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1543,6 +1543,38 @@ keep_descriptor_lower_bound (gfc_expr *e)
   return true;
 }
 
+static void
+copy_descriptor (stmtblock_t *block, tree dest, tree src,
+gfc_expr *src_expr, bool subref)
+{
+  struct lang_type *dest_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (dest));
+  struct lang_type *src_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (src));
+
+  /* When only the array_kind differs, do a view_convert.  */
+  tree tmp1;
+  if (dest_ls
+  && src_ls
+  && dest_ls->rank == src_ls->rank
+  && dest_ls->akind != src_ls->akind)
+tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
+  else
+tmp1 = desc;
+
+  /* Copy the descriptor for pointer assignments.  */
+  gfc_add_modify (block, dest, tmp1);
+
+  /* Add any offsets from subreferences.  */
+  gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+  /* and set the span field.  */
+  tree tmp2
+  if (src_expr->ts.type == BT_CHARACTER)
+tmp2 = gfc_conv_descriptor_span_get (src);
+  else
+tmp2 = gfc_get_array_span (src, src_expr);
+  gfc_conv_descriptor_span_set (block, dest, tmp2);
+}
+
 
 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
 
@@ -8999,37 +9031,175 @@ is_explicit_coarray (gfc_expr *expr)
 
 
 static void
-copy_descriptor (stmtblock_t *block, tree dest, tree src,
-gfc_expr *src_expr, bool subref)
+set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
+   int rank, int corank, gfc_ss *ss, gfc_array_info *info,
+   tree lowers[GFC_MAX_DIMENSIONS],
+   tree uppers[GFC_MAX_DIMENSIONS],
+   bool unlimited_polymorphic, bool data_needed, bool subref)
 {
-  struct lang_type *dest_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (dest));
-  struct lang_type *src_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (src));
+  int ndim = info->ref ? info->ref->u.ar.dimen : rank;
 
-  /* When only the array_kind differs, do a view_convert.  */
-  tree tmp1;
-  if (dest_ls
-  && src_ls
-  && dest_ls->rank == src_ls->rank
-  && dest_ls->akind != src_ls->akind)
-tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
+  /* Set the span field.  */
+  tree tmp = NULL_TREE;
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+tmp = gfc_conv_descriptor_span_get (src);
   else
-tmp1 = desc;
+tmp = gfc_get_array_span (src, src_expr);
+  if (tmp)
+gfc_conv_descriptor_span_set (block, dest, tmp);
+
+  /* The following can be somewhat confusing.  We have two
+ descriptors, a new one and the original array.
+ {dest, parmtype, dim} refer to the new one.
+ {src, type, n, loop} refer to the original, which maybe
+ a descriptorless array.
+ The bounds of the scalarization are the bounds of the section.
+ We don't have to worry about numeric overflows when calculating
+ the offsets because all elements are within the array data.  */
+
+  /* Set the dtype.  */
+  tmp = gfc_conv_descriptor_dtype (dest);
+  tree dtype;
+  if (unlimited_polymorphic)
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
+  else if (src_expr->ts.type == BT_ASSUMED)
+{
+  tree tmp2 = src;
+  if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+   tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+  if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+   tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+  dtype = gfc_conv_descriptor_dtype (tmp2);
+}
+  else
+dtype = gfc_get_dtype (TREE_TYPE (dest));
+  gfc_add_modify (block, tmp, dtype);
 
-  /* Copy the descriptor for pointer assignments.  */
-  gfc_add_modify (block, dest, tmp1);
+  /* The 1st element in the section.  */
+  tree base = gfc_index_zero_node;
+  if (src_expr->ts.type == BT_CHARACTER && src_expr->rank == 0 && corank)
+base = gfc_index_one_node;
 
-  /* Add any offsets from subreferences.  */
-  gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+  /* The offset from the 1st element in the section.  */
+  tree offset = gfc_index_zero_node;
 
-  /* and set the span field.  */
-  tree tmp2
-  if (src_expr->ts.type == BT_CHARACTER)
-tmp2 = gfc_conv_descriptor_span_get (src);
+  for (int n = 0; n < ndim; n++)
+{
+  tree stride = gfc_conv_array_stride (src, n);
+
+  /* Work out the 1st element in the section.  */
+  tree start;
+  if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+   {
+ gcc_assert (info

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation shift descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:6d65a19998ba14a906d73ba6b826a444f50c289b

commit 6d65a19998ba14a906d73ba6b826a444f50c289b
Author: Mikael Morin 
Date:   Thu Jan 16 14:51:42 2025 +0100

Factorisation shift descriptor

Diff:
---
 gcc/fortran/trans-expr.cc | 7 +--
 1 file changed, 1 insertion(+), 6 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5c3bcd157b44..e5896cfd77ae 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1219,7 +1219,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
   tree ctree;
   tree var;
   tree tmp;
-  int dim;
   bool unlimited_poly;
 
   unlimited_poly = class_ts.type == BT_CLASS
@@ -1287,11 +1286,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
  /* Array references with vector subscripts and non-variable 
expressions
 need be converted to a one-based descriptor.  */
  if (e->expr_type != EXPR_VARIABLE)
-   {
- for (dim = 0; dim < e->rank; ++dim)
-   gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
-   }
+   gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, e->rank);
 
  if (class_ts.u.derived->components->as->rank != e->rank)
{

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Introduction gfc_copy_sequence_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:754d5103c0029737eb003bee5eaf0e8c2ae0d235

commit 754d5103c0029737eb003bee5eaf0e8c2ae0d235
Author: Mikael Morin 
Date:   Tue Dec 31 15:27:35 2024 +0100

Introduction gfc_copy_sequence_descriptor

Correction régression sizeof_6

Diff:
---
 gcc/fortran/trans-array.cc | 39 ++-
 gcc/fortran/trans-expr.cc  | 44 
 gcc/fortran/trans.h|  1 +
 3 files changed, 59 insertions(+), 25 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0560c7482ee5..cdf7383164d6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9914,32 +9914,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, 
bool g77,
  if (maybe_shift && !keep_descriptor_lower_bound (expr))
conv_shift_descriptor (&block, se->expr, expr->rank);
 
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+  && CLASS_DATA (fsym)->as
+  && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+   assumed_rank_fsym = true;
+ else
+   assumed_rank_fsym = false;
+
  tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
-   {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
-   gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
-   &block, arr, gfc_index_zero_node,
-   gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
-   &block, arr, gfc_index_zero_node,
-   gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
- gfc_conv_descriptor_dtype (se->expr));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
- build_int_cst (signed_char_type_node, 1));
- gfc_conv_descriptor_span_set (&block, arr,
-   gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
-   }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+   assumed_rank_fsym);
 
  /* Handle optional.  */
  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4ea91f4366dd..334126fae688 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -846,6 +846,50 @@ descriptor_rank (tree descriptor)
 }
 
 
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+  int lhs_rank = descriptor_rank (lhs_desc);
+  int rhs_rank = descriptor_rank (rhs_desc);
+  tree desc;
+
+  if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+  else
+{
+  tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+  gfc_conv_descriptor_data_set (&block, arr,
+   gfc_conv_descriptor_data_get (rhs_desc));
+  gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+  tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+  gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+  gfc_conv_descriptor_stride_set (
+   &block, arr, gfc_index_zero_node,
+   gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+  for (int i = 1; i < lhs_rank; i++)
+   {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+   }
+  gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+  gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_cha

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction bootstrap, ajout ; declaration.

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:963292d4113acc719af10d93e3d2c39b92e540d0

commit 963292d4113acc719af10d93e3d2c39b92e540d0
Author: Mikael Morin 
Date:   Fri Mar 14 15:42:06 2025 +0100

Correction bootstrap, ajout ; declaration.

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4de454db646c..d8717f570c7f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1563,7 +1563,7 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
   && dest_ls->akind != src_ls->akind)
 tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
   else
-tmp1 = desc;
+tmp1 = src;
 
   /* Copy the descriptor for pointer assignments.  */
   gfc_add_modify (block, dest, tmp1);
@@ -1572,7 +1572,7 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
   gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
 
   /* and set the span field.  */
-  tree tmp2
+  tree tmp2;
   if (src_expr->ts.type == BT_CHARACTER)
 tmp2 = gfc_conv_descriptor_span_get (src);
   else

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation copie gfc_conv_expr_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:c3764bfd23b83c540294915945dbaeb45c3f

commit c3764bfd23b83c540294915945dbaeb45c3f
Author: Mikael Morin 
Date:   Wed Jan 15 17:51:21 2025 +0100

Factorisation copie gfc_conv_expr_descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 58 --
 1 file changed, 35 insertions(+), 23 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e8ceb53e8080..5527e99ecc01 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8997,6 +8997,39 @@ is_explicit_coarray (gfc_expr *expr)
   return cas && cas->cotype == AS_EXPLICIT;
 }
 
+
+static void
+copy_descriptor (stmtblock_t *block, tree dest, tree src,
+gfc_expr *src_expr, bool subref)
+{
+  struct lang_type *dest_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (dest));
+  struct lang_type *src_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (src));
+
+  /* When only the array_kind differs, do a view_convert.  */
+  tree tmp1;
+  if (dest_ls
+  && src_ls
+  && dest_ls->rank == src_ls->rank
+  && dest_ls->akind != src_ls->akind)
+tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
+  else
+tmp1 = desc;
+
+  /* Copy the descriptor for pointer assignments.  */
+  gfc_add_modify (block, dest, tmp1);
+
+  /* Add any offsets from subreferences.  */
+  gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+  /* and set the span field.  */
+  tree tmp2
+  if (src_expr->ts.type == BT_CHARACTER)
+tmp2 = gfc_conv_descriptor_span_get (src);
+  else
+tmp2 = gfc_get_array_span (src, src_expr);
+  gfc_conv_descriptor_span_set (block, dest, tmp2);
+}
+
 /* Convert an array for passing as an actual argument.  Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed.  For whole arrays the descriptor is passed.  For array sections
@@ -9131,29 +9164,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   if (full && !transposed_dims (ss))
{
  if (se->direct_byref && !se->byref_noassign)
-   {
- struct lang_type *lhs_ls
-   = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
-   *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
- /* When only the array_kind differs, do a view_convert.  */
- tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
-   && lhs_ls->akind != rhs_ls->akind
- ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
- : desc;
- /* Copy the descriptor for pointer assignments.  */
- gfc_add_modify (&se->pre, se->expr, tmp);
-
- /* Add any offsets from subreferences.  */
- gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
- subref_array_target, expr);
-
- /* and set the span field.  */
- if (ss_info->expr->ts.type == BT_CHARACTER)
-   tmp = gfc_conv_descriptor_span_get (desc);
- else
-   tmp = gfc_get_array_span (desc, expr);
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
-   }
+   copy_descriptor (&se->pre, se->expr, desc, expr,
+subref_array_target);
  else if (se->want_pointer)
{
  /* We pass full arrays directly.  This means that pointers and

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set descriptor with shape

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:4326c50e406921ae8d4b59135cbce8b446cbab82

commit 4326c50e406921ae8d4b59135cbce8b446cbab82
Author: Mikael Morin 
Date:   Fri Mar 14 15:40:09 2025 +0100

Factorisation set descriptor with shape

Diff:
---
 gcc/fortran/trans-array.cc | 77 ++
 gcc/fortran/trans-array.h  |  2 ++
 gcc/fortran/trans-intrinsic.cc | 76 +++--
 3 files changed, 84 insertions(+), 71 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e2f9728ac0c1..4de454db646c 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1581,6 +1581,83 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
 }
 
 
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc,
+  tree ptr, gfc_expr *shape,
+  locus *where)
+{
+  /* Set the span field.  */
+  tree tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  tmp = fold_convert (gfc_array_index_type, tmp);
+  gfc_conv_descriptor_span_set (block, desc, tmp);
+
+  /* Set data value, dtype, and offset.  */
+  tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+  gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+  gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+  /* Start scalarization of the bounds, using the shape argument.  */
+
+  gfc_ss *shape_ss = gfc_walk_expr (shape);
+  gcc_assert (shape_ss != gfc_ss_terminator);
+  gfc_se shapese;
+  gfc_init_se (&shapese, NULL);
+
+  gfc_loopinfo loop;
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, shape_ss);
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, where);
+  gfc_mark_ss_chain_used (shape_ss, 1);
+
+  gfc_copy_loopinfo_to_se (&shapese, &loop);
+  shapese.ss = shape_ss;
+
+  tree stride = gfc_create_var (gfc_array_index_type, "stride");
+  tree offset = gfc_create_var (gfc_array_index_type, "offset");
+  gfc_add_modify (block, stride, gfc_index_one_node);
+  gfc_add_modify (block, offset, gfc_index_zero_node);
+
+  /* Loop body.  */
+  stmtblock_t body;
+  gfc_start_scalarized_body (&loop, &body);
+
+  tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+  /* Set bounds and stride.  */
+  gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+  gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+  gfc_conv_expr (&shapese, shape);
+  gfc_add_block_to_block (&body, &shapese.pre);
+  gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+  gfc_add_block_to_block (&body, &shapese.post);
+
+  /* Calculate offset.  */
+  gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+  gfc_array_index_type, offset, stride));
+  /* Update stride.  */
+  gfc_add_modify (&body, stride,
+ fold_build2_loc (input_location, MULT_EXPR,
+  gfc_array_index_type, stride,
+  fold_convert (gfc_array_index_type,
+shapese.expr)));
+  /* Finish scalarization loop.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (block, &loop.pre);
+  gfc_add_block_to_block (block, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+  gfc_array_index_type, offset));
+  gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
 
 void
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3f39845c898f..05ea68d531ac 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -145,6 +145,8 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol 
*, tree);
 void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
 void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
 void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *, 
gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+   gfc_expr *, locus *);
 
 /* Get a single array element.  */
 void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index db1859a2285f..0d104967472b 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9875,11 +9875,8 @@ conv_isocbinding_subroutine (gfc_code *code)
   gfc_se se;
   gfc_se cptrse;
   gfc_se fptrse;
-  gfc_se shapese;
-  gfc_ss *shape_ss;
-  tree desc, dim, tmp, stride, offset;
-  stmtblock_t body, block;
-  gfc_loopinfo loop;
+  tree desc

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation initialisation subarray_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:6c9f45e4b0c4c370b7e39bd74f391155bfb88c86

commit 6c9f45e4b0c4c370b7e39bd74f391155bfb88c86
Author: Mikael Morin 
Date:   Tue Jan 21 18:44:41 2025 +0100

Factorisation initialisation subarray_descriptor

Diff:
---
 gcc/fortran/trans-expr.cc | 151 --
 1 file changed, 78 insertions(+), 73 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e5896cfd77ae..6e0167341ebe 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9608,17 +9608,90 @@ gfc_trans_subarray_assign (tree dest, gfc_component * 
cm, gfc_expr * expr)
 }
 
 
+static void
+set_subarray_descriptor (stmtblock_t *block, tree desc, tree value,
+gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+  if (value_expr->expr_type != EXPR_VARIABLE)
+gfc_conv_descriptor_data_set (block, value,
+ null_pointer_node);
+
+  /* Obtain the array spec of full array references.  */
+  gfc_array_spec *as;
+  if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+  else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+  /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset.  */
+  tree offset = gfc_conv_descriptor_offset_get (desc);
+  gfc_add_modify (block, offset, gfc_index_zero_node);
+  tree tmp2 = gfc_create_var (gfc_array_index_type, NULL);
+
+  for (int n = 0; n < value_expr->rank; n++)
+{
+  tree span;
+  tree lbound;
+
+  /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+TODO It looks as if gfc_conv_expr_descriptor should return
+the correct bounds and that the following should not be
+necessary.  This would simplify gfc_conv_intrinsic_bound
+as well.  */
+  if (as && as->lower[n])
+   {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+   }
+  else if (as && conv_arg)
+   {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+   gfc_rank_cst[n]);
+   }
+  else if (as)
+   lbound = gfc_conv_descriptor_lbound_get (desc,
+   gfc_rank_cst[n]);
+  else
+   lbound = gfc_index_one_node;
+
+  lbound = fold_convert (gfc_array_index_type, lbound);
+
+  /* Shift the bounds and set the offset accordingly.  */
+  tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+  span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+   tmp, gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+span, lbound);
+  gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[n], tmp);
+  gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[n], lbound);
+
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (desc,
+gfc_rank_cst[n]),
+gfc_conv_descriptor_stride_get (desc,
+gfc_rank_cst[n]));
+  gfc_add_modify (block, tmp2, tmp);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+offset, tmp2);
+  gfc_conv_descriptor_offset_set (block, desc, tmp);
+}
+}
+
+
 static tree
 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
 gfc_expr * expr)
 {
   gfc_se se;
   stmtblock_t block;
-  tree offset;
-  int n;
   tree tmp;
-  tree tmp2;
-  gfc_array_spec *as;
   gfc_expr *arg = NULL;
 
   gfc_start_block (&block);
@@ -9679,10 +9752,6 @@ gfc_trans_alloc_subarray_assign (tree dest, 
gfc_component * cm,
   gfc_add_expr_to_block (&block, tmp);
   gfc_add_block_to_block (&block, &se.post);
 
-  if (expr->expr_type != EXPR_VARIABLE)
-gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
   /* We need to know if the argument of a conversion function is a
  variable, so that the correct lower bound can be used.  */
   if (expr->expr_type == EXPR_FUNCTION
@@ -9692,71 +9761,7 @@ gfc_trans_alloc_subarray_assign (tree dest, 
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
 arg = expr->value.function.actual->expr;
 
-  /* Obtain the array spec of full array references.  */
-  if (arg)
-as = gfc_get_full_arrayspec_from_expr (arg);
-  else
-a

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Refactor conv_shift_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:b0daaedc4619502af24c75cb41200920b7b6b89b

commit b0daaedc4619502af24c75cb41200920b7b6b89b
Author: Mikael Morin 
Date:   Thu Jan 16 15:28:38 2025 +0100

Refactor conv_shift_descriptor

Correction régressions

Correction régression gfc_conv_expr_descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 31 +--
 gcc/fortran/trans-array.h  |  1 -
 2 files changed, 17 insertions(+), 15 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d11d656258a8..ecef6b3a5bb2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1167,16 +1167,15 @@ gfc_build_null_descriptor (tree type)
 /* Modify a descriptor such that the lbound of a given dimension is the value
specified.  This also updates ubound and offset accordingly.  */
 
-void
-gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
- int dim, tree new_lbound)
+static void
+conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
+ tree new_lbound, tree offset)
 {
-  tree offs, ubound, lbound, stride;
+  tree ubound, lbound, stride;
   tree diff, offs_diff;
 
   new_lbound = fold_convert (gfc_array_index_type, new_lbound);
 
-  offs = gfc_conv_descriptor_offset_get (desc);
   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
   stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
@@ -1192,9 +1191,9 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, 
tree desc,
   gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
   offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
   diff, stride);
-  offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offs, offs_diff);
-  gfc_conv_descriptor_offset_set (block, desc, offs);
+  tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, offs_diff);
+  gfc_add_modify (block, offset, tmp);
 
   /* Finally set lbound to value we want.  */
   gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
@@ -1231,6 +1230,10 @@ static void
 conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
   const lb_info &info)
 {
+  tree tmp = gfc_conv_descriptor_offset_get (desc);
+  tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
+  gfc_add_modify (block, offset_var, tmp);
+
   /* Apply a shift of the lbound when supplied.  */
   for (int dim = 0; dim < rank; ++dim)
 {
@@ -1254,8 +1257,10 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, 
int rank,
  lower_bound = lb_var;
}
 
-  gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+  conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
 }
+
+  gfc_conv_descriptor_offset_set (block, desc, offset_var);
 }
 
 
@@ -9246,7 +9251,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   bool subref_array_target = false;
   bool deferred_array_component = false;
   bool substr = false;
-  bool unlimited_polymorphic = false;
   gfc_expr *arg, *ss_expr;
 
   if (se->want_coarray || expr->rank == 0)
@@ -9272,7 +9276,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 }
 
   if (!se->direct_byref)
-unlimited_polymorphic = UNLIMITED_POLY (expr);
+se->unlimited_polymorphic = UNLIMITED_POLY (expr);
 
   /* Special case things we know we can pass easily.  */
   switch (expr->expr_type)
@@ -9676,9 +9680,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
  gfc_get_array_span (desc, expr)));
}
 
-
-  set_descriptor (&se->pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, unlimited_polymorphic,
+  set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, se->unlimited_polymorphic,
  !se->data_not_needed, subref_array_target);
 
   desc = parm;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 378afb9617a3..3f39845c898f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,7 +214,6 @@ tree gfc_get_cfi_dim_sm (tree, tree);
 
 
 /* Shift lower bound of descriptor, updating ubound and offset.  */
-void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Essai suppression unlimited_polymorphic

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:16d9c82b576dd068ca5e1840cd93f487b63d9bd7

commit 16d9c82b576dd068ca5e1840cd93f487b63d9bd7
Author: Mikael Morin 
Date:   Thu Jan 16 20:45:34 2025 +0100

Essai suppression unlimited_polymorphic

Diff:
---
 gcc/fortran/trans-array.cc | 13 -
 gcc/fortran/trans.h|  3 ---
 2 files changed, 4 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ecef6b3a5bb2..1033dabd6c4e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9040,7 +9040,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src, 
gfc_expr *src_expr,
int rank, int corank, gfc_ss *ss, gfc_array_info *info,
tree lowers[GFC_MAX_DIMENSIONS],
tree uppers[GFC_MAX_DIMENSIONS],
-   bool unlimited_polymorphic, bool data_needed, bool subref)
+   bool data_needed, bool subref)
 {
   int ndim = info->ref ? info->ref->u.ar.dimen : rank;
 
@@ -9065,9 +9065,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src, 
gfc_expr *src_expr,
   /* Set the dtype.  */
   tmp = gfc_conv_descriptor_dtype (dest);
   tree dtype;
-  if (unlimited_polymorphic)
-dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
-  else if (src_expr->ts.type == BT_ASSUMED)
+  if (src_expr->ts.type == BT_ASSUMED)
 {
   tree tmp2 = src;
   if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
@@ -9077,7 +9075,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src, 
gfc_expr *src_expr,
   dtype = gfc_conv_descriptor_dtype (tmp2);
 }
   else
-dtype = gfc_get_dtype (TREE_TYPE (dest));
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
   gfc_add_modify (block, tmp, dtype);
 
   /* The 1st element in the section.  */
@@ -9275,9 +9273,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   expr = expr->value.function.actual->expr;
 }
 
-  if (!se->direct_byref)
-se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
   /* Special case things we know we can pass easily.  */
   switch (expr->expr_type)
 {
@@ -9681,7 +9676,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
 
   set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, se->unlimited_polymorphic,
+ ss, info, loop.from, loop.to,
  !se->data_not_needed, subref_array_target);
 
   desc = parm;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index eb1deeec2edd..e8ad7ac53573 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -61,9 +61,6 @@ typedef struct gfc_se
  the reference to the class object here.  */
   tree class_container;
 
-  /* Whether expr is a reference to an unlimited polymorphic object.  */
-  unsigned unlimited_polymorphic:1;
-
   /* If set gfc_conv_variable will return an expression for the array
  descriptor. When set, want_pointer should also be set.
  If not set scalarizing variables will be substituted.  */

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation shift descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:bfefa68c860995e08de97f6011ed2d706eb1ef76

commit bfefa68c860995e08de97f6011ed2d706eb1ef76
Author: Mikael Morin 
Date:   Tue Jan 21 22:27:02 2025 +0100

Factorisation shift descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 117 -
 gcc/fortran/trans-array.h  |   1 +
 gcc/fortran/trans-expr.cc  |  82 ++-
 3 files changed, 100 insertions(+), 100 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d8717f570c7f..83363477710c 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1200,16 +1200,52 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree 
desc, int dim,
 }
 
 
-class lb_info
+class lb_info_base
 {
 public:
+  virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+  using lb_info_base::lower_bound;
   virtual gfc_expr *lower_bound (int dim) const = 0;
+  virtual tree lower_bound (stmtblock_t *block, int dim) const;
 };
 
 
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+  gfc_expr *lb_expr = lower_bound(dim);
+
+  if (lb_expr == nullptr)
+return gfc_index_one_node;
+  else
+{
+  gfc_se lb_se;
+
+  gfc_init_se (&lb_se, nullptr);
+  gfc_conv_expr (&lb_se, lb_expr);
+
+  gfc_add_block_to_block (block, &lb_se.pre);
+  tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+  gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+  gfc_add_block_to_block (block, &lb_se.post);
+
+  return lb_var;
+}
+}
+
+
+
 class unset_lb : public lb_info
 {
 public:
+  using lb_info::lower_bound;
   virtual gfc_expr *lower_bound (int) const { return nullptr; }
 };
 
@@ -1220,6 +1256,7 @@ class defined_lb : public lb_info
   gfc_expr * const * lower_bounds;
 
 public:
+  using lb_info::lower_bound;
   defined_lb (int arg_rank, gfc_expr * const 
arg_lower_bounds[GFC_MAX_DIMENSIONS])
 : rank(arg_rank), lower_bounds(arg_lower_bounds) { }
   virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
@@ -1228,7 +1265,7 @@ public:
 
 static void
 conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
-  const lb_info &info)
+  const lb_info_base &info)
 {
   tree tmp = gfc_conv_descriptor_offset_get (desc);
   tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
@@ -1237,26 +1274,7 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, 
int rank,
   /* Apply a shift of the lbound when supplied.  */
   for (int dim = 0; dim < rank; ++dim)
 {
-  gfc_expr *lb_expr = info.lower_bound(dim);
-
-  tree lower_bound;
-  if (lb_expr == nullptr)
-   lower_bound = gfc_index_one_node;
-  else
-   {
- gfc_se lb_se;
-
- gfc_init_se (&lb_se, nullptr);
- gfc_conv_expr (&lb_se, lb_expr);
-
- gfc_add_block_to_block (block, &lb_se.pre);
- tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
- gfc_add_modify (block, lb_var, lb_se.expr);
- gfc_add_block_to_block (block, &lb_se.post);
-
- lower_bound = lb_var;
-   }
-
+  tree lower_bound = info.lower_bound (block, dim);
   conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
 }
 
@@ -1339,6 +1357,61 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
 }
 
 
+class dataref_lb : public lb_info_base
+{
+  gfc_array_spec *as;
+  gfc_expr *conv_arg;
+  tree desc;
+
+public:
+  dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+: as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+  {}
+  virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+  tree lbound;
+  if (as && as->lower[dim])
+{
+  gfc_se lbse;
+  gfc_init_se (&lbse, NULL);
+  gfc_conv_expr (&lbse, as->lower[dim]);
+  gfc_add_block_to_block (block, &lbse.pre);
+  lbound = gfc_evaluate_now (lbse.expr, block);
+}
+  else if (as && conv_arg)
+{
+  tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+  lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+}
+  else if (as)
+lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+  else
+lbound = gfc_index_one_node;
+
+  return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+   gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+  /* Obtain the array spec of full array references.  */
+  gfc_array_spec *as;
+  if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+  else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+  conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as, 
conv

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_descriptor_from_scalar dans conv_class_to_class

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:b00bd59c03f82c1530f3f503282481c20918cc4b

commit b00bd59c03f82c1530f3f503282481c20918cc4b
Author: Mikael Morin 
Date:   Tue Jan 28 21:03:24 2025 +0100

Factorisation set_descriptor_from_scalar dans conv_class_to_class

Correction régression associate_66

Correction régression PR100040.f90

Diff:
---
 gcc/fortran/trans-expr.cc | 34 ++
 1 file changed, 22 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d8067d4b6f25..c84ef068f403 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -172,6 +172,27 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol 
*sym, gfc_expr *expr)
 }
 
 
+void
+set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+   gfc_expr *scalar_expr)
+{
+  tree type = get_scalar_to_descriptor_type (scalar,
+gfc_expr_attr (scalar_expr));
+  if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+  tree dtype_val = gfc_get_dtype (type);
+  tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (block, dtype_ref, dtype_val);
+
+  tree tmp = gfc_class_data_get (scalar);
+  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+  gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
+
 tree
 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 {
@@ -1434,18 +1455,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_typespec class_ts,
   && e->rank != class_ts.u.derived->components->as->rank)
 {
   if (e->rank == 0)
-   {
- tree type = get_scalar_to_descriptor_type (parmse->expr,
-gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
-   }
+   set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
   else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Refactoring gfc_conv_descriptor_sm_get.

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:686804bdfbfebd2df133c4dd020f56c2afcdd9b3

commit 686804bdfbfebd2df133c4dd020f56c2afcdd9b3
Author: Mikael Morin 
Date:   Wed Jan 22 21:59:46 2025 +0100

Refactoring gfc_conv_descriptor_sm_get.

Diff:
---
 gcc/fortran/trans-array.cc | 11 +++
 gcc/fortran/trans-array.h  |  1 +
 gcc/fortran/trans-expr.cc  |  4 +---
 3 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5ef6f810b083..385bc8fcd380 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -591,6 +591,17 @@ gfc_conv_descriptor_extent_get (tree desc, tree dim)
 }
 
 
+tree
+gfc_conv_descriptor_sm_get (tree desc, tree dim)
+{
+  tree stride = gfc_conv_descriptor_stride_get (desc, dim);
+  tree span = gfc_conv_descriptor_span_get (desc);
+
+  return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, span);
+}
+
+
 static int
 get_type_info (const bt &type)
 {
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1d694989b4c3..296a8052dd73 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -195,6 +195,7 @@ tree gfc_conv_descriptor_stride_get (tree, tree);
 tree gfc_conv_descriptor_lbound_get (tree, tree);
 tree gfc_conv_descriptor_ubound_get (tree, tree);
 tree gfc_conv_descriptor_extent_get (tree, tree);
+tree gfc_conv_descriptor_sm_get (tree, tree);
 tree gfc_conv_descriptor_token (tree);
 
 void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a5bb00a05da3..dc11544b5554 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6426,9 +6426,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr 
*e, gfc_symbol *fsym)
   tmp = gfc_conv_descriptor_extent_get (gfc, idx);
   gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
   /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
-  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-gfc_conv_descriptor_stride_get (gfc, idx),
-gfc_conv_descriptor_span_get (gfc));
+  tmp = gfc_conv_descriptor_sm_get (gfc, idx);
   gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
 
   /* Generate loop.  */

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_contiguous_array

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:a73298da5c841e176ce2b2fc951c7756bc426d3f

commit a73298da5c841e176ce2b2fc951c7756bc426d3f
Author: Mikael Morin 
Date:   Fri Jan 17 17:25:59 2025 +0100

Factorisation set_contiguous_array

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 1033dabd6c4e..c506a5769dc4 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10711,6 +10711,23 @@ gfc_caf_is_dealloc_only (int caf_mode)
 }
 
 
+static void
+set_contiguous_array (stmtblock_t *block, tree desc, tree size, tree data_ptr)
+{
+  gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype_rank_type (1, TREE_TYPE (desc)));
+  gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+  gfc_conv_descriptor_stride_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+  gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_index_zero_node, size);
+  gfc_conv_descriptor_data_set (block, desc, data_ptr);
+}
+
+
 /* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components.  This is the work horse
function for the functions named in this enum.  */
@@ -10971,32 +10988,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree 
decl, tree dest,
  ubound = build_int_cst (gfc_array_index_type, 1);
}
 
- /* Treat strings like arrays.  Or the other way around, do not
-  * generate an additional array layer for scalar components.  */
- if (attr->dimension || c->ts.type == BT_CHARACTER)
-   {
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
-&ubound, 1,
-GFC_ARRAY_ALLOCATABLE, false);
-
- cdesc = gfc_create_var (cdesc, "cdesc");
- DECL_ARTIFICIAL (cdesc) = 1;
-
- gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
- gfc_index_zero_node, ubound);
-   }
- else
-   /* Prevent warning.  */
-   cdesc = NULL_TREE;
-
  if (attr->dimension)
{
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
@@ -11019,13 +11010,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree 
decl, tree dest,
  gfc_add_block_to_block (&tmpblock, &se.pre);
}
 
+ /* Treat strings like arrays.  Or the other way around, do not
+  * generate an additional array layer for scalar components.  */
  if (attr->dimension || c->ts.type == BT_CHARACTER)
-   gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+   {
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+&ubound, 1,
+GFC_ARRAY_ALLOCATABLE, false);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ set_contiguous_array (&tmpblock, cdesc, ubound, comp);
+   }
  else
cdesc = comp;
 
  tree fndecl;
-
  fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr 
(pvoid_type_node,cdesc),

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation initialisation gfc depuis cfi

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:7fdd6dc0441934ea8d80b7ed2295b12d1a74f566

commit 7fdd6dc0441934ea8d80b7ed2295b12d1a74f566
Author: Mikael Morin 
Date:   Thu Jan 23 20:46:59 2025 +0100

Factorisation initialisation gfc depuis cfi

Correction régression scalar descriptor

Diff:
---
 gcc/fortran/trans-expr.cc | 132 +-
 1 file changed, 72 insertions(+), 60 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index dc11544b5554..06a7097491f1 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6100,6 +6100,75 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 #endif
 
 
+static void
+set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
+ gfc_symbol *c_sym)
+{
+  tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+  gfc_conv_descriptor_data_set (block, gfc, tmp);
+
+  if (c_sym->attr.allocatable)
+{
+  /* gfc->span = cfi->elem_len.  */
+  tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+}
+  else
+{
+  /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len).  */
+  tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+  tree tmp2 = fold_convert (gfc_array_index_type,
+   gfc_get_cfi_desc_elem_len (cfi));
+  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+gfc_array_index_type, tmp, tmp2);
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+tmp, gfc_index_zero_node);
+  tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+   gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+}
+  gfc_conv_descriptor_span_set (block, gfc, tmp);
+
+  /* Calculate offset + set lbound, ubound and stride.  */
+  gfc_conv_descriptor_offset_set (block, gfc, gfc_index_zero_node);
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+  /* Loop body.  */
+  stmtblock_t loop_body;
+  gfc_init_block (&loop_body);
+  /* gfc->dim[i].lbound = ... */
+  tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+  gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+  /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (gfc, idx),
+gfc_index_one_node);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+  /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+  tmp = gfc_get_cfi_dim_sm (cfi, idx);
+  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+gfc_array_index_type, tmp,
+fold_convert (gfc_array_index_type,
+  gfc_get_cfi_desc_elem_len (cfi)));
+  gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+  /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_stride_get (gfc, idx),
+gfc_conv_descriptor_lbound_get (gfc, idx));
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_offset_get (gfc), tmp);
+  gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+  /* Generate loop.  */
+  gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0),
+  rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+  gfc_finish_block (&loop_body));
+}
+
 /* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
 
@@ -6479,8 +6548,10 @@ done:
 goto post_call;
 
   gfc_init_block (&block2);
+
   if (e->rank == 0)
 {
+  gfc_init_block (&block2);
   tmp = gfc_get_cfi_desc_base_addr (cfi);
   gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
 }
@@ -6489,66 +6560,7 @@ done:
   tmp = gfc_get_cfi_desc_base_addr (cfi);
   gfc_conv_descriptor_data_set (&block, gfc, tmp);
 
-  if (fsym->attr.allocatable)
-   {
- /* gfc->span = cfi->elem_len.  */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
-   }
-  else
-   {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len).  */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
-  gfc_get_cfi_desc_elem_len (cfi

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_contiguous_array

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:e83e08fa4dcae826c4a5d72ad1a28e6fb0412670

commit e83e08fa4dcae826c4a5d72ad1a28e6fb0412670
Author: Mikael Morin 
Date:   Fri Jan 17 17:48:42 2025 +0100

Factorisation set_contiguous_array

Diff:
---
 gcc/fortran/trans-array.cc | 13 +
 1 file changed, 1 insertion(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c506a5769dc4..e2f9728ac0c1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11174,21 +11174,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree 
decl, tree dest,
  cdesc = gfc_create_var (cdesc, "cdesc");
  DECL_ARTIFICIAL (cdesc) = 1;
 
- gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
- gfc_index_zero_node, ubound);
-
  if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
 
- gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
+ set_contiguous_array (&dealloc_block, cdesc, ubound, comp);
 
  /* Now call the deallocator.  */
  vtab = gfc_find_vtab (&c->ts);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] utilisation booléen allocatable

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:60f961fde9a37a7e17b9dd28cad4e6313228eb18

commit 60f961fde9a37a7e17b9dd28cad4e6313228eb18
Author: Mikael Morin 
Date:   Thu Jan 23 21:38:24 2025 +0100

utilisation booléen allocatable

Diff:
---
 gcc/fortran/trans-expr.cc | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 06a7097491f1..dae09762b012 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6102,12 +6102,12 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 
 static void
 set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
- gfc_symbol *c_sym)
+ bool allocatable)
 {
   tree tmp = gfc_get_cfi_desc_base_addr (cfi);
   gfc_conv_descriptor_data_set (block, gfc, tmp);
 
-  if (c_sym->attr.allocatable)
+  if (allocatable)
 {
   /* gfc->span = cfi->elem_len.  */
   tmp = fold_convert (gfc_array_index_type,
@@ -6560,7 +6560,7 @@ done:
   tmp = gfc_get_cfi_desc_base_addr (cfi);
   gfc_conv_descriptor_data_set (&block, gfc, tmp);
 
-  set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym);
+  set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym->attr.allocatable);
 }
 
   if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_descriptor_from_scalar conv_derived_to_class

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:52233b93213a8578013671aee33bfc9c3a031912

commit 52233b93213a8578013671aee33bfc9c3a031912
Author: Mikael Morin 
Date:   Wed Jan 29 18:22:29 2025 +0100

Factorisation set_descriptor_from_scalar conv_derived_to_class

Diff:
---
 gcc/fortran/trans-expr.cc | 42 +++---
 1 file changed, 23 insertions(+), 19 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c84ef068f403..088df549f797 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,7 +174,8 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol 
*sym, gfc_expr *expr)
 
 void
 set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-   gfc_expr *scalar_expr)
+   gfc_expr *scalar_expr, bool is_class,
+   tree cond_optional)
 {
   tree type = get_scalar_to_descriptor_type (scalar,
 gfc_expr_attr (scalar_expr));
@@ -185,9 +186,22 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc, 
tree scalar,
   tree dtype_ref = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (block, dtype_ref, dtype_val);
 
-  tree tmp = gfc_class_data_get (scalar);
-  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+  tree tmp;
+  if (is_class)
+{
+  tmp = gfc_class_data_get (scalar);
+  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+}
+  else if (cond_optional)
+{
+  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
+   cond_optional, scalar,
+   fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+  else
+tmp = scalar;
 
   gfc_conv_descriptor_data_set (block, desc, tmp);
 }
@@ -1067,20 +1081,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_symbol *fsym,
 
  /* Scalar to an assumed-rank array.  */
  if (fsym->ts.u.derived->components->as)
-   {
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
-   gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
- if (optional)
-   parmse->expr = build3_loc (input_location, COND_EXPR,
-  TREE_TYPE (parmse->expr),
-  cond_optional, parmse->expr,
-  fold_convert (TREE_TYPE 
(parmse->expr),
-null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
-   }
+   set_descriptor_from_scalar (&parmse->pre, ctree,
+   parmse->expr, e, false,
+   cond_optional);
   else
{
  tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1455,7 +1458,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_typespec class_ts,
   && e->rank != class_ts.u.derived->components->as->rank)
 {
   if (e->rank == 0)
-   set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
+   set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
+   true, NULL_TREE);
   else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Update dump match count

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:7c0984b4323edc1eadb27b3cb002c679521a5ad1

commit 7c0984b4323edc1eadb27b3cb002c679521a5ad1
Author: Mikael Morin 
Date:   Thu Jan 30 16:53:48 2025 +0100

Update dump match count

Diff:
---
 gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 
b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
index c83899de0e5b..a1f2a76ff73e 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
@@ -33,5 +33,5 @@ end program
 ! This lead to access to non exsitant memory in opencoarrays.
 ! In single image mode just checking for reduced number of
 ! descriptors is possible, i.e., execute always works.
-! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
+! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 10 "original" } }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:ef9b8102ec142543342d4f9d4f9cc8e78e66483f

commit ef9b8102ec142543342d4f9d4f9cc8e78e66483f
Author: Mikael Morin 
Date:   Wed Jan 29 19:05:04 2025 +0100

Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor

Correction régression pr49213.f90

Correction régression associated_assumed_rank.f90

Suppression code redondant

Diff:
---
 gcc/fortran/trans-expr.cc | 59 ---
 1 file changed, 30 insertions(+), 29 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 088df549f797..c5c2da220c7c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,46 +174,53 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol 
*sym, gfc_expr *expr)
 
 void
 set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-   gfc_expr *scalar_expr, bool is_class,
+   symbol_attribute scalar_attr, bool is_class,
tree cond_optional)
 {
-  tree type = get_scalar_to_descriptor_type (scalar,
-gfc_expr_attr (scalar_expr));
+  tree type = get_scalar_to_descriptor_type (scalar, scalar_attr);
   if (POINTER_TYPE_P (type))
 type = TREE_TYPE (type);
 
-  tree dtype_val = gfc_get_dtype (type);
+  tree etype = gfc_get_element_type (type);
+  tree dtype_val;
+  if (etype == void_type_node)
+dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
+  else
+dtype_val = gfc_get_dtype (type);
+
   tree dtype_ref = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (block, dtype_ref, dtype_val);
 
+  gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
   tree tmp;
   if (is_class)
+tmp = gfc_class_data_get (scalar);
+  else
+tmp = scalar;
+
+  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+  if (cond_optional)
 {
-  tmp = gfc_class_data_get (scalar);
-  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-}
-  else if (cond_optional)
-{
-  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
-   cond_optional, scalar,
+  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+   cond_optional, tmp,
fold_convert (TREE_TYPE (scalar),
  null_pointer_node));
 }
-  else
-tmp = scalar;
 
   gfc_conv_descriptor_data_set (block, desc, tmp);
 }
 
 
+
 tree
 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 {
-  tree desc, type, etype;
+  tree desc, type;
 
   type = get_scalar_to_descriptor_type (scalar, attr);
-  etype = TREE_TYPE (scalar);
   desc = gfc_create_var (type, "desc");
   DECL_ARTIFICIAL (desc) = 1;
 
@@ -224,15 +231,9 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, 
symbol_attribute attr)
   gfc_add_modify (&se->pre, tmp, scalar);
   scalar = tmp;
 }
-  if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = gfc_build_addr_expr (NULL_TREE, scalar);
-  else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
-etype = TREE_TYPE (etype);
-  gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype_rank_type (0, etype));
-  gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
-  gfc_conv_descriptor_span_set (&se->pre, desc,
-   gfc_conv_descriptor_elem_len (desc));
+
+  set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
+ false, NULL_TREE);
 
   /* Copy pointer address back - but only if it could have changed and
  if the actual argument is a pointer and not, e.g., NULL().  */
@@ -1082,8 +1083,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_symbol *fsym,
  /* Scalar to an assumed-rank array.  */
  if (fsym->ts.u.derived->components->as)
set_descriptor_from_scalar (&parmse->pre, ctree,
-   parmse->expr, e, false,
-   cond_optional);
+   parmse->expr, gfc_expr_attr (e),
+   false, cond_optional);
   else
{
  tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1458,8 +1459,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_typespec class_ts,
   && e->rank != class_ts.u.derived->components->as->rank)
 {
   if (e->rank == 0)
-   set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
-   true, NULL_TREE);
+   set_descriptor_from_scalar (&block, ctree, parmse->expr,
+   gfc_expr_attr (e), true, NULL_TREE);
   else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation initialisation depuis cfi

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:971a47a027b198d6ad2662318b273c1b6aa109c9

commit 971a47a027b198d6ad2662318b273c1b6aa109c9
Author: Mikael Morin 
Date:   Fri Jan 24 16:01:58 2025 +0100

Factorisation initialisation depuis cfi

Correction régression contiguous-2.f90

Correction regression contiguous-2.f90

Correction régression bind-c-contiguous-1.f90

Diff:
---
 gcc/fortran/trans-decl.cc | 220 --
 gcc/fortran/trans-expr.cc | 209 ---
 gcc/fortran/trans.h   |   2 +
 3 files changed, 194 insertions(+), 237 deletions(-)

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index bba4b7c8b0d0..f3a63dec05b4 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7024,7 +7024,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t 
*finally,
   stmtblock_t block;
   gfc_init_block (&block);
   tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
-  tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+  tree idx, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
   bool do_copy_inout = false;
 
   /* When allocatable + intent out, free the cfi descriptor.  */
@@ -7216,106 +7216,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t 
*finally,
goto done;
 }
 
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
-{
-  /* gfc->dtype = ... (from declaration, not from cfi).  */
-  etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
-  gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
- gfc_get_dtype_rank_type (sym->as->rank, etype));
-  /* gfc->data = cfi->base_addr. */
-  gfc_conv_descriptor_data_set (&block, gfc_desc,
-   gfc_get_cfi_desc_base_addr (cfi));
-}
-
-  if (sym->ts.type == BT_ASSUMED)
-{
-  /* For type(*), take elem_len + dtype.type from the actual argument.  */
-  gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
- gfc_get_cfi_desc_elem_len (cfi));
-  tree cond;
-  tree ctype = gfc_get_cfi_desc_type (cfi);
-  ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
-  ctype, build_int_cst (TREE_TYPE (ctype),
-CFI_type_mask));
-  tree type = gfc_conv_descriptor_type (gfc_desc);
-
-  /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN  */
-  /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
-  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
- build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_VOID));
-  tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type,
- build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
-  tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
-  /* if (CFI_type_struct) BT_DERIVED else  < tmp2 >  */
-  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
- build_int_cst (TREE_TYPE (ctype),
-CFI_type_struct));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_DERIVED));
-  tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
-  /* if (CFI_type_Character) BT_CHARACTER else  < tmp2 >  */
-  /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
-before (see below, as generated bottom up).  */
-  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Character));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
-  tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
-  /* if (CFI_type_ucs4_char) BT_CHARACTER else  < tmp2 >  */
-  /* Note: gfc->elem_len = cfi->elem_len/4.  */
-  /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
-gfc->elem_len == cfi->elem_len, which helps with operations which use
-sizeof() in Fortran and cfi->elem_len in C.  */
-  tmp = gfc_get_cfi_desc_type (cfi);
-  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp),
- 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Déplacement méthode set_descriptor_from_scalar

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:2706d5a72139c9d716f367cf1c3ccfbe8d40800d

commit 2706d5a72139c9d716f367cf1c3ccfbe8d40800d
Author: Mikael Morin 
Date:   Thu Jan 30 21:07:15 2025 +0100

Déplacement méthode set_descriptor_from_scalar

Correction erreur compil'

Diff:
---
 gcc/fortran/trans-array.cc | 63 +++
 gcc/fortran/trans-array.h  |  3 ++
 gcc/fortran/trans-expr.cc  | 83 +-
 3 files changed, 75 insertions(+), 74 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 385bc8fcd380..8b32b750854d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1786,6 +1786,69 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree 
desc,
   gfc_conv_descriptor_offset_set (block, desc, offset);
 }
 
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+   arrays.  */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+  enum gfc_array_kind akind;
+
+  if (attr.pointer)
+akind = GFC_ARRAY_POINTER_CONT;
+  else if (attr.allocatable)
+akind = GFC_ARRAY_ALLOCATABLE;
+  else
+akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+  if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+scalar = TREE_TYPE (scalar);
+  return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+   akind, !(attr.pointer || attr.target));
+}
+
+
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+   symbol_attribute scalar_attr, bool is_class,
+   tree cond_optional)
+{
+  tree type = gfc_get_scalar_to_descriptor_type (scalar, scalar_attr);
+  if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+  tree etype = gfc_get_element_type (type);
+  tree dtype_val;
+  if (etype == void_type_node)
+dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
+  else
+dtype_val = gfc_get_dtype (type);
+
+  tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (block, dtype_ref, dtype_val);
+
+  gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+  tree tmp;
+  if (is_class)
+tmp = gfc_class_data_get (scalar);
+  else
+tmp = scalar;
+
+  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+  if (cond_optional)
+{
+  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+   cond_optional, tmp,
+   fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+
+  gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
 
 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 296a8052dd73..691231f66903 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,6 +147,9 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol 
*, gfc_expr *, tree);
 void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *, 
gfc_expr *, tree);
 void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
gfc_expr *, locus *);
+tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
+void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
+symbol_attribute, bool, tree);
 
 /* Get a single array element.  */
 void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c5c2da220c7c..ff76b1ba1787 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -83,34 +83,12 @@ gfc_get_character_len_in_bytes (tree type)
 }
 
 
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
-   arrays.  */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
-  enum gfc_array_kind akind;
-
-  if (attr.pointer)
-akind = GFC_ARRAY_POINTER_CONT;
-  else if (attr.allocatable)
-akind = GFC_ARRAY_ALLOCATABLE;
-  else
-akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
-  if (POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = TREE_TYPE (scalar);
-  return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
-   akind, !(attr.pointer || attr.target));
-}
-
-
 tree
 gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr 
*expr, tree scalar)
 {
   symbol_attribute attr = sym->attr;
 
-  tree type = get_scalar_to_descriptor_type (scalar, attr);
+  tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
   tree desc = gfc_create_var (type, "desc");
   DECL_ARTIFICIAL (desc) = 1;
 
@@ -172,55 +150,12 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol 
*sym, gfc_expr *expr)
 }
 
 
-void
-set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Déplacement gfc_set_gfc_from_cfi

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:db316c89fe13530d9bea52badda4fed7e90e8638

commit db316c89fe13530d9bea52badda4fed7e90e8638
Author: Mikael Morin 
Date:   Thu Jan 30 21:27:40 2025 +0100

Déplacement gfc_set_gfc_from_cfi

Correction compil'

Diff:
---
 gcc/fortran/trans-array.cc | 258 +
 gcc/fortran/trans-array.h  |   3 +
 gcc/fortran/trans-expr.cc  | 218 --
 gcc/fortran/trans.h|   3 -
 4 files changed, 241 insertions(+), 241 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9394fe997905..d63c4ac0d01b 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1468,6 +1468,26 @@ gfc_conv_shift_descriptor_subarray (stmtblock_t *block, 
tree desc,
 }
 
 
+int
+gfc_descriptor_rank (tree descriptor)
+{
+  if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+  tree dim = gfc_get_descriptor_dimension (descriptor);
+  tree dim_type = TREE_TYPE (dim);
+  gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+  tree idx_type = TYPE_DOMAIN (dim_type);
+  gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+  gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+  tree idx_max = TYPE_MAX_VALUE (idx_type);
+  if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+  wide_int max = wi::to_wide (idx_max);
+  return max.to_shwi () + 1;
+}
+
+
 void
 gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
   int src_rank, const gfc_array_spec &as)
@@ -1849,26 +1869,6 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree 
desc, tree scalar,
   gfc_conv_descriptor_data_set (block, desc, tmp);
 }
 
-int
-gfc_descriptor_rank (tree descriptor)
-{
-  if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
-  tree dim = gfc_get_descriptor_dimension (descriptor);
-  tree dim_type = TREE_TYPE (dim);
-  gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
-  tree idx_type = TYPE_DOMAIN (dim_type);
-  gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
-  gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
-  tree idx_max = TYPE_MAX_VALUE (idx_type);
-  if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
-  wide_int max = wi::to_wide (idx_max);
-  return max.to_shwi () + 1;
-}
-
-
 void
 gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
  bool assumed_rank_lhs)
@@ -1913,6 +1913,224 @@ gfc_copy_sequence_descriptor (stmtblock_t &block, tree 
lhs_desc, tree rhs_desc,
 }
 
 
+void
+gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
+ stmtblock_t *conditional_block, tree gfc, tree cfi,
+ tree rank, gfc_symbol *gfc_sym,
+ bool init_static, bool contiguous_gfc, bool 
contiguous_cfi)
+{
+  tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+  gfc_conv_descriptor_data_set (unconditional_block, gfc, tmp);
+
+  if (init_static)
+{
+  /* gfc->dtype = ... (from declaration, not from cfi).  */
+  tree etype = gfc_get_element_type (TREE_TYPE (gfc));
+  gfc_add_modify (unconditional_block, gfc_conv_descriptor_dtype (gfc),
+ gfc_get_dtype_rank_type (gfc_sym->as->rank, etype));
+
+  if (gfc_sym->as->type == AS_ASSUMED_RANK)
+   gfc_add_modify (unconditional_block,
+   gfc_conv_descriptor_rank (gfc), rank);
+}
+
+  if (gfc_sym && gfc_sym->ts.type == BT_ASSUMED)
+{
+  /* For type(*), take elem_len + dtype.type from the actual argument.  */
+  gfc_add_modify (unconditional_block, gfc_conv_descriptor_elem_len (gfc),
+ gfc_get_cfi_desc_elem_len (cfi));
+  tree cond;
+  tree ctype = gfc_get_cfi_desc_type (cfi);
+  ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+  ctype, build_int_cst (TREE_TYPE (ctype),
+CFI_type_mask));
+  tree type = gfc_conv_descriptor_type (gfc);
+
+  /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN  */
+  /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+build_int_cst (TREE_TYPE (type), BT_VOID));
+  tree tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+  type,
+  build_int_cst (TREE_TYPE (type), 
BT_UNKNOWN));
+  tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+  /* if (CFI_type_struct) BT_DERIVED else  < tmp2 >  */
+  cond = fold_build2_loc (input_location, EQ_

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Séparation motifs dump assumed_rank_12.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:c3d40aceca0b00adb1aba7c0ca55d56414dfb820

commit c3d40aceca0b00adb1aba7c0ca55d56414dfb820
Author: Mikael Morin 
Date:   Wed Feb 5 11:57:09 2025 +0100

Séparation motifs dump assumed_rank_12.f90

Diff:
---
 gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 6 +-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 
b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index 873498f82d76..cacfb7ed52af 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,5 +16,9 @@ function f() result(res)
 end function f
 end
 
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data = 
.void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" 
"original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);" "original" } }
+! { dg-final { scan-tree-dump "desc.0.dtype = .*;" "original" } }
+! { dg-final { scan-tree-dump "desc.0.data = .void .. D.*;" "original" } }
+! { dg-final { scan-tree-dump "sub \\(&desc.0\\);" "original" } }
+! { dg-final { scan-tree-dump "D.*= .integer.kind=4. .. desc.0.data;" 
"original" } }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Déplacement gfc_copy_sequence_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:b30af8b23e527625ae8df96911cb6be3485d4b5b

commit b30af8b23e527625ae8df96911cb6be3485d4b5b
Author: Mikael Morin 
Date:   Thu Jan 30 21:21:39 2025 +0100

Déplacement gfc_copy_sequence_descriptor

Correction erreur compil'

Diff:
---
 gcc/fortran/trans-array.cc | 64 ++
 gcc/fortran/trans-array.h  |  1 +
 gcc/fortran/trans-expr.cc  | 64 --
 gcc/fortran/trans.h|  1 -
 4 files changed, 65 insertions(+), 65 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8b32b750854d..9394fe997905 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1849,6 +1849,70 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree 
desc, tree scalar,
   gfc_conv_descriptor_data_set (block, desc, tmp);
 }
 
+int
+gfc_descriptor_rank (tree descriptor)
+{
+  if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+  tree dim = gfc_get_descriptor_dimension (descriptor);
+  tree dim_type = TREE_TYPE (dim);
+  gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+  tree idx_type = TYPE_DOMAIN (dim_type);
+  gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+  gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+  tree idx_max = TYPE_MAX_VALUE (idx_type);
+  if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+  wide_int max = wi::to_wide (idx_max);
+  return max.to_shwi () + 1;
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+  int lhs_rank = gfc_descriptor_rank (lhs_desc);
+  int rhs_rank = gfc_descriptor_rank (rhs_desc);
+  tree desc;
+
+  if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+  else
+{
+  tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+  gfc_conv_descriptor_data_set (&block, arr,
+   gfc_conv_descriptor_data_get (rhs_desc));
+  gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+  tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+  gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+  gfc_conv_descriptor_stride_set (
+   &block, arr, gfc_index_zero_node,
+   gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+  for (int i = 1; i < lhs_rank; i++)
+   {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+   }
+  gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+  gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, lhs_rank));
+  gfc_conv_descriptor_span_set (&block, arr,
+   gfc_conv_descriptor_span_get (arr));
+  gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+  desc = arr;
+}
+
+  gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
+
 
 /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 691231f66903..124020a53858 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -150,6 +150,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree, 
tree,
 tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
 void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
 symbol_attribute, bool, tree);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
 
 /* Get a single array element.  */
 void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ff76b1ba1787..16c7c2687526 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -800,70 +800,6 @@ gfc_get_vptr_from_expr (tree expr)
 }
 
 
-int
-gfc_descriptor_rank (tree descriptor)
-{
-  if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
-  tree dim = gfc_get_descriptor_dimension (descriptor);
-  tree dim_type = TREE_TYPE (dim);
-  gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
-  tree idx_type = TYPE_DOMAIN (dim_type);
-  gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
-  gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
-  tree idx_max = TYPE_MAX_VALUE (idx_type);
-  if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
-  wide_int max = wi::to_wide

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Sauvegarde factorisation set_descriptor_from_scalar

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:c41855aa4c01657732c278987635ed3d9bf12c92

commit c41855aa4c01657732c278987635ed3d9bf12c92
Author: Mikael Morin 
Date:   Tue Feb 4 11:16:32 2025 +0100

Sauvegarde factorisation set_descriptor_from_scalar

Correction régression allocate_with_source_15.f03

Nettoyage correction

Correction régression allocate_with_mold_3

Correction allocate_with_source_16.f90

Correction régression assumed_rank_21.f90

Correction coarray_allocate_8.f08

Correction régression pr86470.f90

Correction régression dummy_3.f90

Diff:
---
 gcc/fortran/trans-array.cc | 204 +++--
 gcc/fortran/trans-array.h  |   2 +-
 gcc/fortran/trans-expr.cc  |  67 +--
 gcc/fortran/trans-types.cc |  47 +++
 gcc/fortran/trans-types.h  |   1 +
 gcc/fortran/trans.h|   1 +
 6 files changed, 218 insertions(+), 104 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d63c4ac0d01b..65da97b67066 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -92,6 +92,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-array.h"
 #include "trans-const.h"
 #include "dependency.h"
+#include "gimplify.h"
 
 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
 
@@ -602,7 +603,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
 }
 
 
-static int
+static bt
 get_type_info (const bt &type)
 {
   switch (type)
@@ -613,11 +614,13 @@ get_type_info (const bt &type)
 case BT_COMPLEX:
 case BT_DERIVED:
 case BT_CHARACTER:
-case BT_CLASS:
 case BT_VOID:
 case BT_UNSIGNED:
   return type;
 
+case BT_CLASS:
+  return BT_DERIVED;
+
 case BT_PROCEDURE:
 case BT_ASSUMED:
   return BT_VOID;
@@ -674,9 +677,15 @@ get_size_info (gfc_typespec &ts)
 class modify_info
 {
 public:
+  virtual bool set_dtype () const { return is_initialization (); }
+  virtual bool use_tree_type () const { return false; }
   virtual bool is_initialization () const { return false; }
   virtual bool initialize_data () const { return false; }
+  virtual bool set_span () const { return false; }
+  virtual bool set_token () const { return true; }
   virtual tree get_data_value () const { return NULL_TREE; }
+  virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
+  virtual tree get_length (gfc_typespec *ts) const { return get_size_info 
(*ts); }
 };
 
 class nullification : public modify_info
@@ -700,8 +709,14 @@ class init_info : public modify_info
 public:
   virtual bool is_initialization () const { return true; }
   virtual gfc_typespec *get_type () const { return nullptr; }
+  virtual bt get_type_type (const gfc_typespec &) const;
 };
 
+bt
+init_info::get_type_type (const gfc_typespec & type_info) const
+{
+  return get_type_info (type_info.type);
+}
 
 class default_init : public init_info
 {
@@ -731,23 +746,103 @@ public:
   virtual gfc_typespec *get_type () const { return &ts; }
 };
 
-class scalar_value : public init_info
+
+class scalar_value : public modify_info
 {
 private:
-  gfc_typespec &ts;
+  bool initialisation;
+  gfc_typespec *ts;
   tree value;
+  bool use_tree_type_;
+  bool clear_token;
+  tree get_elt_type () const;
 
 public:
   scalar_value(gfc_typespec &arg_ts, tree arg_value)
-: ts(arg_ts), value(arg_value) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_ 
(false), clear_token(true) { }
+  scalar_value(tree arg_value)
+: initialisation(true), ts(nullptr), value(arg_value), use_tree_type_ 
(true), clear_token(false) { }
+  virtual bool is_initialization () const { return initialisation; }
   virtual bool initialize_data () const { return true; }
-  virtual tree get_data_value () const { return value; }
-  virtual gfc_typespec *get_type () const { return &ts; }
+  virtual tree get_data_value () const;
+  virtual gfc_typespec *get_type () const { return ts; }
+  virtual bool set_span () const { return true; }
+  virtual bool use_tree_type () const { return use_tree_type_; }
+  virtual bool set_token () const { return clear_token; }
+  virtual bt get_type_type (const gfc_typespec &) const;
+  virtual tree get_length (gfc_typespec *ts) const;
 };
 
 
+tree
+scalar_value::get_data_value () const
+{
+  if (POINTER_TYPE_P (TREE_TYPE (value)))
+return value;
+  else
+return gfc_build_addr_expr (NULL_TREE, value);
+}
+
+tree
+scalar_value::get_elt_type () const
+{
+  tree tmp = value;
+
+  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = TREE_TYPE (tmp);
+
+  tree etype = TREE_TYPE (tmp);
+
+  /* For arrays, which are not scalar coarrays.  */
+  if (TREE_CODE (etype) == ARRAY_TYPE && !TYPE_STRING_FLAG (etype))
+etype = TREE_TYPE (etype);
+
+  return etype;
+}
+
+bt
+scalar_value::get_type_type (const gfc_typespec & type_info) const
+{
+  bt n;
+  if (use_tree_type ())
+{
+  tree etype = get_elt_type ();
+  gf

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] réduction différences dump assumed_rank_12.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:733a134201a5dd800e59adfd2b1fdd018452230a

commit 733a134201a5dd800e59adfd2b1fdd018452230a
Author: Mikael Morin 
Date:   Wed Feb 5 11:45:00 2025 +0100

réduction différences dump assumed_rank_12.f90

Diff:
---
 gcc/fortran/trans-array.cc | 126 -
 1 file changed, 124 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 65da97b67066..ab4276c8954c 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1087,11 +1087,131 @@ field_count (tree type)
 }
 
 
-bool
+#if 0
+static bool
 complete_init_p (tree type, vec *init_values)
 {
   return (unsigned) field_count (type) == vec_safe_length (init_values);
 }
+#endif
+
+
+static int
+cmp_wi (const void *x, const void *y)
+{
+  const offset_int *wix = (const offset_int *) x;
+  const offset_int *wiy = (const offset_int *) y;
+
+  return wi::cmpu (*wix, *wiy);
+}
+
+
+static offset_int
+get_offset_bits (tree field)
+{
+  offset_int field_offset = wi::to_offset (DECL_FIELD_OFFSET (field));
+  offset_int field_bit_offset = wi::to_offset (DECL_FIELD_BIT_OFFSET (field));
+  unsigned long offset_align = DECL_OFFSET_ALIGN (field);
+
+  return field_offset * offset_align + field_bit_offset;
+}
+
+
+static bool
+check_cleared_low_bits (const offset_int &val, int bitcount)
+{
+  if (bitcount == 0)
+return true;
+
+  offset_int mask = wi::mask  (bitcount, false);
+  if ((val & mask) != 0)
+return false;
+
+  return true;
+}
+
+
+static bool
+right_shift_if_clear (const offset_int &val, int bitcount, offset_int *result)
+{
+  if (bitcount == 0)
+{
+  *result = val;
+  return true;
+}
+
+  if (!check_cleared_low_bits (val, bitcount))
+return false;
+
+  *result = val >> bitcount;
+  return true;
+}
+
+
+static bool
+contiguous_init_p (tree type, tree value)
+{
+  gcc_assert (TREE_CODE (value) == CONSTRUCTOR);
+  auto_vec field_offsets;
+  int count = field_count (type);
+  field_offsets.reserve (count);
+
+  tree field = TYPE_FIELDS (type);
+  offset_int expected_offset = 0;
+  while (field != NULL_TREE)
+{
+  offset_int field_offset_bits = get_offset_bits (field);
+  offset_int field_offset;
+  if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+   return false;
+
+  offset_int type_size = wi::to_offset (TYPE_SIZE_UNIT (TREE_TYPE 
(field)));
+  int align = wi::ctz (type_size);
+  if (!check_cleared_low_bits (field_offset, align))
+   return false;
+
+  if (field_offset != expected_offset)
+   return false;
+
+  expected_offset += type_size;
+  field_offsets.quick_push (field_offset);
+
+  field = DECL_CHAIN (field);
+}
+
+  auto_vec value_offsets;
+  value_offsets.reserve (count);
+
+  unsigned i;
+  tree field_init;
+  FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+{
+  if (TREE_TYPE (field) != TREE_TYPE (field_init))
+   return false;
+
+  offset_int field_offset_bits = get_offset_bits (field);
+  offset_int field_offset;
+  if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+   return false;
+
+  value_offsets.quick_push (field_offset);
+}
+
+  value_offsets.qsort (cmp_wi);
+
+  unsigned idx = 0;
+  offset_int field_off, val_off;
+  while (field_offsets.iterate (idx, &field_off)
+&& value_offsets.iterate (idx, &val_off))
+{
+  if (val_off != field_off)
+   return false;
+
+  idx++;
+}
+
+  return true;
+}
 
 
 static bool
@@ -1163,7 +1283,9 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind 
kind,
   if (TREE_STATIC (data_ref)
  || !modifiable_p (data_ref))
DECL_INITIAL (data_ref) = value;
-  else if (TREE_CODE (value) == CONSTRUCTOR)
+  else if (TREE_CODE (value) == CONSTRUCTOR
+  && !(TREE_CONSTANT (value)
+   && contiguous_init_p (type, value)))
{
  unsigned i;
  tree field, field_init;

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_descriptor_dimension

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:ee3997f252330c0ee56b864f52dd84577b2f1670

commit ee3997f252330c0ee56b864f52dd84577b2f1670
Author: Mikael Morin 
Date:   Fri Feb 7 12:07:36 2025 +0100

Factorisation set_descriptor_dimension

Correction compil'

Diff:
---
 gcc/fortran/trans-array.cc | 82 +-
 1 file changed, 44 insertions(+), 38 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ee5b95df9ccb..87114f13424b 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1474,6 +1474,41 @@ gfc_build_null_descriptor (tree type)
 }
 
 
+static tree
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset)
+{
+  /* Set bounds in descriptor.  */
+  lbound = fold_convert (gfc_array_index_type, lbound);
+  lbound = gfc_evaluate_now (lbound, block);
+  gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+
+  ubound = fold_convert (gfc_array_index_type, ubound);
+  ubound = gfc_evaluate_now (ubound, block);
+  gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+
+  /* Set stride.  */
+  stride = fold_convert (gfc_array_index_type, stride);
+  stride = gfc_evaluate_now (stride, block);
+  gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
+
+  /* Update offset.  */
+  tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+  *offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+
+  /* Return stride for next dimension.  */
+  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  stride = fold_build2_loc (input_location, MULT_EXPR,
+   gfc_array_index_type, stride, tmp);
+  return stride;
+}
+
+
 /* Modify a descriptor such that the lbound of a given dimension is the value
specified.  This also updates ubound and offset accordingly.  */
 
@@ -1824,9 +1859,9 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, 
tree src,
 
   /* Copy offset but adjust it such that it would correspond
  to a lbound of zero.  */
+  tree offset;
   if (src_rank == -1)
-gfc_conv_descriptor_offset_set (block, dest,
-   gfc_index_zero_node);
+offset = gfc_index_zero_node;
   else
 {
   tree offs = gfc_conv_descriptor_offset_get (src);
@@ -1842,7 +1877,7 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, 
tree src,
  offs = fold_build2_loc (input_location, PLUS_EXPR,
  gfc_array_index_type, offs, tmp);
}
-  gfc_conv_descriptor_offset_set (block, dest, offs);
+  offset = offs;
 }
   /* Set the bounds as declared for the LHS and calculate strides as
  well as another offset update accordingly.  */
@@ -1858,46 +1893,17 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree 
dest, tree src,
   /* Convert declared bounds.  */
   gfc_init_se (&lower_se, NULL);
   gfc_init_se (&upper_se, NULL);
-  gfc_conv_expr (&lower_se, as.lower[dim]);
-  gfc_conv_expr (&upper_se, as.upper[dim]);
+  gfc_conv_expr_val (&lower_se, as.lower[dim]);
+  gfc_conv_expr_val (&upper_se, as.upper[dim]);
 
   gfc_add_block_to_block (block, &lower_se.pre);
   gfc_add_block_to_block (block, &upper_se.pre);
 
-  tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
-  tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
-  lbound = gfc_evaluate_now (lbound, block);
-  ubound = gfc_evaluate_now (ubound, block);
-
-  gfc_add_block_to_block (block, &lower_se.post);
-  gfc_add_block_to_block (block, &upper_se.post);
-
-  /* Set bounds in descriptor.  */
-  gfc_conv_descriptor_lbound_set (block, dest,
- gfc_rank_cst[dim], lbound);
-  gfc_conv_descriptor_ubound_set (block, dest,
- gfc_rank_cst[dim], ubound);
-
-  /* Set stride.  */
-  stride = gfc_evaluate_now (stride, block);
-  gfc_conv_descriptor_stride_set (block, dest,
- gfc_rank_cst[dim], stride);
-
-  /* Update offset.  */
-  tree offs = gfc_conv_descriptor_offset_get (dest);
-  tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type, lbound, stride);
-  offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
-  offs = gfc_evaluate_now (offs, block);
-  gfc_conv_descriptor_offset_set (block, dest, offs);
-
-  /* Update stride.  */
-  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
-  stride = fold_build2_loc (input_location, MULT_EX

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Introduction getters et setters descriptor compil' OK

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:08b15e8c2f67f6e868a127cb68bc537f43e0a7df

commit 08b15e8c2f67f6e868a127cb68bc537f43e0a7df
Author: Mikael Morin 
Date:   Mon Feb 10 19:24:59 2025 +0100

Introduction getters et setters descriptor compil' OK

Correction régression realloc on assign (associate_61, ...)

Correction régression assumed_rank_7.f90

Correction ICE coarray_42.f90

Diff:
---
 gcc/fortran/trans-array.cc | 817 +
 gcc/fortran/trans-array.h  |  26 +-
 gcc/fortran/trans-decl.cc  |   8 +-
 gcc/fortran/trans-expr.cc  |  66 ++--
 gcc/fortran/trans-intrinsic.cc |  18 +-
 gcc/fortran/trans-openmp.cc|   2 +-
 gcc/fortran/trans-stmt.cc  |   7 +-
 gcc/fortran/trans.cc   |   7 +-
 8 files changed, 651 insertions(+), 300 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cbe0c85ca235..0522b1bc6e49 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -242,8 +242,15 @@ gfc_get_cfi_dim_sm (tree desc, tree idx)
 #define LBOUND_SUBFIELD 1
 #define UBOUND_SUBFIELD 2
 
-static tree
-gfc_get_descriptor_field (tree desc, unsigned field_idx)
+
+namespace gfc_descriptor
+{
+
+namespace
+{
+
+tree
+get_field (tree desc, unsigned field_idx)
 {
   tree type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -251,111 +258,119 @@ gfc_get_descriptor_field (tree desc, unsigned field_idx)
   tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
   gcc_assert (field != NULL_TREE);
 
+  return field;
+}
+
+tree
+get_component (tree desc, unsigned field_idx)
+{
+  tree field = get_field (desc, field_idx);
+
   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
  desc, field, NULL_TREE);
 }
 
-/* This provides READ-ONLY access to the data field.  The field itself
-   doesn't have the proper type.  */
+tree
+get_data (tree desc)
+{
+  return get_component (desc, DATA_FIELD);
+}
 
 tree
-gfc_conv_descriptor_data_get (tree desc)
+conv_data_get (tree desc)
 {
   tree type = TREE_TYPE (desc);
-  if (TREE_CODE (type) == REFERENCE_TYPE)
-gcc_unreachable ();
+  gcc_assert (TREE_CODE (type) != REFERENCE_TYPE);
 
-  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
-  return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
+  tree field = get_data (desc);
+  tree t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
+  return non_lvalue_loc (input_location, t);
 }
 
-/* This provides WRITE access to the data field.
-
-   TUPLES_P is true if we are generating tuples.
-
-   This function gets called through the following macros:
- gfc_conv_descriptor_data_set
- gfc_conv_descriptor_data_set.  */
-
 void
-gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
+conv_data_set (stmtblock_t *block, tree desc, tree value)
 {
-  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+  tree field = get_data (desc);
   gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
 }
 
-
-/* This provides address access to the data field.  This should only be
-   used by array allocation, passing this on to the runtime.  */
-
 tree
-gfc_conv_descriptor_data_addr (tree desc)
+conv_data_addr (tree desc)
 {
-  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+  tree field = get_data (desc);
   return gfc_build_addr_expr (NULL_TREE, field);
 }
 
-static tree
-gfc_conv_descriptor_offset (tree desc)
+tree
+get_offset (tree desc)
 {
-  tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
+  tree field = get_component (desc, OFFSET_FIELD);
   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
   return field;
 }
 
 tree
-gfc_conv_descriptor_offset_get (tree desc)
+conv_offset_get (tree desc)
 {
-  return gfc_conv_descriptor_offset (desc);
+  return non_lvalue_loc (input_location, get_offset (desc));
 }
 
 void
-gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
-   tree value)
+conv_offset_set (stmtblock_t *block, tree desc, tree value)
 {
-  tree t = gfc_conv_descriptor_offset (desc);
+  tree t = get_offset (desc);
   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 }
 
-
 tree
-gfc_conv_descriptor_dtype (tree desc)
+get_dtype (tree desc)
 {
-  tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
+  tree field = get_component (desc, DTYPE_FIELD);
   gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
   return field;
 }
 
-static tree
-gfc_conv_descriptor_span (tree desc)
+tree
+conv_dtype_get (tree desc)
+{
+  return non_lvalue_loc (input_location, get_dtype (desc));
+}
+
+void
+conv_dtype_set (stmtblock_t *block, tree desc, tree val)
+{
+  tree t = get_dtype (desc);
+  gfc_add_modify (block, t, val);
+}
+
+tree
+get_span (tree desc)
 {
-  tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
+  tree field = get_component (desc, SPAN_FIELD);
   gcc_assert (TREE_TYPE (field) == gfc_array

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation initialisation dimension descripteur

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:6fe4fd1425a5c2d5b239cd5dd88c017c5e880ae6

commit 6fe4fd1425a5c2d5b239cd5dd88c017c5e880ae6
Author: Mikael Morin 
Date:   Sat Feb 8 21:37:49 2025 +0100

Factorisation initialisation dimension descripteur

Correction régression realloc_on_assign_12.f90

Diff:
---
 gcc/fortran/trans-array.cc | 87 +-
 1 file changed, 48 insertions(+), 39 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 87114f13424b..cbe0c85ca235 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1474,38 +1474,56 @@ gfc_build_null_descriptor (tree type)
 }
 
 
-static tree
-set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
- tree lbound, tree ubound, tree stride, tree *offset)
+static void
+set_bounds_update_offset (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree 
lbound_diff,
+ tree *offset, tree *next_stride, bool 
stride_unchanged)
 {
-  /* Set bounds in descriptor.  */
+  /* Stabilize values in case the expressions depend on the existing bounds.  
*/
   lbound = fold_convert (gfc_array_index_type, lbound);
   lbound = gfc_evaluate_now (lbound, block);
-  gfc_conv_descriptor_lbound_set (block, desc,
- gfc_rank_cst[dim], lbound);
 
   ubound = fold_convert (gfc_array_index_type, ubound);
   ubound = gfc_evaluate_now (ubound, block);
-  gfc_conv_descriptor_ubound_set (block, desc,
- gfc_rank_cst[dim], ubound);
 
-  /* Set stride.  */
   stride = fold_convert (gfc_array_index_type, stride);
   stride = gfc_evaluate_now (stride, block);
-  gfc_conv_descriptor_stride_set (block, desc,
- gfc_rank_cst[dim], stride);
+
+  lbound_diff = fold_convert (gfc_array_index_type, lbound_diff);
+  lbound_diff = gfc_evaluate_now (lbound_diff, block);
+
+  gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+  gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+  if (!stride_unchanged)
+gfc_conv_descriptor_stride_set (block, desc,
+   gfc_rank_cst[dim], stride);
 
   /* Update offset.  */
   tree tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, stride);
-  *offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, *offset, tmp);
+ gfc_array_index_type, lbound_diff, stride);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+gfc_array_index_type, *offset, tmp);
+  *offset = gfc_evaluate_now (tmp, block);
+
+  if (!next_stride)
+return;
 
-  /* Return stride for next dimension.  */
+  /* Set stride for next dimension.  */
   tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
-  stride = fold_build2_loc (input_location, MULT_EXPR,
-   gfc_array_index_type, stride, tmp);
-  return stride;
+  *next_stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+}
+
+
+static void
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset,
+ tree *next_stride)
+{
+  set_bounds_update_offset (block, desc, dim, lbound, ubound, stride, lbound,
+   offset, next_stride, false);
 }
 
 
@@ -1514,7 +1532,7 @@ set_descriptor_dimension (stmtblock_t *block, tree desc, 
int dim,
 
 static void
 conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree 
to_desc, int dim,
- tree new_lbound, tree offset, bool zero_based)
+ tree new_lbound, tree *offset, bool zero_based)
 {
   new_lbound = fold_convert (gfc_array_index_type, new_lbound);
   new_lbound = gfc_evaluate_now (new_lbound, block);
@@ -1538,18 +1556,9 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree 
from_desc, tree to_desc,
  updating the lbound, as they depend on the lbound expression!  */
   tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
   ubound, diff);
-  gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
-  /* Set lbound to the value we want.  */
-  gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim], 
new_lbound);
 
-  tree offs_diff = fold_build2_loc (input_location, MULT_EXPR, 
gfc_array_index_type,
-   diff, stride);
-  tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR, 
gfc_array_index_type,
-  offset, offs_diff);
-  gfc_add_modify (block, offset, tmp2);
-
-  if (from_desc != to_desc)
-

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation gfc_conv_shift_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:f8223bcc7fe3ef718208cc05c4365a3f57e05dc7

commit f8223bcc7fe3ef718208cc05c4365a3f57e05dc7
Author: Mikael Morin 
Date:   Thu Feb 6 17:16:13 2025 +0100

Factorisation gfc_conv_shift_descriptor

Correction compil'

Correction régression allocated_4.f90

Factorisation gfc_conv_shift_descriptor.

Correction régression allocated_4.f90

Modifications mineures

Correction régression bound_10.f90

Correction régression alloc_comp_constructor_1.f90

Correction régression realloc_on_assign_10

Revert "Correction régression realloc_on_assign_10"

This reverts commit 007ca869933eb74b76398200ef0237219ba01cd8.

Correction régression realloc_on_assign_11.f90

Diff:
---
 gcc/fortran/trans-array.cc | 165 ++---
 gcc/fortran/trans-expr.cc  |  15 -
 2 files changed, 94 insertions(+), 86 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c383d9c58342..ee5b95df9ccb 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1478,35 +1478,43 @@ gfc_build_null_descriptor (tree type)
specified.  This also updates ubound and offset accordingly.  */
 
 static void
-conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
- tree new_lbound, tree offset)
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree 
to_desc, int dim,
+ tree new_lbound, tree offset, bool zero_based)
 {
-  tree ubound, lbound, stride;
-  tree diff, offs_diff;
-
   new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+  new_lbound = gfc_evaluate_now (new_lbound, block);
 
-  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
-  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+  tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+  tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+  tree stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
 
-  /* Get difference (new - old) by which to shift stuff.  */
-  diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- new_lbound, lbound);
+  tree diff;
+  if (zero_based)
+diff = new_lbound;
+  else
+{
+  /* Get difference (new - old) by which to shift stuff.  */
+  diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ new_lbound, lbound);
+  diff = gfc_evaluate_now (diff, block);
+}
 
   /* Shift ubound and offset accordingly.  This has to be done before
  updating the lbound, as they depend on the lbound expression!  */
-  ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-   ubound, diff);
-  gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
-  offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-  diff, stride);
-  tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, offs_diff);
-  gfc_add_modify (block, offset, tmp);
+  tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+  ubound, diff);
+  gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
+  /* Set lbound to the value we want.  */
+  gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim], 
new_lbound);
 
-  /* Finally set lbound to value we want.  */
-  gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+  tree offs_diff = fold_build2_loc (input_location, MULT_EXPR, 
gfc_array_index_type,
+   diff, stride);
+  tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR, 
gfc_array_index_type,
+  offset, offs_diff);
+  gfc_add_modify (block, offset, tmp2);
+
+  if (from_desc != to_desc)
+gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank_cst[dim], stride);
 }
 
 
@@ -1514,6 +1522,7 @@ class lb_info_base
 {
 public:
   virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+  virtual bool zero_based_src () const { return false; }
 };
 
 
@@ -1574,21 +1583,64 @@ public:
 
 
 static void
-conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
   const lb_info_base &info)
 {
-  tree tmp = gfc_conv_descriptor_offset_get (desc);
-  tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
-  gfc_add_modify (block, offset_var, tmp);
+  if (src != dest)
+{
+  tree tmp = gfc_conv_descriptor_data_get (src);
+  gfc_conv_descriptor_data_set (block, dest, tmp);
+}
+
+  tree offset_va

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Renseignement token par gfc_set_descriptor_from_scalar.

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:012045ef77a7d31c977a94c06115e88e36f0260a

commit 012045ef77a7d31c977a94c06115e88e36f0260a
Author: Mikael Morin 
Date:   Wed Feb 5 15:12:25 2025 +0100

Renseignement token par gfc_set_descriptor_from_scalar.

Diff:
---
 gcc/fortran/trans-array.cc | 27 ---
 gcc/fortran/trans-array.h  |  2 +-
 gcc/fortran/trans-expr.cc  | 15 +++
 3 files changed, 32 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ab4276c8954c..c383d9c58342 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -684,6 +684,7 @@ public:
   virtual bool set_span () const { return false; }
   virtual bool set_token () const { return true; }
   virtual tree get_data_value () const { return NULL_TREE; }
+  virtual tree get_caf_token () const { return null_pointer_node; }
   virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
   virtual tree get_length (gfc_typespec *ts) const { return get_size_info 
(*ts); }
 };
@@ -753,22 +754,24 @@ private:
   bool initialisation;
   gfc_typespec *ts;
   tree value;
+  tree caf_token;
   bool use_tree_type_;
   bool clear_token;
   tree get_elt_type () const;
 
 public:
   scalar_value(gfc_typespec &arg_ts, tree arg_value)
-: initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_ 
(false), clear_token(true) { }
-  scalar_value(tree arg_value)
-: initialisation(true), ts(nullptr), value(arg_value), use_tree_type_ 
(true), clear_token(false) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), caf_token 
(NULL_TREE),  use_tree_type_ (false), clear_token(true) { }
+  scalar_value(tree arg_value, tree arg_caf_token)
+: initialisation(true), ts(nullptr), value(arg_value), caf_token 
(arg_caf_token), use_tree_type_ (true), clear_token(false) { }
   virtual bool is_initialization () const { return initialisation; }
   virtual bool initialize_data () const { return true; }
   virtual tree get_data_value () const;
   virtual gfc_typespec *get_type () const { return ts; }
   virtual bool set_span () const { return true; }
   virtual bool use_tree_type () const { return use_tree_type_; }
-  virtual bool set_token () const { return clear_token; }
+  virtual bool set_token () const { return clear_token || caf_token != 
NULL_TREE; }
+  virtual tree get_caf_token () const;
   virtual bt get_type_type (const gfc_typespec &) const;
   virtual tree get_length (gfc_typespec *ts) const;
 };
@@ -840,6 +843,16 @@ scalar_value::get_length (gfc_typespec * type_info) const
   return size;
 }
 
+tree
+scalar_value::get_caf_token () const
+{
+  if (set_token ()
+  && caf_token != NULL_TREE)
+return caf_token;
+  else
+return modify_info::get_caf_token ();
+}
+
 
 static tree
 build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
@@ -935,7 +948,7 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
   tree token_field = gfc_advance_chain (fields,
CAF_TOKEN_FIELD - (!dim_present));
   tree token_value = fold_convert (TREE_TYPE (token_field),
-  null_pointer_node);
+  init.get_caf_token ());
   CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
 }
 
@@ -1432,11 +1445,11 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree 
descriptor,
 
 void
 gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-   symbol_attribute *attr)
+   symbol_attribute *attr, tree caf_token)
 {
   init_struct (block, desc,
   get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
-   scalar_value (scalar)));
+   scalar_value (scalar, caf_token)));
 }
 
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 97cf7f8cb41f..2dad79aa9993 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -149,7 +149,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree, 
tree,
gfc_expr *, locus *);
 tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
 void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
-symbol_attribute *);
+symbol_attribute *, tree = NULL_TREE);
 void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
 void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
   gfc_symbol *, bool, bool, bool);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ef4778590958..c283929f44d0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -883,14 +883,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 
gfc_symbol *fsym,
   /* Now set the data field.  */
   ctree = gfc_

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] match: Simplify double not and double negate to a non_lvalue

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:df740459e166e8f4861e540eee29f2bb0f8213d4

commit df740459e166e8f4861e540eee29f2bb0f8213d4
Author: Mikael Morin 
Date:   Thu Jul 4 12:59:34 2024 +0200

match: Simplify double not and double negate to a non_lvalue

I noticed while testing the second patch that none of the NON_LVALUE_EXPR
trees I expected were generated when simplifying unary operators, whereas
they were generated with binary operators.

Regression tested on x86_64-linux.  OK for master?

-- 8< --

gcc/ChangeLog:

* match.pd (`-(-X)`, `~(~X)`): Add a NON_LVALUE_EXPR wrapper to the
simplification of doubled unary operators NEGATE_EXPR and
BIT_NOT_EXPR.

gcc/testsuite/ChangeLog:

* gfortran.dg/non_lvalue_1.f90: New test.

Diff:
---
 gcc/match.pd   |  4 ++--
 gcc/testsuite/gfortran.dg/non_lvalue_1.f90 | 21 +
 2 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/gcc/match.pd b/gcc/match.pd
index ba036e528370..80f4bf6f008f 100644
--- a/gcc/match.pd
+++ b/gcc/match.pd
@@ -2344,7 +2344,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT)
 /* ~~x -> x */
 (simplify
   (bit_not (bit_not @0))
-  @0)
+  (non_lvalue @0))
 
 /* zero_one_valued_p will match when a value is known to be either
0 or 1 including constants 0 or 1.
@@ -3983,7 +3983,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT)
   (negate (nop_convert? (negate @1)))
   (if (!TYPE_OVERFLOW_SANITIZED (type)
&& !TYPE_OVERFLOW_SANITIZED (TREE_TYPE (@1)))
-   (view_convert @1)))
+   (non_lvalue (view_convert @1
 
  /* We can't reassociate floating-point unless -fassociative-math
 or fixed-point plus or minus because of saturation to +-Inf.  */
diff --git a/gcc/testsuite/gfortran.dg/non_lvalue_1.f90 
b/gcc/testsuite/gfortran.dg/non_lvalue_1.f90
new file mode 100644
index ..ac52b2720945
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/non_lvalue_1.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! Check the generation of NON_LVALUE_EXPR trees in cases where a unary 
operator expression
+! simplifies to a data reference.
+
+! A NON_LVALUE_EXPR is generated for a double negation that simplifies to a 
data reference.  */
+function f1 (f1_arg1)
+  integer, value :: f1_arg1
+  integer :: f1
+  f1 = -(-f1_arg1)
+end function
+! { dg-final { scan-tree-dump "__result_f1 = NON_LVALUE_EXPR ;" 
"original" } }
+
+! A NON_LVALUE_EXPR is generated for a double complement that simplifies to a 
data reference.  */
+function f2 (f2_arg1)
+  integer, value :: f2_arg1
+  integer :: f2
+  f2 = not(not(f2_arg1))
+end function
+! { dg-final { scan-tree-dump "__result_f2 = NON_LVALUE_EXPR ;" 
"original" } }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] match: Unwrap non-lvalue as unary or binary operand

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:16097006619ec58d3abe08dd420710ef30537df3

commit 16097006619ec58d3abe08dd420710ef30537df3
Author: Mikael Morin 
Date:   Thu Jul 4 15:24:36 2024 +0200

match: Unwrap non-lvalue as unary or binary operand

This avoids most of the testsuite dump pattern updates with a patch
generating more NON_LVALUE_EXPR trees that I plan to post later.

Regression tested on x86_64-linux.  OK for master?

-- 8< --

gcc/ChangeLog:

* match.pd (`op (non_lvalue X) Y`, `op X (non_lvalue Y)`,
`op (non_lvalue X)`): New simplifications, unwrap NON_LVALUE_EXPR
trees when they are used as operand of a unary or binary operator.

gcc/testsuite/ChangeLog:

* gfortran.dg/non_lvalue_2.f90: New test.

Diff:
---
 gcc/match.pd   | 12 
 gcc/testsuite/gfortran.dg/non_lvalue_2.f90 | 44 ++
 2 files changed, 56 insertions(+)

diff --git a/gcc/match.pd b/gcc/match.pd
index 80f4bf6f008f..86970318b409 100644
--- a/gcc/match.pd
+++ b/gcc/match.pd
@@ -281,6 +281,18 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT)
(outer_op @0 @2)
@3))
 
+/* Remove superfluous NON_LVALUE_EXPR in unary operators.  */
+(for op (UNCOND_UNARY)
+ (simplify (op (non_lvalue @0))
+  (op @0)))
+
+/* Remove superfluous NON_LVALUE_EXPR in binary operators.  */
+(for op (UNCOND_BINARY tcc_comparison)
+ (simplify (op (non_lvalue @0) @1)
+  (op @0 @1))
+ (simplify (op @0 (non_lvalue @1))
+  (op @0 @1)))
+
 /* Simplify x - x.
This is unsafe for certain floats even in non-IEEE formats.
In IEEE, it is unsafe because it does wrong for NaNs.
diff --git a/gcc/testsuite/gfortran.dg/non_lvalue_2.f90 
b/gcc/testsuite/gfortran.dg/non_lvalue_2.f90
new file mode 100644
index ..8c3197eab1f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/non_lvalue_2.f90
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! Check the removal of NON_LVALUE_EXPR if they are used in a non-lvalue context
+
+! The NON_LVALUE_EXPR is dropped if it's part (left operand) of a bigger 
expression
+function f1 (f1_arg1, f1_arg2)
+  integer, value :: f1_arg1, f1_arg2
+  integer :: f1
+  f1 = (f1_arg1 + 0) + f1_arg2
+end function
+! { dg-final { scan-tree-dump "__result_f1 = f1_arg1 \\+ f1_arg2;" "original" 
} }
+
+! The NON_LVALUE_EXPR is dropped if it's part (right operand) of a bigger 
expression
+function f2 (f2_arg1, f2_arg2)
+  integer, value :: f2_arg1, f2_arg2
+  integer :: f2
+  f2 = f2_arg1 + (f2_arg2 + 0)
+end function
+! { dg-final { scan-tree-dump "__result_f2 = f2_arg1 \\+ f2_arg2;" "original" 
} }
+
+! The NON_LVALUE_EXPR is dropped if it's part (left operand) of a binary 
logical operator
+function f3 (f3_arg1)
+  integer, value :: f3_arg1
+  logical :: f3
+  f3 = (f3_arg1 + 0) > 0
+end function
+! { dg-final { scan-tree-dump "__result_f3 = f3_arg1 > 0;" "original" } }
+
+! The NON_LVALUE_EXPR is dropped if it's part (right operand) of a binary 
logical operator
+function f4 (f4_arg1, f4_arg2)
+  integer, value :: f4_arg1, f4_arg2
+  logical :: f4
+  f4 = f4_arg1 > (f4_arg2 + 0)
+end function
+! { dg-final { scan-tree-dump "__result_f4 = f4_arg1 > f4_arg2;" "original" } }
+
+! The NON_LVALUE_EXPR is dropped if it's part of a unary operator
+function f5 (f5_arg1)
+  integer, value :: f5_arg1
+  integer :: f5
+  f5 = -(not(not(f5_arg1)))
+end function
+! { dg-final { scan-tree-dump "__result_f5 = -f5_arg1;" "original" } }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Mises à jour dumps

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:d46afc3495918e9fe4c9169947d061e09f242dac

commit d46afc3495918e9fe4c9169947d061e09f242dac
Author: Mikael Morin 
Date:   Fri Mar 14 16:27:05 2025 +0100

Mises à jour dumps

Mise à jour dump bind-c-contiguous-2.f90

Mise à jour dumps coarray_poly_*.f90

Mise à jour dump coarray_lock_7.f90

Correction dump coarray_allocate_7.f08

Mise à jour dump coarray_lib_alloc_4.f90

Mise à jour dump coarray_lib_alloc_2.f90

Mise à jour dump coarray_lib_alloc_3.f90

Mise à jour dump coarray_lib_alloc_1.f90

Mise à jour dump coarray_lib_token_4.f90

Mise à jour dump coarray_lib_token_3.f90

Mise à jour dump coarray_lib_token_2.f90

Mise à jour dump contiguous_3.f90

Diff:
---
 gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 | 12 ++--
 gcc/testsuite/gfortran.dg/coarray_allocate_7.f08  |  2 +-
 gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 | 12 ++--
 gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 | 12 ++--
 gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 | 12 ++--
 gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 |  6 +++---
 gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 |  4 ++--
 gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90 |  4 ++--
 gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 |  6 +++---
 gcc/testsuite/gfortran.dg/coarray_lock_7.f90  | 12 ++--
 gcc/testsuite/gfortran.dg/coarray_poly_4.f90  |  2 +-
 gcc/testsuite/gfortran.dg/coarray_poly_5.f90  |  2 +-
 gcc/testsuite/gfortran.dg/coarray_poly_6.f90  |  2 +-
 gcc/testsuite/gfortran.dg/coarray_poly_7.f90  |  2 +-
 gcc/testsuite/gfortran.dg/coarray_poly_8.f90  |  2 +-
 gcc/testsuite/gfortran.dg/contiguous_3.f90|  4 ++--
 16 files changed, 48 insertions(+), 48 deletions(-)

diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 
b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90
index 5b546800e7ff..243c4a57cba4 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90
@@ -60,12 +60,12 @@ end
 
 ! Copy in + out
 
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) 
xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ 
shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times {__builtin_memcpy \(\(void \*\) xx->data 
\+ xx->dtype.elem_len \* arrayidx.[0-9]+, _xx->base_addr \+ shift.[0-9]+, 
(?:NON_LVALUE_EXPR <)?xx->dtype.elem_len>?\);} 1 "original" } }
 ! { dg-final { scan-tree-dump-times "xx->data = \\(void \\* restrict\\) 
_xx->base_addr;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) 
xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ 
shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) 
yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, _yy->base_addr \\+ 
shift.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times {__builtin_memcpy \(\(void \*\) xx->data 
\+ xx->dtype.elem_len \* arrayidx.[0-9]+, _xx->base_addr \+ shift.[0-9]+, 
(?:NON_LVALUE_EXPR <)?xx->dtype.elem_len>?\);} 1 "original" } }
+! { dg-final { scan-tree-dump-times {__builtin_memcpy \(\(void \*\) yy->data 
\+ yy->dtype.elem_len \* arrayidx.[0-9]+, _yy->base_addr \+ shift.[0-9]+, 
(?:NON_LVALUE_EXPR <)?yy->dtype.elem_len>?\);} 1 "original" } }
 ! { dg-final { scan-tree-dump-times "yy->data = \\(void \\* restrict\\) 
_yy->base_addr;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_yy->base_addr \\+ 
shift.\[0-9\]+, \\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* 
arrayidx.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times {__builtin_memcpy \(_yy->base_addr \+ 
shift.[0-9]+, \(void \*\) yy->data \+ yy->dtype.elem_len \* arrayidx.[0-9]+, 
(?:NON_LVALUE_EXPR <)?yy->dtype.elem_len>?\);} 1 "original" } }
 
 ! { dg-final { scan-tree-dump-times "zz = 
\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:zz.\[0-9\]+\\\] \\* restrict\\) 
_zz->base_addr;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) zz \\+ 
_zz->elem_len \\* arrayidx.\[0-9\]+, _zz->base_addr \\+ shift.\[0-9\]+, 
_zz->elem_len\\);" 1 "original" } }
@@ -73,10 +73,10 @@ end
 
 ! Copy in only
 
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) 
aa->data \\+ aa->dtype.elem_len \\* arrayidx.\[0-9\]+, _aa->base_addr \\+ 
shift.\[0-9\]+, aa->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times {__builtin_memcpy \(\(void \*\) aa->data 
\+ aa->dtype.elem_len \* arrayidx.[0-9]+, _aa->base_addr \+ shift.[0-9]+, 
(?:NON_LVALUE_EXPR <)?aa->dtype.elem_len>?\);} 1 "original" } }
 
 ! { dg-final { scan-tree-dump-times "aa->data = \\(void \\* restrict\\) 
_aa->base_addr;" 1 "original" } }
-

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction erreur compil'

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:a039db39860a1ec6084d6a0bdab8ceef51ed36a9

commit a039db39860a1ec6084d6a0bdab8ceef51ed36a9
Author: Mikael Morin 
Date:   Fri Mar 14 16:30:09 2025 +0100

Correction erreur compil'

Diff:
---
 gcc/fortran/trans-array.cc | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0522b1bc6e49..05a2fa080ee7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11547,7 +11547,7 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int 
rank)
   tree nelems;
   tree tmp;
   if (rank < 0)
-idx = gfc_conv_descriptor_rank (decl);
+idx = gfc_conv_descriptor_rank_get (decl);
   else
 idx = gfc_rank_cst[rank - 1];
   tmp = gfc_conv_descriptor_extent_get (decl, idx);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction non_lvalue PR97046.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:415ecd58f9b96bcd8bfdc9515b7b6a0f192cde0c

commit 415ecd58f9b96bcd8bfdc9515b7b6a0f192cde0c
Author: Mikael Morin 
Date:   Wed Feb 12 10:07:40 2025 +0100

Correction non_lvalue PR97046.f90

Diff:
---
 gcc/fortran/trans-array.cc | 42 +++---
 1 file changed, 27 insertions(+), 15 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 05a2fa080ee7..6cefd3bf3ed5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2570,24 +2570,31 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
   tree tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, 
cond,
   gfc_finish_block (&set_void),
   gfc_finish_block (&set_unknown));
+
   /* if (CFI_type_struct) BT_DERIVED else  < tmp2 >  */
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
  build_int_cst (TREE_TYPE (ctype),
 CFI_type_struct));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_DERIVED));
+  stmtblock_t set_derived;
+  gfc_init_block (&set_derived);
+  tree derived_value = build_int_cst (TREE_TYPE (type), BT_DERIVED);
+  gfc_conv_descriptor_type_set (&set_derived, gfc, derived_value);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
+ gfc_finish_block (&set_derived), tmp2);
+
   /* if (CFI_type_Character) BT_CHARACTER else  < tmp2 >  */
   /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
 before (see below, as generated bottom up).  */
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
  build_int_cst (TREE_TYPE (ctype),
  CFI_type_Character));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+  stmtblock_t set_character;
+  gfc_init_block (&set_character);
+  tree character_value = build_int_cst (TREE_TYPE (type), BT_CHARACTER);
+  gfc_conv_descriptor_type_set (&set_character, gfc, character_value);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
+ gfc_finish_block (&set_character), tmp2);
+
   /* if (CFI_type_ucs4_char) BT_CHARACTER else  < tmp2 >  */
   /* Note: gfc->elem_len = cfi->elem_len/4.  */
   /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
@@ -2597,18 +2604,22 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
  build_int_cst (TREE_TYPE (tmp),
 CFI_type_ucs4_char));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+  gfc_init_block (&set_character);
+  gfc_conv_descriptor_type_set (&set_character, gfc, character_value);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
+ gfc_finish_block (&set_character), tmp2);
+
   /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else  < tmp2 >  */
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
  build_int_cst (TREE_TYPE (ctype),
  CFI_type_Complex));
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+  stmtblock_t set_complex;
+  gfc_init_block (&set_complex);
+  tree complex_value = build_int_cst (TREE_TYPE (type), BT_COMPLEX);
+  gfc_conv_descriptor_type_set (&set_complex, gfc, complex_value);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
+ gfc_finish_block (&set_complex), tmp2);
+
   /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
   ctype else*/
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 
ctype,
@@ -2624,10 +2635,11 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
 CFI_type_Real));
   cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
  cond, tmp);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Interdiction non-lvalue as lhs

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:c40cc86e77af6f4761bce0876f9d2874e594c456

commit c40cc86e77af6f4761bce0876f9d2874e594c456
Author: Mikael Morin 
Date:   Tue Feb 11 21:34:11 2025 +0100

Interdiction non-lvalue as lhs

git commit correction erreur gimplify

Diff:
---
 gcc/gimplify.cc | 6 ++
 1 file changed, 6 insertions(+)

diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc
index 4f385b1b779b..a33e46e24dc9 100644
--- a/gcc/gimplify.cc
+++ b/gcc/gimplify.cc
@@ -7241,6 +7241,12 @@ gimplify_modify_expr (tree *expr_p, gimple_seq *pre_p, 
gimple_seq *post_p,
   gcc_assert (TREE_CODE (*expr_p) == MODIFY_EXPR
  || TREE_CODE (*expr_p) == INIT_EXPR);
 
+  if (TREE_CODE (*to_p) == NON_LVALUE_EXPR)
+{
+  error ("non-lvalue used as lhs in %qD", *expr_p);
+  return GS_ERROR;
+}
+
   /* Trying to simplify a clobber using normal logic doesn't work,
  so handle it here.  */
   if (TREE_CLOBBER_P (*from_p))

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Ajout surcharge gfc_conv_descriptor_type_set

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:fffeaf28989aa5494230294b975ececc3f448c06

commit fffeaf28989aa5494230294b975ececc3f448c06
Author: Mikael Morin 
Date:   Wed Feb 12 10:22:42 2025 +0100

Ajout surcharge gfc_conv_descriptor_type_set

Diff:
---
 gcc/fortran/trans-array.cc | 41 +
 1 file changed, 29 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6cefd3bf3ed5..7a7f68a1fdb7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -261,6 +261,15 @@ get_field (tree desc, unsigned field_idx)
   return field;
 }
 
+tree
+get_dtype_subfield (tree desc, unsigned subfield)
+{
+  tree dtype = get_field (desc, DTYPE_FIELD);
+  tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), subfield);
+  gcc_assert (field != NULL_TREE);
+  return field;
+}
+
 tree
 get_component (tree desc, unsigned field_idx)
 {
@@ -518,6 +527,14 @@ conv_type_set (stmtblock_t *block, tree desc, tree value)
  fold_convert_loc (loc, TREE_TYPE (t), value));
 }
 
+void
+conv_type_set (stmtblock_t *block, tree desc, int value)
+{
+  tree field = get_dtype_subfield (desc, GFC_DTYPE_TYPE);
+  tree val = build_int_cst (TREE_TYPE (field), value);
+  conv_type_set (block, desc, val);
+}
+
 tree
 get_dimensions (tree desc)
 {
@@ -872,6 +889,12 @@ gfc_conv_descriptor_type_set (stmtblock_t *block, tree 
desc, tree value)
   gfc_descriptor::conv_type_set (block, desc, value);
 }
 
+void
+gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, int value)
+{
+  gfc_descriptor::conv_type_set (block, desc, value);
+}
+
 tree
 gfc_conv_descriptor_token_get (tree desc)
 {
@@ -2550,7 +2573,6 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
   ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
   ctype, build_int_cst (TREE_TYPE (ctype),
 CFI_type_mask));
-  tree type = gfc_conv_descriptor_type_get (gfc);
 
   /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN  */
   /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
@@ -2559,13 +2581,11 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
 
   stmtblock_t set_void;
   gfc_init_block (&set_void);
-  tree void_value = build_int_cst (TREE_TYPE (type), BT_VOID);
-  gfc_conv_descriptor_type_set (&set_void, gfc, void_value);
+  gfc_conv_descriptor_type_set (&set_void, gfc, BT_VOID);
 
   stmtblock_t set_unknown;
   gfc_init_block (&set_unknown);
-  tree unknown_value = build_int_cst (TREE_TYPE (type), BT_UNKNOWN);
-  gfc_conv_descriptor_type_set (&set_unknown, gfc, unknown_value);
+  gfc_conv_descriptor_type_set (&set_unknown, gfc, BT_UNKNOWN);
 
   tree tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, 
cond,
   gfc_finish_block (&set_void),
@@ -2577,8 +2597,7 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
 CFI_type_struct));
   stmtblock_t set_derived;
   gfc_init_block (&set_derived);
-  tree derived_value = build_int_cst (TREE_TYPE (type), BT_DERIVED);
-  gfc_conv_descriptor_type_set (&set_derived, gfc, derived_value);
+  gfc_conv_descriptor_type_set (&set_derived, gfc, BT_DERIVED);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
  gfc_finish_block (&set_derived), tmp2);
 
@@ -2590,8 +2609,7 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
  CFI_type_Character));
   stmtblock_t set_character;
   gfc_init_block (&set_character);
-  tree character_value = build_int_cst (TREE_TYPE (type), BT_CHARACTER);
-  gfc_conv_descriptor_type_set (&set_character, gfc, character_value);
+  gfc_conv_descriptor_type_set (&set_character, gfc, BT_CHARACTER);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
  gfc_finish_block (&set_character), tmp2);
 
@@ -2605,7 +2623,7 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
  build_int_cst (TREE_TYPE (tmp),
 CFI_type_ucs4_char));
   gfc_init_block (&set_character);
-  gfc_conv_descriptor_type_set (&set_character, gfc, character_value);
+  gfc_conv_descriptor_type_set (&set_character, gfc, BT_CHARACTER);
   tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
  gfc_finish_block (&set_character), tmp2);
 
@@ -2615,8 +2633,7 @@ gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
  CFI_type_Complex));
   stmtblock_t set_complex;
   gfc_init_block (&set_complex);
-  tree complex_value = build_int_cst (TREE_TYPE (type), BT_COMPLEX);
-  gfc_conv_descriptor_type_set (&set_complex, 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction erreurs non-lvalue lhs pr113363.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:0ecf50436efed1728c0e55b3f27d191a7cc74b1f

commit 0ecf50436efed1728c0e55b3f27d191a7cc74b1f
Author: Mikael Morin 
Date:   Wed Feb 12 10:47:31 2025 +0100

Correction erreurs non-lvalue lhs pr113363.f90

Diff:
---
 gcc/fortran/trans-decl.cc | 21 +
 gcc/fortran/trans.cc  |  4 ++--
 2 files changed, 19 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 94423688e5a6..6134bc368111 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -5110,10 +5110,23 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, 
gfc_wrapped_block * block)
  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
  /* Nullify when entering the scope.  */
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-TREE_TYPE (se.expr), se.expr,
-fold_convert (TREE_TYPE (se.expr),
-  null_pointer_node));
+ if (sym->ts.type == BT_CLASS
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension))
+   {
+ stmtblock_t nullify;
+ gfc_init_block (&nullify);
+ gfc_conv_descriptor_data_set (&nullify, descriptor,
+   null_pointer_node);
+ tmp = gfc_finish_block (&nullify);
+   }
+ else
+   {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+TREE_TYPE (se.expr), se.expr,
+fold_convert (TREE_TYPE 
(se.expr),
+  
null_pointer_node));
+   }
  if (sym->attr.optional)
{
  tree present = gfc_conv_expr_present (sym);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 9880726c6113..c72bf8be4198 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1737,7 +1737,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 gfc_call_free (data_ptr),
 build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->loop->post, tmp);
-  gfc_add_modify (&se->loop->post, data_ptr, data_null);
+  gfc_conv_descriptor_data_set (&se->loop->post, desc, data_null);
 }
   else
 {
@@ -1751,7 +1751,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 gfc_call_free (data_ptr),
 build_empty_stmt (input_location));
  gfc_add_expr_to_block (&se->finalblock, tmp);
- gfc_add_modify (&se->finalblock, data_ptr, data_null);
+ gfc_conv_descriptor_data_set (&se->finalblock, desc, data_null);
}
 }
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Déplacement fonction

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:e3fbeb0683fbc7caeb0911ead3fc3d80d34e3ed5

commit e3fbeb0683fbc7caeb0911ead3fc3d80d34e3ed5
Author: Mikael Morin 
Date:   Fri Feb 14 09:34:02 2025 +0100

Déplacement fonction

Diff:
---
 gcc/fortran/trans-array.cc | 53 ++
 gcc/fortran/trans-array.h  |  1 +
 gcc/fortran/trans-expr.cc  | 41 ++-
 3 files changed, 47 insertions(+), 48 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0ca865ef82a8..ad974cd30ed8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2227,6 +2227,44 @@ gfc_conv_shift_descriptor_subarray (stmtblock_t *block, 
tree desc,
 }
 
 
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+  tree lbound[GFC_MAX_DIMENSIONS],
+  tree ubound[GFC_MAX_DIMENSIONS])
+{
+  tree size = gfc_index_one_node;
+  tree offset = gfc_index_zero_node;
+  for (int n = 0; n < rank; n++)
+{
+  tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp,
+gfc_index_one_node);
+  gfc_conv_descriptor_ubound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ tmp);
+  gfc_conv_descriptor_lbound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+  size = gfc_evaluate_now (size, block);
+  offset = fold_build2_loc (input_location, MINUS_EXPR,
+   gfc_array_index_type,
+   offset, size);
+  offset = gfc_evaluate_now (offset, block);
+  tmp = gfc_conv_array_extent_dim (lbound[n], ubound[n], nullptr);
+  size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+}
+
+  gfc_conv_descriptor_offset_set (block, desc,
+ offset);
+}
+
+
+
+
 int
 gfc_descriptor_rank (tree descriptor)
 {
@@ -8412,15 +8450,12 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
 start at zero, but when allocating it, the standard expects
 the array to start at one.  Therefore fix the upper bound to be
 (desc.ubound - desc.lbound) + 1.  */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
-gfc_array_index_type,
-gfc_conv_descriptor_ubound_get (
-  expr3_desc, gfc_rank_cst[n]),
-gfc_conv_descriptor_lbound_get (
-  expr3_desc, gfc_rank_cst[n]));
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
-gfc_array_index_type, tmp,
-gfc_index_one_node);
+ tmp = gfc_conv_array_extent_dim (
+ gfc_conv_descriptor_lbound_get (expr3_desc,
+ gfc_rank_cst[n]),
+ gfc_conv_descriptor_ubound_get (expr3_desc,
+ gfc_rank_cst[n]),
+ nullptr);
  se.expr = gfc_evaluate_now (tmp, pblock);
}
  else
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 836a177da014..f37f09c21cff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -237,6 +237,7 @@ void gfc_conv_shift_descriptor (stmtblock_t*, tree, const 
gfc_array_ref &);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
 void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
 void gfc_conv_shift_descriptor_subarray (stmtblock_t*, tree, gfc_expr *, 
gfc_expr *);
+void gfc_conv_shift_descriptor (stmtblock_t *, tree, int, tree *, tree *);
 
 /* Add pre-loop scalarization code for intrinsic functions which require
special handling.  */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 699770428658..6fd9a1f389f6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5364,43 +5364,6 @@ gfc_apply_interface_mapping (gfc_interface_mapping * 
mapping,
 }
 
 
-static void
-shift_descriptor (stmtblock_t *block, tree desc, int rank,
- tree lbound[GFC_MAX_DIMENSIONS],
- tree ubound[GFC_MAX_DIMENSIONS])
-
-{
-  tree size = gfc_index_one_node;
-  tree offset = gfc_index_zero_node;
-  for (int n = 0; n < rank; n++)
-{
-  tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
-  tmp = fold_build2_loc (input_location, PLUS_EXPR,
-gf

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Mise à jour offset & span dans gfc_array_init_size

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:4547cd297e61032f66ef4664052e91ae3e29a17c

commit 4547cd297e61032f66ef4664052e91ae3e29a17c
Author: Mikael Morin 
Date:   Fri Feb 14 11:22:35 2025 +0100

Mise à jour offset & span dans gfc_array_init_size

Diff:
---
 gcc/fortran/trans-array.cc | 34 --
 1 file changed, 12 insertions(+), 22 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 368ae8c320e1..a1bce1282391 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8354,8 +8354,8 @@ descriptor_element_size (tree descriptor, tree 
expr3_elem_size,
 /*GCC ARRAYS*/
 
 static tree
-gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
-gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
+gfc_array_init_size (tree descriptor, int rank, int corank, gfc_expr ** lower,
+gfc_expr ** upper, stmtblock_t * pblock,
 stmtblock_t * descriptor_block, tree * overflow,
 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
 tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
@@ -8597,6 +8597,12 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
   if (rank == 0)
 return element_size;
 
+  /* Update the array descriptor with the offset and the span.  */
+  offset = gfc_evaluate_now (offset, pblock);
+  gfc_conv_descriptor_offset_set (descriptor_block, descriptor, offset);
+  tmp = fold_convert (gfc_array_index_type, element_size);
+  gfc_conv_descriptor_span_set (descriptor_block, descriptor, tmp);
+
   *nelems = gfc_evaluate_now (stride, pblock);
   stride = fold_convert (size_type_node, stride);
 
@@ -8624,12 +8630,6 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
   size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
  stride, element_size);
 
-  if (poffset != NULL)
-{
-  offset = gfc_evaluate_now (offset, pblock);
-  *poffset = offset;
-}
-
   if (integer_zerop (or_expr))
 return size;
   if (integer_onep (or_expr))
@@ -8692,7 +8692,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
 {
   tree tmp;
   tree pointer;
-  tree offset = NULL_TREE;
   tree token = NULL_TREE;
   tree size;
   tree msg;
@@ -8821,11 +8820,10 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
   size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
   : ref->u.ar.as->rank,
  coarray ? ref->u.ar.as->corank : 0,
- &offset, lower, upper,
- &se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3, e3_arr_desc,
- e3_has_nodescriptor, expr, element_size,
- explicit_ts);
+ lower, upper, &se->pre, &set_descriptor_block,
+ &overflow, expr3_elem_size, nelems, expr3,
+ e3_arr_desc, e3_has_nodescriptor, expr,
+ element_size, explicit_ts);
 
   if (dimension)
 {
@@ -8962,14 +8960,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
 
   gfc_add_expr_to_block (&se->pre, tmp);
 
-  /* Update the array descriptor with the offset and the span.  */
-  if (dimension)
-{
-  gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
-  tmp = fold_convert (gfc_array_index_type, element_size);
-  gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
-}
-
   set_descriptor = gfc_finish_block (&set_descriptor_block);
   if (status != NULL_TREE)
 {

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set_descriptor_dimension

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:27d7b26c992ed0cd169fc850035b3a3130244d99

commit 27d7b26c992ed0cd169fc850035b3a3130244d99
Author: Mikael Morin 
Date:   Thu Feb 13 20:26:47 2025 +0100

Factorisation set_descriptor_dimension

Correction typo

Diff:
---
 gcc/fortran/trans-array.cc | 12 +---
 1 file changed, 5 insertions(+), 7 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e6608eb4c9fa..0ca865ef82a8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1906,6 +1906,9 @@ set_bounds_update_offset (stmtblock_t *block, tree desc, 
int dim,
 gfc_conv_descriptor_stride_set (block, desc,
gfc_rank_cst[dim], stride);
 
+  if (!offset && !next_stride)
+return;
+
   /* Update offset.  */
   tree tmp = fold_build2_loc (input_location, MULT_EXPR,
  gfc_array_index_type, lbound_diff, stride);
@@ -3664,13 +3667,8 @@ set_temporary_descriptor (stmtblock_t *block, tree desc, 
tree class_src,
   for (n = 0; n < rank; n++)
{
  /* Store the stride and bound components in the descriptor.  */
- gfc_conv_descriptor_stride_set (block, desc, gfc_rank_cst[n],
- stride[n]);
-
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[n],
- gfc_index_zero_node);
-
- gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[n], 
ubound[n]);
+ set_descriptor_dimension (block, desc, n, gfc_index_zero_node, 
ubound[n],
+   stride[n], nullptr, nullptr);
}
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Séparation get_array_memory_size

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:d39f440ad8e155955de1e935158b4682cb45f1ca

commit d39f440ad8e155955de1e935158b4682cb45f1ca
Author: Mikael Morin 
Date:   Fri Feb 14 12:07:08 2025 +0100

Séparation get_array_memory_size

Diff:
---
 gcc/fortran/trans-array.cc | 160 ++---
 1 file changed, 91 insertions(+), 69 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a1bce1282391..9d42e3e902d1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8322,6 +8322,70 @@ descriptor_element_size (tree descriptor, tree 
expr3_elem_size,
 }
 
 
+static tree
+get_array_memory_size (tree element_size, tree elements_count,
+  tree empty_array_cond, stmtblock_t * pblock,
+  tree * overflow)
+{
+  tree tmp;
+  tree size;
+  tree thencase;
+  tree elsecase;
+  tree cond;
+  tree var;
+  stmtblock_t thenblock;
+  stmtblock_t elseblock;
+
+
+
+  elements_count = fold_convert (size_type_node, elements_count);
+
+  /* First check for overflow. Since an array of type character can
+ have zero element_size, we must check for that before
+ dividing.  */
+  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+size_type_node,
+TYPE_MAX_VALUE (size_type_node), element_size);
+  cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+   logical_type_node, tmp, elements_count),
+  PRED_FORTRAN_OVERFLOW);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+integer_one_node, integer_zero_node);
+  cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+   logical_type_node, element_size,
+   build_int_cst (size_type_node, 0)),
+  PRED_FORTRAN_SIZE_ZERO);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+integer_zero_node, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+*overflow, tmp);
+  *overflow = gfc_evaluate_now (tmp, pblock);
+
+  size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ elements_count, element_size);
+
+  if (integer_zerop (empty_array_cond))
+return size;
+  if (integer_onep (empty_array_cond))
+return build_int_cst (size_type_node, 0);
+
+  var = gfc_create_var (TREE_TYPE (size), "size");
+  gfc_start_block (&thenblock);
+  gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
+  thencase = gfc_finish_block (&thenblock);
+
+  gfc_start_block (&elseblock);
+  gfc_add_modify (&elseblock, var, size);
+  elsecase = gfc_finish_block (&elseblock);
+
+  tmp = gfc_evaluate_now (empty_array_cond, pblock);
+  tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  return var;
+}
+
+
 /* Fills in an array descriptor, and returns the size of the array.
The size will be a simple_val, ie a variable or a constant.  Also
calculates the offset of the base.  The pointer argument overflow,
@@ -8354,25 +8418,20 @@ descriptor_element_size (tree descriptor, tree 
expr3_elem_size,
 /*GCC ARRAYS*/
 
 static tree
-gfc_array_init_size (tree descriptor, int rank, int corank, gfc_expr ** lower,
-gfc_expr ** upper, stmtblock_t * pblock,
-stmtblock_t * descriptor_block, tree * overflow,
-tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
-tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
-tree element_size, bool explicit_ts)
+gfc_array_init_count (tree descriptor, int rank, int corank, gfc_expr ** lower,
+ gfc_expr ** upper, stmtblock_t * pblock,
+ stmtblock_t * descriptor_block, tree * overflow,
+ tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
+ bool e3_has_nodescriptor, gfc_expr *expr,
+ tree element_size, bool explicit_ts,
+ tree *empty_array_cond)
 {
   tree type;
   tree tmp;
   tree size;
   tree offset;
   tree stride;
-  tree or_expr;
-  tree thencase;
-  tree elsecase;
   tree cond;
-  tree var;
-  stmtblock_t thenblock;
-  stmtblock_t elseblock;
   gfc_expr *ubound;
   gfc_se se;
   int n;
@@ -8426,7 +8485,7 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, gfc_expr ** lower,
   else
 gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
 
-  or_expr = logical_false_node;
+  tree empty_cond = logical_false_node;
 
   for (n = 0; n < rank; n++)
 {
@@ -8519,7 +8578,8 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, gfc_expr ** lower,
  gfc_rank_cst[n], stride);
 
   /* Calculate size and check whethe

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation shift_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:d942a13460fe8a830552789d7e8cc5e700f54937

commit d942a13460fe8a830552789d7e8cc5e700f54937
Author: Mikael Morin 
Date:   Thu Feb 13 21:03:54 2025 +0100

Factorisation shift_descriptor

Diff:
---
 gcc/fortran/trans-expr.cc | 76 ---
 1 file changed, 39 insertions(+), 37 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f8a57e99bc89..699770428658 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5364,6 +5364,43 @@ gfc_apply_interface_mapping (gfc_interface_mapping * 
mapping,
 }
 
 
+static void
+shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ tree lbound[GFC_MAX_DIMENSIONS],
+ tree ubound[GFC_MAX_DIMENSIONS])
+
+{
+  tree size = gfc_index_one_node;
+  tree offset = gfc_index_zero_node;
+  for (int n = 0; n < rank; n++)
+{
+  tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp,
+gfc_index_one_node);
+  gfc_conv_descriptor_ubound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ tmp);
+  gfc_conv_descriptor_lbound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+  size = gfc_evaluate_now (size, block);
+  offset = fold_build2_loc (input_location, MINUS_EXPR,
+   gfc_array_index_type,
+   offset, size);
+  offset = gfc_evaluate_now (offset, block);
+  tmp = gfc_conv_array_extent_dim (lbound[n], ubound[n], nullptr);
+  size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+}
+
+  gfc_conv_descriptor_offset_set (block, desc,
+ offset);
+}
+
+
 /* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
after the function call.  */
@@ -5384,7 +5421,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, 
int g77,
   tree tmp_index;
   tree tmp;
   tree base_type;
-  tree size;
   stmtblock_t body;
   int n;
   int dimen;
@@ -5635,42 +5671,8 @@ class_array_fcn:
   /* Determine the offset for pointer formal arguments and set the
  lbounds to one.  */
   if (formal_ptr)
-{
-  size = gfc_index_one_node;
-  offset = gfc_index_zero_node;
-  for (n = 0; n < dimen; n++)
-   {
- tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
-   gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
-gfc_array_index_type, tmp,
-gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- gfc_index_one_node);
- size = gfc_evaluate_now (size, &parmse->pre);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
-   gfc_array_index_type,
-   offset, size);
- offset = gfc_evaluate_now (offset, &parmse->pre);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
-gfc_array_index_type,
-rse.loop->to[n], rse.loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
-gfc_array_index_type,
-tmp, gfc_index_one_node);
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
-   }
-
-  gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
- offset);
-}
+shift_descriptor (&parmse->pre, parmse->expr, dimen,
+ rse.loop->from, rse.loop->to);
 
   /* We want either the address for the data or the address of the descriptor,
  depending on the mode of passing array arguments.  */

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Sauvegarde modif

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:69d2b21187627d3909c4564656c29c2d12cbed0c

commit 69d2b21187627d3909c4564656c29c2d12cbed0c
Author: Mikael Morin 
Date:   Fri Feb 14 16:55:42 2025 +0100

Sauvegarde modif

Diff:
---
 gcc/fortran/trans-array.cc | 94 --
 gcc/fortran/trans-expr.cc  | 25 ++--
 2 files changed, 85 insertions(+), 34 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 80f21d6f8de9..cadeac673e8a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5602,18 +5602,48 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, 
bool subscript,
  break;
 
case GFC_SS_FUNCTION:
- /* Array function return value.  We call the function and save its
-result in a temporary for use inside the loop.  */
- gfc_init_se (&se, NULL);
- se.loop = loop;
- se.ss = ss;
- if (gfc_is_class_array_function (expr))
-   expr->must_finalize = 1;
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&outer_loop->pre, &se.pre);
- gfc_add_block_to_block (&outer_loop->post, &se.post);
- gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
- ss_info->string_length = se.string_length;
+ {
+   /* Array function return value.  We call the function and save its
+  result in a temporary for use inside the loop.  */
+   gfc_init_se (&se, NULL);
+   se.loop = loop;
+   se.ss = ss;
+   bool class_func = gfc_is_class_array_function (expr);
+   if (class_func)
+ expr->must_finalize = 1;
+   gfc_conv_expr (&se, expr);
+   gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+   if (class_func
+   && se.expr
+   && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+ {
+   tree tmp = gfc_class_data_get (se.expr);
+   info->descriptor = tmp;
+   info->data = gfc_conv_descriptor_data_get (tmp);
+   info->offset = gfc_conv_descriptor_offset_get (tmp);
+   for (gfc_ss *s = ss; s; s = s->parent)
+ for (int n = 0; n < s->dimen; n++)
+   {
+ int dim = s->dim[n];
+ tree tree_dim = gfc_rank_cst[dim];
+
+ tree start = gfc_conv_descriptor_lbound_get (tmp, 
tree_dim);
+ start = gfc_evaluate_now (start, &outer_loop->pre);
+ info->start[dim] = start;
+
+ tree end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
+ end = gfc_evaluate_now (end, &outer_loop->pre);
+ info->end[dim] = end;
+
+ tree stride = gfc_conv_descriptor_stride_get (tmp, 
tree_dim);
+ stride = gfc_evaluate_now (stride, &outer_loop->pre);
+ info->stride[dim] = stride;
+   }
+ }
+   gfc_add_block_to_block (&outer_loop->post, &se.post);
+   gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
+   ss_info->string_length = se.string_length;
+ }
  break;
 
case GFC_SS_CONSTRUCTOR:
@@ -8120,6 +8150,44 @@ set_loop_bounds (gfc_loopinfo *loop)
 }
 
 
+/* Last attempt to set the loop bounds, in case they depend on an allocatable
+   function result.  */
+
+static void
+late_set_loop_bounds (gfc_loopinfo *loop)
+{
+  int n, dim;
+  gfc_array_info *info;
+  gfc_ss **loopspec;
+
+  loopspec = loop->specloop;
+
+  for (n = 0; n < loop->dimen; n++)
+{
+  /* We should have found the scalarization loop specifier.  If not,
+that's bad news.  */
+  gcc_assert (loopspec[n]);
+
+  info = &loopspec[n]->info->data.array;
+  dim = loopspec[n]->dim[n];
+
+  /* Set the extents of this range.  */
+  if ((loop->from[n] == NULL_TREE
+  || loop->to[n] == NULL_TREE)
+ && loopspec[n]->info->type == GFC_SS_FUNCTION
+ && info->start[dim]
+ && info->end[dim])
+   {
+ loop->from[n] = info->start[dim];
+ loop->to[n] = info->end[dim];
+   }
+}
+
+  for (loop = loop->nested; loop; loop = loop->next)
+set_loop_bounds (loop);
+}
+
+
 /* Initialize the scalarization loop.  Creates the loop variables.  Determines
the range of the loop variables.  Creates a temporary if required.
Also generates code for scalar expressions which have been
@@ -8138,6 +8206,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
  allocating the temporary.  */
   gfc_add_loop_ss_code (loop, loop->ss, false, where);
 
+  late_set_loop_bounds (loop);
+
   tmp_ss = loop->temp_ss;
   /* If we want a temporary then create it.  */
   if (tmp_ss != NULL)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 56392f963c90..c2edab5841b0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation descriptor_element_size

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:062fc19daf23884c9e66a49e54b09e90776cb1e7

commit 062fc19daf23884c9e66a49e54b09e90776cb1e7
Author: Mikael Morin 
Date:   Fri Feb 14 11:04:01 2025 +0100

Factorisation descriptor_element_size

Diff:
---
 gcc/fortran/trans-array.cc | 85 +++---
 1 file changed, 51 insertions(+), 34 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ad974cd30ed8..368ae8c320e1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8282,6 +8282,46 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int 
corank)
 }
 
 
+static tree
+descriptor_element_size (tree descriptor, tree expr3_elem_size,
+gfc_expr *expr3)
+{
+  tree type;
+  tree tmp;
+
+  type = TREE_TYPE (descriptor);
+
+  /* Obviously, if there is a SOURCE expression (expr3) we must use its element
+ size.  */
+  if (expr3_elem_size != NULL_TREE)
+tmp = expr3_elem_size;
+  else if (expr3 != NULL)
+{
+  if (expr3->ts.type == BT_CLASS)
+   {
+ gfc_se se_sz;
+ gfc_expr *sz = gfc_copy_expr (expr3);
+ gfc_add_vptr_component (sz);
+ gfc_add_size_component (sz);
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ tmp = se_sz.expr;
+   }
+  else
+   {
+ tmp = gfc_typenode_for_spec (&expr3->ts);
+ tmp = TYPE_SIZE_UNIT (tmp);
+   }
+}
+  else
+tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
+  /* Convert to size_t.  */
+  return fold_convert (size_type_node, tmp);
+}
+
+
 /* Fills in an array descriptor, and returns the size of the array.
The size will be a simple_val, ie a variable or a constant.  Also
calculates the offset of the base.  The pointer argument overflow,
@@ -8319,7 +8359,7 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
 stmtblock_t * descriptor_block, tree * overflow,
 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
 tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
-tree *element_size, bool explicit_ts)
+tree element_size, bool explicit_ts)
 {
   tree type;
   tree tmp;
@@ -8552,37 +8592,10 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
 }
 
   /* The stride is the number of elements in the array, so multiply by the
- size of an element to get the total size.  Obviously, if there is a
- SOURCE expression (expr3) we must use its element size.  */
-  if (expr3_elem_size != NULL_TREE)
-tmp = expr3_elem_size;
-  else if (expr3 != NULL)
-{
-  if (expr3->ts.type == BT_CLASS)
-   {
- gfc_se se_sz;
- gfc_expr *sz = gfc_copy_expr (expr3);
- gfc_add_vptr_component (sz);
- gfc_add_size_component (sz);
- gfc_init_se (&se_sz, NULL);
- gfc_conv_expr (&se_sz, sz);
- gfc_free_expr (sz);
- tmp = se_sz.expr;
-   }
-  else
-   {
- tmp = gfc_typenode_for_spec (&expr3->ts);
- tmp = TYPE_SIZE_UNIT (tmp);
-   }
-}
-  else
-tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
-
-  /* Convert to size_t.  */
-  *element_size = fold_convert (size_type_node, tmp);
+ size of an element to get the total size.  */
 
   if (rank == 0)
-return *element_size;
+return element_size;
 
   *nelems = gfc_evaluate_now (stride, pblock);
   stride = fold_convert (size_type_node, stride);
@@ -8592,14 +8605,14 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
  dividing.  */
   tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
 size_type_node,
-TYPE_MAX_VALUE (size_type_node), *element_size);
+TYPE_MAX_VALUE (size_type_node), element_size);
   cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
logical_type_node, tmp, stride),
   PRED_FORTRAN_OVERFLOW);
   tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
 integer_one_node, integer_zero_node);
   cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
-   logical_type_node, *element_size,
+   logical_type_node, element_size,
build_int_cst (size_type_node, 0)),
   PRED_FORTRAN_SIZE_ZERO);
   tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
@@ -8609,7 +8622,7 @@ gfc_array_init_size (tree descriptor, int rank, int 
corank, tree * poffset,
   *overflow = gfc_evaluate_now (tmp, pblock);
 
   size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- stride, *element_size);
+ stride, ele

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression class_to_type_2.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:22e2303e995a79b0998caca0d0ff1079b0f4aef9

commit 22e2303e995a79b0998caca0d0ff1079b0f4aef9
Author: Mikael Morin 
Date:   Fri Feb 14 17:23:47 2025 +0100

Correction régression class_to_type_2.f90

Diff:
---
 gcc/fortran/trans-array.cc | 8 +---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 51e5bcd2c281..75a41a38ea12 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8266,9 +8266,11 @@ gfc_set_delta (gfc_loopinfo *loop)
   gfc_ss_type ss_type;
 
   ss_type = ss->info->type;
-  if (ss_type != GFC_SS_SECTION
- && ss_type != GFC_SS_COMPONENT
- && ss_type != GFC_SS_CONSTRUCTOR)
+  if (!(ss_type == GFC_SS_SECTION
+   || ss_type == GFC_SS_COMPONENT
+   || ss_type == GFC_SS_CONSTRUCTOR
+   || (ss_type == GFC_SS_FUNCTION
+   && gfc_is_class_array_function (ss->info->expr
continue;
 
   info = &ss->info->data.array;

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction ICE class_to_type_1

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:b97c5ec4b146ab2b66d207a5aa6916cf065783f9

commit b97c5ec4b146ab2b66d207a5aa6916cf065783f9
Author: Mikael Morin 
Date:   Fri Feb 14 17:11:03 2025 +0100

Correction ICE class_to_type_1

Diff:
---
 gcc/fortran/trans-array.cc | 30 --
 1 file changed, 16 insertions(+), 14 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cadeac673e8a..51e5bcd2c281 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8164,22 +8164,24 @@ late_set_loop_bounds (gfc_loopinfo *loop)
 
   for (n = 0; n < loop->dimen; n++)
 {
-  /* We should have found the scalarization loop specifier.  If not,
-that's bad news.  */
-  gcc_assert (loopspec[n]);
-
-  info = &loopspec[n]->info->data.array;
-  dim = loopspec[n]->dim[n];
-
   /* Set the extents of this range.  */
-  if ((loop->from[n] == NULL_TREE
-  || loop->to[n] == NULL_TREE)
- && loopspec[n]->info->type == GFC_SS_FUNCTION
- && info->start[dim]
- && info->end[dim])
+  if (loop->from[n] == NULL_TREE
+ || loop->to[n] == NULL_TREE)
{
- loop->from[n] = info->start[dim];
- loop->to[n] = info->end[dim];
+ /* We should have found the scalarization loop specifier.  If not,
+that's bad news.  */
+ gcc_assert (loopspec[n]);
+
+ info = &loopspec[n]->info->data.array;
+ dim = loopspec[n]->dim[n];
+
+ if (loopspec[n]->info->type == GFC_SS_FUNCTION
+ && info->start[dim]
+ && info->end[dim])
+   {
+ loop->from[n] = info->start[dim];
+ loop->to[n] = info->end[dim];
+   }
}
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Renommage gfc_array_init_count -> gfc_descr_init_count

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:678f770b44a585b9827163c4b07416949ef69320

commit 678f770b44a585b9827163c4b07416949ef69320
Author: Mikael Morin 
Date:   Fri Feb 14 13:46:24 2025 +0100

Renommage gfc_array_init_count -> gfc_descr_init_count

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e950cbf3e765..80f21d6f8de9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8418,7 +8418,7 @@ get_array_memory_size (tree element_size, tree 
elements_count,
 /*GCC ARRAYS*/
 
 static tree
-gfc_array_init_count (tree descriptor, int rank, int corank, gfc_expr ** lower,
+gfc_descr_init_count (tree descriptor, int rank, int corank, gfc_expr ** lower,
  gfc_expr ** upper, stmtblock_t * pblock,
  stmtblock_t * descriptor_block, tree * overflow,
  tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
@@ -8831,7 +8831,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
  later will mislead the generation of the array dimensions for allocatable/
  pointer components in derived types.  */
   int rank = alloc_w_e3_arr_spec ? expr->rank : ref->u.ar.as->rank;
-  tree count = gfc_array_init_count (se->expr, rank,
+  tree count = gfc_descr_init_count (se->expr, rank,
 coarray ? ref->u.ar.as->corank : 0,
 lower, upper, &se->pre,
 &set_descriptor_block, &overflow,

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Suppression modif offset trans_associate_var

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:677397c04ae053e15056af72169b02fcda0c8524

commit 677397c04ae053e15056af72169b02fcda0c8524
Author: Mikael Morin 
Date:   Mon Feb 17 14:43:06 2025 +0100

Suppression modif offset trans_associate_var

Diff:
---
 gcc/fortran/trans-stmt.cc | 15 ---
 1 file changed, 15 deletions(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 41cda2b2c418..535f409f7c2b 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2134,21 +2134,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block 
*block)
 
  desc = gfc_class_data_get (se.expr);
 
- /* Set the offset.  */
- offset = gfc_index_zero_node;
- for (n = 0; n < e->rank; n++)
-   {
- dim = gfc_rank_cst[n];
- tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type,
-gfc_conv_descriptor_stride_get (desc, dim),
-gfc_conv_descriptor_lbound_get (desc, 
dim));
- offset = fold_build2_loc (input_location, MINUS_EXPR,
-   gfc_array_index_type,
-   offset, tmp);
-   }
- gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
-
  if (need_len_assign)
{
  if (e->symtree

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Suppression set span dans trans_associate_var

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:7df04e1e587a83eec3edf4421248304d40601cc2

commit 7df04e1e587a83eec3edf4421248304d40601cc2
Author: Mikael Morin 
Date:   Mon Feb 17 16:16:47 2025 +0100

Suppression set span dans trans_associate_var

Diff:
---
 gcc/fortran/trans-stmt.cc | 10 --
 1 file changed, 10 deletions(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 33234df2219f..335d3a36080a 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2012,16 +2012,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block 
*block)
  gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
 
-  /* If this is a subreference array pointer associate name use the
-associate variable element size for the value of 'span'.  */
-  if (sym->attr.subref_array_pointer && !se.direct_byref)
-   {
- gcc_assert (e->expr_type == EXPR_VARIABLE);
- tmp = gfc_get_array_span (se.expr, e);
-
- gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
-   }
-
   if (e->expr_type == EXPR_FUNCTION
  && sym->ts.type == BT_DERIVED
  && sym->ts.u.derived

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Factorisation set temporary descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:03aae9140f9e10b5969fc77cc435f7fde182028a

commit 03aae9140f9e10b5969fc77cc435f7fde182028a
Author: Mikael Morin 
Date:   Wed Feb 12 18:17:41 2025 +0100

Factorisation set temporary descriptor

Suppression code redondant initialisation descriptor temporaire

Réduction différences

Correction régression class_transformational_2

Diff:
---
 gcc/fortran/trans-array.cc | 119 -
 1 file changed, 74 insertions(+), 45 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7a7f68a1fdb7..e6608eb4c9fa 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3308,13 +3308,14 @@ gfc_set_loop_bounds_from_array_spec 
(gfc_interface_mapping * mapping,
DYNAMIC is true if the caller may want to extend the array later
using realloc.  This prevents us from putting the array on the stack.  */
 
-static void
+static tree
 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
  gfc_array_info * info, tree size, tree nelem,
  tree initial, bool dynamic, bool dealloc)
 {
   tree tmp;
   tree desc;
+  tree ptr = NULL_TREE;
   bool onstack;
 
   desc = info->descriptor;
@@ -3322,7 +3323,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, 
stmtblock_t * post,
   if (size == NULL_TREE || (dynamic && integer_zerop (size)))
 {
   /* A callee allocated array.  */
-  gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+  ptr = null_pointer_node;
   onstack = false;
 }
   else
@@ -3350,8 +3351,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, 
stmtblock_t * post,
   fold_build1_loc (input_location,
DECL_EXPR, TREE_TYPE (tmp),
tmp));
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- gfc_conv_descriptor_data_set (pre, desc, tmp);
+ ptr = gfc_build_addr_expr (NULL_TREE, tmp);
}
   else
{
@@ -3359,7 +3359,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, 
stmtblock_t * post,
  if (initial == NULL_TREE)
{
  tmp = gfc_call_malloc (pre, NULL, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ ptr = gfc_evaluate_now (tmp, pre);
}
  else
{
@@ -3402,18 +3402,12 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, 
stmtblock_t * post,
  build_empty_stmt (input_location));
  gfc_add_expr_to_block (pre, tmp);
 
- tmp = fold_convert (pvoid_type_node, packed);
+ ptr = fold_convert (pvoid_type_node, packed);
}
-
- gfc_conv_descriptor_data_set (pre, desc, tmp);
}
 }
   info->data = gfc_conv_descriptor_data_get (desc);
 
-  /* The offset is zero because we create temporaries with a zero
- lower bound.  */
-  gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
-
   if (dealloc && !onstack)
 {
   /* Free the temporary.  */
@@ -3421,6 +3415,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, 
stmtblock_t * post,
   tmp = gfc_call_free (tmp);
   gfc_add_expr_to_block (post, tmp);
 }
+
+  return ptr;
 }
 
 
@@ -3632,6 +3628,61 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, 
tree *eltype,
 }
 
 
+static void
+set_temporary_descriptor (stmtblock_t *block, tree desc, tree class_src,
+ tree elemsize, tree data_ptr,
+ tree ubound[GFC_MAX_DIMENSIONS],
+ tree stride[GFC_MAX_DIMENSIONS], int rank,
+ bool callee_allocated, bool rank_changer)
+{
+  int n;
+
+  if (!class_src)
+{
+  /* Fill in the array dtype.  */
+  gfc_conv_descriptor_dtype_set (block, desc,
+gfc_get_dtype (TREE_TYPE (desc)));
+}
+  else if (rank_changer)
+{
+  /* For classes, we copy the whole original class descriptor to the
+ temporary one, so we don't need to set the individual dtype fields.
+Except for the case of rank altering intrinsics for which we
+generate descriptors of different rank.  */
+
+  /* Take the dtype from the class expression.  */
+  tree src_data = gfc_class_data_get (class_src);
+  tree dtype = gfc_conv_descriptor_dtype_get (src_data);
+  gfc_conv_descriptor_dtype_set (block, desc, dtype);
+
+  /* These transformational functions change the rank.  */
+  gfc_conv_descriptor_rank_set (block, desc, rank);
+}
+
+  if (!callee_allocated)
+{
+  for (n = 0; n < rank; n++)
+   {
+ /* Store the stride and bound components in the descriptor.  */
+ gfc_conv_descriptor_stride_set (block, desc, gfc_rank_cst[n],
+ stride[n]);
+
+ 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction bootstrap suppression variables inutilisées

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:67854909eacbab0a1e386dbf5f0bb2ba9e73c1b1

commit 67854909eacbab0a1e386dbf5f0bb2ba9e73c1b1
Author: Mikael Morin 
Date:   Mon Feb 17 15:48:12 2025 +0100

Correction bootstrap suppression variables inutilisées

Diff:
---
 gcc/fortran/trans-stmt.cc | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 535f409f7c2b..33234df2219f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1736,9 +1736,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block 
*block)
   bool class_target;
   bool unlimited;
   tree desc;
-  tree offset;
-  tree dim;
-  int n;
   tree charlen;
   bool need_len_assign;
   bool whole_array = true;

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régressions inline_sum_*

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:7bed5363364cad904d31937f5f39798c42bbb8e6

commit 7bed5363364cad904d31937f5f39798c42bbb8e6
Author: Mikael Morin 
Date:   Fri Feb 14 18:55:55 2025 +0100

Correction régressions inline_sum_*

Diff:
---
 gcc/fortran/trans-array.cc | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 05fb9c3119d7..008829140eb7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8187,7 +8187,7 @@ late_set_loop_bounds (gfc_loopinfo *loop)
 }
 
   for (loop = loop->nested; loop; loop = loop->next)
-set_loop_bounds (loop);
+late_set_loop_bounds (loop);
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Suppression argument nelems gfc_array_allocate

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:498dfa7396961dd54a8a16661f891d5d5d9dec2e

commit 498dfa7396961dd54a8a16661f891d5d5d9dec2e
Author: Mikael Morin 
Date:   Fri Feb 14 12:11:43 2025 +0100

Suppression argument nelems gfc_array_allocate

Diff:
---
 gcc/fortran/trans-array.cc | 6 ++
 gcc/fortran/trans-array.h  | 2 +-
 gcc/fortran/trans-stmt.cc  | 5 +
 3 files changed, 4 insertions(+), 9 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9d42e3e902d1..0a738e5d7b25 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8703,9 +8703,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref 
**prev_ref_in)
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
-   tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
-   bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
-   bool explicit_ts)
+   gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
+   gfc_omp_namelist *omp_alloc, bool explicit_ts)
 {
   tree tmp;
   tree pointer;
@@ -8842,7 +8841,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
 expr3_elem_size, expr3, e3_arr_desc,
 e3_has_nodescriptor, expr, element_size,
 explicit_ts, &empty_array_cond);
-  *nelems = count;
 
   tree size = get_array_memory_size (element_size, count, empty_array_cond,
 &se->pre, &overflow);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index f37f09c21cff..357bd64fb766 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -21,7 +21,7 @@ along with GCC; see the file COPYING3.  If not see
 /* Generate code to initialize and allocate an array.  Statements are added to
se, which should contain an expression for the array descriptor.  */
 bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
-tree, tree *, gfc_expr *, tree, bool,
+tree, gfc_expr *, tree, bool,
 gfc_omp_namelist *, bool);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 72fa06093797..41cda2b2c418 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6541,7 +6541,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist 
*omp_allocate)
   stmtblock_t block;
   stmtblock_t post;
   stmtblock_t final_block;
-  tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
   bool needs_caf_sync, caf_refs_comp;
   bool e3_has_nodescriptor = false;
@@ -7073,7 +7072,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist 
*omp_allocate)
 to handle the complete array allocation.  Only the element size
 needs to be provided, which is done most of the time by the
 pre-evaluation step.  */
-  nelems = NULL_TREE;
   if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
|| code->expr3->ts.type == BT_CLASS))
{
@@ -7145,8 +7143,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist 
*omp_allocate)
}
 
   if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
-  label_finish, tmp, &nelems,
-  e3rhs ? e3rhs : code->expr3,
+  label_finish, tmp, e3rhs ? e3rhs : code->expr3,
   e3_is == E3_DESC ? expr3 : NULL_TREE,
   e3_has_nodescriptor, omp_alloc_item,
   code->ext.alloc.ts.type != BT_UNKNOWN))

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Utilisation setter trans_associate_var

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:b584cb483771ec97720aab7d88a25f19f0900630

commit b584cb483771ec97720aab7d88a25f19f0900630
Author: Mikael Morin 
Date:   Mon Feb 17 17:15:10 2025 +0100

Utilisation setter trans_associate_var

Diff:
---
 gcc/fortran/trans-stmt.cc | 7 ---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 335d3a36080a..1ba72aaba697 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2297,9 +2297,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block 
*block)
{
  tmp = sym->backend_decl;
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
-   tmp = gfc_conv_descriptor_data_get (tmp);
- gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
-   null_pointer_node));
+   gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
+ else
+   gfc_add_modify (&se.pre, tmp,
+   fold_convert (TREE_TYPE (tmp), null_pointer_node));
}
 
   lhs = gfc_lval_expr_from_sym (sym);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Suppression mise à jour offset forall

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:121eac20ba2a339b5b521e58a4b744005359d3ba

commit 121eac20ba2a339b5b521e58a4b744005359d3ba
Author: Mikael Morin 
Date:   Mon Feb 17 17:28:01 2025 +0100

Suppression mise à jour offset forall

Diff:
---
 gcc/fortran/trans-stmt.cc | 7 ---
 1 file changed, 7 deletions(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 1ba72aaba697..99f46bf12154 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -4021,13 +4021,6 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t 
*pre, stmtblock_t *post)
   gfc_add_block_to_block (pre, &tse.pre);
   gfc_add_block_to_block (post, &tse.post);
   tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
-
-  if (c->expr1->ref->u.ar.type != AR_SECTION)
-   {
- /* Use the variable offset for the temporary.  */
- tmp = gfc_conv_array_offset (old_sym->backend_decl);
- gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
-   }
 }
   else
 {

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression class_assign_4.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:6f09819583bf8f197c5ac367cfd118dfea41af81

commit 6f09819583bf8f197c5ac367cfd118dfea41af81
Author: Mikael Morin 
Date:   Sat Feb 15 18:29:16 2025 +0100

Correction régression class_assign_4.f90

Diff:
---
 gcc/fortran/trans-array.cc | 6 --
 1 file changed, 6 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 008829140eb7..04965132c4f7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3630,12 +3630,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, 
tree *eltype,
  tmp2 = gfc_class_len_get (class_expr);
  gfc_add_modify (pre, tmp, tmp2);
}
-
-  if (rhs_function)
-   {
- tmp = gfc_class_data_get (class_expr);
- gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
-   }
 }
   else if (rhs_ss->info->data.array.descriptor)
{

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Mise à jour commentaires.

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:dbc08bec1d3c415e8b82955b17d45f29dcc31c01

commit dbc08bec1d3c415e8b82955b17d45f29dcc31c01
Author: Mikael Morin 
Date:   Fri Feb 14 12:23:42 2025 +0100

Mise à jour commentaires.

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0a738e5d7b25..e950cbf3e765 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8322,6 +8322,13 @@ descriptor_element_size (tree descriptor, tree 
expr3_elem_size,
 }
 
 
+/* Calculates the memory size of an array, given the size of its elements,
+   the number of them, and the predicate whether the array is empty.
+elements_count = (size_t) elements_count;
+overflow += element_size == 0 ? 0: (MAX/element_size < elements_count ? 1: 
0);
+tmp = elements_count * element_size;
+return (tmp);  */
+
 static tree
 get_array_memory_size (tree element_size, tree elements_count,
   tree empty_array_cond, stmtblock_t * pblock,
@@ -8336,8 +8343,6 @@ get_array_memory_size (tree element_size, tree 
elements_count,
   stmtblock_t thenblock;
   stmtblock_t elseblock;
 
-
-
   elements_count = fold_convert (size_type_node, elements_count);
 
   /* First check for overflow. Since an array of type character can
@@ -8386,11 +8391,10 @@ get_array_memory_size (tree element_size, tree 
elements_count,
 }
 
 
-/* Fills in an array descriptor, and returns the size of the array.
-   The size will be a simple_val, ie a variable or a constant.  Also
-   calculates the offset of the base.  The pointer argument overflow,
-   which should be of integer type, will increase in value if overflow
-   occurs during the size calculation.  Returns the size of the array.
+/* Fills in an array descriptor, and returns the number of elements in the
+   array.  The pointer argument overflow, which should be of integer type,
+   will increase in value if overflow occurs during the size calculation.
+   Also sets the condition whether the array is empty through empty_array_cond.
{
 stride = 1;
 offset = 0;
@@ -8407,13 +8411,9 @@ get_array_memory_size (tree element_size, tree 
elements_count,
   }
 for (n = rank; n < rank+corank; n++)
   (Set lcobound/ucobound as above.)
-element_size = sizeof (array element);
-if (!rank)
-  return element_size
-stride = (size_t) stride;
-overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
-stride = stride * element_size;
-return (stride);
+if (rank == 0)
+  return 1;
+return stride;
}  */
 /*GCC ARRAYS*/
 
@@ -8653,9 +8653,6 @@ gfc_array_init_count (tree descriptor, int rank, int 
corank, gfc_expr ** lower,
 
   *empty_array_cond = empty_cond;
 
-  /* The stride is the number of elements in the array, so multiply by the
- size of an element to get the total size.  */
-
   if (rank == 0)
 return gfc_index_one_node;
 
@@ -8842,8 +8839,10 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
 e3_has_nodescriptor, expr, element_size,
 explicit_ts, &empty_array_cond);
 
-  tree size = get_array_memory_size (element_size, count, empty_array_cond,
-&se->pre, &overflow);
+  tree size = rank == 0
+ ? element_size
+ : get_array_memory_size (element_size, count, empty_array_cond,
+  &se->pre, &overflow);
 
   if (dimension)
 {

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Essai suppression code inutile

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:a6ae3d04dd25eda353e9f6333a9bc5b12241d98e

commit a6ae3d04dd25eda353e9f6333a9bc5b12241d98e
Author: Mikael Morin 
Date:   Fri Feb 14 13:50:51 2025 +0100

Essai suppression code inutile

Diff:
---
 gcc/fortran/trans-expr.cc | 10 --
 1 file changed, 10 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6fd9a1f389f6..56392f963c90 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5478,16 +5478,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, 
int g77,
   /* Translate the expression.  */
   gfc_conv_expr (&rse, expr);
 
-  /* Reset the offset for the function call since the loop
- is zero based on the data pointer.  Note that the temp
- comes first in the loop chain since it is added second.  */
-  if (gfc_is_class_array_function (expr))
-{
-  tmp = loop.ss->loop_chain->info->data.array.descriptor;
-  gfc_conv_descriptor_offset_set (&loop.pre, tmp,
- gfc_index_zero_node);
-}
-
   gfc_conv_tmp_array_ref (&lse);
 
   if (intent != INTENT_OUT)

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction class_result_10.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:e137626d1a1304ee74504ce1b632da3537236ac7

commit e137626d1a1304ee74504ce1b632da3537236ac7
Author: Mikael Morin 
Date:   Fri Feb 14 18:48:22 2025 +0100

Correction class_result_10.f90

Diff:
---
 gcc/fortran/trans-array.cc | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 75a41a38ea12..05fb9c3119d7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7465,7 +7465,8 @@ done:
  int dim = ss->dim[n];
 
  info->start[dim]  = gfc_index_zero_node;
- info->end[dim]= gfc_index_zero_node;
+ if (ss_info->type != GFC_SS_FUNCTION)
+   info->end[dim]= gfc_index_zero_node;
  info->stride[dim] = gfc_index_one_node;
}
  break;

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Sauvegarde suppression initialisation inutile bornes pour taire warnings

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:58cd443a07498ff8056a4c9557635696f5586a0f

commit 58cd443a07498ff8056a4c9557635696f5586a0f
Author: Mikael Morin 
Date:   Fri Mar 14 16:37:46 2025 +0100

Sauvegarde suppression initialisation inutile bornes pour taire warnings

Diff:
---
 gcc/fortran/gfortran.h |  4 
 gcc/fortran/trans-array.cc | 52 +++---
 gcc/fortran/trans-expr.cc  | 39 +-
 3 files changed, 41 insertions(+), 54 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b480992d144a..92dcf9c7c2d2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2020,10 +2020,6 @@ typedef struct gfc_symbol
   /* Set if this should be passed by value, but is not a VALUE argument
  according to the Fortran standard.  */
   unsigned pass_as_value:1;
-  /* Set if an allocatable array variable has been allocated in the current
- scope. Used in the suppression of uninitialized warnings in reallocation
- on assignment.  */
-  unsigned allocated_in_scope:1;
   /* Set if an external dummy argument is called with different argument lists.
  This is legal in Fortran, but can cause problems with autogenerated
  C prototypes for C23.  */
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2fabffb53e73..50c558784ec2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7040,13 +7040,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * 
loop, stmtblock_t * body)
 
 static void
 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
-   tree desc, int dim, bool lbound, bool deferred)
+   tree desc, int dim, bool lbound, bool deferred, bool save_value)
 {
   gfc_se se;
   gfc_expr * input_val = values[dim];
   tree *output = &bounds[dim];
 
-
   if (input_val)
 {
   /* Specified section bound.  */
@@ -7072,7 +7071,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds, 
gfc_expr ** values,
   *output = lbound ? gfc_conv_array_lbound (desc, dim) :
 gfc_conv_array_ubound (desc, dim);
 }
-  *output = gfc_evaluate_now (*output, block);
+  if (save_value)
+*output = gfc_evaluate_now (*output, block);
 }
 
 
@@ -7105,18 +7105,18 @@ gfc_conv_section_startstride (stmtblock_t * block, 
gfc_ss * ss, int dim)
  || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
   desc = info->descriptor;
   stride = ar->stride[dim];
-
+  bool save_value = !ss->is_alloc_lhs;
 
   /* Calculate the start of the range.  For vector subscripts this will
  be the range of the vector.  */
   evaluate_bound (block, info->start, ar->start, desc, dim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, save_value);
 
   /* Similarly calculate the end.  Although this is not used in the
  scalarizer, it is needed when checking bounds and where the end
  is an expression with side-effects.  */
   evaluate_bound (block, info->end, ar->end, desc, dim, false,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, save_value);
 
 
   /* Calculate the stride.  */
@@ -7127,7 +7127,11 @@ gfc_conv_section_startstride (stmtblock_t * block, 
gfc_ss * ss, int dim)
   gfc_init_se (&se, NULL);
   gfc_conv_expr_type (&se, stride, gfc_array_index_type);
   gfc_add_block_to_block (block, &se.pre);
-  info->stride[dim] = gfc_evaluate_now (se.expr, block);
+  tree value = se.expr;
+  if (save_value)
+   info->stride[dim] = gfc_evaluate_now (value, block);
+  else
+   info->stride[dim] = value;
 }
 }
 
@@ -9088,8 +9092,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
   else
   gfc_add_expr_to_block (&se->pre, set_descriptor);
 
-  expr->symtree->n.sym->allocated_in_scope = 1;
-
   return true;
 }
 
@@ -10916,7 +10918,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
  gcc_assert (n == codim - 1);
  evaluate_bound (&loop.pre, info->start, ar->start,
  info->descriptor, n + ndim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, true);
  loop.from[n + loop.dimen] = info->start[n + ndim];
}
   else
@@ -13605,7 +13607,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   stmtblock_t realloc_block;
   stmtblock_t alloc_block;
   stmtblock_t fblock;
-  stmtblock_t loop_pre_block;
   gfc_ref *ref;
   gfc_ss *rss;
   gfc_ss *lss;
@@ -13816,35 +13817,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
 if (ref->type == REF_COMPONENT)
   break;
 
-  if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
-{
-  gfc_start_block (&loop_pre_block);
-  for (n = 0; n < expr1->rank; n++)
-   {
- gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
-   

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression realloc_on_assign_23.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:79fc4682e55916d07325b0c8bcb8d24fd87e59c7

commit 79fc4682e55916d07325b0c8bcb8d24fd87e59c7
Author: Mikael Morin 
Date:   Mon Feb 17 21:28:01 2025 +0100

Correction régression realloc_on_assign_23.f90

Diff:
---
 gcc/fortran/trans-expr.cc | 8 +---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index db338cce..f8336145fd2f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12588,6 +12588,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
   rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
 }
 
+  tree reallocation = NULL_TREE;
   if (lss != gfc_ss_terminator)
 {
   /* The assignment needs scalarization.  */
@@ -12661,9 +12662,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
{
  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
  ompws_flags &= ~OMPWS_SCALARIZER_WS;
- tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
- if (tmp != NULL_TREE)
-   gfc_add_expr_to_block (&loop.pre, tmp);
+ reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, 
expr2);
}
 
   for (gfc_ss *s = loop.ss; s != gfc_ss_terminator; s = s->loop_chain)
@@ -12996,6 +12995,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
   if (maybe_workshare)
ompws_flags &= ~OMPWS_SCALARIZER_BODY;
 
+  if (reallocation != NULL_TREE)
+   gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
+
   /* Generate the copying loops.  */
   gfc_trans_scalarizing_loops (&loop, &body);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression realloc_on_assign_1.f03

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:d3343f63c9fa88d4ad97fd6ab225ef400d4ba62d

commit d3343f63c9fa88d4ad97fd6ab225ef400d4ba62d
Author: Mikael Morin 
Date:   Mon Feb 17 21:59:00 2025 +0100

Correction régression realloc_on_assign_1.f03

Diff:
---
 gcc/fortran/trans-expr.cc | 42 +++---
 1 file changed, 23 insertions(+), 19 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f8336145fd2f..7714f3415c28 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12662,26 +12662,30 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
{
  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
  ompws_flags &= ~OMPWS_SCALARIZER_WS;
+ stmtblock_t reallocation_block;
+ gfc_init_block (&reallocation_block);
  reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, 
expr2);
-   }
-
-  for (gfc_ss *s = loop.ss; s != gfc_ss_terminator; s = s->loop_chain)
-   {
- if (!s->is_alloc_lhs)
-   continue;
+ gfc_add_expr_to_block (&reallocation_block, reallocation);
 
- gcc_assert (s->info->type == GFC_SS_SECTION);
- gfc_array_info *info = &s->info->data.array;
- info->offset = gfc_evaluate_now (info->offset, &loop.pre);
- info->saved_offset = info->offset;
- for (int i = 0; i < s->dimen; i++)
+ for (gfc_ss *s = loop.ss; s != gfc_ss_terminator; s = s->loop_chain)
{
- int dim = s->dim[i];
- info->start[dim] = gfc_evaluate_now (info->start[dim], &loop.pre);
- info->end[dim] = gfc_evaluate_now (info->end[dim], &loop.pre);
- info->stride[dim] = gfc_evaluate_now (info->stride[dim], 
&loop.pre);
- info->delta[dim] = gfc_evaluate_now (info->delta[dim], &loop.pre);
+ if (!s->is_alloc_lhs)
+   continue;
+
+ gcc_assert (s->info->type == GFC_SS_SECTION);
+ gfc_array_info *info = &s->info->data.array;
+ info->offset = gfc_evaluate_now (info->offset, 
&reallocation_block);
+ info->saved_offset = info->offset;
+ for (int i = 0; i < s->dimen; i++)
+   {
+ int dim = s->dim[i];
+ info->start[dim] = gfc_evaluate_now (info->start[dim], 
&reallocation_block);
+ info->end[dim] = gfc_evaluate_now (info->end[dim], 
&reallocation_block);
+ info->stride[dim] = gfc_evaluate_now (info->stride[dim], 
&reallocation_block);
+ info->delta[dim] = gfc_evaluate_now (info->delta[dim], 
&reallocation_block);
+   }
}
+ reallocation = gfc_finish_block (&reallocation_block);
}
 
   /* Start the scalarized loop body.  */
@@ -12992,12 +12996,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
  gfc_add_expr_to_block (&body, tmp);
}
 
-  if (maybe_workshare)
-   ompws_flags &= ~OMPWS_SCALARIZER_BODY;
-
   if (reallocation != NULL_TREE)
gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
 
+  if (maybe_workshare)
+   ompws_flags &= ~OMPWS_SCALARIZER_BODY;
+
   /* Generate the copying loops.  */
   gfc_trans_scalarizing_loops (&loop, &body);

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression pr108889.f90 realloc_on_assign*

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:48a376e32d7966114dd57852bc96ba06f57ae671

commit 48a376e32d7966114dd57852bc96ba06f57ae671
Author: Mikael Morin 
Date:   Mon Feb 17 22:59:01 2025 +0100

Correction régression pr108889.f90 realloc_on_assign*

Diff:
---
 gcc/fortran/trans-array.cc | 75 +++---
 gcc/fortran/trans-expr.cc  | 23 --
 2 files changed, 58 insertions(+), 40 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 50c558784ec2..b1094fbb8c92 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5742,12 +5742,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * 
ss, int base)
&& DECL_P (TREE_OPERAND (tmp, 0)))
|| (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
&& TREE_CODE (se.expr) == COMPONENT_REF
-   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))
+   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)
+ && !ss->is_alloc_lhs)
tmp = gfc_evaluate_now (tmp, block);
   info->data = tmp;
 
   tmp = gfc_conv_array_offset (se.expr);
-  info->offset = gfc_evaluate_now (tmp, block);
+  if (!ss->is_alloc_lhs)
+   tmp = gfc_evaluate_now (tmp, block);
+  info->offset = tmp;
 
   /* Make absolutely sure that the saved_offset is indeed saved
 so that the variable is still accessible after the loops
@@ -8314,7 +8317,10 @@ gfc_set_delta (gfc_loopinfo *loop)
 gfc_array_index_type,
 info->start[dim], tmp);
 
- info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+ if (ss->is_alloc_lhs)
+   info->delta[dim] = tmp;
+ else 
+   info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
}
}
 }
@@ -13596,6 +13602,52 @@ concat_str_length (gfc_expr* expr)
 }
 
 
+static void
+update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
+{
+  for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
+{
+  if (!s->is_alloc_lhs)
+   continue;
+
+  gcc_assert (s->info->type == GFC_SS_SECTION);
+  gfc_array_info *info = &s->info->data.array;
+  tree desc = info->descriptor;
+
+#define UPDATE_VALUE(field, value) \
+ do \
+   { \
+ if ((field) && VAR_P ((field))) \
+   { \
+ tree val = (value); \
+ gfc_add_modify (block, (field), val); \
+   } \
+ else \
+   (field) = gfc_evaluate_now ((field), block); \
+   } \
+ while (0)
+
+  UPDATE_VALUE (info->data, gfc_conv_descriptor_data_get (desc));
+  UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc));
+  info->saved_offset = info->offset;
+  for (int i = 0; i < s->dimen; i++)
+   {
+ int dim = s->dim[i];
+ tree tree_dim = gfc_rank_cst[dim]; 
+ UPDATE_VALUE (info->start[dim],
+   gfc_conv_descriptor_lbound_get (desc, tree_dim));
+ UPDATE_VALUE (info->end[dim],
+   gfc_conv_descriptor_ubound_get (desc, tree_dim));
+ UPDATE_VALUE (info->stride[dim],
+   gfc_conv_descriptor_stride_get (desc, tree_dim));
+ info->delta[dim] = gfc_evaluate_now (info->delta[dim], block);
+   }
+
+#undef UPDATE_VALUE
+}
+}
+
+
 /* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it.  */
 
@@ -13688,7 +13740,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   && !expr2->value.function.isym)
 expr2->ts.u.cl->backend_decl = rss->info->string_length;
 
-  gfc_start_block (&fblock);
+  gfc_init_block (&fblock);
 
   /* Since the lhs is allocatable, this must be a descriptor type.
  Get the data and array size.  */
@@ -13960,10 +14012,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
  the array offset is saved and the info.offset is used for a
  running offset.  Use the saved_offset instead.  */
   gfc_conv_descriptor_offset_set (&fblock, desc, offset);
-  if (linfo->saved_offset
-  && VAR_P (linfo->saved_offset))
-gfc_add_modify (&fblock, linfo->saved_offset,
-   gfc_conv_descriptor_offset_get (desc));
 
   /* Now set the deltas for the lhs.  */
   for (n = 0; n < expr1->rank; n++)
@@ -13973,8 +14021,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   tmp = fold_build2_loc (input_location, MINUS_EXPR,
 gfc_array_index_type, tmp,
 loop->from[dim]);
-  if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
-   gfc_add_modify (&fblock, linfo->delta[dim], tmp);
 }
 
   /* Take into account _len of unlimited polymorphic entities, so that span
@@ -14195,17 +14241,12 @@ 

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression associate_46.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:670b0c103a6922544c85557ae2434ee144bfb4c9

commit 670b0c103a6922544c85557ae2434ee144bfb4c9
Author: Mikael Morin 
Date:   Tue Feb 18 12:35:05 2025 +0100

Correction régression associate_46.f90

Diff:
---
 gcc/fortran/trans-array.cc | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b1094fbb8c92..797895a2d33f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -13478,6 +13478,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
   gfc_ref * ref;
   gfc_symbol *sym;
 
+  if (!flag_realloc_lhs)
+return false;
+
   if (!expr->ref)
 return false;

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression func_result_6.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:47759397f87b10b10315eb21260ad4779b2703c6

commit 47759397f87b10b10315eb21260ad4779b2703c6
Author: Mikael Morin 
Date:   Tue Feb 18 19:18:37 2025 +0100

Correction régression func_result_6.f90

Diff:
---
 gcc/fortran/resolve.cc | 50 --
 1 file changed, 36 insertions(+), 14 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 8d02eeb9fdf0..ecc130812604 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -2799,6 +2799,31 @@ done:
 }
 
 
+static void
+expression_shape (gfc_expr *e, gfc_array_spec *as)
+{
+  mpz_t array[GFC_MAX_DIMENSIONS];
+  int i;
+
+  if (e->rank <= 0 || e->shape != NULL)
+return;
+
+  for (i = 0; i < e->rank; i++)
+if (!spec_dimen_size (as, i, &array[i]))
+  goto fail;
+
+  e->shape = gfc_get_shape (e->rank);
+
+  memcpy (e->shape, array, e->rank * sizeof (mpz_t));
+
+  return;
+
+fail:
+  for (i--; i >= 0; i--)
+mpz_clear (array[i]);
+}
+
+
 /* Function resolution */
 
 /* Resolve a function call known to be generic.
@@ -2822,15 +2847,17 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
  else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
expr->ts = s->result->ts;
 
- if (s->as != NULL)
-   {
- expr->rank = s->as->rank;
- expr->corank = s->as->corank;
-   }
- else if (s->result != NULL && s->result->as != NULL)
+ if (s->result != NULL && s->result->as != NULL)
{
  expr->rank = s->result->as->rank;
  expr->corank = s->result->as->corank;
+ expression_shape (expr, s->result->as);
+   }
+ else if (s->as != NULL)
+   {
+ expr->rank = s->as->rank;
+ expr->corank = s->as->corank;
+ expression_shape (expr, s->as);
}
 
  gfc_set_sym_referenced (expr->value.function.esym);
@@ -2974,11 +3001,13 @@ found:
 {
   expr->rank = CLASS_DATA (sym)->as->rank;
   expr->corank = CLASS_DATA (sym)->as->corank;
+  expression_shape (expr, CLASS_DATA (sym)->as);
 }
   else if (sym->as != NULL)
 {
   expr->rank = sym->as->rank;
   expr->corank = sym->as->corank;
+  expression_shape (expr, sym->as);
 }
 
   return MATCH_YES;
@@ -3103,6 +3132,7 @@ resolve_unknown_f (gfc_expr *expr)
 {
   expr->rank = sym->as->rank;
   expr->corank = sym->as->corank;
+  expression_shape (expr, sym->as);
 }
 
   /* Type of the expression is either the type of the symbol or the
@@ -3640,11 +3670,6 @@ resolve_function (gfc_expr *expr)
 "Using function %qs at %L is deprecated",
 sym->name, &expr->where);
 
-  if (!(expr->value.function.isym
-   || !expr->value.function.esym
-   || expr->value.function.esym->attr.elemental))
-gfc_expression_rank (expr);
-
   return t;
 }
 
@@ -5893,9 +5918,6 @@ gfc_resolve_ref (gfc_expr *expr)
 }
 
 
-/* Given an expression, determine its shape.  This is easier than it sounds.
-   Leaves the shape array NULL if it is not possible to determine the shape.  
*/
-
 static void
 expression_shape (gfc_expr *e)
 {

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression array_function_6.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:a964afbbf0a516f06a37575ad2b00f537a915f8a

commit a964afbbf0a516f06a37575ad2b00f537a915f8a
Author: Mikael Morin 
Date:   Tue Feb 18 15:07:23 2025 +0100

Correction régression array_function_6.f90

Diff:
---
 gcc/fortran/resolve.cc |  4 
 gcc/fortran/trans-array.cc | 11 ---
 2 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cdf043b64115..3b20e42110d8 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3639,6 +3639,10 @@ resolve_function (gfc_expr *expr)
 gfc_warning (OPT_Wdeprecated_declarations,
 "Using function %qs at %L is deprecated",
 sym->name, &expr->where);
+
+  if (!expr->value.function.isym)
+gfc_expression_rank (expr);
+
   return t;
 }
 
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 797895a2d33f..9c064f96c11f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -13743,7 +13743,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   && !expr2->value.function.isym)
 expr2->ts.u.cl->backend_decl = rss->info->string_length;
 
-  gfc_init_block (&fblock);
+  gfc_start_block (&fblock);
 
   /* Since the lhs is allocatable, this must be a descriptor type.
  Get the data and array size.  */
@@ -14248,9 +14248,14 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   tmp = build1_v (LABEL_EXPR, jump_label2);
   gfc_add_expr_to_block (&fblock, tmp);
 
-  update_reallocated_descriptor (&fblock, loop);
+  tree realloc_code = gfc_finish_block (&fblock);
 
-  return gfc_finish_block (&fblock);
+  stmtblock_t result_block;
+  gfc_init_block (&result_block);
+  gfc_add_expr_to_block (&result_block, realloc_code);
+  update_reallocated_descriptor (&result_block, loop);
+
+  return gfc_finish_block (&result_block);
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Correction régression class_transformational_2.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:926fb0ef5f6b9ac41275ee3a85baa7d662af3abe

commit 926fb0ef5f6b9ac41275ee3a85baa7d662af3abe
Author: Mikael Morin 
Date:   Wed Feb 19 14:39:29 2025 +0100

Correction régression class_transformational_2.f90

Diff:
---
 gcc/fortran/trans-array.cc | 1 -
 1 file changed, 1 deletion(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9c064f96c11f..e05893e42564 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -13630,7 +13630,6 @@ update_reallocated_descriptor (stmtblock_t *block, 
gfc_loopinfo *loop)
} \
  while (0)
 
-  UPDATE_VALUE (info->data, gfc_conv_descriptor_data_get (desc));
   UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc));
   info->saved_offset = info->offset;
   for (int i = 0; i < s->dimen; i++)

[gcc(refs/users/mikael/heads/refactor_descriptor_v05)] Ajout nom variable dans temp select type

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:a9b9e40b155031e00835fa4072616266a0ef9e2a

commit a9b9e40b155031e00835fa4072616266a0ef9e2a
Author: Mikael Morin 
Date:   Tue Feb 18 22:08:17 2025 +0100

Ajout nom variable dans temp select type

Diff:
---
 gcc/fortran/resolve.cc | 24 +---
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ecc130812604..892de57bb32e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10820,7 +10820,6 @@ resolve_select_type (gfc_code *code, gfc_namespace 
*old_ns)
   for (body = code->block; body; body = body->block)
 {
   gfc_symbol *vtab;
-  gfc_expr *e;
   c = body->ext.block.case_list;
 
   /* Generate an index integer expression for address of the
@@ -10828,6 +10827,7 @@ resolve_select_type (gfc_code *code, gfc_namespace 
*old_ns)
 is stored in c->high and is used to resolve intrinsic cases.  */
   if (c->ts.type != BT_UNKNOWN)
{
+ gfc_expr *e;
  if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
  vtab = gfc_find_derived_vtab (c->ts.u.derived);
@@ -10860,11 +10860,21 @@ resolve_select_type (gfc_code *code, gfc_namespace 
*old_ns)
 when this case is actually true, so build a new ASSOCIATE
 that does precisely this here (instead of using the
 'global' one).  */
+  const char * var_name = "";
+  if (code->expr1->symtree)
+   var_name = code->expr1->symtree->name;
+  if (code->expr1->ref)
+   {
+ for (gfc_ref *r = code->expr1->ref; r; r = r->next)
+   if (r->type == REF_COMPONENT
+   && strcmp (r->u.c.component->name, "_data") != 0)
+ var_name = r->u.c.component->name;
+   }
 
   if (c->ts.type == BT_CLASS)
-   sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+   sprintf (name, "__tmp_class_%s_%s", c->ts.u.derived->name, var_name);
   else if (c->ts.type == BT_DERIVED)
-   sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+   sprintf (name, "__tmp_type_%s_%s", c->ts.u.derived->name, var_name);
   else if (c->ts.type == BT_CHARACTER)
{
  HOST_WIDE_INT charlen = 0;
@@ -10872,12 +10882,12 @@ resolve_select_type (gfc_code *code, gfc_namespace 
*old_ns)
  && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
  snprintf (name, sizeof (name),
-   "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
-   gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+   "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
+   gfc_basic_typename (c->ts.type), charlen, c->ts.kind, 
var_name);
}
   else
-   sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
-c->ts.kind);
+   sprintf (name, "__tmp_%s_%d_%s", gfc_basic_typename (c->ts.type),
+c->ts.kind, var_name);
 
   st = gfc_find_symtree (ns->sym_root, name);
   gcc_assert (st->n.sym->assoc);

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:f24a0afcfac627c7779ec39583f67247d0b84496

commit f24a0afcfac627c7779ec39583f67247d0b84496
Author: Mikael Morin 
Date:   Mon Feb 17 18:49:30 2025 +0100

Correction régression forall_13

Diff:
---
 gcc/fortran/trans-array.cc | 86 ++
 gcc/fortran/trans-array.h  |  3 +-
 gcc/fortran/trans-expr.cc  |  5 ++-
 gcc/fortran/trans-intrinsic.cc |  6 ++-
 gcc/fortran/trans-stmt.cc  |  2 +-
 gcc/fortran/trans.h|  1 +
 6 files changed, 64 insertions(+), 39 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 04965132c4f7..2fabffb53e73 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1910,17 +1910,20 @@ set_bounds_update_offset (stmtblock_t *block, tree 
desc, int dim,
 return;
 
   /* Update offset.  */
-  tree tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound_diff, stride);
-  tmp = fold_build2_loc (input_location, MINUS_EXPR,
-gfc_array_index_type, *offset, tmp);
-  *offset = gfc_evaluate_now (tmp, block);
+  if (!integer_zerop (lbound_diff))
+{
+  tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound_diff, stride);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+gfc_array_index_type, *offset, tmp);
+  *offset = gfc_evaluate_now (tmp, block);
+}
 
   if (!next_stride)
 return;
 
   /* Set stride for next dimension.  */
-  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  tree tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
   *next_stride = fold_build2_loc (input_location, MULT_EXPR,
  gfc_array_index_type, stride, tmp);
 }
@@ -3666,9 +3669,11 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, 
tree *eltype,
 static void
 set_temporary_descriptor (stmtblock_t *block, tree desc, tree class_src,
  tree elemsize, tree data_ptr,
+ tree lbound[GFC_MAX_DIMENSIONS],
  tree ubound[GFC_MAX_DIMENSIONS],
  tree stride[GFC_MAX_DIMENSIONS], int rank,
- bool callee_allocated, bool rank_changer)
+ bool callee_allocated, bool rank_changer,
+ bool shift_bounds)
 {
   int n;
 
@@ -3694,13 +3699,15 @@ set_temporary_descriptor (stmtblock_t *block, tree 
desc, tree class_src,
   gfc_conv_descriptor_rank_set (block, desc, rank);
 }
 
+  tree offset = gfc_index_zero_node;
   if (!callee_allocated)
 {
   for (n = 0; n < rank; n++)
{
  /* Store the stride and bound components in the descriptor.  */
- set_descriptor_dimension (block, desc, n, gfc_index_zero_node, 
ubound[n],
-   stride[n], nullptr, nullptr);
+ tree this_lbound = shift_bounds ? gfc_index_zero_node : lbound[n];
+ set_descriptor_dimension (block, desc, n, this_lbound, ubound[n],
+   stride[n], &offset, nullptr);
}
 }
 
@@ -3710,7 +3717,7 @@ set_temporary_descriptor (stmtblock_t *block, tree desc, 
tree class_src,
 
   /* The offset is zero because we create temporaries with a zero
  lower bound.  */
-  gfc_conv_descriptor_offset_set (block, desc, gfc_index_zero_node);
+  gfc_conv_descriptor_offset_set (block, desc, offset);
 }
 
 
@@ -3735,7 +3742,8 @@ set_temporary_descriptor (stmtblock_t *block, tree desc, 
tree class_src,
 tree
 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * 
ss,
 tree eltype, tree initial, bool dynamic,
-bool dealloc, bool callee_alloc, locus * where)
+bool dealloc, bool callee_alloc, locus * where,
+bool shift_bounds)
 {
   gfc_loopinfo *loop;
   gfc_ss *s;
@@ -3822,19 +3830,22 @@ gfc_trans_create_temp_array (stmtblock_t * pre, 
stmtblock_t * post, gfc_ss * ss,
{
  dim = s->dim[n];
 
- /* Callee allocated arrays may not have a known bound yet.  */
- if (loop->to[n])
-   loop->to[n] = gfc_evaluate_now (
-   fold_build2_loc (input_location, MINUS_EXPR,
-gfc_array_index_type,
-loop->to[n], loop->from[n]),
-   pre);
- loop->from[n] = gfc_index_zero_node;
-
- /* We have just changed the loop bounds, we must clear the
-corresponding specloop, so that delta calculation is not skipped
-later in gfc_set_delta.  */
- loop->specloop[n] = NULL;
+ if (shift_bounds)
+   {
+ /* Callee allocated arrays may not have a known bound yet.  */
+ if (loop->to[n])
+   loop-