ada: Legal access discriminant default expression incorrectly rejected

If a limited private partial view of a type has an access discriminant with
a default expression, and if the type (perhaps tagged, perhaps not) is
completed by deriving from an immutably limited type, then the default
discriminant expression should not be rejected.

gcc/ada/ChangeLog:

	* sem_ch6.adb (Check_Discriminant_Conformance): In testing whether
	a default expression is permitted for an access discriminant, we
	need to know whether the discriminated type is immutably limited.
	Handle another part of this test that cannot easily be handled in
	Sem_Aux.Is_Immutably_Limited. This involves declaring a new local
	function, Is_Derived_From_Immutably_Limited_Type.

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 076fb89c7b5082487420ab24fba908f672eb760f..c200871b852002dbc43f2f4a9633f36c358616b1 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6436,6 +6436,14 @@ package body Sem_Ch6 is
               (Typ : Entity_Id) return Boolean;
             --  Returns True iff Typ has a tagged limited partial view.
 
+            function Is_Derived_From_Immutably_Limited_Type
+              (Typ : Entity_Id) return Boolean;
+            --  Returns True iff Typ is a derived type (tagged or not)
+            --  whose ancestor type is immutably limited. The unusual
+            --  ("unusual" is one word for it) thing about this function
+            --  is that it handles the case where the ancestor name's Entity
+            --  attribute has not been set yet.
+
             -------------------------------------
             -- Has_Tagged_Limited_Partial_View --
             -------------------------------------
@@ -6451,6 +6459,31 @@ package body Sem_Ch6 is
                  and then Limited_Present (Parent (Priv));
             end Has_Tagged_Limited_Partial_View;
 
+            --------------------------------------------
+            -- Is_Derived_From_Immutably_Limited_Type --
+            --------------------------------------------
+
+            function Is_Derived_From_Immutably_Limited_Type
+              (Typ : Entity_Id) return Boolean
+            is
+               Type_Def : constant Node_Id := Type_Definition (Parent (Typ));
+               Parent_Name : Node_Id;
+            begin
+               if Nkind (Type_Def) /= N_Derived_Type_Definition then
+                  return False;
+               end if;
+               Parent_Name := Subtype_Indication (Type_Def);
+               if Nkind (Parent_Name) = N_Subtype_Indication then
+                  Parent_Name := Subtype_Mark (Parent_Name);
+               end if;
+               if Parent_Name not in N_Has_Entity_Id
+                 or else No (Entity (Parent_Name))
+               then
+                  Find_Type (Parent_Name);
+               end if;
+               return Is_Immutably_Limited_Type (Entity (Parent_Name));
+            end Is_Derived_From_Immutably_Limited_Type;
+
          begin
             if NewD or OldD then
 
@@ -6489,6 +6522,12 @@ package body Sem_Ch6 is
 
                  and then not Has_Tagged_Limited_Partial_View
                                 (Defining_Identifier (N))
+
+                 --  Check for another case that would be awkward to handle
+                 --  in Is_Immutably_Limited_Type
+
+                 and then not Is_Derived_From_Immutably_Limited_Type
+                                (Defining_Identifier (N))
                then
                   Error_Msg_N
                     ("(Ada 2005) default value for access discriminant "