[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.

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 430af2ded2fea8f6b9284e41094c65c51d3cff6e..3d50f5e86c36ce66fb4e508e5bb6a007cb42f7e0 100644 (file)
--- 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.