From: Steve Baird <baird@adacore.com>
Date: Thu, 7 Dec 2023 00:06:28 +0000 (-0800)
Subject: ada: Error compiling Ada 2022 object renaming with no subtype mark
X-Git-Tag: basepoints/gcc-15~3094
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=85f0ae3c54ad48e62ca02e61a1aa1ab3c8664142;p=thirdparty%2Fgcc.git

ada: Error compiling Ada 2022 object renaming with no subtype mark

In some cases the compiler would crash or generate spurious errors
compiling a legal object renaming declaration that lacks a subtype mark.
In addition to fixing the immediate problem, change Atree.Copy_Slots
so that attempts to modify either the Empty or the Error nodes
(e.g., by passing one of them as the target in a call to Rewrite)
are ineffective. Cope with the consequences of this.

gcc/ada/

	* sem_ch8.adb (Check_Constrained_Object): Before updating the
	subtype mark of an object renaming declaration by calling Rewrite,
	first check whether the destination of the Rewrite call exists.
	* atree.adb (Copy_Slots): Return without performing any updates if
	Destination equals Empty or Error, or if Source equals Empty. Any
	of those conditions indicates an error case.
	* sem_ch12.adb (Analyze_Formal_Derived_Type): Avoid cascading
	errors.
	* sem_ch3.adb (Analyze_Number_Declaration): In an error case, do
	not pass Error as destination in a call to Rewrite.
	(Find_Type_Of_Subtype_Indic): In an error case, do not pass Error
	or Empty as destination in a call to Rewrite.
---

diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index f265526afb71..7a55b18c6058 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -1260,9 +1260,9 @@ package body Atree is
       end if;
    end Change_Node;
 
-   ----------------
-   -- Copy_Slots --
-   ----------------
+   ------------------------
+   -- Copy_Dynamic_Slots --
+   ------------------------
 
    procedure Copy_Dynamic_Slots
      (From, To : Node_Offset; Num_Slots : Slot_Count)
@@ -1282,6 +1282,10 @@ package body Atree is
       Destination_Slots := Source_Slots;
    end Copy_Dynamic_Slots;
 
+   ----------------
+   -- Copy_Slots --
+   ----------------
+
    procedure Copy_Slots (Source, Destination : Node_Id) is
       pragma Debug (Validate_Node (Source));
       pragma Assert (Source /= Destination);
@@ -1292,6 +1296,12 @@ package body Atree is
         Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
 
    begin
+      --  Empty_Or_Error use as described in types.ads
+      if Destination <= Empty_Or_Error or No (Source) then
+         pragma Assert (Serious_Errors_Detected > 0);
+         return;
+      end if;
+
       Copy_Dynamic_Slots
         (Off_F (Source), Off_F (Destination), S_Size);
       All_Node_Offsets (Destination).Slots := All_Node_Offsets (Source).Slots;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index d2285082f97c..5bddb5a8556f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -2541,6 +2541,12 @@ package body Sem_Ch12 is
          end if;
       end if;
 
+      if Subtype_Mark (Def) <= Empty_Or_Error then
+         pragma Assert (Serious_Errors_Detected > 0);
+         --  avoid passing bad argument to Entity
+         return;
+      end if;
+
       --  If the parent type has a known size, so does the formal, which makes
       --  legal representation clauses that involve the formal.
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index a6bc8c95cd28..70cf772edcc2 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3668,7 +3668,7 @@ package body Sem_Ch3 is
    --------------------------------
 
    procedure Analyze_Number_Declaration (N : Node_Id) is
-      E     : constant Node_Id   := Expression (N);
+      E     : Node_Id            := Expression (N);
       Id    : constant Entity_Id := Defining_Identifier (N);
       Index : Interp_Index;
       It    : Interp;
@@ -3694,14 +3694,13 @@ package body Sem_Ch3 is
 
       Set_Is_Pure (Id, Is_Pure (Current_Scope));
 
-      --  Process expression, replacing error by integer zero, to avoid
-      --  cascaded errors or aborts further along in the processing
-
       --  Replace Error by integer zero, which seems least likely to cause
       --  cascaded errors.
 
       if E = Error then
-         Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
+         pragma Assert (Serious_Errors_Detected > 0);
+         E := Make_Integer_Literal (Sloc (N), Uint_0);
+         Set_Expression (N, E);
          Set_Error_Posted (E);
       end if;
 
@@ -18615,7 +18614,10 @@ package body Sem_Ch3 is
       --  Otherwise we have a subtype mark without a constraint
 
       elsif Error_Posted (S) then
-         Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
+         --  Don't rewrite if S is Empty or Error
+         if S > Empty_Or_Error then
+            Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
+         end if;
          return Any_Type;
 
       else
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 2e6b1b6d7855..5408be3e1a52 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -861,7 +861,19 @@ package body Sem_Ch8 is
                    Defining_Identifier => Subt,
                    Subtype_Indication  =>
                      Make_Subtype_From_Expr (Nam, Typ)));
-               Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc));
+
+               declare
+                  New_Subtype_Mark : constant Node_Id :=
+                    New_Occurrence_Of (Subt, Loc);
+               begin
+                  if Present (Subtype_Mark (N)) then
+                     Rewrite (Subtype_Mark (N), New_Subtype_Mark);
+                  else
+                     --  An Ada2022 renaming with no subtype mark
+                     Set_Subtype_Mark (N, New_Subtype_Mark);
+                  end if;
+               end;
+
                Set_Etype (Nam, Subt);
 
                --  Suppress discriminant checks on this subtype if the original