diff options
| author | Arnaud Charlet <charlet@adacore.com> | 2020-07-13 05:23:17 -0400 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2020-10-20 03:21:36 -0400 |
| commit | 8281a07f0cd02f96690b7c96a4768c68c44917a2 (patch) | |
| tree | 031e009806ec7e3bcc9dd03327d3ee06393bdc32 | |
| parent | 83dcc2bd35e5dc981a13959b9bb6750736cd6544 (diff) | |
| download | gcc-8281a07f0cd02f96690b7c96a4768c68c44917a2.zip gcc-8281a07f0cd02f96690b7c96a4768c68c44917a2.tar.gz gcc-8281a07f0cd02f96690b7c96a4768c68c44917a2.tar.bz2 | |
[Ada] Spurious discriminant check on "for of" loop
gcc/ada/
* sem_ch8.adb (Check_Constrained_Object): Suppress discriminant
checks when the type has default discriminants and comes from
expansion of a "for of" loop.
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 28 |
1 files changed, 26 insertions, 2 deletions
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 430af2d..3d50f5e 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -776,8 +776,9 @@ package body Sem_Ch8 is ------------------------------ procedure Check_Constrained_Object is - Typ : constant Entity_Id := Etype (Nam); - Subt : Entity_Id; + Typ : constant Entity_Id := Etype (Nam); + Subt : Entity_Id; + Loop_Scheme : Node_Id; begin if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference @@ -821,6 +822,29 @@ package body Sem_Ch8 is Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); Set_Etype (Nam, Subt); + -- Suppress discriminant checks on this subtype if the original + -- type has defaulted discriminants and Id is a "for of" loop + -- iterator. + + if Has_Defaulted_Discriminants (Typ) + and then Nkind (Original_Node (Parent (N))) = N_Loop_Statement + then + Loop_Scheme := Iteration_Scheme (Original_Node (Parent (N))); + + if Present (Loop_Scheme) + and then Present (Iterator_Specification (Loop_Scheme)) + and then + Defining_Identifier + (Iterator_Specification (Loop_Scheme)) = Id + then + Set_Checks_May_Be_Suppressed (Subt); + Push_Local_Suppress_Stack_Entry + (Entity => Subt, + Check => Discriminant_Check, + Suppress => True); + end if; + end if; + -- Freeze subtype at once, to prevent order of elaboration -- issues in the backend. The renamed object exists, so its -- type is already frozen in any case. |