[gcc r15-8057] libstdc++: Fix views::zip_transform constraints for empty range pack [PR111138]

[Tomasz Kaminski via Gcc-cvs]

https://gcc.gnu.org/g:5abe571e0276fafcc6eed27c27abb28943e67c6f

commit r15-8057-g5abe571e0276fafcc6eed27c27abb28943e67c6f
Author: Tomasz Kamiński 
Date:   Fri Mar 7 11:54:38 2025 +0100

libstdc++: Fix views::zip_transform constraints for empty range pack 
[PR38]

Add missing move_constructible && regular_invocable constrains on functor 
type,
and is_object on functor result type for invocations of views::zip_transform
without range arguments.

PR libstdc++/38

libstdc++-v3/ChangeLog:

* include/std/ranges (_ZipTransform::operator()):
Create separate overload for calls with empty range pack,
and add move_constructible, regular_invocable and
is_object_v>> constraints.
* testsuite/std/ranges/zip_transform/1.cc: New tests

Reviewed-by: Patrick Palka 
Jonathan Wakely 
Signed-off-by: Tomasz Kamiński 

Diff:
---
 libstdc++-v3/include/std/ranges | 16 +++-
 .../testsuite/std/ranges/zip_transform/1.cc | 21 +
 2 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/libstdc++-v3/include/std/ranges b/libstdc++-v3/include/std/ranges
index ef277b81bd3c..34c6f113e216 100644
--- a/libstdc++-v3/include/std/ranges
+++ b/libstdc++-v3/include/std/ranges
@@ -5333,15 +5333,21 @@ namespace views::__adaptor
 
 struct _ZipTransform
 {
+  template
+   requires move_constructible> && 
regular_invocable&>
+ && is_object_v&>>>
+   constexpr auto
+   operator() [[nodiscard]] (_Fp&& __f) const
+   {
+ return views::empty&>>>;
+   }
+
   template
-   requires (sizeof...(_Ts) == 0) || 
__detail::__can_zip_transform_view<_Fp, _Ts...>
+   requires (sizeof...(_Ts) != 0) && 
__detail::__can_zip_transform_view<_Fp, _Ts...>
constexpr auto
operator() [[nodiscard]] (_Fp&& __f, _Ts&&... __ts) const
{
- if constexpr (sizeof...(_Ts) == 0)
-   return views::empty&>>>;
- else
-   return zip_transform_view(std::forward<_Fp>(__f), 
std::forward<_Ts>(__ts)...);
+  return zip_transform_view(std::forward<_Fp>(__f), 
std::forward<_Ts>(__ts)...);
}
 };
 
diff --git a/libstdc++-v3/testsuite/std/ranges/zip_transform/1.cc 
b/libstdc++-v3/testsuite/std/ranges/zip_transform/1.cc
index 20abdcba0f85..9a0ad3814e66 100644
--- a/libstdc++-v3/testsuite/std/ranges/zip_transform/1.cc
+++ b/libstdc++-v3/testsuite/std/ranges/zip_transform/1.cc
@@ -9,6 +9,23 @@
 namespace ranges = std::ranges;
 namespace views = std::views;
 
+template
+concept can_zip_transform = requires (T t) {
+  views::zip_transform(std::forward(t));
+};
+
+static_assert(!can_zip_transform);
+
+struct NonMovable {
+  NonMovable(NonMovable&&) = delete;
+};
+
+static_assert(!can_zip_transform);
+static_assert(!can_zip_transform);
+
+static_assert(!can_zip_transform);
+static_assert(can_zip_transform);
+
 constexpr bool
 test01()
 {
@@ -46,6 +63,10 @@ test01()
   VERIFY( ranges::size(z3) == 3 );
   VERIFY( ranges::equal(z3, (int[]){3, 6, 9}) );
 
+  auto z4 = views::zip_transform([] () { return 1; });
+  VERIFY( ranges::size(z4) == 0 );
+  static_assert( std::same_as, int> );
+
   return true;
 }

[gcc(refs/users/omachota/heads/rtl-ssa-dce)] rtl-ssa-dce: phis are marked correctly

[Ondrej Machota via Gcc-cvs]

https://gcc.gnu.org/g:5d97053d63fb4f6380a56eaaf3a3488be5ef0454

commit 5d97053d63fb4f6380a56eaaf3a3488be5ef0454
Author: Ondřej Machota 
Date:   Fri Mar 14 14:04:39 2025 +0100

rtl-ssa-dce: phis are marked correctly

Diff:
---
 gcc/dce.cc | 112 ++---
 1 file changed, 25 insertions(+), 87 deletions(-)

diff --git a/gcc/dce.cc b/gcc/dce.cc
index 959677663855..c8c8be2293a1 100644
--- a/gcc/dce.cc
+++ b/gcc/dce.cc
@@ -1470,7 +1470,7 @@ bool is_rtx_insn_prelive(rtx_insn *insn) {
 return true;
 
   rtx body = PATTERN(insn);
-  if (GET_CODE(body) == CLOBBER) // 
~/Documents/gcc/gcc/testsuite/gcc.c-torture/compile/2605-1.c
+  if (GET_CODE(body) == CLOBBER) // 
gcc/gcc/testsuite/gcc.c-torture/compile/2605-1.c
 return true;
 
   if (side_effects_with_mem(body) || can_throw_internal(body))
@@ -1585,12 +1585,18 @@ rtl_ssa_dce_prelive(std::unordered_set 
&marked)
 static std::unordered_set
 rtl_ssa_dce_mark()
 {
+  std::unordered_set marked_sets{};
+
+
   std::unordered_set marked{};
+  // phi insn might have more that one phi node: 
gcc/gcc/testsuite/gcc.c-torture/execute/2224-1.c
+  std::unordered_set marked_phi_nodes{};
+  // Phi will not be prelive
   auto worklist = rtl_ssa_dce_prelive(marked);
   auto_vec worklist_new{};
   for (auto && item : worklist) {
 insn_info * insn = item;
-std::cerr << "cp Current: " << insn->uid() << '\n';
+// std::cerr << "cp Current: " << insn->uid() << '\n';
 for (auto&& use : insn->uses()) {
   set_info* set = use->def();
   if (set) {
@@ -1610,20 +1616,26 @@ rtl_ssa_dce_mark()
  * TODO : a phi insn might be visited more times due to having more phi 
nodes
  * Either we have to mark phi nodes or do not mark phi insn
 */
-std::cerr << "Current: " << insn->uid() << '\n';
+// std::cerr << "Current: " << insn->uid() << '\n';
 // if (insn->uid() == -21) {
   // std::cerr << "Insn -21 phi? " << insn->is_phi() << '\n';
 // }
 
-if ((marked.count(insn) > 0)) {
+if ((marked.count(insn) > 0) && !insn->is_phi()) {
   continue;
 }
 
+// std::cout << insn->uid() << " not skipped\n";
+
 marked.emplace(insn);
 
 use_array uses = insn->uses();
 if (insn->is_phi()) {
   phi_info* pi = as_a (set);
+  if (marked_phi_nodes.count(pi) > 0) {
+continue;
+  }
+  marked_phi_nodes.emplace(pi);
   uses = pi->inputs();
 }
 
@@ -1641,80 +1653,6 @@ rtl_ssa_dce_mark()
 }
   }
 
-  // if (dump_file)
-  //   fprintf(dump_file, "Finished inherently live, marking parents\n");
-  // while (!worklist.is_empty())
-  // {
-  //   insn_info *insn = worklist.pop();
-  //   use_array uses = insn->uses();
-  //   if (insn->is_phi()) {
-  // std::cerr << "Phi : "<< insn->uid() << " - uses: " << 
insn->num_uses() << ", defs:" << insn->num_defs() << '\n';
-  // for (auto&& use : uses) {
-  //   debug(use);
-  //   std::cerr << '\n';
-  // }
-  //   } else if (insn->is_artificial()) {
-  // std::cerr << "Artificial " << insn->uid() << " - uses: " << 
insn->num_uses() << ", defs:" << insn->num_defs() << '\n';
-  // for (auto&& use : uses) {
-  //   debug(use);
-  //   std::cerr << '\n';
-  // }
-  //   }
-
-  //   if (dump_file)
-  // fprintf(dump_file, "Looking at: %d, uses: %d\n", insn->uid(), 
uses.size());
-
-  //   //std::cerr << "Insn: " << insn->uid() << ", uses: " << uses.size() << 
'\n';
-  // std::cerr << "Current: " << insn->uid() << '\n';
-  //   for (size_t i = 0; i < uses.size(); i++)
-  //   {
-  // // debug(uses[i]);
-  // use_info* use = uses[i];
-  // // debug(use->def());
-  // // if (use->def() != nullptr) {
-  // //   std::cerr << use->def()->insn()->uid() << '\n';
-  // // }
-  // // std::cerr << '\n';
-  // // debug(use);
-  // // std::cerr << '\n';
-  
-  // set_info* set = use->def();
-  // if (!set) {
-  //   continue;
-  // }
-  // insn_info *parent_insn = set->insn();
-  // if (!parent_insn) {
-  //   continue;
-  // }
-  // // if (parent_insn->is_phi()) { // this is weird...
-  // //   // debug(use->def());
-  // //   phi_info * pi = as_a (use->def());
-  // //   // std::cerr << "phi inputs: " << pi->num_inputs() << '\n';
-  // //   for (auto&& input: pi->inputs()) {
-  // // use_info* phi_use = input;
-  // // std::cerr << "Via phi insn: " << phi_use->def()->insn()->uid() 
<< '\n';
-  // //   }
-  // // }
-  // int parent_insn_uid = parent_insn->uid();
-  // // propage that some instruction in chain is live from bottom to top
-  // if (dump_file)
-  //   fprintf(dump_file, "Trying to add: %d\n", parent_insn_uid);
-  // // not yet marked
-  // if (!(marked.count(parent_insn) > 0))
-  // {
-  //   //std::cerr << "Adding: " << parent_insn_uid << " to worklist";
-  //   if (dump_file)
-  // fprintf(du

[gcc r15-8054] Revert "GCN, nvptx: Basic '__cxa_guard_{acquire, abort, release}' for C++ static local variables suppo

[Thomas Schwinge via Gcc-cvs]

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

commit r15-8054-gfad9d58e057e5f976cacdca90e2519ed5f0990ad
Author: Thomas Schwinge 
Date:   Sat Dec 23 11:01:08 2023 +0100

Revert "GCN, nvptx: Basic '__cxa_guard_{acquire,abort,release}' for C++ 
static local variables support"

GCN, nvptx now has libstdc++-v3/libsupc++ proper.

This reverts commit c0bf7ea189ecf252152fe15134f70f576bcd20b2.

Diff:
---
 libgcc/c++-minimal/README   |  2 -
 libgcc/c++-minimal/guard.c  | 97 -
 libgcc/config/gcn/t-amdgcn  |  3 --
 libgcc/config/nvptx/t-nvptx |  3 --
 4 files changed, 105 deletions(-)

diff --git a/libgcc/c++-minimal/README b/libgcc/c++-minimal/README
deleted file mode 100644
index 832f1265f7e1..
--- a/libgcc/c++-minimal/README
+++ /dev/null
@@ -1,2 +0,0 @@
-Minimal hacked-up version of some C++ support for offload devices, until we
-have libstdc++-v3/libsupc++ proper.
diff --git a/libgcc/c++-minimal/guard.c b/libgcc/c++-minimal/guard.c
deleted file mode 100644
index 98ac288c7944..
--- a/libgcc/c++-minimal/guard.c
+++ /dev/null
@@ -1,97 +0,0 @@
-/* 'libstdc++-v3/libsupc++/guard.cc' for offload devices, until we have
-   libstdc++-v3/libsupc++ proper.
-
-   Copyright (C) 2002-2025 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify it under
-the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 3, or (at your option) any later
-version.
-
-GCC is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
-for more details.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
-.  */
-
-#if defined __AMDGCN__
-#elif defined __nvptx__
-#else
-# error not ported
-#endif
-
-#include "../../libstdc++-v3/config/cpu/generic/cxxabi_tweaks.h"
-
-/* Copy'n'paste/edit from 'libstdc++-v3/libsupc++/cxxabi.h'.  */
-
-int
-__cxa_guard_acquire(__guard*);
-
-void
-__cxa_guard_release(__guard*);
-
-void
-__cxa_guard_abort(__guard*);
-
-/* Copy'n'paste/edit from 'libstdc++-v3/libsupc++/guard.cc'.  */
-
-#undef _GLIBCXX_GUARD_TEST_AND_ACQUIRE
-#undef _GLIBCXX_GUARD_SET_AND_RELEASE
-#define _GLIBCXX_GUARD_SET_AND_RELEASE(G) _GLIBCXX_GUARD_SET (G)
-
-static inline int
-init_in_progress_flag(__guard* g)
-{ return ((char *)g)[1]; }
-
-static inline void
-set_init_in_progress_flag(__guard* g, int v)
-{ ((char *)g)[1] = v; }
-
-static inline void
-throw_recursive_init_exception(void)
-{
-  // Use __builtin_trap so we don't require abort().
-  __builtin_trap();
-}
-
-// acquire() is a helper function used to acquire guard if thread support is
-// not compiled in or is compiled in but not enabled at run-time.
-static int
-acquire(__guard *g)
-{
-  // Quit if the object is already initialized.
-  if (_GLIBCXX_GUARD_TEST(g))
-return 0;
-
-  if (init_in_progress_flag(g))
-throw_recursive_init_exception();
-
-  set_init_in_progress_flag(g, 1);
-  return 1;
-}
-
-int __cxa_guard_acquire (__guard *g)
-{
-  return acquire (g);
-}
-
-void __cxa_guard_abort (__guard *g)
-{
-  set_init_in_progress_flag(g, 0);
-}
-
-void __cxa_guard_release (__guard *g)
-{
-  set_init_in_progress_flag(g, 0);
-  _GLIBCXX_GUARD_SET_AND_RELEASE (g);
-}
diff --git a/libgcc/config/gcn/t-amdgcn b/libgcc/config/gcn/t-amdgcn
index b00adc72bad7..d1d9a4f92b52 100644
--- a/libgcc/config/gcn/t-amdgcn
+++ b/libgcc/config/gcn/t-amdgcn
@@ -8,9 +8,6 @@ LIB2ADD += $(srcdir)/config/gcn/atomic.c \
   $(srcdir)/config/gcn/lib2-bswapti2.c \
   $(srcdir)/config/gcn/unwind-gcn.c
 
-# Until we have libstdc++-v3/libsupc++ proper.
-LIB2ADD += $(srcdir)/c++-minimal/guard.c
-
 LIB2ADDEH=
 LIB2FUNCS_EXCLUDE=__main
 
diff --git a/libgcc/config/nvptx/t-nvptx b/libgcc/config/nvptx/t-nvptx
index 1ff574c2982a..f295898d69fc 100644
--- a/libgcc/config/nvptx/t-nvptx
+++ b/libgcc/config/nvptx/t-nvptx
@@ -3,9 +3,6 @@ LIB2ADD=$(srcdir)/config/nvptx/reduction.c \
$(srcdir)/config/nvptx/atomic.c \
$(srcdir)/config/nvptx/unwind-nvptx.c
 
-# Until we have libstdc++-v3/libsupc++ proper.
-LIB2ADD += $(srcdir)/c++-minimal/guard.c
-
 LIB2ADDEH=
 LIB2FUNCS_EXCLUDE=

[gcc r15-8052] GCN, nvptx: Allow for "hosted" libstdc++ build

[Thomas Schwinge via Gcc-cvs]

https://gcc.gnu.org/g:1268924a2eed4e4f4cf1f43cc996b2f0eedeb07e

commit r15-8052-g1268924a2eed4e4f4cf1f43cc996b2f0eedeb07e
Author: Thomas Schwinge 
Date:   Thu Feb 20 16:31:50 2025 +0100

GCN, nvptx: Allow for "hosted" libstdc++ build

We need '-fno-exceptions', '-fno-rtti', disable generation of PCH files, and
for nvptx twiddle some more knobs.

PR target/92713
PR target/101544
libstdc++-v3/
* config/cpu/nvptx/cpu_defines.h: New.
* config/cpu/nvptx/t-nvptx: Likewise.
* configure.host: Handle GCN, nvptx.

Diff:
---
 libstdc++-v3/config/cpu/nvptx/cpu_defines.h | 36 
 libstdc++-v3/config/cpu/nvptx/t-nvptx   |  7 ++
 libstdc++-v3/configure.host | 37 +
 3 files changed, 80 insertions(+)

diff --git a/libstdc++-v3/config/cpu/nvptx/cpu_defines.h 
b/libstdc++-v3/config/cpu/nvptx/cpu_defines.h
new file mode 100644
index ..65744e08527e
--- /dev/null
+++ b/libstdc++-v3/config/cpu/nvptx/cpu_defines.h
@@ -0,0 +1,36 @@
+// Specific definitions for nvptx platforms  -*- C++ -*-
+
+// Copyright (C) 2025 Free Software Foundation, Inc.
+//
+// This file is part of the GNU ISO C++ Library.  This library is free
+// software; you can redistribute it and/or modify it under the
+// terms of the GNU General Public License as published by the
+// Free Software Foundation; either version 3, or (at your option)
+// any later version.
+
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+// GNU General Public License for more details.
+
+// Under Section 7 of GPL version 3, you are granted additional
+// permissions described in the GCC Runtime Library Exception, version
+// 3.1, as published by the Free Software Foundation.
+
+// You should have received a copy of the GNU General Public License and
+// a copy of the GCC Runtime Library Exception along with this program;
+// see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+// .
+
+/** @file bits/cpu_defines.h
+ *  This is an internal header file, included by other library headers.
+ *  Do not attempt to use it directly. @headername{iosfwd}
+ */
+
+#ifndef _GLIBCXX_CPU_DEFINES
+#define _GLIBCXX_CPU_DEFINES 1
+
+// No support for referencing weak symbols without a definition.
+#define _GLIBCXX_USE_WEAK_REF 0
+
+#endif
diff --git a/libstdc++-v3/config/cpu/nvptx/t-nvptx 
b/libstdc++-v3/config/cpu/nvptx/t-nvptx
new file mode 100644
index ..a2f0f2dcb609
--- /dev/null
+++ b/libstdc++-v3/config/cpu/nvptx/t-nvptx
@@ -0,0 +1,7 @@
+# Per-file flags, see '../../../configure.host', "inject per-file flags".
+
+# 'ptxas'/CUDA Driver rejects objects with a lot of global constant data:
+# ptxas error   : File uses too much global constant data ([...])
+# Cut short the assembly-time check; defer to actual use of the object file.
+AM_MAKEFLAGS += CXXFLAGS-src/c++17/floating_to_chars.lo=-Wa,--no-verify
+AM_MAKEFLAGS += CXXFLAGS-src/c++20/tzdb.lo=-Wa,--no-verify
diff --git a/libstdc++-v3/configure.host b/libstdc++-v3/configure.host
index 933a43f241c3..cb4c28a62bf3 100644
--- a/libstdc++-v3/configure.host
+++ b/libstdc++-v3/configure.host
@@ -150,6 +150,9 @@ case "${host_cpu}" in
   arm*)
 cpu_defines_dir=cpu/arm
 ;;
+  nvptx)
+cpu_defines_dir=cpu/nvptx
+;;
   powerpc* | rs6000)
 cpu_defines_dir=cpu/powerpc
 ;;
@@ -367,6 +370,16 @@ case "${host}" in
   arm*-*-freebsd*)
  
port_specific_symbol_files="\$(srcdir)/../config/os/gnu-linux/arm-eabi-extra.ver"
  ;;
+  nvptx-*-none)
+# For 'make all-target-libstdc++-v3', we need to inject per-file flags:
+OPTIMIZE_CXXFLAGS="${OPTIMIZE_CXXFLAGS} \$(CXXFLAGS-\$(subdir)/\$@)"
+# ..., see:
+tmake_file="$tmake_file cpu/nvptx/t-nvptx"
+
+# For 'make all-target-libstdc++-v3', re 'alloca'/VLA usage:
+EXTRA_CFLAGS="${EXTRA_CFLAGS} -mfake-ptx-alloca"
+OPTIMIZE_CXXFLAGS="${OPTIMIZE_CXXFLAGS} -mfake-ptx-alloca"
+;;
   powerpc*-*-darwin*)
 
port_specific_symbol_files="\$(srcdir)/../config/os/bsd/darwin/ppc-extra.ver"
 ;;
@@ -383,3 +396,27 @@ case "${host}" in
 abi_baseline_subdir_switch=--print-multi-os-directory
 ;;
 esac
+
+
+# Dumb down libstdc++ for certain configurations.
+# THIS TABLE IS SORTED.  KEEP IT THAT WAY.
+case "${host}" in
+  amdgcn-*-amdhsa \
+  | nvptx-*-none )
+# For 'make all-target-libstdc++-v3' and 'make check-target-libstdc++-v3',
+# exception handling is not supported: in case that exception handling
+# constructs survive compiler optimizations, the back ends error out:
+# sorry, unimplemented: exception handling not supported
+EXTRA_CXX_FLAGS="${EXTRA_CXX_FLAGS} -fno-exceptions"
+
+# For 'make all-target-libstdc++-v3' and 'make check-target-libstdc++-v

[gcc r15-8061] ipa: Do not modify cgraph edges from thunk clones during inlining (PR116572)

[Martin Jambor via Gcc-cvs]

https://gcc.gnu.org/g:075ec330307c5b1fe5ed166a633c718c06b01437

commit r15-8061-g075ec330307c5b1fe5ed166a633c718c06b01437
Author: Martin Jambor 
Date:   Fri Mar 14 16:07:01 2025 +0100

ipa: Do not modify cgraph edges from thunk clones during inlining (PR116572)

In PR 116572 we hit an assert that a thunk which does not have a body
looks like it has one.  It does not, but the call_stmt of its outgoing
edge points to a statement, which should not.  In fact it has several
outgoing call graph edges, which cannot be.  The problem is that the
code updating the edges to reflect inlining into the master clone (an
ex-thunk, unlike the clone, which is still an unexpanded thunk) is
being updated during inling into the master clone.  This patch simply
makes the code to skip unexpanded thunk clones.

gcc/ChangeLog:

2025-03-13  Martin Jambor  

PR ipa/116572
* cgraph.cc (cgraph_update_edges_for_call_stmt): Do not update
edges of clones that are unexpanded thunk.  Assert that the node
passed as the parameter is not an unexpanded thunk.

gcc/testsuite/ChangeLog:

2025-03-13  Martin Jambor  

PR ipa/116572
* g++.dg/ipa/pr116572.C: New test.

Diff:
---
 gcc/cgraph.cc   |  7 +--
 gcc/testsuite/g++.dg/ipa/pr116572.C | 37 +
 2 files changed, 42 insertions(+), 2 deletions(-)

diff --git a/gcc/cgraph.cc b/gcc/cgraph.cc
index d0b19ad850e0..6ae6a97f6f56 100644
--- a/gcc/cgraph.cc
+++ b/gcc/cgraph.cc
@@ -1708,12 +1708,15 @@ cgraph_update_edges_for_call_stmt (gimple *old_stmt, 
tree old_decl,
   cgraph_node *node;
 
   gcc_checking_assert (orig);
+  gcc_assert (!orig->thunk);
   cgraph_update_edges_for_call_stmt_node (orig, old_stmt, old_decl, new_stmt);
   if (orig->clones)
 for (node = orig->clones; node != orig;)
   {
-   cgraph_update_edges_for_call_stmt_node (node, old_stmt, old_decl,
-   new_stmt);
+   /* Do not attempt to adjust bodies of yet unexpanded thunks.  */
+   if (!node->thunk)
+ cgraph_update_edges_for_call_stmt_node (node, old_stmt, old_decl,
+ new_stmt);
if (node->clones)
  node = node->clones;
else if (node->next_sibling_clone)
diff --git a/gcc/testsuite/g++.dg/ipa/pr116572.C 
b/gcc/testsuite/g++.dg/ipa/pr116572.C
new file mode 100644
index ..909568e1c72c
--- /dev/null
+++ b/gcc/testsuite/g++.dg/ipa/pr116572.C
@@ -0,0 +1,37 @@
+/* { dg-do compile } */
+/* { dg-options "-std=c++20 -O3 -fsanitize=undefined" } */
+
+long v;
+template  struct A;
+template , typename = C>
+class B;
+template <>
+struct A
+{
+  static int foo(char *s, const char *t, long n) { return __builtin_memcmp(s, 
t, n); }
+};
+template 
+struct B {
+  long b;
+  B(const C *);
+  C *bar() const;
+  constexpr unsigned long baz(const C *, unsigned long, unsigned long) const 
noexcept;
+  void baz() { C c; baz(&c, 0, v); }
+};
+template 
+constexpr unsigned long
+B::baz(const C *s, unsigned long, unsigned long n) const noexcept
+{
+  C *x = bar(); if (!x) return b; D::foo(x, s, n); return 0;
+}
+namespace {
+struct F { virtual ~F() {} };
+struct F2 { virtual void foo(B) const; };
+struct F3 : F, F2 { void foo(B s) const { s.baz(); } } f;
+}
+int
+main()
+{
+  F *p;
+  dynamic_cast(p)->foo("");
+}

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Suppression xfail typebound_call_22.f03

[Mikael Morin via Gcc-cvs]

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

commit 6d201cc4a0c083f891275312700b51d6221b2dd9
Author: Mikael Morin 
Date:   Fri Mar 14 12:20:44 2025 +0100

Suppression xfail typebound_call_22.f03

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

diff --git a/gcc/testsuite/gfortran.dg/typebound_call_22.f03 
b/gcc/testsuite/gfortran.dg/typebound_call_22.f03
index 30f86937fe2f..b9f0b7125732 100644
--- a/gcc/testsuite/gfortran.dg/typebound_call_22.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_call_22.f03
@@ -26,4 +26,4 @@ program test
   call x%bar ()
 end program
 
-! { dg-final { scan-tree-dump-times "base \\(\\);" 1 "optimized" { xfail *-*-* 
} } }
+! { dg-final { scan-tree-dump-times "base \\(\\);" 1 "optimized" } }

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction reste régression class_defined_operator_2.f03

[Mikael Morin via Gcc-cvs]

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

commit 7b771742050db945ad8ff753bbcb4ba6d1063044
Author: Mikael Morin 
Date:   Tue Mar 11 13:39:58 2025 +0100

Correction reste régression class_defined_operator_2.f03

Diff:
---
 gcc/fortran/trans-types.cc | 21 +
 1 file changed, 9 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 69c147bf5720..9c765feca482 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2853,24 +2853,21 @@ get_class_canonical_type (gfc_symbol *derived, int 
rank, int corank)
   symbol_attribute attr;
   memset (&attr, 0, sizeof (attr));
   attr.dummy = 1;
-  attr.dimension = derived->attr.dimension;
-  attr.codimension = derived->attr.codimension;
+  attr.dimension = rank != 0;
+  attr.codimension = corank != 0;
 
-  gfc_array_spec as;
-  gfc_array_spec *pas;
+  gfc_array_spec *as;
   if (rank != 0 || corank != 0)
 {
-  memset (&as, 0, sizeof (as));
-  as.type = AS_DEFERRED;
-  as.rank = rank;
-  as.corank = corank;
-
-  pas = &as;
+  as = gfc_get_array_spec ();
+  as->type = AS_DEFERRED;
+  as->rank = rank;
+  as->corank = corank;
 }
   else
-pas = nullptr;
+as = nullptr;
 
-  gfc_build_class_symbol (&ts, &attr, &pas);
+  gfc_build_class_symbol (&ts, &attr, &as);
 
   gfc_find_symbol (class_name, ns, 0, &canonical_class);
   if (canonical_class)

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:83b3443c8351c48327dc24ad5285af5f7c0018b6

commit 83b3443c8351c48327dc24ad5285af5f7c0018b6
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 8d20abbe0304..2d0338c0dc5c 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 r15-8048] libstdc++: fix compile error when converting std::weak_ptr

[Giuseppe D'Angelo via Gcc-cvs]

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

commit r15-8048-gdf0e6509bf74421ea68a2e025300bcd6ca63722f
Author: Giuseppe D'Angelo 
Date:   Tue Dec 10 00:56:13 2024 +0100

libstdc++: fix compile error when converting std::weak_ptr

A std::weak_ptr can be converted to a compatible
std::weak_ptr. This is implemented by having suitable converting
constructors to std::weak_ptr which dispatch to the __weak_ptr base
class (implementation detail).

In __weak_ptr, lock() is supposed to return a __shared_ptr,
not a __shared_ptr (that is, __shared_ptr).

Unfortunately the return type of lock() and the type of the returned
__shared_ptr were mismatching and that was causing a compile error: when
converting a __weak_ptr to a __weak_ptr through __weak_ptr's
converting constructor, the code calls lock(), and that simply fails to
build.

Fix it by removing the usage of element_type inside lock(), and using
_Tp instead.

Note that std::weak_ptr::lock() itself was already correct; the one in
__weak_ptr was faulty (and that is the one called by __weak_ptr's
converting constructors).

libstdc++-v3/ChangeLog:

* include/bits/shared_ptr_base.h (lock): Fixed a compile error
when calling lock() on a weak_ptr, by removing an
erroneous usage of element_type from within lock().
* 
testsuite/20_util/shared_ptr/requirements/explicit_instantiation/1.cc:
Add more tests for array types.
* 
testsuite/20_util/weak_ptr/requirements/explicit_instantiation/1.cc:
Likewise.
* testsuite/20_util/shared_ptr/requirements/1.cc: New test.
* testsuite/20_util/weak_ptr/requirements/1.cc: New test.

Diff:
---
 libstdc++-v3/include/bits/shared_ptr_base.h|  2 +-
 .../testsuite/20_util/shared_ptr/requirements/1.cc | 33 ++
 .../requirements/explicit_instantiation/1.cc   | 12 
 .../testsuite/20_util/weak_ptr/requirements/1.cc   | 33 ++
 .../requirements/explicit_instantiation/1.cc   | 12 
 5 files changed, 91 insertions(+), 1 deletion(-)

diff --git a/libstdc++-v3/include/bits/shared_ptr_base.h 
b/libstdc++-v3/include/bits/shared_ptr_base.h
index 053857b4c29f..3622e0291178 100644
--- a/libstdc++-v3/include/bits/shared_ptr_base.h
+++ b/libstdc++-v3/include/bits/shared_ptr_base.h
@@ -2075,7 +2075,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION
 
   __shared_ptr<_Tp, _Lp>
   lock() const noexcept
-  { return __shared_ptr(*this, std::nothrow); }
+  { return __shared_ptr<_Tp, _Lp>(*this, std::nothrow); }
 
   long
   use_count() const noexcept
diff --git a/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/1.cc 
b/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/1.cc
new file mode 100644
index ..8ddb5d220ac7
--- /dev/null
+++ b/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/1.cc
@@ -0,0 +1,33 @@
+// { dg-do compile { target c++11 } }
+// { dg-require-effective-target hosted }
+
+#include 
+#include 
+
+using namespace __gnu_test;
+
+void
+test01()
+{
+  std::shared_ptr ptr;
+  std::shared_ptr ptr2 = ptr;
+
+#if __cpp_lib_shared_ptr_arrays >= 201611L
+  std::shared_ptr ptr_array;
+  std::shared_ptr ptr_array2 = ptr_array;
+  std::shared_ptr ptr_array3 = ptr_array;
+#endif
+}
+
+void
+test02()
+{
+  std::shared_ptr ptr;
+  std::shared_ptr ptr2 = ptr;
+
+#if __cpp_lib_shared_ptr_arrays >= 201611L
+  std::shared_ptr ptr_array;
+  std::shared_ptr ptr_array2 = ptr_array;
+  std::shared_ptr ptr_array3 = ptr_array;
+#endif
+}
diff --git 
a/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/explicit_instantiation/1.cc
 
b/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/explicit_instantiation/1.cc
index 6418e0c4bc7c..3bd05c36f8fc 100644
--- 
a/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/explicit_instantiation/1.cc
+++ 
b/libstdc++-v3/testsuite/20_util/shared_ptr/requirements/explicit_instantiation/1.cc
@@ -28,3 +28,15 @@ template class std::shared_ptr;
 template class std::shared_ptr;
 template class std::shared_ptr;
 template class std::shared_ptr;
+
+#if __cpp_lib_shared_ptr_arrays >= 201611L
+template class std::shared_ptr;
+template class std::shared_ptr;
+template class std::shared_ptr;
+template class std::shared_ptr;
+
+template class std::shared_ptr;
+template class std::shared_ptr;
+template class std::shared_ptr;
+template class std::shared_ptr;
+#endif
diff --git a/libstdc++-v3/testsuite/20_util/weak_ptr/requirements/1.cc 
b/libstdc++-v3/testsuite/20_util/weak_ptr/requirements/1.cc
new file mode 100644
index ..04ea837d85a7
--- /dev/null
+++ b/libstdc++-v3/testsuite/20_util/weak_ptr/requirements/1.cc
@@ -0,0 +1,33 @@
+// { dg-do compile { target c++11 } }
+// { dg-require-effective-target hosted }
+
+#include 
+#include 
+
+using namespace __gnu_test;
+
+void
+test01()
+{
+  std::weak_ptr ptr;
+

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

[Mikael Morin via Gcc-cvs]

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

commit 0a069e0a92dd9591fe919e14e4bec361ac96346c
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 2ec19e44a465..00b749196446 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_v03)] Correction régression assumed_rank_20.f90

[Mikael Morin via Gcc-cvs]

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

commit a181d00d8a0e0347bfba8dff5831a682e03ed431
Author: Mikael Morin 
Date:   Fri Mar 14 18:40:40 2025 +0100

Correction régression assumed_rank_20.f90

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 b8fc0c4bea3e..98dee213ca1a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1132,7 +1132,7 @@ private:
 
 public:
   default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
-  virtual bool initialize_data () const { return !attr.pointer; }
+  virtual bool initialize_data () const { return !attr.pointer || 
(gfc_option.rtcheck & GFC_RTCHECK_POINTER); }
   virtual tree get_data_value () const {
 if (!initialize_data ())
   return NULL_TREE;
@@ -14469,7 +14469,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, 
gfc_wrapped_block * block)
  pointers when -fcheck=pointer is specified.  */
   if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
   && (sym->attr.allocatable
- || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER
+ || sym->attr.pointer))
 {
   /* Declare the variable static so its array descriptor stays present
 after leaving the scope.  It may still be accessed through another

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:1340fd7a9b2a244989f74d90f1a31a9fcae63e1d

commit 1340fd7a9b2a244989f74d90f1a31a9fcae63e1d
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 f211ad187613..913f04019a1e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10802,7 +10802,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
@@ -10810,6 +10809,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);
@@ -10842,11 +10842,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;
@@ -10854,12 +10864,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_v03)] Renommage gfc_array_init_count -> gfc_descr_init_count

[Mikael Morin via Gcc-cvs]

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

commit 7f36a555917ff9d82c3bb9edabe971096c75d554
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 3ac5a36a73e6..2ea1d47bb3d8 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 r15-8062] cobol: Don't run cobol tests with -m32 or -mx32 [PR119290]

[Jakub Jelinek via Gcc-cvs]

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

commit r15-8062-gb2de4b0926bddbb97b991dd95592c714ee519e1e
Author: Jakub Jelinek 
Date:   Fri Mar 14 20:32:43 2025 +0100

cobol: Don't run cobol tests with -m32 or -mx32 [PR119290]

The following patch adds cobol effective target and uses it to guard main
loop in cobol.dg/dg.exp, so that we don't run the tests on unsupported
multilibs.

Tested on x86_64-linux with
make check-cobol RUNTESTFLAGS='--target_board=unix\{-m32,-m64\} dg.exp'
which previously had all FAILs in the -m32 case and now doesn't report
any PASSes/FAILs/XFAILs/XPASSes etc, while for -m64 the testsuite is run
normally.

2025-03-14  Jakub Jelinek  

PR cobol/119290
* lib/target-supports.exp (check_compile): Use *.cob extension for
"*> COBOL" comment.
* lib/cobol-dg.exp (check_effective_target_cobol): New procedure.
* cobol.dg/dg.exp: Guard main loop with 
[check_effective_target_cobol]
test.

Diff:
---
 gcc/testsuite/cobol.dg/dg.exp |  4 +++-
 gcc/testsuite/lib/cobol-dg.exp| 11 +++
 gcc/testsuite/lib/target-supports.exp |  2 ++
 3 files changed, 16 insertions(+), 1 deletion(-)

diff --git a/gcc/testsuite/cobol.dg/dg.exp b/gcc/testsuite/cobol.dg/dg.exp
index c81634ac8170..e75e3ab18954 100644
--- a/gcc/testsuite/cobol.dg/dg.exp
+++ b/gcc/testsuite/cobol.dg/dg.exp
@@ -34,8 +34,10 @@ set cobol_test_path $srcdir/$subdir
 set all_flags $DEFAULT_COBFLAGS
 
 # Main loop.
-cobol-dg-runtest [lsort \
+if [check_effective_target_cobol] {
+cobol-dg-runtest [lsort \
[glob -nocomplain $srcdir/$subdir/*.cob ] ] "" $all_flags
+}
 
 # All done.
 dg-finish
diff --git a/gcc/testsuite/lib/cobol-dg.exp b/gcc/testsuite/lib/cobol-dg.exp
index 51df13df19f1..1c512d5382ab 100644
--- a/gcc/testsuite/lib/cobol-dg.exp
+++ b/gcc/testsuite/lib/cobol-dg.exp
@@ -83,3 +83,14 @@ proc cobol-dg-runtest { testcases flags default-extra-flags 
} {
torture-finish
 }
 }
+
+proc check_effective_target_cobol {} {
+# Check if the COBOL FE can compile trivial programs.
+return [check_no_compiler_messages cobol assembly {
+*> COBOL
+IDENTIFICATION DIVISION.
+PROGRAM-ID. pass.
+PROCEDURE DIVISION.
+STOP RUN.
+}]
+}
diff --git a/gcc/testsuite/lib/target-supports.exp 
b/gcc/testsuite/lib/target-supports.exp
index c456f7d2c6fa..2a3bdd2579a5 100644
--- a/gcc/testsuite/lib/target-supports.exp
+++ b/gcc/testsuite/lib/target-supports.exp
@@ -38,6 +38,7 @@
 # "// ObjC++" for ObjC++
 # "// Go" for Go
 # "// Rust" for Rust
+# "*> COBOL" for COBOL
 # and "(* Modula-2" for Modula-2
 # If the tool is ObjC/ObjC++ then we overide the extension to .m/.mm to
 # allow for ObjC/ObjC++ specific flags.
@@ -72,6 +73,7 @@ proc check_compile {basename type contents args} {
"*/\\* ObjC*" { set src ${basename}[pid].m }
"*// Go*" { set src ${basename}[pid].go }
"*// Rust*" { set src ${basename}[pid].rs }
+   "*\\*> COBOL*" { set src ${basename}[pid].cob }
"*(\\* Modula-2*" { set src ${basename}[pid].mod }
default {
switch -- $tool {

[gcc r15-8063] libstdc++: Missing 'constexpr' in vector's from_range ctor [PR119282]

[Patrick Palka via Gcc-cvs]

https://gcc.gnu.org/g:2f03a8d7be9775312c50abdc99109aaf8641bda3

commit r15-8063-g2f03a8d7be9775312c50abdc99109aaf8641bda3
Author: Patrick Palka 
Date:   Fri Mar 14 16:10:35 2025 -0400

libstdc++: Missing 'constexpr' in vector's from_range ctor [PR119282]

A missing 'constexpr' in the non-forward (and non-sized) branch of our
recently implemented vector from_range ctor was causing this valid example
to be rejected with a cryptic error.

PR libstdc++/119282

libstdc++-v3/ChangeLog:

* include/bits/stl_vector.h (vector::vector(from_range_t)): Add
missing 'constexpr' to local class _Clear.
* testsuite/std/ranges/conv/1.cc (test_pr119282): New test.

Reviewed-by: Jonathan Wakely 

Diff:
---
 libstdc++-v3/include/bits/stl_vector.h  |  2 +-
 libstdc++-v3/testsuite/std/ranges/conv/1.cc | 13 +
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/libstdc++-v3/include/bits/stl_vector.h 
b/libstdc++-v3/include/bits/stl_vector.h
index 43d3cd1f1714..9c75f64b6ef8 100644
--- a/libstdc++-v3/include/bits/stl_vector.h
+++ b/libstdc++-v3/include/bits/stl_vector.h
@@ -778,7 +778,7 @@ _GLIBCXX_BEGIN_NAMESPACE_CONTAINER
  // but will not destroy elements. This RAII type destroys them.
  struct _Clear
  {
-   ~_Clear() { if (_M_this) _M_this->clear(); }
+   constexpr ~_Clear() { if (_M_this) _M_this->clear(); }
vector* _M_this;
  } __guard{this};
 
diff --git a/libstdc++-v3/testsuite/std/ranges/conv/1.cc 
b/libstdc++-v3/testsuite/std/ranges/conv/1.cc
index 09fd515edf1b..231cb9d9934a 100644
--- a/libstdc++-v3/testsuite/std/ranges/conv/1.cc
+++ b/libstdc++-v3/testsuite/std/ranges/conv/1.cc
@@ -466,6 +466,18 @@ test_composition()
   auto str = adaptor(" ");
 }
 
+constexpr bool
+test_pr119282()
+{
+  // PR libstdc++/119282
+  auto v = std::array{1, 2, 3}
+| std::views::transform([](auto x) { return std::array{x}; })
+| std::views::join
+| std::ranges::to();
+  VERIFY( std::ranges::size(v) == 3 );
+  return true;
+}
+
 int main()
 {
   test_p1206r7_examples();
@@ -480,4 +492,5 @@ int main()
   test_constexpr();
   test_sfinae();
   test_composition();
+  static_assert(test_pr119282());
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction initialisation variable

[Mikael Morin via Gcc-cvs]

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

commit 60cfdc9b4d2158306806b757f0ac518acb5afb06
Author: Mikael Morin 
Date:   Thu Mar 6 19:27:49 2025 +0100

Correction initialisation variable

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

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 6edc4984906d..158cbe010ca7 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -6580,7 +6580,7 @@ exec_context_evaluate_tests ()
   tree v9i = create_var (a9i, "v9i");
   tree p = create_var (ptr_type_node, "p");
 
-  vec decls9;
+  vec decls9 {};
   decls9.safe_push (v9i);
   decls9.safe_push (p);

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

[Mikael Morin via Gcc-cvs]

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

commit c55fbf86b0ab261b66416719f2ff5fa4f4feeec4
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 c8876f1dd03d..c0fdb8a72f67 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_v03)] Implémentation optional pour supprimer dépendance à c++17

[Mikael Morin via Gcc-cvs]

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

commit e0edb330ecc1735e50c504ffb3b290b5c69613ea
Author: Mikael Morin 
Date:   Thu Mar 6 22:07:28 2025 +0100

Implémentation optional pour supprimer dépendance à c++17

Diff:
---
 gcc/cgraphunit.cc | 70 +++
 1 file changed, 60 insertions(+), 10 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 158cbe010ca7..9c5b7f5b882b 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -213,7 +213,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "wide-int.h"
 #include "selftest.h"
 #include "tree-ssanames.h"
-#include 
 
 /* Queue of cgraph nodes scheduled to be added into cgraph.  This is a
secondary queue used during optimization to accommodate passes that
@@ -2475,7 +2474,7 @@ public:
   data_value (tree type)
 : data_value (get_constant_type_size (type))
   {}
-  data_value (const data_value &) = default;
+  data_value (const data_value &);
   data_value & operator= (const data_value &);
   value_type classify () const;
   value_type classify (unsigned offset, unsigned width) const;
@@ -2593,7 +2592,50 @@ public:
 };
 
 
-static std::optional 
+template 
+class optional 
+{
+  union u
+{
+  u (T arg) : value (arg) {}
+  u () : dummy (0) {}
+  u (const u & other, bool present) { if (present) { new (&value) T 
(other.value); } else { new (&dummy) char (0); } }
+  ~u () {} // TODO
+  T value;
+  char dummy;
+}
+  u;
+  bool present;
+
+public:
+  optional () : u (), present (false) {}
+  optional (T arg) : u (arg), present (true) {}
+  optional (const optional & other) : u (other.u, other.present), present 
(other.present) {}
+  ~optional () {}  // TODO
+  optional & operator= (const optional & other) { new (this) optional (other); 
return *this; }
+  T & operator * () const;
+  void emplace (T value);
+};
+
+
+template 
+T &
+optional::operator* () const
+{
+  gcc_assert (present);
+  return const_cast  (u.value);
+}
+
+template 
+void
+optional::emplace (T arg)
+{
+  present = true;
+  u.value = arg;
+}
+
+
+static optional 
 execute (struct function *func, exec_context &caller,
 context_printer & printer, vec * args);
 
@@ -2660,7 +2702,7 @@ public:
   data_storage & get_storage (unsigned idx) const;
   context_printer & get_printer () const { return printer; }
   data_value evaluate (tree expr) const;
-  std::optional  execute_function (struct function *);
+  optional  execute_function (struct function *);
   edge select_leaving_edge (basic_block bb, gimple *last_stmt);
   void jump (edge e);
 };
@@ -3138,10 +3180,18 @@ data_storage::get_ref () const
 }
 
 
+data_value::data_value (const data_value & other)
+  : bit_width (other.bit_width),
+  constant_mask (other.constant_mask),
+  address_mask (other.address_mask),
+  constant_value (other.constant_value),
+  addresses (other.addresses)
+{}
+
+
 data_value & data_value::operator= (const data_value & other)
 {
-  gcc_assert (other.bit_width == bit_width);
-  set (other);
+  new (this) data_value (other);
   return *this;
 }
 
@@ -4209,7 +4259,7 @@ exec_context::execute_call (gcall *g)
 return;
 
   tree lhs = gimple_call_lhs (g);
-  std::optional  result;
+  optional  result;
   if (gimple_call_builtin_p (g, BUILT_IN_MALLOC))
 {
   gcc_assert (lhs != NULL_TREE);
@@ -4225,7 +4275,7 @@ exec_context::execute_call (gcall *g)
   data_storage &storage = allocate (alloc_amount);
 
   storage_address address (storage.get_ref (), 0);
-  result->set_address (address);
+  (*result).set_address (address);
 }
   else
 {
@@ -4376,7 +4426,7 @@ exec_context::jump (edge e)
 }
 
 
-std::optional 
+optional 
 exec_context::execute_function (struct function *func)
 {
   printer.print_function_entry (func);
@@ -4413,7 +4463,7 @@ exec_context::execute_function (struct function *func)
 }
 
 
-static std::optional 
+static optional 
 execute (struct function * func, exec_context & caller,
 context_printer & printer, vec * arg_values)
 {

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:32776c461fbcffa37db09a40b85f95d64e24897a

commit 32776c461fbcffa37db09a40b85f95d64e24897a
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 fd34c64fb16e..b9b79e832dd2 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 r15-8050] tree-optimization/119274 - improve VN optimistic dominance query

[Richard Biener via Gcc-cvs]

https://gcc.gnu.org/g:6470b4d749a0b9896b985858ee6eae095cd8a37a

commit r15-8050-g6470b4d749a0b9896b985858ee6eae095cd8a37a
Author: Richard Biener 
Date:   Fri Mar 14 10:01:20 2025 +0100

tree-optimization/119274 - improve VN optimistic dominance query

The following improves how VN performs its dominance queries to
determine availability, exploiting edges considered unreachable.
The function already contains code to handle the leader block
forking the CFG, but that looks like a situation that won't
help the dominance query ever.  The following adds handling
of the more useful case where this block forwards to a CFG
merge with the forwarder being the only executable entry.

This helps optimizing the code so the spurious array diagnostic
does no longer appear.

PR tree-optimization/119274
* tree-ssa-sccvn.cc (dominated_by_p_w_unex): Handle the
top block being the only executable forwarder to a CFG
merge.

* g++.dg/opt/pr119274.C: New testcase.

Diff:
---
 gcc/testsuite/g++.dg/opt/pr119274.C | 20 
 gcc/tree-ssa-sccvn.cc   | 28 
 2 files changed, 48 insertions(+)

diff --git a/gcc/testsuite/g++.dg/opt/pr119274.C 
b/gcc/testsuite/g++.dg/opt/pr119274.C
new file mode 100644
index ..79b406162db9
--- /dev/null
+++ b/gcc/testsuite/g++.dg/opt/pr119274.C
@@ -0,0 +1,20 @@
+// { dg-do compile { target c++11 } }
+// { dg-options "-O2 -Wall" }
+
+#include 
+#include 
+
+typedef std::vector v1;
+
+static
+void drop_inplace(v1 & c, size_t len)
+{
+  if (len <= c.size())
+c[len-1] = 0;  /* { dg-bogus "outside array bounds" } */
+}
+
+void func()
+{
+  v1 vec1{1,2,3,4,5,6};
+  drop_inplace(vec1, 10);
+}
diff --git a/gcc/tree-ssa-sccvn.cc b/gcc/tree-ssa-sccvn.cc
index 5a8c7c3aa10b..40c38fa020a6 100644
--- a/gcc/tree-ssa-sccvn.cc
+++ b/gcc/tree-ssa-sccvn.cc
@@ -5169,6 +5169,34 @@ dominated_by_p_w_unex (basic_block bb1, basic_block bb2, 
bool allow_back)
}
}
 }
+  /* Iterate to the single successor of bb2 with only a single executable
+ incoming edge.  */
+  else if (EDGE_COUNT (bb2->succs) == 1
+  && EDGE_COUNT (single_succ (bb2)->preds) > 1)
+{
+  edge prede = NULL;
+  FOR_EACH_EDGE (e, ei, single_succ (bb2)->preds)
+   if ((e->flags & EDGE_EXECUTABLE)
+   || (!allow_back && (e->flags & EDGE_DFS_BACK)))
+ {
+   if (prede)
+ {
+   prede = NULL;
+   break;
+ }
+   prede = e;
+ }
+  /* We might actually get to a query with BB2 not visited yet when
+we're querying for a predicated value.  */
+  if (prede && prede->src == bb2)
+   {
+ bb2 = prede->dest;
+
+ /* Re-do the dominance check with changed bb2.  */
+ if (dominated_by_p (CDI_DOMINATORS, bb1, bb2))
+   return true;
+   }
+}
 
   /* We could now iterate updating bb1 / bb2.  */
   return false;

[gcc r15-8051] libstdc++: Include missing algorithm header in priority_queue tests.

[Tomasz Kaminski via Gcc-cvs]

https://gcc.gnu.org/g:62dc2d24f1ee9fd81b85937b0f1b7d51818fb0d4

commit r15-8051-g62dc2d24f1ee9fd81b85937b0f1b7d51818fb0d4
Author: Tomasz Kamiński 
Date:   Fri Mar 14 12:42:17 2025 +0100

libstdc++: Include missing algorithm header in priority_queue tests.

libstdc++-v3/ChangeLog:

* testsuite/23_containers/priority_queue/cons_from_range.cc:
Add `#include .
* testsuite/23_containers/priority_queue/members/push_range.cc:
Add `#include .

Diff:
---
 libstdc++-v3/testsuite/23_containers/priority_queue/cons_from_range.cc   | 1 +
 .../testsuite/23_containers/priority_queue/members/push_range.cc | 1 +
 2 files changed, 2 insertions(+)

diff --git 
a/libstdc++-v3/testsuite/23_containers/priority_queue/cons_from_range.cc 
b/libstdc++-v3/testsuite/23_containers/priority_queue/cons_from_range.cc
index a7ff3e3b0372..977ef981b871 100644
--- a/libstdc++-v3/testsuite/23_containers/priority_queue/cons_from_range.cc
+++ b/libstdc++-v3/testsuite/23_containers/priority_queue/cons_from_range.cc
@@ -1,5 +1,6 @@
 // { dg-do run { target c++23 } }
 
+#include 
 #include 
 #include 
 #include 
diff --git 
a/libstdc++-v3/testsuite/23_containers/priority_queue/members/push_range.cc 
b/libstdc++-v3/testsuite/23_containers/priority_queue/members/push_range.cc
index 7ab7ad199354..2f7765231688 100644
--- a/libstdc++-v3/testsuite/23_containers/priority_queue/members/push_range.cc
+++ b/libstdc++-v3/testsuite/23_containers/priority_queue/members/push_range.cc
@@ -1,5 +1,6 @@
 // { dg-do run { target c++23 } }
 
+#include 
 #include 
 #include 
 #include 

[gcc r15-8047] tree-optimization/119155 - wrong aligned access for vectorized packed access

[Richard Biener via Gcc-cvs]

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

commit r15-8047-gadb14c7625178b501389c2d7d7c2feec37da7a19
Author: Richard Biener 
Date:   Fri Mar 7 12:57:42 2025 +0100

tree-optimization/119155 - wrong aligned access for vectorized packed access

When doing strided SLP vectorization we use the wrong alignment for
the possibly piecewise access of the vector elements for loads and
stores.  While we are carefully using element aligned loads and
stores that isn't enough for the case the original scalar accesses
are packed.  The following instead honors larger alignment when
present but correctly falls back to the original scalar alignment
used.

PR tree-optimization/119155
* tree-vect-stmts.cc (vectorizable_store): Do not always
use vector element alignment for VMAT_STRIDED_SLP but
a more correct alignment towards both ends.
(vectorizable_load): Likewise.

* gcc.dg/vect/pr119155.c: New testcase.

Diff:
---
 gcc/testsuite/gcc.dg/vect/pr119155.c | 26 ++
 gcc/tree-vect-stmts.cc   | 25 +
 2 files changed, 47 insertions(+), 4 deletions(-)

diff --git a/gcc/testsuite/gcc.dg/vect/pr119155.c 
b/gcc/testsuite/gcc.dg/vect/pr119155.c
new file mode 100644
index ..b860cf24b0fa
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/vect/pr119155.c
@@ -0,0 +1,26 @@
+#include 
+#include "tree-vect.h"
+
+struct s { int x; } __attribute__((packed));
+
+void __attribute__((noipa))
+f (char *xc, char *yc, int z)
+{
+  for (int i = 0; i < 100; ++i)
+{
+  struct s *x = (struct s *) xc;
+  struct s *y = (struct s *) yc;
+  x->x += y->x;
+  xc += z;
+  yc += z;
+}
+}
+
+int main ()
+{
+  check_vect ();
+  char *x = malloc (100 * sizeof (struct s) + 1);
+  char *y = malloc (100 * sizeof (struct s) + 1);
+  f (x + 1, y + 1, sizeof (struct s));
+  return 0;
+}
diff --git a/gcc/tree-vect-stmts.cc b/gcc/tree-vect-stmts.cc
index f894787f7bfb..17e3b1db894a 100644
--- a/gcc/tree-vect-stmts.cc
+++ b/gcc/tree-vect-stmts.cc
@@ -8904,7 +8904,15 @@ vectorizable_store (vec_info *vinfo,
}
}
}
- ltype = build_aligned_type (ltype, TYPE_ALIGN (elem_type));
+ unsigned align;
+ if (alignment_support_scheme == dr_aligned)
+   align = known_alignment (DR_TARGET_ALIGNMENT (first_dr_info));
+ else
+   align = dr_alignment (vect_dr_behavior (vinfo, first_dr_info));
+ /* Alignment is at most the access size if we do multiple stores.  */
+ if (nstores > 1)
+   align = MIN (tree_to_uhwi (TYPE_SIZE_UNIT (ltype)), align);
+ ltype = build_aligned_type (ltype, align * BITS_PER_UNIT);
  ncopies = SLP_TREE_NUMBER_OF_VEC_STMTS (slp_node);
}
 
@@ -10851,7 +10859,7 @@ vectorizable_load (vec_info *vinfo,
  &ptype);
  if (vtype != NULL_TREE)
{
- dr_alignment_support dr_align = dr_aligned;
+ dr_alignment_support dr_align;
  int mis_align = 0;
  if (VECTOR_TYPE_P (ptype))
{
@@ -10860,6 +10868,8 @@ vectorizable_load (vec_info *vinfo,
= vect_supportable_dr_alignment (vinfo, dr_info, ptype,
 mis_align);
}
+ else
+   dr_align = dr_unaligned_supported;
  if (dr_align == dr_aligned
  || dr_align == dr_unaligned_supported)
{
@@ -10872,8 +10882,15 @@ vectorizable_load (vec_info *vinfo,
}
}
}
- /* Else fall back to the default element-wise access.  */
- ltype = build_aligned_type (ltype, TYPE_ALIGN (TREE_TYPE (vectype)));
+ unsigned align;
+ if (alignment_support_scheme == dr_aligned)
+   align = known_alignment (DR_TARGET_ALIGNMENT (first_dr_info));
+ else
+   align = dr_alignment (vect_dr_behavior (vinfo, first_dr_info));
+ /* Alignment is at most the access size if we do multiple loads.  */
+ if (nloads > 1)
+   align = MIN (tree_to_uhwi (TYPE_SIZE_UNIT (ltype)), align);
+ ltype = build_aligned_type (ltype, align * BITS_PER_UNIT);
}
 
   if (slp)

[gcc r15-8053] GCN, nvptx: Don't default-disable libstdc++ build

[Thomas Schwinge via Gcc-cvs]

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

commit r15-8053-gc650b557cb01f97bebb894aa68e5e74c2147c395
Author: Thomas Schwinge 
Date:   Mon Jul 11 22:36:39 2022 +0200

GCN, nvptx: Don't default-disable libstdc++ build

In addition to making libstdc++ itself available, this, via enabling
'build-gcc/*/libstdc++-v3/scripts/testsuite_flags', in particular also makes
the standard C++ headers available to 'make check-gcc-c++'.  With that, 
there
are a lot of FAIL/UNRESOLVED -> PASS progressions, where we previously ran
into, for example:

FAIL: g++.dg/coroutines/co-await-syntax-00-needs-expr.C  (test for 
errors, line 6)
FAIL: g++.dg/coroutines/co-await-syntax-00-needs-expr.C (test for 
excess errors)
Excess errors:
[...]/gcc/testsuite/g++.dg/coroutines/coro.h:132:10: fatal error: 
cstdlib: No such file or directory

Similarly, there are a lot of FAIL/UNRESOLVED -> UNSUPPORTED "progressions" 
due
to 'sorry, unimplemented: exception handling not supported'.

The 'make check-target-libstdc++-v3' results don't look too bad, either.

This also reverts Subversion r221362
(Git commit d94fae044da071381b73a2ee8afa874b14fa3820) "No libstdc++ for 
nvptx",
and commit 2f4f3c0e9345805160ecacd6de527b519a8c9206 "No libstdc++ for GCN".

With libstdc++ now available, libgrust gets enabled, which we in turn again
have to disable, for 'sorry, unimplemented: exception handling not 
supported'
reasons.

PR target/92713
PR target/101544
* configure.ac [GCN, nvptx] (noconfigdirs): Don't add
'target-libstdc++-v3'.  Add 'target-libgrust'.
* configure: Regenerate.
gcc/
* config/gcn/gcn.h (LIBSTDCXX): Don't set.
* config/nvptx/nvptx.h (LIBSTDCXX): Likewise.

Diff:
---
 configure| 16 +++-
 configure.ac | 16 +++-
 gcc/config/gcn/gcn.h |  4 
 gcc/config/nvptx/nvptx.h |  4 
 4 files changed, 22 insertions(+), 18 deletions(-)

diff --git a/configure b/configure
index 59a2a29e8799..e1063ccd9c3b 100755
--- a/configure
+++ b/configure
@@ -3431,10 +3431,6 @@ if test "${ENABLE_LIBSTDCXX}" = "default" ; then
   # VxWorks uses the Dinkumware C++ library.
   noconfigdirs="$noconfigdirs target-libstdc++-v3"
   ;;
-amdgcn*-*-*)
-  # Not ported/fails to build when using newlib.
-  noconfigdirs="$noconfigdirs target-libstdc++-v3"
-  ;;
 arm*-wince-pe*)
   # the C++ libraries don't build on top of CE's C libraries
   noconfigdirs="$noconfigdirs target-libstdc++-v3"
@@ -4148,7 +4144,7 @@ case "${target}" in
 noconfigdirs="$noconfigdirs gprof"
 ;;
   nvptx*-*-*)
-noconfigdirs="$noconfigdirs target-libssp target-libstdc++-v3"
+noconfigdirs="$noconfigdirs target-libssp"
 ;;
   sh-*-*)
 case "${target}" in
@@ -10395,6 +10391,16 @@ case ,${enable_languages}, in
 # Disable target libgrust if we're not building target libstdc++.
 noconfigdirs="$noconfigdirs target-libgrust"
 ;;
+  *)
+   case "${target}" in
+ amdgcn*-*-* \
+ | nvptx*-*-* )
+   # Build fails in 'libgrust/libproc_macro_internal/':
+   # sorry, unimplemented: exception handling not supported
+   noconfigdirs="$noconfigdirs target-libgrust"
+   ;;
+   esac
+   ;;
 esac
 ;;
 esac
diff --git a/configure.ac b/configure.ac
index 8967423ccdcf..eec6f817a4ba 100644
--- a/configure.ac
+++ b/configure.ac
@@ -657,10 +657,6 @@ if test "${ENABLE_LIBSTDCXX}" = "default" ; then
   # VxWorks uses the Dinkumware C++ library.
   noconfigdirs="$noconfigdirs target-libstdc++-v3"
   ;;
-amdgcn*-*-*)
-  # Not ported/fails to build when using newlib.
-  noconfigdirs="$noconfigdirs target-libstdc++-v3"
-  ;;
 arm*-wince-pe*)
   # the C++ libraries don't build on top of CE's C libraries
   noconfigdirs="$noconfigdirs target-libstdc++-v3"
@@ -1365,7 +1361,7 @@ case "${target}" in
 noconfigdirs="$noconfigdirs gprof"
 ;;
   nvptx*-*-*)
-noconfigdirs="$noconfigdirs target-libssp target-libstdc++-v3"
+noconfigdirs="$noconfigdirs target-libssp"
 ;;
   sh-*-*)
 case "${target}" in
@@ -2696,6 +2692,16 @@ case ,${enable_languages}, in
 # Disable target libgrust if we're not building target libstdc++.
 noconfigdirs="$noconfigdirs target-libgrust"
 ;;
+  *)
+   case "${target}" in
+ amdgcn*-*-* \
+ | nvptx*-*-* )
+   # Build fails in 'libgrust/libproc_macro_internal/':
+   # sorry, unimplemented: exception handling not supported
+   noconfigdirs="$noconfigdirs target-libgrust"
+   ;;
+   esac
+   ;;
 esac
 ;;
 esac
diff --git a/gcc/config/gcn/gcn.h b/gcc/config/gcn/gcn.h
index d7f92eb4b813..5198fbca2078 100644
--- a/gcc/

[gcc r15-8059] c, c++: Set DECL_NOT_GIMPLE_REG_P on *PART_EXPR operand on lhs of MODIFY_EXPR [PR119120]

[Jakub Jelinek via Gcc-cvs]

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

commit r15-8059-gd0d7c6632c2913c0243f048a15ff64aec6b6232e
Author: Jakub Jelinek 
Date:   Fri Mar 14 15:31:47 2025 +0100

c, c++: Set DECL_NOT_GIMPLE_REG_P on *PART_EXPR operand on lhs of 
MODIFY_EXPR [PR119120]

The PR119190 patch I've posted regresses the PR119120 testcase (not adding
to testsuite, as it is fairly hard to scan for that problem).
The issue is that for the partial setting of _Complex floating vars
through __real__ on it first and __imag__ later (or vice versa) and since
we forced all complex vars into SSA form we often have undefined (D)
arguments of those COMPLEX_EXPRs.  When we don't DCE them (for -O0 debug
info reasons), their expansion will copy both the real and imag parts
using the floating mode and on some targets like 387 that copying alone can
unfortunately trigger exceptions on sNaNs or other problematic bit patterns
and for uninitialized memory it can be triggered randomly based on whatever
is on the stack before.

The following patch sets DECL_NOT_GIMPLE_REG_P flag in the FEs during
genericization.
I think Fortran doesn't have a way to modify just real or just complex
part separately.

The patch is for code like
  _ComplexT __t;
  __real__ __t = __z.real();
  __imag__ __t = __z.imag();
  _M_value *= __t;
  return *this;
at -O0 which used to appear widely even in libstdc++ before GCC 9
and happens in real-world code.  At -O0 for debug info reasons (see
PR119190) we don't want to aggressively DCE statements and when we
since r0-100845 try to rewrite vars with COMPLEX_TYPE into SSA form
aggressively, the above results in copying of uninitialized data
when expanding COMPLEX_EXPRs added so that the vars can be in SSA form.
The patch detects during genericization the partial initialization and
doesn't rewrite such vars to SSA at -O0.  This has to be done before
gimplification starts, otherwise e.g. the attached testcase ICEs.

2025-03-14  Jakub Jelinek  

PR target/119120
* c-gimplify.cc (c_genericize_control_r): Set DECL_NOT_GIMPLE_REG_P
on {REAL,IMAG}PART_EXPR is_gimple_reg operand at -O0 if it is lhs
of a MODIFY_EXPR.

* cp-gimplify.cc (cp_genericize_r): Set DECL_NOT_GIMPLE_REG_P
on {REAL,IMAG}PART_EXPR is_gimple_reg operand at -O0 if it is lhs
of a MODIFY_EXPR.

* c-c++-common/pr119120.c: New test.

Diff:
---
 gcc/c-family/c-gimplify.cc| 12 +++
 gcc/cp/cp-gimplify.cc | 12 +++
 gcc/testsuite/c-c++-common/pr119120.c | 40 +++
 3 files changed, 64 insertions(+)

diff --git a/gcc/c-family/c-gimplify.cc b/gcc/c-family/c-gimplify.cc
index dc5e80dfa6be..c6fb7646567e 100644
--- a/gcc/c-family/c-gimplify.cc
+++ b/gcc/c-family/c-gimplify.cc
@@ -727,6 +727,18 @@ c_genericize_control_stmt (tree *stmt_p, int 
*walk_subtrees, void *data,
 static tree
 c_genericize_control_r (tree *stmt_p, int *walk_subtrees, void *data)
 {
+  tree stmt = *stmt_p;
+  /* Mark stores to parts of complex automatic non-addressable
+ variables as DECL_NOT_GIMPLE_REG_P for -O0.  This can't be
+ done during gimplification.  See PR119120.  */
+  if (TREE_CODE (stmt) == MODIFY_EXPR
+  && (TREE_CODE (TREE_OPERAND (stmt, 0)) == REALPART_EXPR
+ || TREE_CODE (TREE_OPERAND (stmt, 0)) == IMAGPART_EXPR)
+  && !optimize
+  && DECL_P (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0))
+  && is_gimple_reg (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0)))
+DECL_NOT_GIMPLE_REG_P (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0)) = 1;
+
   c_genericize_control_stmt (stmt_p, walk_subtrees, data,
 c_genericize_control_r, NULL);
   return NULL;
diff --git a/gcc/cp/cp-gimplify.cc b/gcc/cp/cp-gimplify.cc
index 45f4e27b8b74..04e430801d5f 100644
--- a/gcc/cp/cp-gimplify.cc
+++ b/gcc/cp/cp-gimplify.cc
@@ -2277,6 +2277,18 @@ cp_genericize_r (tree *stmt_p, int *walk_subtrees, void 
*data)
TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
   break;
 
+case MODIFY_EXPR:
+  /* Mark stores to parts of complex automatic non-addressable
+variables as DECL_NOT_GIMPLE_REG_P for -O0.  This can't be
+done during gimplification.  See PR119120.  */
+  if ((TREE_CODE (TREE_OPERAND (stmt, 0)) == REALPART_EXPR
+  || TREE_CODE (TREE_OPERAND (stmt, 0)) == IMAGPART_EXPR)
+ && !optimize
+ && DECL_P (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0))
+ && is_gimple_reg (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0)))
+   DECL_NOT_GIMPLE_REG_P (TREE_OPERAND (TREE_OPERAND (stmt, 0), 0)) = 1;
+  break;
+
 default:
   if (IS_TYPE_OR_DECL_P (stmt))
*walk_subtrees = 0;
diff --git a/gcc/testsuite/c-c++-common/pr11

[gcc r15-8060] match.pd: Fix up r15-8025 simplification [PR119287]

[Jakub Jelinek via Gcc-cvs]

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

commit r15-8060-gab0133cdba5dbcc29655593377e80586f7080472
Author: Jakub Jelinek 
Date:   Fri Mar 14 15:34:32 2025 +0100

match.pd: Fix up r15-8025 simplification [PR119287]

The following testcase ICEs since r15-8025.
tree_nop_conversion_p doesn't imply TREE_TYPE (@0) is uselessly convertible
to type, e.g. they could be INTEGER_TYPEs with the same precision but
different TYPE_SIGN.

The following patch just adds a convert so that it creates a valid IL
even in those cases.

2025-03-14  Jakub Jelinek  

PR tree-optimization/119287
* match.pd (((X >> C1) & C2) * (1 << C1) to X & (C2 << C1)): Use
(convert @0) instead of @0 in the substitution.

* gcc.dg/pr119287.c: New test.

Diff:
---
 gcc/match.pd|  2 +-
 gcc/testsuite/gcc.dg/pr119287.c | 16 
 2 files changed, 17 insertions(+), 1 deletion(-)

diff --git a/gcc/match.pd b/gcc/match.pd
index 89612d1b15b6..98f637373242 100644
--- a/gcc/match.pd
+++ b/gcc/match.pd
@@ -5284,7 +5284,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT)
 || tree_int_cst_sgn (@2) >= 0)
&& wi::to_wide (@3) == wi::set_bit_in_zero (shift, prec))
 (with { auto mask = wide_int::from (wi::to_wide (@2), prec, UNSIGNED); }
- (bit_and @0 { wide_int_to_tree (type, mask << shift); }))
+ (bit_and (convert @0) { wide_int_to_tree (type, mask << shift); }))
 
 /* ~(~X >> Y) -> X >> Y (for arithmetic shift).  */
 (simplify
diff --git a/gcc/testsuite/gcc.dg/pr119287.c b/gcc/testsuite/gcc.dg/pr119287.c
new file mode 100644
index ..b4b29afab916
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/pr119287.c
@@ -0,0 +1,16 @@
+/* PR tree-optimization/119287 */
+/* { dg-do compile } */
+/* { dg-options "-O2 -fwrapv" } */
+
+unsigned a;
+int b;
+signed char c, d;
+
+void
+foo (void)
+{
+  c = a >> 14 & 1;
+  for (; d;)
+c = 1;
+  b = c << 14;
+}

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:83a6dc1bc513368e39c5c6ec6adb4b29d4f8a828

commit 83a6dc1bc513368e39c5c6ec6adb4b29d4f8a828
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 c08664a5a053..e79b4b40f83b 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 e79cc590d2c3..2518c65aadab 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9868,11 +9868,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_v03)] Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor

[Mikael Morin via Gcc-cvs]

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

commit cab7316f723763564058b381f85dd2948389879a
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 25aade757594..56cef8b382aa 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_v03)] Sauvegarde factorisation set_descriptor_from_scalar

[Mikael Morin via Gcc-cvs]

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

commit 1d87733fb2a12c4ed75b1d84af0731dfa646f0cd
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 97d9f882ee4c..fd34c64fb16e 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_v03)] Déplacement fonction

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:9e9030951592f83556ac71fc36ab41c119e482ee

commit 9e9030951592f83556ac71fc36ab41c119e482ee
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 5be7e29130d3..2ec19e44a465 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 f9078dd1b694..be5df5e1fa8e 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_v03)] Renseignement token par gfc_set_descriptor_from_scalar.

[Mikael Morin via Gcc-cvs]

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

commit e935f964d8dfa7a9db3242f1e0e3ea4dce6b213b
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 b9b79e832dd2..77e1e1abea4f 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 8bf985dcac58..2373f267169f 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_v03)] Correction erreur compil'

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:9e938377ea3337cc07feee8ab1398ee5912c898d

commit 9e938377ea3337cc07feee8ab1398ee5912c898d
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 2fb832ff2d22..e52a87653505 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_v03)] Ajout surcharge gfc_conv_descriptor_type_set

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:9c2922b62d4203c069e62b2b54d431f33a9fbcb7

commit 9c2922b62d4203c069e62b2b54d431f33a9fbcb7
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 460c7ce6037f..e9b9084b79b6 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_v03)] Séparation motifs dump assumed_rank_12.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:26cb9480cc5ab421cc5dfe32500eaa23e5eef2f3

commit 26cb9480cc5ab421cc5dfe32500eaa23e5eef2f3
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_v03)] Correction régression class_to_type_2.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:41b056229a428f1bfc1d13e7a8ef87e7e3601b30

commit 41b056229a428f1bfc1d13e7a8ef87e7e3601b30
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 f285f4550088..8d20abbe0304 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_v03)] Utilisation setter trans_associate_var

[Mikael Morin via Gcc-cvs]

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

commit b383284afec653cad74fa6ba44dbbaff5cad6a66
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 cd9e88536b08..c2b2fc1562aa 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_v03)] Correction régression realloc_on_assign_1.f03

[Mikael Morin via Gcc-cvs]

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

commit c22a5a2463e428ee7fb962087d6dc5e4a95e61d9
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 23c82f22c3ef..8e7034f59420 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12648,26 +12648,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.  */
@@ -12978,12 +12982,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_v03)] Suppression modif offset trans_associate_var

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:6966490b3ee205b95db8a2e6259a301243dec164

commit 6966490b3ee205b95db8a2e6259a301243dec164
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 fec2f52de4a4..c8876f1dd03d 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] Created branch 'mikael/heads/refactor_descriptor_v03' in namespace 'refs/users'

[Mikael Morin via Gcc-cvs]

The branch 'mikael/heads/refactor_descriptor_v03' was created in namespace 
'refs/users' pointing to:

 6d201cc4a0c0... Suppression xfail typebound_call_22.f03

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:14d53ab4598a8db1fc1f20dbdbfaa88ee8e78bfd

commit 14d53ab4598a8db1fc1f20dbdbfaa88ee8e78bfd
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 28fee25ff7e4..69dbcc31cc4a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -13632,7 +13632,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_v03)] Essai suppression unlimited_polymorphic

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:54cd4ae1122d7ec90f08506c0de65a3b936a4cc1

commit 54cd4ae1122d7ec90f08506c0de65a3b936a4cc1
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 e30e38aa2816..095a44dc8d3a 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 8752f8c03818..e0cba5a1ea22 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_v03)] Affichage des mises à jour de structures champ par champ

[Mikael Morin via Gcc-cvs]

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

commit 1d7de2d039edcdfc0d42e8b00cc7cf288fd442ee
Author: Mikael Morin 
Date:   Wed Mar 5 21:11:56 2025 +0100

Affichage des mises à jour de structures champ par champ

Diff:
---
 gcc/cgraphunit.cc | 172 --
 1 file changed, 101 insertions(+), 71 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 84bba681da85..660a39584d61 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2863,6 +2863,59 @@ context_printer::print_bb_entry (basic_block bb)
 }
 
 
+static tree
+pick_subref_at (tree var_ref, unsigned offset)
+{
+  tree ref = var_ref;
+  unsigned remaining_offset = offset;
+  while (true)
+{
+  tree var_type = TREE_TYPE (ref);
+  if (TREE_CODE (var_type) == ARRAY_TYPE)
+   {
+ tree elt_type = TREE_TYPE (var_type);
+ unsigned elt_width;
+ gcc_assert (get_constant_type_size (elt_type, elt_width));
+ unsigned HOST_WIDE_INT hw_idx = remaining_offset / elt_width;
+ tree t_idx = build_int_cst (integer_type_node, hw_idx);
+ ref = build4 (ARRAY_REF, elt_type, ref,
+   t_idx, NULL_TREE, NULL_TREE);
+ remaining_offset -= hw_idx * elt_width;
+   }
+  else if (TREE_CODE (var_type) == RECORD_TYPE)
+   {
+ tree field = NULL_TREE;
+ HOST_WIDE_INT field_position = -1;
+ tree next_field = TYPE_FIELDS (TREE_TYPE (ref));
+
+ do
+   {
+ HOST_WIDE_INT next_position;
+ next_position = int_bit_position (next_field);
+ if (next_position > remaining_offset)
+   break;
+
+ field = next_field;
+ field_position = next_position;
+ next_field = TREE_CHAIN (field);
+   }
+ while (next_field != NULL_TREE);
+
+ gcc_assert (field != NULL_TREE
+ && field_position >= 0);
+
+ ref = build3 (COMPONENT_REF, TREE_TYPE (field),
+   ref, field, NULL_TREE);
+ remaining_offset -= field_position;
+   }
+  else
+   break;
+}
+  gcc_assert (remaining_offset == 0);
+  return ref;
+}
+
+
 static tree
 find_mem_ref_replacement (exec_context & context, tree data_ref, unsigned 
offset)
 {
@@ -2891,54 +2944,11 @@ find_mem_ref_replacement (exec_context & context, tree 
data_ref, unsigned offset
   gcc_assert (offset < UINT_MAX - shwi_offset);
   HOST_WIDE_INT remaining_offset = shwi_offset * CHAR_BIT + offset;
 
-  while (true)
-   {
- if (TREE_CODE (var_type) == ARRAY_TYPE)
-   {
- tree elt_type = TREE_TYPE (var_type);
- unsigned elt_width;
- gcc_assert (get_constant_type_size (elt_type, elt_width));
- unsigned HOST_WIDE_INT hw_idx = remaining_offset / elt_width;
- tree t_idx = build_int_cst (integer_type_node, hw_idx);
- var_ref = build4 (ARRAY_REF, elt_type, var_ref,
-   t_idx, NULL_TREE, NULL_TREE);
- remaining_offset -= hw_idx * elt_width;
-   }
- else if (TREE_CODE (var_type) == RECORD_TYPE)
-   {
- tree field = NULL_TREE;
- HOST_WIDE_INT field_position = -1;
- tree next_field = TYPE_FIELDS (TREE_TYPE (var_ref));
-
- do
-   {
- HOST_WIDE_INT next_position;
- next_position = int_bit_position (next_field);
- if (next_position > remaining_offset)
-   break;
-
- field = next_field;
- field_position = next_position;
- next_field = TREE_CHAIN (field);
-   }
- while (next_field != NULL_TREE);
-
- gcc_assert (field != NULL_TREE
- && field_position >= 0);
-
- var_ref = build3 (COMPONENT_REF, TREE_TYPE (field),
-   var_ref, field, NULL_TREE);
- remaining_offset -= field_position;
-   }
- else
-   break;
- var_type = TREE_TYPE (var_ref);
-   }
-  gcc_assert (remaining_offset == 0);
-  return var_ref;
+  return pick_subref_at (var_ref, remaining_offset);
 }
 }
 
+
 tree
 context_printer::print_first_data_ref_part (exec_context & context, tree 
data_ref, unsigned offset)
 {
@@ -2955,10 +2965,10 @@ context_printer::print_first_data_ref_part 
(exec_context & context, tree data_re
 /* Fall through.  */
 
 default:
-  print (data_ref);
+  tree ref = pick_subref_at (data_ref, offset);
+  print (ref);
+  return TREE_TYPE (ref);
 }
-
-  return TREE_TYPE (data_ref);
 }
 
 void
@@ -2983,25 +2993,6 @@ context_printer::print_value_update (exec_context & 
context, tree lhs, const dat
   print_newline ();
   previously_done += just_done;
 }
-  //pp_newline_and_indent (&pp, -2);
-#if 0
-  t

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Affichage conditionnelle

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:2f30e5eb84f32d981b11a446134a207cde993dce

commit 2f30e5eb84f32d981b11a446134a207cde993dce
Author: Mikael Morin 
Date:   Thu Mar 6 11:01:40 2025 +0100

Affichage conditionnelle

Diff:
---
 gcc/cgraphunit.cc | 11 ++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index c7c2e2f2e24f..71eaf0509fdf 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -4257,8 +4257,15 @@ exec_context::execute (basic_block bb)
 edge
 exec_context::select_leaving_edge (basic_block bb, gimple *last_stmt)
 {
+  if (last_stmt != nullptr)
+printer.begin_stmt (last_stmt);
+
   if (last_stmt == nullptr || is_a  (last_stmt))
-return single_succ_edge (bb);
+{
+  if (last_stmt != nullptr)
+   printer.end_stmt (last_stmt);
+  return single_succ_edge (bb);
+}
 
   if (is_a  (last_stmt))
 {
@@ -4291,6 +4298,8 @@ exec_context::select_leaving_edge (basic_block bb, gimple 
*last_stmt)
selected = e;
  }
 
+  printer.end_stmt (last_stmt);
+
   gcc_assert (selected != nullptr);
   return selected;
 }

[gcc r15-8056] Prevent use of ASM_EXPR for optimized COBOL compilations [PR119214]

[Robert Dubner via Gcc-cvs]

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

commit r15-8056-gb673d7b593f63a526a85d56204f1217bc4fbf6a1
Author: Robert Dubner 
Date:   Thu Mar 13 21:03:46 2025 -0400

Prevent use of ASM_EXPR for optimized COBOL compilations [PR119214]

The creation of assembler labels using ASM_EXPR causes name collisions in 
the
assembly language because some optimizations repeat code, and those labels
can get repeated. Use of "if( !optimize )" prevents (at least) that problem 
when
it cropped up with "-O -ftrace"

gcc/cobol:

PR cobol/119214
* gengen.cc: applies if( !optimize ) test

Diff:
---
 gcc/cobol/gengen.cc | 55 +
 1 file changed, 30 insertions(+), 25 deletions(-)

diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 4fc0a830c1ed..e4331204d0ad 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -3429,30 +3429,35 @@ gg_trans_unit_var_decl(const char *var_name)
 void
 gg_insert_into_assembler(const char *format, ...)
   {
-  // This routine inserts text directly into the assembly language stream.
-
-  // Note that if for some reason your text has to have a '%' character, it
-  // needs to be doubled in the GENERIC tag.  And that means if it is in the
-  // 'format' variable, it needs to be quadrupled.
+  // Temporarily defeat all ASM_EXPR for optimized code per PR119214
+  // The correct solution using LABEL_DECL is forthcoming
+  if( !optimize )
+{
+// This routine inserts text directly into the assembly language stream.
+
+// Note that if for some reason your text has to have a '%' character, it
+// needs to be doubled in the GENERIC tag.  And that means if it is in the
+// 'format' variable, it needs to be quadrupled.
+
+// Create the string to be inserted:
+char ach[256];
+va_list ap;
+va_start(ap, format);
+vsnprintf(ach, sizeof(ach), format, ap);
+va_end(ap);
+
+// Create the required generic tag
+tree asm_expr = build5_loc( location_from_lineno(),
+ASM_EXPR,
+VOID,
+build_string(strlen(ach), ach),
+NULL_TREE,
+NULL_TREE,
+NULL_TREE,
+NULL_TREE);
+//SET_EXPR_LOCATION (asm_expr, UNKNOWN_LOCATION);
 
-  // Create the string to be inserted:
-  char ach[256];
-  va_list ap;
-  va_start(ap, format);
-  vsnprintf(ach, sizeof(ach), format, ap);
-  va_end(ap);
-
-  // Create the required generic tag
-  tree asm_expr = build5_loc( location_from_lineno(),
-  ASM_EXPR,
-  VOID,
-  build_string(strlen(ach), ach),
-  NULL_TREE,
-  NULL_TREE,
-  NULL_TREE,
-  NULL_TREE);
-  //SET_EXPR_LOCATION (asm_expr, UNKNOWN_LOCATION);
-
-  // And insert it as a statement
-  gg_append_statement(asm_expr);
+// And insert it as a statement
+gg_append_statement(asm_expr);
+}
   }

[gcc(refs/users/jmelcr/heads/omp-cp)] omp-cp: fix info copying in fn-summary, fix callback edge inlining

[Josef Melcr via Gcc-cvs]

https://gcc.gnu.org/g:307ba5b392678330c44b9a43215856eef5befc60

commit 307ba5b392678330c44b9a43215856eef5befc60
Author: Josef Melcr 
Date:   Fri Mar 14 15:13:42 2025 +0100

omp-cp: fix info copying in fn-summary, fix callback edge inlining

gcc/ChangeLog:

* cgraph.cc (cgraph_add_edge_to_call_site_hash): Exclude
callback edges.
(cgraph_node::get_edge): Return parent edge if callback is found
first.
(cgraph_edge::set_call_stmt): Fix callback edges.
(cgraph_edge::first_callback_target): New function.
(cgraph_edge::next_callback_target): New function.
(cgraph_node::remove_callers): Remove callback edges when
removing their parent.
(cgraph_node::verify_node): Fix type.
* cgraph.h: Add declarations.
* ipa-fnsummary.cc (analyze_function_body): Fix summary copying
when dealing with callback edges.
* ipa-inline-transform.cc (inline_transform): Set child call
stmts when setting their parent.
* ipa-prop.cc (ipa_compute_jump_functions_for_edge): Fix
segfault when dealing with indirect edges.
* tree-inline.cc (copy_bb): Add callback edge copying.

Signed-off-by: Josef Melcr 

Diff:
---
 gcc/cgraph.cc   | 63 ++---
 gcc/cgraph.h|  6 +
 gcc/ipa-fnsummary.cc| 16 
 gcc/ipa-inline-transform.cc | 12 -
 gcc/ipa-prop.cc |  2 +-
 gcc/tree-inline.cc  | 13 ++
 6 files changed, 101 insertions(+), 11 deletions(-)

diff --git a/gcc/cgraph.cc b/gcc/cgraph.cc
index eabba370aa1f..e032cc0b4864 100644
--- a/gcc/cgraph.cc
+++ b/gcc/cgraph.cc
@@ -721,6 +721,8 @@ cgraph_add_edge_to_call_site_hash (cgraph_edge *e)
  one indirect); always hash the direct one.  */
   if (e->speculative && e->indirect_unknown_callee)
 return;
+  if (e->callback)
+return;
   cgraph_edge **slot = e->caller->call_site_hash->find_slot_with_hash
   (e->call_stmt, cgraph_edge_hasher::hash (e->call_stmt), INSERT);
   if (*slot)
@@ -769,6 +771,9 @@ cgraph_node::get_edge (gimple *call_stmt)
n++;
   }
 
+  if (e && e->callback)
+e = e->get_callback_parent_edge ();
+
   if (n > 100)
 {
   call_site_hash = hash_table::create_ggc (120);
@@ -845,7 +850,7 @@ cgraph_edge::set_call_stmt (cgraph_edge *e, gcall *new_stmt,
 {
   cgraph_edge *current, *next;
 
-  current = e;
+  current = e->first_callback_target ();
   gcall *old_stmt = current->call_stmt;
   for (cgraph_edge *d = current; d; d = next)
{
@@ -1213,6 +1218,36 @@ cgraph_edge::get_callback_parent_edge ()
   return e;
 }
 
+cgraph_edge *
+cgraph_edge::first_callback_target ()
+{
+  gcc_checking_assert (has_callback || callback);
+  cgraph_edge *e = NULL;
+  for (e = caller->callees; e; e = e->next_callee)
+{
+  if (e->callback && e->call_stmt == call_stmt)
+   {
+ break;
+   }
+}
+  return e;
+}
+
+cgraph_edge *
+cgraph_edge::next_callback_target ()
+{
+  gcc_checking_assert (has_callback || callback);
+  cgraph_edge *e = NULL;
+  for (e = next_callee; e; e = e->next_callee)
+{
+  if (e->callback && e->call_stmt == call_stmt)
+   {
+ break;
+   }
+}
+  return e;
+}
+
 /* Speculative call consists of an indirect edge and one or more
direct edge+ref pairs.
 
@@ -1867,6 +1902,17 @@ cgraph_node::remove_callers (void)
   for (e = callers; e; e = f)
 {
   f = e->next_caller;
+  if (e->has_callback)
+   {
+ cgraph_edge *cbe, *next_cbe = NULL;
+ for (cbe = e->first_callback_target (); cbe; cbe = next_cbe)
+   {
+ next_cbe = cbe->next_callback_target ();
+ symtab->call_edge_removal_hooks (cbe);
+ cbe->remove_caller ();
+ symtab->free_edge (cbe);
+   }
+   }
   symtab->call_edge_removal_hooks (e);
   e->remove_caller ();
   symtab->free_edge (e);
@@ -4032,11 +4078,20 @@ cgraph_node::verify_node (void)
ncallbacks++)
;
  for (cgraph_edge *cbe = callees; cbe; cbe = cbe->next_callee)
-   if (cbe->callback && cbe->call_stmt == e->call_stmt)
- nfound_edges++;
+   {
+ if (cbe->callback && cbe->call_stmt == e->call_stmt) {
+
+   nfound_edges++;
+
+ }
+ else if (cbe->callback) {
+   fprintf (stderr, "sus verify %s -> %s\n",
+cbe->caller->name (), cbe->callee->name ());
+ }
+   }
  if (ncallbacks != nfound_edges)
{
- error ("callback edge %s->%s child edge count mismach, "
+ error ("callback edge %s->%s child edge count mismatch, "

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:04aaeab4f84ec5bbc9e0b46fee5a5dd6aca91c8f

commit 04aaeab4f84ec5bbc9e0b46fee5a5dd6aca91c8f
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 5e1ad67aa3fd..24f681a79b9c 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_v03)] Appel méthode shift descriptor dans gfc_trans_pointer_assignment

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:2a458b78674f25b72305bae1e48005a6c3417eb8

commit 2a458b78674f25b72305bae1e48005a6c3417eb8
Author: Mikael Morin 
Date:   Tue Dec 17 22:37:18 2024 +0100

Appel méthode shift descriptor dans gfc_trans_pointer_assignment

Diff:
---
 gcc/fortran/trans-array.cc | 129 +++--
 gcc/fortran/trans-array.h  |   1 +
 gcc/fortran/trans-expr.cc  |  28 +-
 3 files changed, 129 insertions(+), 29 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index db6468d4fa19..5db21222ae07 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1153,13 +1153,136 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, 
tree desc,
 }
 
 
+class lb_info
+{
+public:
+  virtual gfc_expr *lower_bound (int dim) const = 0;
+};
+
+
+class unset_lb : public lb_info
+{
+public:
+  virtual gfc_expr *lower_bound (int) const { return nullptr; }
+};
+
+
+class defined_lb : public lb_info
+{
+  int rank;
+  gfc_expr * const * lower_bounds;
+
+public:
+  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]; }
+};
+
+
 static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+  const lb_info &info)
 {
   /* 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);
+{
+  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;
+   }
+
+  gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+}
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+  conv_shift_descriptor (block, desc, rank, unset_lb ());
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+  gfc_expr * const lower_bounds[GFC_MAX_DIMENSIONS])
+{
+  conv_shift_descriptor (block, desc, rank, defined_lb (rank, lower_bounds));
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc,
+  const gfc_array_spec &as)
+{
+  conv_shift_descriptor (block, desc, as.rank, as.lower);
+}
+
+
+static void
+set_type (array_type &type, array_type value)
+{
+  gcc_assert (type == AS_UNKNOWN || type == value);
+  type = value;
+}
+
+
+static void
+array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
+{
+  spec.rank = ref.dimen;
+  spec.corank = ref.codimen;
+
+  spec.type = AS_UNKNOWN;
+  spec.cotype = AS_ASSUMED_SIZE;
+
+  for (int dim = 0; dim < spec.rank + spec.corank; dim++)
+switch (ref.dimen_type[dim])
+  {
+  case DIMEN_ELEMENT:
+   spec.upper[dim] = ref.start[dim];
+   set_type (spec.type, AS_EXPLICIT);
+   break;
+
+  case DIMEN_RANGE:
+   spec.lower[dim] = ref.start[dim];
+   spec.upper[dim] = ref.end[dim];
+   if (spec.upper[dim] == nullptr)
+ set_type (spec.type, AS_DEFERRED);
+   else
+ set_type (spec.type, AS_EXPLICIT);
+   break;
+
+  default:
+   break;
+  }
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
+  const gfc_array_ref &ar)
+{
+  gfc_array_spec as;
+
+  array_ref_to_array_spec (ar, as);
+
+  conv_shift_descriptor (block, desc, as);
 }
 
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 17e3d08fdba0..3b05a2eb197a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,6 +214,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 &);
 
 /* 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 d81fa514dad0..564ec36999c3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11360,32 +11360,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, 
gfc_expr * expr2)
}
}
  else
-   {
- /* Bounds remapping.  Just shift the lower bounds.  */
-
- 

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

[Mikael Morin via Gcc-cvs]

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

commit e7aa6473af4187ec5a140dde0c9e42174982301b
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 e238a1f29e73..5e1ad67aa3fd 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_v03)] Factorisation set_contiguous_array

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:66efb52d8615e049a854e052ddf00c31188df3a8

commit 66efb52d8615e049a854e052ddf00c31188df3a8
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 33e4ede985a4..c08664a5a053 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_v03)] Sauvegarde modifs

[Mikael Morin via Gcc-cvs]

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

commit a2e632b52abb44986096314fe0a53fc9f984c966
Author: Mikael Morin 
Date:   Sat Dec 7 22:22:10 2024 +0100

Sauvegarde modifs

Annulation suppression else

Correction assertions

Initialisation vptr

Non initialisation elem_len pour les conteneurs de classe

Mise à jour class_allocatable_14

Diff:
---
 gcc/fortran/trans-array.cc  | 52 ++
 gcc/fortran/trans-array.h   |  2 +
 gcc/fortran/trans-decl.cc   | 58 +
 gcc/testsuite/gfortran.dg/class_allocate_14.f90 |  2 +-
 4 files changed, 66 insertions(+), 48 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5348d9784a8f..2aef10cef59a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -736,6 +736,58 @@ gfc_build_null_descriptor (tree type, gfc_typespec &ts,
 }
 
 
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+  vec *v = nullptr;
+
+  tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+  tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+  tree data_type = TREE_TYPE (data_field);
+
+  gcc_assert (ts.type == BT_CLASS);
+  tree data_value;
+  if (ts.u.derived->components->attr.dimension
+  || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+{
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+  data_value = gfc_build_null_descriptor (data_type,
+ ts,
+ 
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+}
+  else
+{
+  gcc_assert (POINTER_TYPE_P (data_type));
+  data_value = fold_convert (data_type, null_pointer_node);
+}
+  CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+  tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+
+  tree vptr_value;
+  if (ts.u.derived->attr.unlimited_polymorphic)
+vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+  else
+{
+  gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+  tree vsym_decl = gfc_get_symbol_decl (vsym);
+  vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+}
+  CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+  
+  return build_constructor (type, v);
+}
+
+
 void
 gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
 {
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294b0749..63a77d562a7b 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -140,6 +140,8 @@ void gfc_set_delta (gfc_loopinfo *);
 void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
 /* Build a null array descriptor constructor.  */
 tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree 
descriptor);
 
 /* Get a single array element.  */
 void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 893eac07c764..bc9b7afc7a71 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4777,16 +4777,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, 
gfc_wrapped_block * block)
   else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
 {
   /* Nullify explicit return class arrays on entry.  */
-  tree type;
   tmp = get_proc_result (proc_sym);
-   if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
-   gfc_start_block (&init);
-   tmp = gfc_class_data_get (tmp);
-   type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
-   gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
-   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+  if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+   {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+   }
 }
 
 
@@ -4928,48 +4926,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, 
gfc_wrapped_block * block)
}
}
 
-  if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
-   {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
-   

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:934e6a2f1f9b2da78fe53d1ae4746966944ead83

commit 934e6a2f1f9b2da78fe53d1ae4746966944ead83
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 5db21222ae07..aab5ac6cffab 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_v03)] Déplacement gfc_copy_sequence_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:8476914249d183df6439c7a0058fcca9957559b5

commit 8476914249d183df6439c7a0058fcca9957559b5
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 64d7b6c3f64e..d421c8c5c431 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 ee344bfb5477..c694709e8438 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_v03)] Sauvegarde modif

[Mikael Morin via Gcc-cvs]

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

commit e707baa2fd1c36dd4e8a327a3e83422a0eb37fb8
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 2ea1d47bb3d8..3582837e77e4 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 fcd6dfee43c2..153b6f4d2800 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran

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

[Mikael Morin via Gcc-cvs]

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

commit d0f9fc5d57426a6165e1606ef299ba8e6ec044de
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 bbcba5c5bcca..03f290736078 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_v03)] Déplacement méthode set_descriptor_from_scalar

[Mikael Morin via Gcc-cvs]

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

commit da5e5710423d6343f0a87d02839a6081754af298
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 e40c1dbf2783..64d7b6c3f64e 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 56cef8b382aa..ee344bfb5477 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_v03)] Factorisation initialisation gfc depuis cfi

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:2023667ca26ed29394eb90b918192c20f51998cb

commit 2023667ca26ed29394eb90b918192c20f51998cb
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 4451ce1d7ba0..5e9a91dae220 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_v03)] Update dump match count

[Mikael Morin via Gcc-cvs]

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

commit e3aef1c5f79dae91e67f59654ee0c5639788
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_v03)] Factorisation set_descriptor_from_scalar dans conv_class_to_class

[Mikael Morin via Gcc-cvs]

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

commit 08f4b49929b1a93df91e481a1c1ed29d5b492fc4
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 e4a9181613c8..ea025da94a8c 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_v03)] Correction bootstrap, ajout ; declaration.

[Mikael Morin via Gcc-cvs]

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

commit 0ab2f3b55a2ddd4fe6dbc1910510d5ededf604b8
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 e79b4b40f83b..2f8286dc794a 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_v03)] Introduction gfc_conv_descriptor_extent_get

[Mikael Morin via Gcc-cvs]

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

commit b8713ef83c2657dae4578a94ac478c37d4ebf739
Author: Mikael Morin 
Date:   Wed Jan 22 19:02:13 2025 +0100

Introduction gfc_conv_descriptor_extent_get

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d94404c6d060..cc785b39d817 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -546,6 +546,51 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree 
desc,
 }
 
 
+/* Calculate the size of a given array dimension from the bounds.  This
+   is simply (ubound - lbound + 1) if this expression is positive
+   or 0 if it is negative (pick either one if it is zero).  Optionally
+   (if or_expr is present) OR the (expression != 0) condition to it.  */
+
+static tree
+conv_array_extent_dim (tree lbound, tree ubound, bool maybe_negative, tree* 
or_expr)
+{
+  tree res;
+  tree cond;
+
+  /* Calculate (ubound - lbound + 1).  */
+  res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ubound, lbound);
+  res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+gfc_index_one_node);
+
+  /* Check whether the size for this dimension is negative.  */
+  if (maybe_negative)
+{
+  cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
+ gfc_index_zero_node);
+  res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, 
cond,
+gfc_index_zero_node, res);
+}
+
+  /* Build OR expression.  */
+  if (maybe_negative && or_expr)
+*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+   logical_type_node, *or_expr, cond);
+
+  return res;
+}
+
+
+tree
+gfc_conv_descriptor_extent_get (tree desc, tree dim)
+{
+  tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+  tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+  return conv_array_extent_dim (lbound, ubound, false, NULL);
+}
+
+
 static int
 get_type_info (const bt &type)
 {
@@ -7131,30 +7176,9 @@ gfc_set_delta (gfc_loopinfo *loop)
 tree
 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
 {
-  tree res;
-  tree cond;
-
-  /* Calculate (ubound - lbound + 1).  */
-  res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-ubound, lbound);
-  res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
-gfc_index_one_node);
-
-  /* Check whether the size for this dimension is negative.  */
-  cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
- gfc_index_zero_node);
-  res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
-gfc_index_zero_node, res);
-
-  /* Build OR expression.  */
-  if (or_expr)
-*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-   logical_type_node, *or_expr, cond);
-
-  return res;
+  return conv_array_extent_dim (lbound, ubound, true, or_expr);
 }
 
-
 /* For an array descriptor, get the total number of elements.  This is just
the product of the extents along from_dim to to_dim.  */
 
@@ -7168,14 +7192,7 @@ gfc_conv_descriptor_size_1 (tree desc, int from_dim, int 
to_dim)
 
   for (dim = from_dim; dim < to_dim; ++dim)
 {
-  tree lbound;
-  tree ubound;
-  tree extent;
-
-  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
-  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-
-  extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]);
   res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 res, extent);
 }
@@ -10568,12 +10585,7 @@ gfc_full_array_size (stmtblock_t *block, tree decl, 
int rank)
 idx = gfc_conv_descriptor_rank (decl);
   else
 idx = gfc_rank_cst[rank - 1];
-  nelems = gfc_conv_descriptor_ubound_get (decl, idx);
-  tmp = gfc_conv_descriptor_lbound_get (decl, idx);
-  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-nelems, tmp);
-  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-tmp, gfc_index_one_node);
+  tmp = gfc_conv_descriptor_extent_get (decl, idx);
   tmp = gfc_evaluate_now (tmp, block);
 
   nelems = gfc_conv_descriptor_stride_get (decl, idx);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index f9988a5fd109..1d694989b4c3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -194,6 +194,7 @@

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

[Mikael Morin via Gcc-cvs]

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

commit bd3fd914be677aa6b791524822b9eede57af1855
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 95060af47859..23c82f22c3ef 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12574,6 +12574,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.  */
@@ -12647,9 +12648,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)
@@ -12982,6 +12981,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_v03)] Factorisation initialisation depuis cfi

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:554aebc87d83b8abe5ab9d00c4c97453f74e8531

commit 554aebc87d83b8abe5ab9d00c4c97453f74e8531
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 bc9b7afc7a71..6f1a166bd01e 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_v03)] data_value: Suppression champ context et déplacement méthode print vers context_printer

[Mikael Morin via Gcc-cvs]

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

commit b7c9a2a9af849aeddae1adc433b89ef32b0444ea
Author: Mikael Morin 
Date:   Mon Mar 3 17:57:10 2025 +0100

data_value: Suppression champ context et déplacement méthode print vers 
context_printer

Diff:
---
 gcc/cgraphunit.cc | 177 +-
 1 file changed, 83 insertions(+), 94 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index c6dfc0f486b0..fbefcd522efd 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2407,7 +2407,6 @@ namespace selftest
 
 class data_value
 {
-  const exec_context & context;
   unsigned bit_width;
   wide_int constant_mask;
   wide_int address_mask;
@@ -2425,15 +2424,15 @@ class data_value
   friend void selftest::data_value_set_at_tests ();
 
 public:
-  data_value (const exec_context &ctx, unsigned width)
-: context (ctx), bit_width (width),
+  data_value (unsigned width)
+: bit_width (width),
 constant_mask (wi::shwi (HOST_WIDE_INT_0, width)),
 address_mask (wi::shwi (HOST_WIDE_INT_0, width)),
 constant_value (wi::shwi (HOST_WIDE_INT_0, width)),
 addresses ()
   {}
-  data_value (const exec_context &ctx, tree type)
-: data_value (ctx, get_constant_type_size (type))
+  data_value (tree type)
+: data_value (get_constant_type_size (type))
   {}
   data_value (const data_value &) = default;
   data_value & operator= (const data_value &);
@@ -2452,10 +2451,6 @@ public:
   data_storage *get_address_at (unsigned offset) const;
   data_value get_at (unsigned offset, unsigned width) const;
   bool is_fully_defined () const { return (~(constant_mask | address_mask)) == 
0; }
-  void print_at (pretty_printer & pp, tree type, unsigned offset,
-unsigned width) const;
-  void print_at (pretty_printer & pp, tree type, unsigned offset) const;
-  void print (pretty_printer & pp, tree type) const;
 };
 
 
@@ -2501,11 +2496,11 @@ class data_storage
 
 public:
   data_storage (const exec_context &ctx, tree decl)
-: context (ctx), type (STRG_VARIABLE), value (ctx, TREE_TYPE (decl)),
+: context (ctx), type (STRG_VARIABLE), value (TREE_TYPE (decl)),
 u (decl)
   {}
   data_storage (const exec_context &ctx, unsigned alloc_index, unsigned 
alloc_amount)
-: context (ctx), type (STRG_ALLOC), value (ctx, alloc_amount),
+: context (ctx), type (STRG_ALLOC), value (alloc_amount),
 u (alloc_index, alloc_amount)
   {}
   storage_type get_type () const { return type; }
@@ -2550,6 +2545,9 @@ public:
   tree print_first_data_ref_part (exec_context & context, tree data_ref, 
unsigned offset);
   void print_value_update (exec_context & context, tree, const data_value &); 
   void end_stmt (gimple *);
+  void print_at (const data_value & value, tree type, unsigned offset, 
unsigned width);
+  void print_at (const data_value & value, tree type, unsigned offset);
+  void print (const data_value & value, tree type);
 };
 
 
@@ -2962,7 +2960,7 @@ context_printer::print_value_update (exec_context & 
context, tree lhs, const dat
   pp_space (&pp);
   pp_equal (&pp);
   pp_space (&pp);
-  value.print_at (pp, type_output, previously_done, just_done);
+  print_at (value, type_output, previously_done, just_done);
   print_newline ();
   previously_done += just_done;
 }
@@ -3318,7 +3316,7 @@ data_value::get_address () const
 data_value
 data_value::get_at (unsigned offset, unsigned width) const
 {
-  data_value result (context, width);
+  data_value result (width);
   switch (classify (offset, width))
 {
 case VAL_CONSTANT:
@@ -3339,26 +3337,26 @@ data_value::get_at (unsigned offset, unsigned width) 
const
 
 
 void
-data_value::print_at (pretty_printer & pp, tree type, unsigned offset,
- unsigned width) const
+context_printer::print_at (const data_value & value, tree type, unsigned 
offset,
+  unsigned width)
 {
   if (TREE_CODE (type) == VECTOR_TYPE)
 {
-  gcc_assert (width == bit_width);
+  gcc_assert (width == value.get_bitwidth ());
   gcc_assert (offset == 0);
   tree elt_type = TREE_TYPE (type);
   unsigned elt_width;
   gcc_assert (get_constant_type_size (elt_type, elt_width));
   gcc_assert (elt_width != 0);
-  gcc_assert (bit_width % elt_width == 0);
+  gcc_assert (width % elt_width == 0);
   pp_left_brace (&pp);
   bool needs_comma = false;
-  for (unsigned i = 0; i < bit_width / elt_width; i++)
+  for (unsigned i = 0; i < width / elt_width; i++)
{
  if (needs_comma)
pp_comma (&pp);
  pp_space (&pp);
- print_at (pp, elt_type, i * elt_width);
+ print_at (value, elt_type, i * elt_width);
  needs_comma = true;
}
   pp_space (&pp);
@@ -3366,14 +3364,14 @@ data_value::print_at (pretty_printer & pp, tree type, 
unsigned offset,
 }
   else
 {
-  enum value_type val_type = classify (offset, width)

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

[Mikael Morin via Gcc-cvs]

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

commit 8fabf6231403b688f81657c3188e0d20f6e60195
Author: Mikael Morin 
Date:   Tue Feb 18 22:41:55 2025 +0100

Correction typebound_operator_9.f90

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

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ad4d0bbad6e4..686b690fc1c3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12589,8 +12589,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
   /* Walk the rhs.  */
   rss = gfc_walk_expr (expr2);
   if (rss == gfc_ss_terminator)
-   /* The rhs is scalar.  Add a ss for the expression.  */
-   rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+   {
+ /* The rhs is scalar.  Add a ss for the expression.  */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ lss->is_alloc_lhs = 0;
+   }
+
   /* When doing a class assign, then the handle to the rhs needs to be a
 pointer to allow for polymorphism.  */
   if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))

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

[Mikael Morin via Gcc-cvs]

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

commit ffa7329b66ad48d388715248bf7d1ca2620cb767
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 03f290736078..fa68d03b1f88 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_v03)] Sauvegarde suppression initialisation inutile bornes pour taire warnings

[Mikael Morin via Gcc-cvs]

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

commit 7da3557e8d2b321d3003a9a758fa5fcfa0f4778e
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 fb1e119f4aef..6b9c11b44f3e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2019,10 +2019,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 8e1fef6b301f..fd83c6ae66a7 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
@@ -13607,7 +13609,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;
@@ -13818,35 +13819,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_v03)] Correction ICE class_to_type_1

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:057f0c6bab0e61a522a894a0bfe618e345c9d1ab

commit 057f0c6bab0e61a522a894a0bfe618e345c9d1ab
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 3582837e77e4..f285f4550088 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_v03)] Correction régression class_assign_4.f90

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:47f527b9605b6c112f0f0cf2973251c9c9376344

commit 47f527b9605b6c112f0f0cf2973251c9c9376344
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 646df29e848e..a5c14886511c 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_v03)] Prise en charge zero extension

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:136929c7198627c9273030a4c19effae5be54454

commit 136929c7198627c9273030a4c19effae5be54454
Author: Mikael Morin 
Date:   Wed Mar 5 15:43:19 2025 +0100

Prise en charge zero extension

Diff:
---
 gcc/cgraphunit.cc | 59 +--
 1 file changed, 57 insertions(+), 2 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index e7b6e45386bf..c52e6559fede 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2436,6 +2436,7 @@ namespace selftest
   void context_printer_print_value_update_tests ();
   void exec_context_evaluate_tests ();
   void exec_context_evaluate_literal_tests ();
+  void exec_context_evaluate_unary_tests ();
   void exec_context_evaluate_binary_tests ();
   void exec_context_execute_assign_tests ();
   void exec_context_execute_call_tests ();
@@ -2638,6 +2639,7 @@ class exec_context
   friend void selftest::data_value_set_address_tests ();
   friend void selftest::data_value_set_tests ();
   friend void selftest::exec_context_evaluate_literal_tests ();
+  friend void selftest::exec_context_evaluate_unary_tests ();
   friend void selftest::exec_context_evaluate_binary_tests ();
   friend void selftest::exec_context_execute_assign_tests ();
   friend void selftest::exec_context_execute_call_tests ();
@@ -3821,12 +3823,29 @@ exec_context::evaluate_constructor (tree cstr) const
 
 
 data_value
-exec_context::evaluate_unary (enum tree_code code, tree type ATTRIBUTE_UNUSED, 
tree arg) const
+exec_context::evaluate_unary (enum tree_code code, tree type, tree arg) const
 {
   switch (code)
 {
 case NOP_EXPR:
-  return evaluate (arg);
+  {
+   data_value value = evaluate (arg);
+   unsigned target_width = get_constant_type_size (type);
+   unsigned source_width = value.get_bitwidth ();
+   if (source_width == target_width)
+ return value;
+
+   gcc_assert (value.classify () == VAL_CONSTANT);
+   tree t = value.to_tree (TREE_TYPE (arg));
+   tree r = fold_unary (code, type, t);
+   gcc_assert (TREE_CODE (r) == INTEGER_CST);
+   wide_int wi_r = wi::to_wide (r);
+
+   data_value result (type);
+   result.set_cst (wi_r);
+   return result;
+  }
+  break;
 
 default:
   {
@@ -3874,6 +3893,8 @@ exec_context::evaluate_binary (enum tree_code code, tree 
type, tree lhs, tree rh
  }
else
  {
+   gcc_assert (code == PLUS_EXPR
+   || code == POINTER_PLUS_EXPR);
data_value *val_address = nullptr, *val_offset = nullptr;
if (lhs_type == VAL_ADDRESS && rhs_type == VAL_CONSTANT)
  {
@@ -6350,6 +6371,39 @@ exec_context_evaluate_constructor_tests ()
   ASSERT_PRED1 (strg2.matches, b);
 }
 
+
+void
+exec_context_evaluate_unary_tests ()
+{
+  heap_memory mem;
+  context_printer printer;
+
+  tree c1 = create_var (char_type_node, "c1");
+
+  vec decls1;
+  decls1.safe_push (c1);
+
+  context_builder builder1;
+  builder1.add_decls (&decls1);
+  exec_context ctx1 = builder1.build (mem, printer);
+
+  wide_int wi18 = wi::uhwi (18, CHAR_BIT);
+  data_value val18 (char_type_node);
+  val18.set_cst (wi18);
+  data_storage *strg_c1 = ctx1.find_reachable_var (c1);
+  gcc_assert (strg_c1 != nullptr);
+  strg_c1->set (val18);
+  
+  data_value val1 = ctx1.evaluate_unary (NOP_EXPR, integer_type_node, c1);
+
+  ASSERT_EQ (val1.get_bitwidth (), HOST_BITS_PER_INT);
+  ASSERT_EQ (val1.classify (), VAL_CONSTANT);
+  wide_int wi1 = val1.get_cst ();
+  ASSERT_PRED1 (wi::fits_uhwi_p, wi1);
+  ASSERT_EQ (wi1.to_uhwi (), 18);
+}
+
+
 void
 exec_context_evaluate_binary_tests ()
 {
@@ -7253,6 +7307,7 @@ gimple_exec_cc_tests ()
   exec_context_evaluate_tests ();
   exec_context_evaluate_literal_tests ();
   exec_context_evaluate_constructor_tests ();
+  exec_context_evaluate_unary_tests ();
   exec_context_evaluate_binary_tests ();
   exec_context_execute_assign_tests ();
   exec_context_execute_call_tests ();

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

[Mikael Morin via Gcc-cvs]

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

commit af5275a1714af0fd73e6af8f1c87b04fbeaa4ad7
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 5bdd970f570f..6f9f93ce1986 100644
--- a/gcc/gimplify.cc
+++ b/gcc/gimplify.cc
@@ -7061,6 +7061,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_v03)] Factorisation set_descriptor_from_scalar conv_derived_to_class

[Mikael Morin via Gcc-cvs]

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

commit df6c137cf4e4ebe258fb66cbfcc6a9045a9f7299
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 ea025da94a8c..25aade757594 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_v03)] Suppression argument nelems gfc_array_allocate

[Mikael Morin via Gcc-cvs]

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

commit afed76dbc269b52c2ee92d4f607b514721ec5176
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 fadeef6bb099..5b3f0ad58f0f 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 8298003aa22a..fec2f52de4a4 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6399,7 +6399,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;
@@ -6931,7 +6930,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))
{
@@ -7003,8 +7001,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_v03)] Modification affichage MEM_REF d'alloc.

[Mikael Morin via Gcc-cvs]

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

commit ae42c3df608ec18da96a26730b015546144140ad
Author: Mikael Morin 
Date:   Thu Mar 6 17:22:35 2025 +0100

Modification affichage MEM_REF d'alloc.

Diff:
---
 gcc/cgraphunit.cc | 162 +++---
 1 file changed, 155 insertions(+), 7 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 51fa9143f7ca..6edc4984906d 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2433,6 +2433,7 @@ namespace selftest
   void data_value_set_at_tests ();
   void data_value_set_address_tests ();
   void data_value_print_tests ();
+  void context_printer_print_tests ();
   void context_printer_print_first_data_ref_part_tests ();
   void context_printer_print_value_update_tests ();
   void exec_context_evaluate_tests ();
@@ -2568,6 +2569,7 @@ class context_printer
 
   friend void selftest::exec_context_evaluate_tests ();
   friend void selftest::data_value_print_tests ();
+  friend void selftest::context_printer_print_tests ();
   friend void selftest::context_printer_print_first_data_ref_part_tests ();
   friend void selftest::context_printer_print_value_update_tests ();
 
@@ -2576,7 +2578,7 @@ public:
   context_printer (dump_flags_t f);
   pretty_printer & get_pretty_printer () const { return const_cast 
 (pp); }
   void begin_stmt (gimple *);
-  void print (tree);
+  void print (exec_context *, tree);
   void print_newline ();
   void print_function_entry (struct function * func);
   void print_function_exit (struct function * func);
@@ -2638,6 +2640,7 @@ class exec_context
   friend void selftest::data_value_print_tests ();
   friend void selftest::data_value_set_address_tests ();
   friend void selftest::data_value_set_tests ();
+  friend void selftest::context_printer_print_tests ();
   friend void selftest::exec_context_evaluate_literal_tests ();
   friend void selftest::exec_context_evaluate_unary_tests ();
   friend void selftest::exec_context_evaluate_binary_tests ();
@@ -2808,9 +2811,50 @@ context_printer::begin_stmt (gimple *g)
 }
 
 void
-context_printer::print (tree expr)
+context_printer::print (exec_context * ctx, tree expr)
 {
-  dump_generic_node (&pp, expr, pp_indentation (&pp), flags, false);
+  switch (TREE_CODE (expr))
+{
+case MEM_REF:
+  {
+   gcc_assert (ctx != nullptr);
+   data_value val = ctx->evaluate (TREE_OPERAND (expr, 0));
+   gcc_assert (val.classify () == VAL_ADDRESS);
+   storage_address *address = val.get_address ();
+   gcc_assert (address != nullptr);
+
+   data_value val_off = ctx->evaluate (TREE_OPERAND (expr, 1));
+   gcc_assert (val_off.classify () == VAL_CONSTANT);
+   wide_int wi_off = val_off.get_cst ();
+   wi_off = (wi_off * CHAR_BIT) + address->offset;
+
+   if (!wi::fits_uhwi_p (wi_off))
+ gcc_unreachable ();
+   unsigned offset_bits = wi_off.to_uhwi ();
+   gcc_assert (offset_bits % CHAR_BIT == 0);
+   unsigned offset_bytes = offset_bits / CHAR_BIT;
+
+   unsigned size_bits;
+   if (!get_constant_type_size (TREE_TYPE (expr), size_bits))
+ gcc_unreachable ();
+   gcc_assert (size_bits % CHAR_BIT == 0);
+   unsigned size_bytes = size_bits / CHAR_BIT;
+
+   address->storage.get ().print (*this);
+   pp_left_bracket (&pp);
+   pp_decimal_int (&pp, offset_bytes);
+   pp_character (&pp, 'B');
+   pp_colon (&pp);
+   pp_plus (&pp);
+   pp_decimal_int (&pp, size_bytes);
+   pp_character (&pp, 'B');
+   pp_right_bracket (&pp);
+  }
+  break;
+
+default:
+  dump_generic_node (&pp, expr, pp_indentation (&pp), flags, false);
+}
 }
 
 
@@ -3005,7 +3049,7 @@ context_printer::print_first_data_ref_part (exec_context 
& context, tree data_re
   pp_indent (&pp);
   pp_character (&pp, '#');
   pp_space (&pp);
-  print (ref);
+  print (&context, ref);
   return TREE_TYPE (ref);
 }
 }
@@ -3478,7 +3522,7 @@ context_printer::print_at (const data_value & value, tree 
type, unsigned offset,
tree int_type = make_signed_type (width);
tree cst = wide_int_to_tree (int_type, wi_val);
tree real = fold_build1 (VIEW_CONVERT_EXPR, type, cst);
-   print (real);
+   print (nullptr, real);
  }
else
  pp_wide_int (&pp, wi_val, SIGNED); 
@@ -3542,7 +3586,7 @@ data_storage::print (context_printer & printer) const
 case STRG_VARIABLE:
   {
tree decl = get_variable ();
-   printer.print (decl);
+   printer.print (nullptr, decl);
   }
   break;
 
@@ -5466,6 +5510,109 @@ data_storage_set_at_tests ()
 }
 
 
+void
+context_printer_print_tests ()
+{
+  heap_memory mem1;
+
+  context_printer printer1;
+  pretty_printer & pp1 = printer1.pp;
+
+  tree p1 = create_var (ptr_type_node, "p1");
+
+  vec decls1 {};
+  decls1.safe_push (p1);
+
+  context_builder builder1;
+  builder1.

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction offset MEM_REF

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:0647498123c253f44cbdd2267ccd18b8da3ec7b4

commit 0647498123c253f44cbdd2267ccd18b8da3ec7b4
Author: Mikael Morin 
Date:   Wed Mar 5 13:08:43 2025 +0100

Correction offset MEM_REF

Diff:
---
 gcc/cgraphunit.cc | 166 +-
 1 file changed, 165 insertions(+), 1 deletion(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index b556626adab5..e7b6e45386bf 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -3152,6 +3152,7 @@ data_value::set_cst_at (unsigned dest_offset, unsigned 
value_width,
   enum value_type orig_type = classify (dest_offset, value_width);
   wide_int dest_mask = wi::shifted_mask (dest_offset, value_width, false,
 bit_width);
+  gcc_assert (orig_type != VAL_ADDRESS);
   if (orig_type != VAL_CONSTANT)
 {
   constant_mask |= dest_mask;
@@ -3417,6 +3418,15 @@ context_printer::print_at (const data_value & value, 
tree type, unsigned offset,
storage_address *address = value.get_address_at (offset);
data_storage &target_storage = address->storage.get ();
target_storage.print (*this);
+   unsigned off = address->offset;
+   if (off > 0)
+ {
+   pp_string (&pp, " + ");
+   gcc_assert (off % CHAR_BIT == 0);
+   off /= CHAR_BIT;
+   pp_decimal_int (&pp, off);
+   pp_character (&pp, 'B');
+ }
  }
  break;
 
@@ -3672,6 +3682,7 @@ exec_context::evaluate (tree expr) const
storage_address *address = val_ptr.get_address ();
gcc_assert (address != nullptr);
data_value storage_value = address->storage.get ().get_value ();
+   unsigned ptr_offset = address->offset;
 
tree offset_bytes = TREE_OPERAND (expr, 1);
data_value val_off = evaluate (offset_bytes);
@@ -3701,7 +3712,7 @@ exec_context::evaluate (tree expr) const
offset += additional_off.to_uhwi ();
  }
 
-   return storage_value.get_at (offset * CHAR_BIT, bit_width);
+   return storage_value.get_at (offset * CHAR_BIT + ptr_offset, bit_width);
   }
   break;
 
@@ -5269,6 +5280,58 @@ data_value_print_tests ()
 }
 
 
+void
+data_storage_set_at_tests ()
+{
+  heap_memory mem;
+  context_printer printer;
+
+  tree a5i = build_array_type_nelts (integer_type_node, 5);
+  tree v5i = create_var (a5i, "v5i");
+  tree p = create_var (ptr_type_node, "p");
+
+  vec decls{};
+  decls.safe_push (p);
+  decls.safe_push (v5i);
+  vec empty{};
+
+  context_builder builder {};
+  builder.add_decls (&decls);
+  exec_context ctx = builder.build (mem, printer);
+
+  data_storage *storage_p = ctx.find_reachable_var (p);
+  gcc_assert (storage_p != nullptr);
+  data_storage *storage_v5 = ctx.find_reachable_var (v5i);
+  gcc_assert (storage_v5 != nullptr);
+
+  ASSERT_EQ (storage_p->get_value ().classify (), VAL_UNDEFINED);
+
+  storage_address addr0 (storage_v5->get_ref (), 0);
+  data_value val0 (ptr_type_node);
+  val0.set_address (addr0);
+
+  storage_p->set (val0);
+
+  data_value valp0 = storage_p->get_value ();
+  ASSERT_EQ (valp0.classify (), VAL_ADDRESS);
+  storage_address *addrp0 = valp0.get_address ();
+  ASSERT_EQ (&addrp0->storage.get (), storage_v5);
+  ASSERT_EQ (addrp0->offset, 0);
+
+  storage_address addr3 (storage_v5->get_ref (), 24);
+  data_value val3 (ptr_type_node);
+  val3.set_address (addr3);
+
+  storage_p->set (val3);
+
+  data_value valp3 = storage_p->get_value ();
+  ASSERT_EQ (valp3.classify (), VAL_ADDRESS);
+  storage_address *addrp3 = valp3.get_address ();
+  ASSERT_EQ (&addrp3->storage.get (), storage_v5);
+  ASSERT_EQ (addrp3->offset, 24);
+}
+
+
 void
 context_printer_print_first_data_ref_part_tests ()
 {
@@ -5644,6 +5707,7 @@ context_printer_print_value_update_tests ()
   const char *str = pp_formatted_text (&pp);
   ASSERT_STREQ (str, "# my_lhs = &my_var\n");
 
+
   context_printer printer2;
   pretty_printer & pp2 = printer2.pp;
   pp_buffer (&pp2)->m_flush_p = false;
@@ -5748,6 +5812,33 @@ context_printer_print_value_update_tests ()
 
   const char *str4 = pp_formatted_text (&pp4);
   ASSERT_STREQ (str4, "# v2i.der2i_i1 = 2\n# v2i.der2i_i2 = 11\n");
+
+
+  heap_memory mem5;
+  context_printer printer5;
+  pretty_printer & pp5 = printer5.pp;
+  pp_buffer (&pp5)->m_flush_p = false;
+
+  tree a5i = build_array_type_nelts (integer_type_node, 5);
+  tree v5i = create_var (a5i, "v5i");
+  tree p = create_var (ptr_type_node, "p");
+
+  vec decls5{};
+  decls5.safe_push (v5i);
+  decls5.safe_push (p);
+
+  context_builder builder5;
+  builder5.add_decls (&decls5);
+  exec_context ctx5 = builder5.build (mem5, printer5);
+
+  data_storage *strg_v5i = ctx5.find_reachable_var (v5i);
+  storage_address addr_v5i (strg_v5i->get_ref (), 24);
+  data_value val5 (ptr_type_node);;
+  val5.set_address (addr_v5i);
+
+  printer5.print_value_update (ctx5, p, val5);
+  const char *str5 = pp_formatted_text (&

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

[Mikael Morin via Gcc-cvs]

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

commit 6fb9c9fb7f2487b57e88dc1760bd74d198c2843b
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 e9b9084b79b6..ecffd0d5c0c6 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_v03)] Correction dynamic_dispatch_4.f03.

[Mikael Morin via Gcc-cvs]

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

commit 8aff8a58d16fb6d5771f6889eb880b00d780f0fe
Author: Mikael Morin 
Date:   Tue Mar 11 21:43:38 2025 +0100

Correction dynamic_dispatch_4.f03.

Diff:
---
 gcc/fortran/f95-lang.cc | 46 +-
 1 file changed, 41 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index c5098a24102a..dec2485168b3 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -309,24 +309,60 @@ gfc_finish (void)
 }
 
 
+static bool
+is_non_root_class_wrapper_type (tree t)
+{
+  if (!TYPE_P (t))
+return false;
+
+  if (!GFC_CLASS_TYPE_P (t))
+return false;
+
+  if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+return false;
+
+  return true;
+}
+
+
 static alias_set_type
 gfc_get_alias_set (tree t)
 {
   if (!TYPE_P (t))
 return -1;
 
-  if (!GFC_CLASS_TYPE_P (t))
-return -1;
+  tree parent_type = NULL_TREE;
+  if (POINTER_TYPE_P (t))
+{
+  tree pointee_type = TREE_TYPE (t);
+  if (!is_non_root_class_wrapper_type (pointee_type))
+   return -1;
 
-  if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+  tree parent_wrapper_type = GFC_TYPE_PARENT_CLASS_TYPE (pointee_type);
+  if (TREE_CODE (t) == REFERENCE_TYPE)
+   parent_type = build_reference_type (parent_wrapper_type);
+  else
+   parent_type = build_pointer_type (parent_wrapper_type);
+}
+  else if (!is_non_root_class_wrapper_type (t))
 return -1;
+  else
+parent_type = GFC_TYPE_PARENT_CLASS_TYPE (t);
 
   alias_set_type new_set = get_default_alias_set (t);
   TYPE_ALIAS_SET (t) = new_set;
-  tree parent_wrapper_type = GFC_TYPE_PARENT_CLASS_TYPE (t);
-  alias_set_type parent_set = get_alias_set (parent_wrapper_type);
+  alias_set_type parent_set = get_alias_set (parent_type);
 
   record_alias_subset (parent_set, new_set);
+  
+  if (!POINTER_TYPE_P (t))
+{
+  alias_set_type parent_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(parent_type)));
+  alias_set_type child_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(t)));
+
+  record_alias_subset (parent_base_set, child_base_set);
+}
+
   return new_set;
 }

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

[Mikael Morin via Gcc-cvs]

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

commit 7f6d305a466cda9bfd1b3438fcbe78c71458578d
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 be5df5e1fa8e..fcd6dfee43c2 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_v03)] Utilisation d'un seul objet heap_memory global

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:453902cec8ce276ecb32a9b5b5c57676de4ffb62

commit 453902cec8ce276ecb32a9b5b5c57676de4ffb62
Author: Mikael Morin 
Date:   Tue Mar 4 18:40:22 2025 +0100

Utilisation d'un seul objet heap_memory global

Diff:
---
 gcc/cgraphunit.cc | 513 ++
 1 file changed, 364 insertions(+), 149 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index dfeb89ab8194..a97fbec407c6 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2371,14 +2371,34 @@ enum value_type
 };
 
 
+enum storage_type
+{
+  STRG_VARIABLE,
+  STRG_ALLOC
+};
+
+class heap_memory;
+
 struct storage_ref
 {
-  const exec_context & context;
+  enum storage_type type;
+  union u
+{
+  u (const exec_context & ctx) : var_context (&ctx) {}
+  u (const heap_memory & m) : alloc_mem (&m) {}
+  const exec_context * var_context;
+  const heap_memory * alloc_mem;
+}
+  u;
   unsigned storage_index;
 
   storage_ref (const exec_context & ctx, unsigned idx)
-: context (ctx), storage_index (idx)
+: type (STRG_VARIABLE), u (ctx), storage_index (idx)
+  {}
+  storage_ref (const heap_memory & mem, unsigned idx)
+: type (STRG_ALLOC), u (mem), storage_index (idx)
   {}
+  storage_ref (const storage_ref & other) = default;
   data_storage & get () const;
 };
 
@@ -2388,8 +2408,8 @@ struct storage_address
   storage_ref storage;
   unsigned offset;
 
-  storage_address (const exec_context & ctx, unsigned idx, unsigned off)
-: storage (ctx, idx), offset (off)
+  storage_address (const storage_ref & ref, unsigned off)
+: storage (ref), offset (off)
   {}
 };
 
@@ -2408,6 +2428,7 @@ namespace selftest
   void exec_context_evaluate_binary_tests ();
   void exec_context_execute_assign_tests ();
   void exec_context_execute_call_tests ();
+  void exec_context_allocate_tests ();
 }
 
 
@@ -2461,57 +2482,54 @@ public:
 };
 
 
-enum storage_type
-{
-  STRG_VARIABLE,
-  STRG_ALLOC
-};
+class heap_memory;
+class context_printer;
 
 
 class data_storage
 {
-  const exec_context & context;
   const storage_type type;
   data_value value;
 
   union u
 {
-  u (tree t) : variable (t) {}
-  u (unsigned alloc_idx, unsigned alloc_amount)
-   : allocated (alloc_idx, alloc_amount)
+  u (const exec_context & ctx, tree t) : variable (ctx, t) {}
+  u (const heap_memory & mem, unsigned alloc_idx, unsigned alloc_amount)
+   : allocated (mem, alloc_idx, alloc_amount)
   {}
   //~u () {}
 
   struct v
{
- v (tree t) : decl (t) {}
+ v (const exec_context & ctx, tree t) : context (ctx), decl (t) {}
+ const exec_context & context;
  const tree decl;
}
   variable;
 
   const struct a
{
- a (unsigned alloc_idx, unsigned alloc_amount)
-   : index (alloc_idx), amount_bits (alloc_amount)
+ a (const heap_memory & mem, unsigned alloc_idx, unsigned alloc_amount)
+   : alloc_mem (mem), index (alloc_idx), amount_bits (alloc_amount)
  {}
- unsigned index;
- unsigned amount_bits;
+ const heap_memory & alloc_mem;
+ const unsigned index;
+ const unsigned amount_bits;
}
   allocated;
 }
   u;
 
 public:
-  data_storage (const exec_context &ctx, tree decl)
-: context (ctx), type (STRG_VARIABLE), value (TREE_TYPE (decl)),
-u (decl)
+  data_storage (const exec_context & ctx, tree decl)
+: type (STRG_VARIABLE), value (TREE_TYPE (decl)),
+u (ctx, decl)
   {}
-  data_storage (const exec_context &ctx, unsigned alloc_index, unsigned 
alloc_amount)
-: context (ctx), type (STRG_ALLOC), value (alloc_amount),
-u (alloc_index, alloc_amount)
+  data_storage (const heap_memory & mem, unsigned alloc_index, unsigned 
alloc_amount)
+: type (STRG_ALLOC), value (alloc_amount),
+u (mem, alloc_index, alloc_amount)
   {}
   storage_type get_type () const { return type; }
-  const exec_context & get_context () const { return context; }
   tree get_variable () const;
 
   bool matches (tree var) const
@@ -2524,7 +2542,8 @@ public:
   data_storage & operator= (const data_storage& other) = default;
   void set (const data_value & val) { return value.set (val); }
   void set_at (const data_value & val, unsigned offset) { return value.set_at 
(val, offset); }
-  void print (pretty_printer & pp) const;
+  void print (context_printer & printer) const;
+  storage_ref get_ref () const;
 };
 
 
@@ -2542,6 +2561,7 @@ class context_printer
 public:
   context_printer ();
   context_printer (dump_flags_t f);
+  pretty_printer & get_pretty_printer () const { return const_cast 
 (pp); }
   void begin_stmt (gimple *);
   void print (tree);
   void print_newline ();
@@ -2559,15 +2579,30 @@ public:
 
 
 static data_value
-execute (struct function *func, exec_context *caller,
+execute (struct function *func, exec_context &caller,
 context_printer & printer, vec * args);
 
+
+class heap_me

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

[Mikael Morin via Gcc-cvs]

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

commit d18a72c5bcbbacf0320d943fa6720744313a3f45
Author: Mikael Morin 
Date:   Fri Mar 7 10:22:58 2025 +0100

Correction régression PR100040.f90

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

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 9ef699ee29dd..3dc650c8eba2 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -3833,8 +3833,10 @@ gfc_trans_select_rank_cases (gfc_code * code)
   /* Calculate the switch expression.  */
   gfc_init_se (&se, NULL);
   gfc_conv_expr_descriptor (&se, code->expr1);
+  gfc_add_block_to_block (&block, &se.pre);
   rank = gfc_conv_descriptor_rank_get (se.expr);
   rank = gfc_evaluate_now (rank, &block);
+  gfc_add_block_to_block (&block, &se.post);
   symbol_attribute attr = gfc_expr_attr (code->expr1);
   if (!attr.pointer && !attr.allocatable)
 {

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction class_defined_operator_1.f03

[Mikael Morin via Gcc-cvs]

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

commit ff9dcaf96f36526023d9dfb16f8ba9ad9f8dc669
Author: Mikael Morin 
Date:   Wed Mar 12 15:19:04 2025 +0100

Correction class_defined_operator_1.f03

Diff:
---
 gcc/fortran/f95-lang.cc | 13 ++---
 1 file changed, 10 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index dec2485168b3..851723bc9704 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -357,10 +357,17 @@ gfc_get_alias_set (tree t)
   
   if (!POINTER_TYPE_P (t))
 {
-  alias_set_type parent_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(parent_type)));
-  alias_set_type child_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(t)));
-
+  tree parent_field = TYPE_FIELDS (parent_type);
+  tree child_field = TYPE_FIELDS (t);
+  alias_set_type parent_base_set = get_alias_set (parent_field);
+  alias_set_type child_base_set = get_alias_set (child_field);
   record_alias_subset (parent_base_set, child_base_set);
+
+  parent_field = TREE_CHAIN (parent_field);
+  child_field = TREE_CHAIN (child_field);
+  alias_set_type parent_vtype_ptr_set = get_alias_set (TREE_TYPE 
(parent_field));
+  alias_set_type child_vtype_ptr_set = get_alias_set (TREE_TYPE 
(child_field));
+  record_alias_subset (parent_vtype_ptr_set, child_vtype_ptr_set);
 }
 
   return new_set;

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:3bf5b2590f7567c4b03b1cc1093dc1bd2b37bde4

commit 3bf5b2590f7567c4b03b1cc1093dc1bd2b37bde4
Author: Mikael Morin 
Date:   Wed Mar 12 15:57:05 2025 +0100

Correction PR100020.f90

Diff:
---
 gcc/fortran/trans-types.cc | 5 -
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 0d7bab924571..cc5713c37eac 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2860,7 +2860,10 @@ get_class_canonical_type (gfc_symbol *derived, int rank, 
int corank)
   if (rank != 0 || corank != 0)
 {
   as = gfc_get_array_spec ();
-  as->type = AS_DEFERRED;
+  if (rank == -1)
+   as->type = AS_ASSUMED_RANK;
+  else
+   as->type = AS_DEFERRED;
   as->rank = rank;
   as->corank = corank;
 }

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] gimple-exec: affichage valeur undef

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:7891dce8e6095671061c34ad674dbe2b1dac6df5

commit 7891dce8e6095671061c34ad674dbe2b1dac6df5
Author: Mikael Morin 
Date:   Thu Mar 13 09:46:18 2025 +0100

gimple-exec: affichage valeur undef

Diff:
---
 gcc/cgraphunit.cc | 174 +-
 1 file changed, 158 insertions(+), 16 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 9c5b7f5b882b..ec6ae33e0435 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2442,6 +2442,7 @@ namespace selftest
   void exec_context_execute_assign_tests ();
   void exec_context_execute_call_tests ();
   void exec_context_allocate_tests ();
+  void exec_context_evaluate_condition_tests ();
 }
 
 
@@ -2663,6 +2664,7 @@ class exec_context
   data_value evaluate_constructor (tree cstr) const;
   data_value evaluate_unary (enum tree_code code, tree type, tree arg) const;
   data_value evaluate_binary (enum tree_code code, tree type, tree lhs, tree 
rhs) const;
+  bool evaluate_condition (gcond *cond) const;
   template 
   void add_variables (vec *variables, unsigned vars_count);
   template 
@@ -2689,6 +2691,7 @@ class exec_context
   friend void selftest::exec_context_execute_assign_tests ();
   friend void selftest::exec_context_execute_call_tests ();
   friend void selftest::exec_context_allocate_tests ();
+  friend void selftest::exec_context_evaluate_condition_tests ();
 
 public:
   exec_context (exec_context & caller, context_printer & printer,
@@ -3579,6 +3582,10 @@ context_printer::print_at (const data_value & value, 
tree type, unsigned offset,
  }
  break;
 
+   case VAL_UNDEFINED:
+ pp_string (&pp, "");
+ break;
+
default:
  gcc_unreachable ();
}
@@ -4348,6 +4355,59 @@ exec_context::execute (basic_block bb)
 }
 
 
+bool
+exec_context::evaluate_condition (gcond *cond) const
+{
+  enum tree_code code = gimple_cond_code (cond);
+  tree lhs = gimple_cond_lhs (cond);
+  tree rhs = gimple_cond_rhs (cond);
+
+  data_value val_lhs = evaluate (lhs);
+  data_value val_rhs = evaluate (rhs);
+
+  enum value_type lhs_type, rhs_type;
+  lhs_type = val_lhs.classify ();
+  rhs_type = val_rhs.classify ();
+  if (lhs_type == VAL_CONSTANT && rhs_type == VAL_CONSTANT)
+{
+  tree lval = val_lhs.to_tree (TREE_TYPE (lhs));
+  tree rval = val_rhs.to_tree (TREE_TYPE (rhs));
+
+  tree result = fold_binary (code, boolean_type_node, lval, rval);
+  gcc_assert (result != NULL_TREE);
+
+  if (integer_onep (result))
+   return true;
+  else if (integer_zerop (result))
+   return false;
+  else
+   gcc_unreachable ();
+}
+  else if ((lhs_type == VAL_CONSTANT && rhs_type == VAL_ADDRESS)
+  || (lhs_type == VAL_ADDRESS && rhs_type == VAL_CONSTANT))
+{
+  /* Comparison of an address against a null pointer.  */
+  data_value * null = nullptr;
+  if (lhs_type == VAL_CONSTANT)
+   null = &val_lhs;
+  else if (rhs_type == VAL_CONSTANT)
+   null = &val_rhs;
+  else
+   gcc_unreachable ();
+
+  gcc_assert (null->get_cst () == 0);
+  if (code == EQ_EXPR)
+   return false;
+  else if (code == NE_EXPR)
+   return true;
+  else
+   gcc_unreachable ();
+}
+  else
+gcc_unreachable ();
+}
+
+
 edge
 exec_context::select_leaving_edge (basic_block bb, gimple *last_stmt)
 {
@@ -4363,25 +4423,12 @@ exec_context::select_leaving_edge (basic_block bb, 
gimple *last_stmt)
 
   if (is_a  (last_stmt))
 {
-  gcond *cond = as_a  (last_stmt);
-
-  enum tree_code code = gimple_cond_code (cond);
-  tree lhs = gimple_cond_lhs (cond);
-  tree rhs = gimple_cond_rhs (cond);
-
-  tree lval = evaluate (lhs).to_tree (TREE_TYPE (lhs));
-  tree rval = evaluate (rhs).to_tree (TREE_TYPE (rhs));
-
-  tree result = fold_binary (code, boolean_type_node, lval, rval);
-  gcc_assert (result != NULL_TREE);
-
+  bool cond_result = evaluate_condition (as_a  (last_stmt));
   int flag;
-  if (integer_onep (result))
+  if (cond_result)
flag = EDGE_TRUE_VALUE;
-  else if (integer_zerop (result))
-   flag = EDGE_FALSE_VALUE;
   else
-   gcc_unreachable ();
+   flag = EDGE_FALSE_VALUE;
 
   edge e, selected = nullptr;
   edge_iterator ei;
@@ -5505,6 +5552,16 @@ data_value_print_tests ()
   printer9.print (v9, float_type_node);
 
   ASSERT_STREQ (pp_formatted_text (&pp9), "2.0e+0");
+
+
+  context_printer printer10;
+  pretty_printer & pp10 = printer10.pp;
+
+  data_value v10 (integer_type_node);
+
+  printer10.print (v10, integer_type_node);
+
+  ASSERT_STREQ (pp_formatted_text (&pp10), "");
 }
 
 
@@ -7067,6 +7124,90 @@ exec_context_evaluate_binary_tests ()
 }
 
 
+void
+exec_context_evaluate_condition_tests ()
+{
+  heap_memory mem1;
+  context_printer printer1;
+
+  tree a = create_var (integer_type_node, "a");
+  tree b = create_var (integer_type_node, "b");
+
+  vec decls1 {};
+  decls1.safe

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] gimple-exec Restauration tests print_first_data_ref_part

[Mikael Morin via Gcc-cvs]

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

commit 6ccdbf6eea18109b5c5deb515d0d82c0078d807a
Author: Mikael Morin 
Date:   Thu Mar 6 11:10:40 2025 +0100

gimple-exec Restauration tests print_first_data_ref_part

Diff:
---
 gcc/cgraphunit.cc | 353 +-
 1 file changed, 349 insertions(+), 4 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 71eaf0509fdf..51fa9143f7ca 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2582,7 +2582,7 @@ public:
   void print_function_exit (struct function * func);
   void print_bb_jump (edge e);
   void print_bb_entry (basic_block bb);
-  tree print_first_data_ref_part (exec_context & context, tree data_ref, const 
data_value & value, unsigned offset, int * ignored_bits);
+  tree print_first_data_ref_part (exec_context & context, tree data_ref, 
unsigned offset, int * ignored_bits);
   void print_value_update (exec_context & context, tree, const data_value &); 
   void end_stmt (gimple *);
   void print_at (const data_value & value, tree type, unsigned offset, 
unsigned width);
@@ -2979,7 +2979,7 @@ find_mem_ref_replacement (exec_context & context, tree 
data_ref,
 
 
 tree
-context_printer::print_first_data_ref_part (exec_context & context, tree 
data_ref, const data_value & value, unsigned offset, int * ignored_bits)
+context_printer::print_first_data_ref_part (exec_context & context, tree 
data_ref, unsigned offset, int * ignored_bits)
 {
   switch (TREE_CODE (data_ref))
 {
@@ -2988,7 +2988,7 @@ context_printer::print_first_data_ref_part (exec_context 
& context, tree data_re
tree mem_replacement = find_mem_ref_replacement (context, data_ref,
 offset);
if (mem_replacement != NULL_TREE)
- return print_first_data_ref_part (context, mem_replacement, value, 0, 
ignored_bits);
+ return print_first_data_ref_part (context, mem_replacement, 0, 
ignored_bits);
   }
 
 /* Fall through.  */
@@ -3018,7 +3018,7 @@ context_printer::print_value_update (exec_context & 
context, tree lhs, const dat
   while (previously_done < width)
 {
   int ignored_bits = 0;
-  tree type_done = print_first_data_ref_part (context, lhs, value,
+  tree type_done = print_first_data_ref_part (context, lhs,
  previously_done,
  &ignored_bits);
   if (type_done == NULL_TREE)
@@ -5466,6 +5466,350 @@ data_storage_set_at_tests ()
 }
 
 
+void
+context_printer_print_first_data_ref_part_tests ()
+{
+  vec empty{};
+
+  tree der2i = make_node (RECORD_TYPE);
+  tree der2i_i2 = build_decl (input_location, FIELD_DECL,
+ get_identifier ("der2i_i2"), integer_type_node);
+  DECL_CONTEXT (der2i_i2) = der2i;
+  DECL_CHAIN (der2i_i2) = NULL_TREE;
+  tree der2i_i1 = build_decl (input_location, FIELD_DECL,
+ get_identifier ("der2i_i1"), integer_type_node);
+  DECL_CONTEXT (der2i_i1) = der2i;
+  DECL_CHAIN (der2i_i1) = der2i_i2;
+  TYPE_FIELDS (der2i) = der2i_i1;
+  layout_type (der2i);
+
+  tree var2i = create_var (der2i, "var2i");
+
+  heap_memory mem1;
+  context_printer printer1;
+  pretty_printer & pp1 = printer1.pp;
+  exec_context ctx1 = context_builder ().build (mem1, printer1);
+
+  tree res1 = printer1.print_first_data_ref_part (ctx1, var2i, 0, nullptr);
+
+  ASSERT_EQ (res1, integer_type_node);
+  const char * str1 = pp_formatted_text (&pp1);
+  ASSERT_STREQ (str1, "# var2i.der2i_i1");
+
+
+  context_printer printer2;
+  pretty_printer & pp2 = printer2.pp;
+
+  vec decls2{};
+  decls2.safe_push (var2i);
+
+  context_builder builder2 {};
+  builder2.add_decls (&decls2);
+  exec_context ctx2 = builder2.build (mem1, printer2);
+
+  tree mem_var2i = build2 (MEM_REF, der2i,
+  build1 (ADDR_EXPR, ptr_type_node, var2i),
+  build_zero_cst (ptr_type_node));
+
+  tree res2 = printer2.print_first_data_ref_part (ctx2, mem_var2i, 0, nullptr);
+
+  ASSERT_EQ (res2, integer_type_node);
+  const char * str2 = pp_formatted_text (&pp2);
+  ASSERT_STREQ (str2, "# var2i.der2i_i1");
+
+
+  context_printer printer3;
+  pretty_printer & pp3 = printer3.pp;
+
+  context_builder builder3 {};
+  builder3.add_decls (&decls2);
+  exec_context ctx3 = builder3.build (mem1, printer3);
+
+  tree long_var2i = build2 (MEM_REF, long_integer_type_node,
+  build1 (ADDR_EXPR, ptr_type_node, var2i),
+  build_zero_cst (ptr_type_node));
+
+  tree res3 = printer3.print_first_data_ref_part (ctx3, long_var2i, 0, 
nullptr);
+
+  ASSERT_EQ (res3, integer_type_node);
+  const char * str3 = pp_formatted_text (&pp3);
+  ASSERT_STREQ (str3, "# var2i.der2i_i1");
+
+
+  tree der2s = make_node (RECORD_TYPE);
+  tree der2s_s2 = build_decl (input_location, FIELD_DECL,
+ get_identifier (

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Prise en charges des functions sans valeur de retour + free

[Mikael Morin via Gcc-cvs]

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

commit 8aba3758c4fe9acff8919a6f716c81021a482cb8
Author: Mikael Morin 
Date:   Thu Mar 6 10:55:01 2025 +0100

Prise en charges des functions sans valeur de retour + free

Diff:
---
 gcc/cgraphunit.cc | 96 +--
 1 file changed, 72 insertions(+), 24 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index cc59fece0984..c7c2e2f2e24f 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -213,6 +213,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "wide-int.h"
 #include "selftest.h"
 #include "tree-ssanames.h"
+#include 
 
 /* Queue of cgraph nodes scheduled to be added into cgraph.  This is a
secondary queue used during optimization to accommodate passes that
@@ -2590,7 +2591,7 @@ public:
 };
 
 
-static data_value
+static std::optional 
 execute (struct function *func, exec_context &caller,
 context_printer & printer, vec * args);
 
@@ -2656,7 +2657,7 @@ public:
   data_storage & get_storage (unsigned idx) const;
   context_printer & get_printer () const { return printer; }
   data_value evaluate (tree expr) const;
-  data_value execute_function (struct function *);
+  std::optional  execute_function (struct function *);
   edge select_leaving_edge (basic_block bb, gimple *last_stmt);
   void jump (edge e);
 };
@@ -4137,11 +4138,39 @@ exec_context::execute_assign (gassign *g)
 }
 
 
+static bool
+is_ignored_function_call (gcall *g)
+{
+  if (gimple_call_builtin_p (g, BUILT_IN_FREE))
+return true;
+
+  tree fn = gimple_call_fn (g);
+  if (TREE_CODE (fn) == ADDR_EXPR)
+fn = TREE_OPERAND (fn, 0);
+  gcc_assert (TREE_CODE (fn) == FUNCTION_DECL);
+  const char *fn_name = IDENTIFIER_POINTER (DECL_NAME (fn));
+  if (strcmp (fn_name, "_gfortran_set_args") == 0
+  || strcmp (fn_name, "_gfortran_set_options") == 0)
+return true;
+
+  return false;
+}
+
+
+
 void
 exec_context::execute_call (gcall *g)
 {
+  if (is_ignored_function_call (g))
+return;
+
+  tree lhs = gimple_call_lhs (g);
+  std::optional  result;
   if (gimple_call_builtin_p (g, BUILT_IN_MALLOC))
 {
+  gcc_assert (lhs != NULL_TREE);
+  result.emplace (data_value (TREE_TYPE (lhs)));
+
   gcc_assert (gimple_call_num_args (g) == 1);
   tree arg = gimple_call_arg (g, 0);
   data_value size = evaluate (arg);
@@ -4151,16 +4180,8 @@ exec_context::execute_call (gcall *g)
   HOST_WIDE_INT alloc_amount = wi_size.to_uhwi ();
   data_storage &storage = allocate (alloc_amount);
 
-  tree lhs = gimple_call_lhs (g);
-  gcc_assert (lhs != NULL_TREE);
-  data_value ptr (TREE_TYPE (lhs));
   storage_address address (storage.get_ref (), 0);
-  ptr.set_address (address);
-
-  printer.print_value_update (*this, lhs, ptr);
-  data_storage *lhs_strg = find_var (lhs);
-  gcc_assert (lhs_strg != nullptr);
-  lhs_strg->set (ptr);
+  result->set_address (address);
 }
   else
 {
@@ -4168,12 +4189,7 @@ exec_context::execute_call (gcall *g)
   if (TREE_CODE (fn) == ADDR_EXPR)
fn = TREE_OPERAND (fn, 0);
   gcc_assert (TREE_CODE (fn) == FUNCTION_DECL);
-  const char *fn_name = IDENTIFIER_POINTER (DECL_NAME (fn));
-  if (strcmp (fn_name, "_gfortran_set_args") == 0
- || strcmp (fn_name, "_gfortran_set_options") == 0)
-   return;
 
-  tree lhs = gimple_call_lhs (g);
   unsigned nargs = gimple_call_num_args (g); 
   auto_vec  arguments;
   arguments.reserve (nargs);
@@ -4181,13 +4197,17 @@ exec_context::execute_call (gcall *g)
   for (unsigned i = 0; i < nargs; i++)
arguments.quick_push (gimple_call_arg (g, i));
 
-  data_value result = ::execute (DECL_STRUCT_FUNCTION (fn), *this, printer,
-&arguments);
-  printer.print_value_update (*this, lhs, result);
-  data_storage *lhs_strg = find_var (lhs);
-  gcc_assert (lhs_strg != nullptr);
-  lhs_strg->set (result);
+  result = ::execute (DECL_STRUCT_FUNCTION (fn), *this, printer,
+ &arguments);
 }
+
+  if (lhs == NULL_TREE)
+return;
+
+  printer.print_value_update (*this, lhs, *result);
+  data_storage *lhs_strg = find_var (lhs);
+  gcc_assert (lhs_strg != nullptr);
+  lhs_strg->set (*result);
 }
 
 
@@ -4303,7 +4323,7 @@ exec_context::jump (edge e)
 }
 
 
-data_value
+std::optional 
 exec_context::execute_function (struct function *func)
 {
   printer.print_function_entry (func);
@@ -4321,19 +4341,26 @@ exec_context::execute_function (struct function *func)
  break;
}
 
+  if (bb == EXIT_BLOCK_PTR_FOR_FN (func))
+   break;
+
   edge e = select_leaving_edge (bb, last_stmt);
   jump (e);
   bb = e->dest;
 }
 
+  if (final_stmt == nullptr)
+return {};
   tree retexpr = gimple_return_retval (final_stmt);
+  if (retexpr == NULL_TREE)
+return {};
   data_value result = evaluate (retexpr);
 

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction régression alloc_comp_assign_12 etc

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:84488c6956d90cbf8e2c60ce754dd5e13025e46c

commit 84488c6956d90cbf8e2c60ce754dd5e13025e46c
Author: Mikael Morin 
Date:   Thu Mar 6 19:32:28 2025 +0100

Correction régression alloc_comp_assign_12 etc

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2d6519f8b0b6..480df9829dec 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5713,6 +5713,24 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * 
ss, int base)
   gfc_conv_expr_lhs (&se, ss_info->expr);
   gfc_add_block_to_block (block, &se.pre);
   info->descriptor = se.expr;
+  if (TREE_CODE (info->descriptor) == INDIRECT_REF)
+{
+  tree ptr = TREE_OPERAND (info->descriptor, 0);
+  ptr = gfc_evaluate_now (ptr, block);
+  TREE_OPERAND (info->descriptor, 0) = ptr;
+}
+  else if (TREE_CODE (info->descriptor) == COMPONENT_REF)
+{
+  tree parent_ref = TREE_OPERAND (info->descriptor, 0);
+  tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref));
+  tree ptr = fold_build1_loc (input_location, ADDR_EXPR,
+ parent_ptr_type, parent_ref);
+  ptr = gfc_evaluate_now (ptr, block);
+  tree deref = fold_build1_loc (input_location, INDIRECT_REF,
+   TREE_TYPE (parent_ref),
+   ptr);
+  TREE_OPERAND (info->descriptor, 0) = deref;
+}
   ss_info->string_length = se.string_length;
   ss_info->class_container = se.class_container;

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Changement type retour get_address: data_storage -> storage_address

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:76639591dd8d30bfce66a5c2cb32510506677ace

commit 76639591dd8d30bfce66a5c2cb32510506677ace
Author: Mikael Morin 
Date:   Tue Mar 4 22:32:21 2025 +0100

Changement type retour get_address: data_storage -> storage_address

Diff:
---
 gcc/cgraphunit.cc | 91 ---
 1 file changed, 47 insertions(+), 44 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 5290f7f27cfd..c5907e55055e 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2485,8 +2485,8 @@ public:
   void set_cst (const wide_int & val);
   wide_int get_cst_at (unsigned offset, unsigned width) const;
   wide_int get_cst () const;
-  data_storage *get_address () const;
-  data_storage *get_address_at (unsigned offset) const;
+  storage_address *get_address () const;
+  storage_address *get_address_at (unsigned offset) const;
   data_value get_at (unsigned offset, unsigned width) const;
   bool is_fully_defined () const { return (~(constant_mask | address_mask)) == 
0; }
   tree to_tree (tree type) const;
@@ -2869,13 +2869,13 @@ find_mem_ref_replacement (exec_context & context, tree 
data_ref, unsigned offset
   if (ptr_val.classify () != VAL_ADDRESS)
 return NULL_TREE;
 
-  data_storage *ptr_target = ptr_val.get_address ();
-  gcc_assert (ptr_target != nullptr);
-  if (ptr_target->get_type () != STRG_VARIABLE)
+  storage_address *ptr_address = ptr_val.get_address ();
+  data_storage &ptr_target = ptr_address->storage.get ();
+  if (ptr_target.get_type () != STRG_VARIABLE)
 return NULL_TREE;
 
   tree access_type = TREE_TYPE (data_ref);
-  tree var_ref = ptr_target->get_variable ();
+  tree var_ref = ptr_target.get_variable ();
   tree var_type = TREE_TYPE (var_ref);
 
   if (var_type == access_type)
@@ -3315,7 +3315,7 @@ data_value::get_cst () const
   return get_cst_at (0, bit_width);
 }
 
-data_storage *
+storage_address *
 data_value::get_address_at (unsigned offset) const
 {
   gcc_assert (classify (offset, HOST_BITS_PER_PTR) == VAL_ADDRESS);
@@ -3324,13 +3324,13 @@ data_value::get_address_at (unsigned offset) const
 
   stored_address *addr_info = find_address (offset);
   if (addr_info != nullptr)
-return &(addr_info->address.storage.get ());
+return &(addr_info->address);
 
   return nullptr;
 }
 
 
-data_storage *
+storage_address *
 data_value::get_address () const
 {
   gcc_assert (bit_width == HOST_BITS_PER_PTR);
@@ -3351,9 +3351,7 @@ data_value::get_at (unsigned offset, unsigned width) const
 case VAL_ADDRESS:
   {
gcc_assert (width == HOST_BITS_PER_PTR);
-   data_storage *storage = get_address_at (offset);
-   storage_address address (storage->get_ref (), 0);
-   result.set_address (address);
+   result.set_address (*get_address_at (offset));
   }
   break;
 
@@ -3419,9 +3417,9 @@ context_printer::print_at (const data_value & value, tree 
type, unsigned offset,
  {
gcc_assert (width == HOST_BITS_PER_PTR);
pp_ampersand (&pp);
-   data_storage *target_storage = value.get_address_at (offset);
-   gcc_assert (target_storage != nullptr);
-   target_storage->print (*this);
+   storage_address *address = value.get_address_at (offset);
+   data_storage &target_storage = address->storage.get ();
+   target_storage.print (*this);
  }
  break;
 
@@ -3674,9 +3672,9 @@ exec_context::evaluate (tree expr) const
tree ptr = TREE_OPERAND (expr, 0);
data_value val_ptr = evaluate (ptr);
gcc_assert (val_ptr.classify () == VAL_ADDRESS);
-   data_storage *storage = val_ptr.get_address ();
-   gcc_assert (storage != nullptr);
-   data_value storage_value = storage->get_value ();
+   storage_address *address = val_ptr.get_address ();
+   gcc_assert (address != nullptr);
+   data_value storage_value = address->storage.get ().get_value ();
 
tree offset_bytes = TREE_OPERAND (expr, 1);
data_value val_off = evaluate (offset_bytes);
@@ -3927,7 +3925,7 @@ exec_context::decompose_ref (tree data_ref, data_storage 
* & storage, int & offs
tree var = TREE_OPERAND (data_ref, 0);
data_value addr = evaluate (var);
gcc_assert (addr.classify () == VAL_ADDRESS);
-   storage = addr.get_address ();
+   storage = &(addr.get_address ()->storage.get ());
 
tree off = TREE_OPERAND (data_ref, 1);
data_value off_val = evaluate (off);
@@ -4835,14 +4833,14 @@ data_value_set_address_tests ()
   val1.set_address (address_a);
 
   ASSERT_EQ (val1.classify (), VAL_ADDRESS);
-  ASSERT_EQ (val1.get_address (), storage_a);
+  ASSERT_EQ (&val1.get_address ()->storage.get (), storage_a);
 
   data_storage *storage_b = ctx.find_reachable_var (b);
   storage_address address_b (storage_b->get_ref (), 0);
   val1.set_address (address_b);
 
   ASSERT_EQ (val1.classify (), VAL_ADDRESS);
-  ASSERT_EQ (val1.get_address (), storage_b);
+  ASSERT_EQ (&

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

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:584a8ddc06a8fcba45b6cb141236d579acec8435

commit 584a8ddc06a8fcba45b6cb141236d579acec8435
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 77e1e1abea4f..bbcba5c5bcca 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_v03)] Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class

[Mikael Morin via Gcc-cvs]

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

commit 0e366549f6d5ced80a809c2a8ecebf0e9a456597
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 2aef10cef59a..2389fc53555d 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_v03)] Déplacement gfc_set_gfc_from_cfi

[Mikael Morin via Gcc-cvs]

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

commit c121f9df543f5d92d3f1bf763f0622e61675243a
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 d421c8c5c431..97d9f882ee4c 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 r15-8066] RISC-V: Refine the testcases for cond_widen_complicate-3

[Pan Li via Gcc-cvs]

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

commit r15-8066-gf70f4b60debce4a223725781d1973c05d8d1dfa9
Author: Pan Li 
Date:   Wed Mar 12 11:26:52 2025 +0800

RISC-V: Refine the testcases for cond_widen_complicate-3

Rearrange the test cases of cond_widen_complicate-3 by different types
into different files, instead of put all types together.  Then we can
easily reduce the range when asm check fails.

The below test suites are passed locally, let's wait online CI says.
* The rv64gcv fully regression test.

gcc/testsuite/ChangeLog:

* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3.c: 
Removed.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f16.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f32.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i16.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i32.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i8.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-u16.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-u32.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-u8.c: 
New test.
* gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3.h: New 
test.

Signed-off-by: Pan Li 

Diff:
---
 .../rvv/autovec/cond/cond_widen_complicate-3-f16.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-f32.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-i16.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-i32.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-i8.c  |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-u16.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-u32.c |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3-u8.c  |  9 ++
 .../rvv/autovec/cond/cond_widen_complicate-3.c | 36 --
 .../rvv/autovec/cond/cond_widen_complicate-3.h | 21 +
 10 files changed, 93 insertions(+), 36 deletions(-)

diff --git 
a/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f16.c 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f16.c
new file mode 100644
index ..e4ff3106b0e0
--- /dev/null
+++ 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f16.c
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+/* { dg-additional-options "-march=rv32gcv_zvfh -mabi=ilp32d 
-mrvv-vector-bits=scalable -ffast-math" } */
+
+#include "cond_widen_complicate-3.h"
+
+TEST_TYPE (float, _Float16)
+
+/* { dg-final { scan-assembler-times {\tvfwmul\.vv} 1 } } */
+/* { dg-final { scan-assembler-not {\tvmerge\.vvm\t} } } */
diff --git 
a/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f32.c 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f32.c
new file mode 100644
index ..7d2b44827cdc
--- /dev/null
+++ 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-f32.c
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+/* { dg-additional-options "-march=rv32gcv -mabi=ilp32d 
-mrvv-vector-bits=scalable -ffast-math" } */
+
+#include "cond_widen_complicate-3.h"
+
+TEST_TYPE (double, float)
+
+/* { dg-final { scan-assembler-times {\tvfwmul\.vv} 1 } } */
+/* { dg-final { scan-assembler-not {\tvmerge\.vvm\t} } } */
diff --git 
a/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i16.c 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i16.c
new file mode 100644
index ..dc7e1da76b80
--- /dev/null
+++ 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i16.c
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+/* { dg-additional-options "-march=rv32gcv -mabi=ilp32d 
-mrvv-vector-bits=scalable" } */
+
+#include "cond_widen_complicate-3.h"
+
+TEST_TYPE (int32_t, int16_t)
+
+/* { dg-final { scan-assembler-times {\tvwmul\.vv} 1 } } */
+/* { dg-final { scan-assembler-not {\tvmerge\.vvm\t} } } */
diff --git 
a/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i32.c 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i32.c
new file mode 100644
index ..de1072f5673f
--- /dev/null
+++ 
b/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i32.c
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+/* { dg-additional-options "-march=rv32gcv -mabi=ilp32d 
-mrvv-vector-bits=scalable" } */
+
+#include "cond_widen_complicate-3.h"
+
+TEST_TYPE (int64_t, int32_t)
+
+/* { dg-final { scan-assembler-times {\tvwmul\.vv} 1 } } */
+/* { dg-final { scan-assembler-not {\tvmerge\.vvm\t} } } */
diff --git 
a/gcc/testsuite/gcc.target/riscv/rvv/autovec/cond/cond_widen_complicate-3-i8.c 
b/gcc/testsuit

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction initialisation bornes temp alloc_comp_assign_12.f03

[Mikael Morin via Gcc-cvs]

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

commit e6313ff0bd2230621d678b00e5db148e70b8b574
Author: Mikael Morin 
Date:   Wed Feb 19 20:06:10 2025 +0100

Correction initialisation bornes temp alloc_comp_assign_12.f03

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 69dbcc31cc4a..2d6519f8b0b6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3672,7 +3672,7 @@ set_temporary_descriptor (stmtblock_t *block, tree desc, 
tree class_src,
  tree lbound[GFC_MAX_DIMENSIONS],
  tree ubound[GFC_MAX_DIMENSIONS],
  tree stride[GFC_MAX_DIMENSIONS], int rank,
- bool callee_allocated, bool rank_changer,
+ bool omit_bounds, bool rank_changer,
  bool shift_bounds)
 {
   int n;
@@ -3700,7 +3700,7 @@ set_temporary_descriptor (stmtblock_t *block, tree desc, 
tree class_src,
 }
 
   tree offset = gfc_index_zero_node;
-  if (!callee_allocated)
+  if (!omit_bounds)
 {
   for (n = 0; n < rank; n++)
{
@@ -4032,6 +4032,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, 
stmtblock_t * post, gfc_ss * ss,
}
 }
 
+  bool bounds_known = size != NULL_TREE;
+
   /* Get the size of the array.  */
   if (size && !callee_alloc)
 {
@@ -4055,8 +4057,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, 
stmtblock_t * post, gfc_ss * ss,
dealloc);
 
   set_temporary_descriptor (pre, desc, class_expr, elemsize, data_ptr,
-   from, to, stride, total_dim,
-   size == NULL_TREE || callee_alloc,
+   from, to, stride, total_dim, !bounds_known,
rank_changer, shift_bounds);
 
   while (ss->parent)

[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Suppression méthode evaluate_litteral

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:9b5c6e05c8766827742f0daf3bf8dfcda76acc3e

commit 9b5c6e05c8766827742f0daf3bf8dfcda76acc3e
Author: Mikael Morin 
Date:   Tue Mar 4 10:32:35 2025 +0100

Suppression méthode evaluate_litteral

Diff:
---
 gcc/cgraphunit.cc | 22 +-
 1 file changed, 1 insertion(+), 21 deletions(-)

diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index 8a207f3b30fb..1bcf56daded8 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2563,7 +2563,6 @@ class exec_context
   unsigned next_alloc_index;
   //void add_variables (const exec_context &);
   data_value evaluate_constructor (tree cstr) const;
-  data_value evaluate_literal (enum tree_code code, tree value) const;
   data_value evaluate_unary (enum tree_code code, tree arg) const;
   template 
   void add_variables (vec *variables, unsigned vars_count);
@@ -3724,25 +3723,6 @@ exec_context::evaluate_unary (enum tree_code code, tree 
arg) const
 }
 }
 
-data_value
-exec_context::evaluate_literal (enum tree_code code, tree value) const
-{
-  data_value result(TREE_TYPE (value));
-  switch (code)
-{
-case INTEGER_CST:
-  {
-   wide_int wi_val = wi::to_wide (value);
-   result.set_cst (wi_val);
-  }
-  break;
-
-default:
-  gcc_unreachable ();
-}
-  return result;
-}
-
 void
 exec_context::decompose_ref (tree data_ref, data_storage * & storage, int & 
offset) const
 {
@@ -5832,7 +5812,7 @@ exec_context_evaluate_literal_tests ()
 
   tree cst = build_int_cst (integer_type_node, 13);
 
-  data_value val = ctx.evaluate_literal (INTEGER_CST, cst);
+  data_value val = ctx.evaluate (cst);
   ASSERT_EQ (val.classify (), VAL_CONSTANT);
   wide_int wi_value = val.get_cst ();
   ASSERT_PRED1 (wi::fits_shwi_p, wi_value);

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

[Mikael Morin via Gcc-cvs]

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

commit aeab2d327c30ee2e47fa59eb0e70c44e58151231
Author: Mikael Morin 
Date:   Thu Mar 13 21:25:04 2025 +0100

Correction régression class_optional_2.f90

Diff:
---
 gcc/fortran/trans-types.cc | 63 +++---
 1 file changed, 32 insertions(+), 31 deletions(-)

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 33f6bfbc5d85..7976d672c539 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2833,8 +2833,11 @@ cobounds_match_decl (const gfc_symbol *derived)
 
 
 gfc_symbol *
-get_class_canonical_type (gfc_symbol *derived, int rank, int corank)
+get_class_canonical_type (gfc_symbol *derived, gfc_array_spec *as)
 {
+
+  int rank = as ? as->rank : 0;
+  int corank = as ? as->corank : 0;
   const char *class_name = gfc_class_name (derived, rank, corank, 0, 0);
 
   gfc_namespace *ns = gfc_class_namespace (derived);
@@ -2843,7 +2846,13 @@ get_class_canonical_type (gfc_symbol *derived, int rank, 
int corank)
   gfc_find_symbol (class_name, ns, 0, &canonical_class);
 
   if (canonical_class != nullptr)
-return canonical_class;
+{
+  gfc_array_spec *found_as = canonical_class->components->as;
+  if (gfc_compare_array_spec (as, found_as))
+   return canonical_class;
+  else
+   return nullptr;
+}
 
   gfc_typespec ts;
   memset (&ts, 0, sizeof (ts));
@@ -2856,21 +2865,9 @@ get_class_canonical_type (gfc_symbol *derived, int rank, 
int corank)
   attr.dimension = rank != 0;
   attr.codimension = corank != 0;
 
-  gfc_array_spec *as;
-  if (rank != 0 || corank != 0)
-{
-  as = gfc_get_array_spec ();
-  if (rank == -1)
-   as->type = AS_ASSUMED_RANK;
-  else
-   as->type = AS_DEFERRED;
-  as->rank = rank;
-  as->corank = corank;
-}
-  else
-as = nullptr;
+  gfc_array_spec *tmp_as = gfc_copy_array_spec (as);
 
-  gfc_build_class_symbol (&ts, &attr, &as);
+  gfc_build_class_symbol (&ts, &attr, &tmp_as);
 
   gfc_find_symbol (class_name, ns, 0, &canonical_class);
   if (canonical_class)
@@ -2892,10 +2889,8 @@ get_class_canonical_type (gfc_symbol *cls)
   gfc_component * data_comp = cls->components;
 
   gfc_symbol *derived = data_comp->ts.u.derived;
-  int rank = data_comp->as ? data_comp->as->rank : 0;
-  int corank = data_comp->as ? data_comp->as->corank : 0;
 
-  return get_class_canonical_type (derived, rank, corank);
+  return get_class_canonical_type (derived, data_comp->as);
 }
 
 
@@ -2908,9 +2903,10 @@ tree
 gfc_get_derived_type (gfc_symbol * derived, int codimen)
 {
   tree typenode = NULL, field = NULL, field_type = NULL;
-  tree canonical = NULL_TREE;
+  tree canonical = NULL_TREE, class_canonical = NULL_TREE;
   tree *chain = NULL;
   bool got_canonical = false;
+  bool self_is_canonical = false;
   bool unlimited_entity = false;
   gfc_component *c;
   gfc_namespace *ns;
@@ -2973,6 +2969,15 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
   && gfc_get_module_backend_decl (derived))
 goto copy_derived_types;
 
+  if (derived->attr.is_class)
+{
+  gfc_symbol * canonical_sym = get_class_canonical_type (derived);
+  if (canonical_sym == derived)
+   self_is_canonical = true;
+  else if (canonical_sym != nullptr)
+   class_canonical = gfc_get_derived_type (canonical_sym, codimen);
+}
+
   /* The derived types from an earlier namespace can be used as the
  canonical type.  */
   if (derived->backend_decl == NULL
@@ -3009,6 +3014,8 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
 
   derived->backend_decl = NULL_TREE;
 }
+  else if (class_canonical)
+canonical = class_canonical;
 
   /* derived->backend_decl != 0 means we saw it before, but its
  components' backend_decl may have not been built.  */
@@ -3250,24 +3257,18 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
   /* Now lay out the derived type, including the fields.  */
   if (canonical)
 TYPE_CANONICAL (typenode) = canonical;
-  else if (derived->attr.is_class)
+  else if (self_is_canonical)
+TYPE_CANONICAL (typenode) = typenode;
+
+  if (derived->attr.is_class)
 {
-  gfc_symbol * canonical_sym = get_class_canonical_type (derived);
-  if (canonical_sym != nullptr)
-   {
- tree canonical_sym_decl = gfc_get_derived_type (canonical_sym, 
codimen);
- TYPE_CANONICAL (typenode) = TYPE_CANONICAL (canonical_sym_decl);
-   }
   gfc_component * data_comp = derived->components;
   gfc_symbol *orig_type = data_comp->ts.u.derived;
   if (orig_type->attr.extension)
{
- int rank = data_comp->as ? data_comp->as->rank : 0;
- int corank = data_comp->as ? data_comp->as->corank : 0;
-
  gfc_symbol * parent_type = orig_type->components->ts.u.derived;
  gfc_symbol * parent_wrapper = get_class_canonical_type (parent_type, 
-