[Ada] ICE handling discriminant-dependent index constraint for access component

The compiler would fail with an internal error in some cases involving
a discriminated record type that provides a discriminant-dependent index
constraint for the subtype of a component of an access-to-array type when a
dereference of that component of some object is mentioned in a pre- or
postcondition expression.

gcc/ada/

	* sem_ch4.adb
	(Analyze_Selected_Component): Define new Boolean-valued function,
	Constraint_Has_Unprefixed_Discriminant_Reference, which takes a
	subtype that is subject to a discriminant-dependent constraint and
	returns True if any of the constraint values are unprefixed
	discriminant names. Usually, the Etype of a selected component
	node is set to Etype of the component. However, in the case of an
	access-to-array component for which this predicate returns True,
	we instead use the base type of the Etype of the component.
	Normally such problematic discriminant references are addressed by
	calling Build_Actual_Subtype_Of_Component, but that doesn't work
	if Full_Analyze is False.

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index ed2f621c9d9519712ca3bfc31796fb516daa2fc3..b63b5c862c62ea64141c746db592a5c5967940a4 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -4814,6 +4814,14 @@ package body Sem_Ch4 is
       Is_Single_Concurrent_Object : Boolean;
       --  Set True if the prefix is a single task or a single protected object
 
+      function Constraint_Has_Unprefixed_Discriminant_Reference
+        (Typ : Entity_Id) return Boolean;
+      --  Given a subtype that is subject to a discriminant-dependent
+      --  constraint, returns True if any of the values of the constraint
+      --  (i.e., any of the index values for an index constraint, any of
+      --  the discriminant values for a discriminant constraint)
+      --  are unprefixed discriminant names.
+
       procedure Find_Component_In_Instance (Rec : Entity_Id);
       --  In an instance, a component of a private extension may not be visible
       --  while it was visible in the generic. Search candidate scope for a
@@ -4842,6 +4850,56 @@ package body Sem_Ch4 is
       --  _Procedure, and collect all its interpretations (since it may be an
       --  overloaded interface primitive); otherwise return False.
 
+      ------------------------------------------------------
+      -- Constraint_Has_Unprefixed_Discriminant_Reference --
+      ------------------------------------------------------
+
+      function Constraint_Has_Unprefixed_Discriminant_Reference
+        (Typ : Entity_Id) return Boolean
+      is
+
+         function Is_Discriminant_Name (N : Node_Id) return Boolean is
+           ((Nkind (N) = N_Identifier)
+              and then (Ekind (Entity (N)) = E_Discriminant));
+      begin
+         if Is_Array_Type (Typ) then
+            declare
+               Index : Node_Id := First_Index (Typ);
+               Rng   : Node_Id;
+            begin
+               while Present (Index) loop
+                  Rng := Index;
+                  if Nkind (Rng) = N_Subtype_Indication then
+                     Rng := Range_Expression (Constraint (Rng));
+                  end if;
+
+                  if Nkind (Rng) = N_Range then
+                     if Is_Discriminant_Name (Low_Bound (Rng))
+                       or else Is_Discriminant_Name (High_Bound (Rng))
+                     then
+                        return True;
+                     end if;
+                  end if;
+
+                  Next_Index (Index);
+               end loop;
+            end;
+         else
+            declare
+               Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Typ));
+            begin
+               while Present (Elmt) loop
+                  if Is_Discriminant_Name (Node (Elmt)) then
+                     return True;
+                  end if;
+                  Next_Elmt (Elmt);
+               end loop;
+            end;
+         end if;
+
+         return False;
+      end Constraint_Has_Unprefixed_Discriminant_Reference;
+
       --------------------------------
       -- Find_Component_In_Instance --
       --------------------------------
@@ -5289,6 +5347,33 @@ package body Sem_Ch4 is
                      end;
                   end if;
 
+               --  If Etype (Comp) is an access type whose designated subtype
+               --  is constrained by an unprefixed discriminant value,
+               --  then ideally we would build a new subtype with an
+               --  appropriately prefixed discriminant value and use that
+               --  instead, as is done in Build_Actual_Subtype_Of_Component.
+               --  That turns out to be difficult in this context (with
+               --  Full_Analysis = False, we could be processing a selected
+               --  component that occurs in a Postcondition pragma;
+               --  PPC pragmas are odd because they can contain references
+               --  to formal parameters that occur outside the subprogram).
+               --  So instead we punt on building a new subtype and we
+               --  use the base type instead. This might introduce
+               --  correctness problems if N were the target of an
+               --  assignment (because a required check might be omitted);
+               --  fortunately, that's impossible because a reference to the
+               --  current instance of a type does not denote a variable view
+               --  when the reference occurs within an aspect_specification.
+               --  GNAT's Precondition and Postcondition pragmas follow the
+               --  same rules as a Pre or Post aspect_specification.
+
+               elsif Has_Discriminant_Dependent_Constraint (Comp)
+                 and then Ekind (Etype (Comp)) = E_Access_Subtype
+                 and then Constraint_Has_Unprefixed_Discriminant_Reference
+                            (Designated_Type (Etype (Comp)))
+               then
+                  Set_Etype (N, Base_Type (Etype (Comp)));
+
                --  If Full_Analysis not enabled, just set the Etype
 
                else