[COMMITTED,08/13] ada: Allow mutably tagged types to work with qualified expressions

Message ID 20240702132130.523603-8-poulhies@adacore.com
State Committed
Commit 03308301c7bb2eed0bc8990db7038aac3a2dcb97
Headers
Series [COMMITTED,01/13] ada: Document that -gnatdJ is unused |

Commit Message

Marc Poulhiès July 2, 2024, 1:21 p.m. UTC
  From: Justin Squirek <squirek@adacore.com>

This patch modifies the experimental 'Size'Class feature such that objects of
mutably tagged types can be assigned qualified expressions featuring a
definite type (e.g. Mutable_Obj := Root_Child_T'(Root_T with others => <>)).

gcc/ada/

	* sem_ch5.adb:
	(Analyze_Assignment): Add special expansion for qualified expressions
	in certain cases dealing with mutably tagged types.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_ch5.adb | 14 ++++++++++++++
 1 file changed, 14 insertions(+)
  

Patch

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 644bd21ce93..5739fe06ea2 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -697,6 +697,19 @@  package body Sem_Ch5 is
       then
          Resolve (Rhs, Base_Type (T1));
 
+      --  When the right hand side is a qualified expression and the left hand
+      --  side is mutably tagged we force the right hand side to be class-wide
+      --  so that they are compatible both for the purposes of checking
+      --  legality rules as well as assignment expansion.
+
+      elsif Is_Mutably_Tagged_Type (T1)
+        and then Nkind (Rhs) = N_Qualified_Expression
+      then
+         Make_Mutably_Tagged_Conversion (Rhs, T1);
+         Resolve (Rhs, T1);
+
+      --  Otherwise, resolve the right hand side normally
+
       else
          Resolve (Rhs, T1);
       end if;
@@ -765,6 +778,7 @@  package body Sem_Ch5 is
         and then not Is_Class_Wide_Type (T2)
         and then not Is_Tag_Indeterminate (Rhs)
         and then not Is_Dynamically_Tagged (Rhs)
+        and then not Is_Mutably_Tagged_Type (T1)
       then
          Error_Msg_N ("dynamically tagged expression required!", Rhs);
       end if;