From: Steve Baird <ba...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/atree.adb | 16 +++++++++++++---
gcc/ada/sem_ch12.adb | 6 ++++++
gcc/ada/sem_ch3.adb | 14 ++++++++------
gcc/ada/sem_ch8.adb | 14 +++++++++++++-
4 files changed, 40 insertions(+), 10 deletions(-)
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index f265526afb7..7a55b18c605 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 d2285082f97..5bddb5a8556 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 a6bc8c95cd2..70cf772edcc 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 2e6b1b6d785..5408be3e1a5 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
--
2.43.0
