diff options
author | Steve Baird <baird@adacore.com> | 2023-12-06 16:06:28 -0800 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2024-01-09 14:13:30 +0100 |
commit | 85f0ae3c54ad48e62ca02e61a1aa1ab3c8664142 (patch) | |
tree | f4dd6bd9d3d61b6a5fcb1370660b6587b0262850 | |
parent | c1ebec34788353bf126a1df1c75e1ee2110c8795 (diff) | |
download | gcc-85f0ae3c54ad48e62ca02e61a1aa1ab3c8664142.zip gcc-85f0ae3c54ad48e62ca02e61a1aa1ab3c8664142.tar.gz gcc-85f0ae3c54ad48e62ca02e61a1aa1ab3c8664142.tar.bz2 |
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.
-rw-r--r-- | gcc/ada/atree.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sem_ch12.adb | 6 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 14 | ||||
-rw-r--r-- | 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 f265526..7a55b18 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 d228508..5bddb5a 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 a6bc8c9..70cf772 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 2e6b1b6..5408be3 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 |