[Ada] Self reference access discriminant

gcc/ada/

	* sem_ch3.adb (Check_Anonymous_Access_Component): Factor out
	core processing of Check_Anonymous_Access_Components.
	(Check_Anonymous_Access_Components): Call
	Check_Anonymous_Access_Component.
	(Process_Discriminants): Call Check_Anonymous_Access_Component.
	* freeze.adb (Freeze_Record_Type): Code cleanups and add more tree
	checking to handle changes in sem_ch3.adb.
	* sem_ch8.adb (Find_Type): Remove special case for access
	discriminant in task types, these are now supported.

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index cbdecaa7552f9ebc7cabe31d64a7156caeb85715..bf20cbcef44888e352ab4e93461c3c11c8d50b0b 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4002,11 +4002,6 @@ package body Freeze is
          --  Set True if we find at least one component with no component
          --  clause (used to warn about useless Pack pragmas).
 
-         function Check_Allocator (N : Node_Id) return Node_Id;
-         --  If N is an allocator, possibly wrapped in one or more level of
-         --  qualified expression(s), return the inner allocator node, else
-         --  return Empty.
-
          procedure Check_Itype (Typ : Entity_Id);
          --  If the component subtype is an access to a constrained subtype of
          --  an already frozen type, make the subtype frozen as well. It might
@@ -4022,25 +4017,6 @@ package body Freeze is
          --  variants referenceed by the Variant_Part VP are frozen. This is
          --  a recursive routine to deal with nested variants.
 
-         ---------------------
-         -- Check_Allocator --
-         ---------------------
-
-         function Check_Allocator (N : Node_Id) return Node_Id is
-            Inner : Node_Id;
-         begin
-            Inner := N;
-            loop
-               if Nkind (Inner) = N_Allocator then
-                  return Inner;
-               elsif Nkind (Inner) = N_Qualified_Expression then
-                  Inner := Expression (Inner);
-               else
-                  return Empty;
-               end if;
-            end loop;
-         end Check_Allocator;
-
          -----------------
          -- Check_Itype --
          -----------------
@@ -4355,22 +4331,24 @@ package body Freeze is
 
             elsif Is_Access_Type (Etype (Comp))
               and then Present (Parent (Comp))
+              and then
+                Nkind (Parent (Comp))
+                  in N_Component_Declaration | N_Discriminant_Specification
               and then Present (Expression (Parent (Comp)))
             then
                declare
                   Alloc : constant Node_Id :=
-                            Check_Allocator (Expression (Parent (Comp)));
+                            Unqualify (Expression (Parent (Comp)));
 
                begin
-                  if Present (Alloc) then
+                  if Nkind (Alloc) = N_Allocator then
 
                      --  If component is pointer to a class-wide type, freeze
                      --  the specific type in the expression being allocated.
                      --  The expression may be a subtype indication, in which
                      --  case freeze the subtype mark.
 
-                     if Is_Class_Wide_Type
-                          (Designated_Type (Etype (Comp)))
+                     if Is_Class_Wide_Type (Designated_Type (Etype (Comp)))
                      then
                         if Is_Entity_Name (Expression (Alloc)) then
                            Freeze_And_Append
@@ -4382,17 +4360,14 @@ package body Freeze is
                             (Entity (Subtype_Mark (Expression (Alloc))),
                              N, Result);
                         end if;
-
                      elsif Is_Itype (Designated_Type (Etype (Comp))) then
                         Check_Itype (Etype (Comp));
-
                      else
                         Freeze_And_Append
                           (Designated_Type (Etype (Comp)), N, Result);
                      end if;
                   end if;
                end;
-
             elsif Is_Access_Type (Etype (Comp))
               and then Is_Itype (Designated_Type (Etype (Comp)))
             then

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 478439781871d4638e0d271208fc58f995807ce2..eb28a694a5c942f30f0c031b9d2d440ad0794857 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -245,11 +245,12 @@ package body Sem_Ch3 is
    --  belongs must be a concurrent type or a descendant of a type with
    --  the reserved word 'limited' in its declaration.
 
-   procedure Check_Anonymous_Access_Components
-      (Typ_Decl  : Node_Id;
-       Typ       : Entity_Id;
-       Prev      : Entity_Id;
-       Comp_List : Node_Id);
+   procedure Check_Anonymous_Access_Component
+     (Typ_Decl   : Node_Id;
+      Typ        : Entity_Id;
+      Prev       : Entity_Id;
+      Comp_Def   : Node_Id;
+      Access_Def : Node_Id);
    --  Ada 2005 AI-382: an access component in a record definition can refer to
    --  the enclosing record, in which case it denotes the type itself, and not
    --  the current instance of the type. We create an anonymous access type for
@@ -259,6 +260,13 @@ package body Sem_Ch3 is
    --  circularity issues in Gigi. We create an incomplete type for the record
    --  declaration, which is the designated type of the anonymous access.
 
+   procedure Check_Anonymous_Access_Components
+     (Typ_Decl  : Node_Id;
+      Typ       : Entity_Id;
+      Prev      : Entity_Id;
+      Comp_List : Node_Id);
+   --  Call Check_Anonymous_Access_Component on Comp_List
+
    procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id);
    --  Check that, if a new discriminant is used in a constraint defining the
    --  parent subtype of a derivation, its subtype is statically compatible
@@ -11157,21 +11165,20 @@ package body Sem_Ch3 is
       end if;
    end Check_Aliased_Component_Types;
 
-   ---------------------------------------
-   -- Check_Anonymous_Access_Components --
-   ---------------------------------------
+   --------------------------------------
+   -- Check_Anonymous_Access_Component --
+   --------------------------------------
 
-   procedure Check_Anonymous_Access_Components
-      (Typ_Decl  : Node_Id;
-       Typ       : Entity_Id;
-       Prev      : Entity_Id;
-       Comp_List : Node_Id)
+   procedure Check_Anonymous_Access_Component
+     (Typ_Decl   : Node_Id;
+      Typ        : Entity_Id;
+      Prev       : Entity_Id;
+      Comp_Def   : Node_Id;
+      Access_Def : Node_Id)
    is
-      Loc         : constant Source_Ptr := Sloc (Typ_Decl);
+      Loc         : constant Source_Ptr := Sloc (Comp_Def);
       Anon_Access : Entity_Id;
       Acc_Def     : Node_Id;
-      Comp        : Node_Id;
-      Comp_Def    : Node_Id;
       Decl        : Node_Id;
       Type_Def    : Node_Id;
 
@@ -11205,13 +11212,18 @@ package body Sem_Ch3 is
          --  Is_Tagged indicates whether the type is tagged. It is tagged if
          --  it's "is new ... with record" or else "is tagged record ...".
 
+         Typ_Def   : constant Node_Id :=
+           (if Nkind (Typ_Decl) = N_Full_Type_Declaration
+            then Type_Definition (Typ_Decl) else Empty);
          Is_Tagged : constant Boolean :=
-             (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
-               and then
-                 Present (Record_Extension_Part (Type_Definition (Typ_Decl))))
-           or else
-             (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
-               and then Tagged_Present (Type_Definition (Typ_Decl)));
+           Present (Typ_Def)
+             and then
+               ((Nkind (Typ_Def) = N_Derived_Type_Definition
+                  and then
+                    Present (Record_Extension_Part (Typ_Def)))
+                or else
+                  (Nkind (Typ_Def) = N_Record_Definition
+                    and then Tagged_Present (Typ_Def)));
 
       begin
          --  If there is a previous partial view, no need to create a new one
@@ -11429,88 +11441,104 @@ package body Sem_Ch3 is
          return False;
       end Mentions_T;
 
-   --  Start of processing for Check_Anonymous_Access_Components
+   --  Start of processing for Check_Anonymous_Access_Component
 
    begin
-      if No (Comp_List) then
-         return;
-      end if;
+      if Present (Access_Def) and then Mentions_T (Access_Def) then
+         Acc_Def := Access_To_Subprogram_Definition (Access_Def);
 
-      Comp := First (Component_Items (Comp_List));
-      while Present (Comp) loop
-         if Nkind (Comp) = N_Component_Declaration
-           and then Present
-             (Access_Definition (Component_Definition (Comp)))
-           and then
-             Mentions_T (Access_Definition (Component_Definition (Comp)))
-         then
-            Comp_Def := Component_Definition (Comp);
-            Acc_Def :=
-              Access_To_Subprogram_Definition (Access_Definition (Comp_Def));
-
-            Build_Incomplete_Type_Declaration;
-            Anon_Access := Make_Temporary (Loc, 'S');
-
-            --  Create a declaration for the anonymous access type: either
-            --  an access_to_object or an access_to_subprogram.
-
-            if Present (Acc_Def) then
-               if Nkind (Acc_Def) = N_Access_Function_Definition then
-                  Type_Def :=
-                    Make_Access_Function_Definition (Loc,
-                      Parameter_Specifications =>
-                        Parameter_Specifications (Acc_Def),
-                      Result_Definition        => Result_Definition (Acc_Def));
-               else
-                  Type_Def :=
-                    Make_Access_Procedure_Definition (Loc,
-                      Parameter_Specifications =>
-                        Parameter_Specifications (Acc_Def));
-               end if;
+         Build_Incomplete_Type_Declaration;
+         Anon_Access := Make_Temporary (Loc, 'S');
 
+         --  Create a declaration for the anonymous access type: either
+         --  an access_to_object or an access_to_subprogram.
+
+         if Present (Acc_Def) then
+            if Nkind (Acc_Def) = N_Access_Function_Definition then
+               Type_Def :=
+                 Make_Access_Function_Definition (Loc,
+                   Parameter_Specifications =>
+                     Parameter_Specifications (Acc_Def),
+                   Result_Definition        => Result_Definition (Acc_Def));
             else
                Type_Def :=
-                 Make_Access_To_Object_Definition (Loc,
-                   Subtype_Indication =>
-                      Relocate_Node
-                        (Subtype_Mark (Access_Definition (Comp_Def))));
-
-               Set_Constant_Present
-                 (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
-               Set_All_Present
-                 (Type_Def, All_Present (Access_Definition (Comp_Def)));
+                 Make_Access_Procedure_Definition (Loc,
+                   Parameter_Specifications =>
+                     Parameter_Specifications (Acc_Def));
             end if;
 
-            Set_Null_Exclusion_Present
-              (Type_Def,
-               Null_Exclusion_Present (Access_Definition (Comp_Def)));
+         else
+            Type_Def :=
+              Make_Access_To_Object_Definition (Loc,
+                Subtype_Indication =>
+                   Relocate_Node (Subtype_Mark (Access_Def)));
 
-            Decl :=
-              Make_Full_Type_Declaration (Loc,
-                Defining_Identifier => Anon_Access,
-                Type_Definition     => Type_Def);
+            Set_Constant_Present (Type_Def, Constant_Present (Access_Def));
+            Set_All_Present (Type_Def, All_Present (Access_Def));
+         end if;
 
-            Insert_Before (Typ_Decl, Decl);
-            Analyze (Decl);
+         Set_Null_Exclusion_Present
+           (Type_Def, Null_Exclusion_Present (Access_Def));
 
-            --  If an access to subprogram, create the extra formals
+         Decl :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Anon_Access,
+             Type_Definition     => Type_Def);
 
-            if Present (Acc_Def) then
-               Create_Extra_Formals (Designated_Type (Anon_Access));
-            end if;
+         Insert_Before (Typ_Decl, Decl);
+         Analyze (Decl);
+
+         --  If an access to subprogram, create the extra formals
 
+         if Present (Acc_Def) then
+            Create_Extra_Formals (Designated_Type (Anon_Access));
+         end if;
+
+         if Nkind (Comp_Def) = N_Component_Definition then
             Rewrite (Comp_Def,
               Make_Component_Definition (Loc,
-                Subtype_Indication =>
-               New_Occurrence_Of (Anon_Access, Loc)));
+                Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc)));
+         else
+            pragma Assert (Nkind (Comp_Def) = N_Discriminant_Specification);
+            Rewrite (Comp_Def,
+              Make_Discriminant_Specification (Loc,
+                Defining_Identifier => Defining_Identifier (Comp_Def),
+                Discriminant_Type   => New_Occurrence_Of (Anon_Access, Loc)));
+         end if;
 
-            if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
-               Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
-            else
-               Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
-            end if;
+         if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
+            Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
+         else
+            Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
+         end if;
+
+         Set_Is_Local_Anonymous_Access (Anon_Access);
+      end if;
+   end Check_Anonymous_Access_Component;
+
+   ---------------------------------------
+   -- Check_Anonymous_Access_Components --
+   ---------------------------------------
 
-            Set_Is_Local_Anonymous_Access (Anon_Access);
+   procedure Check_Anonymous_Access_Components
+     (Typ_Decl  : Node_Id;
+      Typ       : Entity_Id;
+      Prev      : Entity_Id;
+      Comp_List : Node_Id)
+   is
+      Comp : Node_Id;
+   begin
+      if No (Comp_List) then
+         return;
+      end if;
+
+      Comp := First (Component_Items (Comp_List));
+      while Present (Comp) loop
+         if Nkind (Comp) = N_Component_Declaration then
+            Check_Anonymous_Access_Component
+              (Typ_Decl, Typ, Prev,
+               Component_Definition (Comp),
+               Access_Definition (Component_Definition (Comp)));
          end if;
 
          Next (Comp);
@@ -20041,19 +20069,34 @@ package body Sem_Ch3 is
          end if;
 
          if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
-            Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
+            Check_Anonymous_Access_Component
+              (Typ_Decl   => N,
+               Typ        => Defining_Identifier (N),
+               Prev       => Prev,
+               Comp_Def   => Discr,
+               Access_Def => Discriminant_Type (Discr));
+
+            --  if Check_Anonymous_Access_Component replaced Discr then
+            --  its Original_Node points to the old Discr and the access type
+            --  for Discr_Type has already been created.
+
+            if Original_Node (Discr) /= Discr then
+               Discr_Type := Etype (Discriminant_Type (Discr));
+            else
+               Discr_Type :=
+                 Access_Definition (Discr, Discriminant_Type (Discr));
 
-            --  Ada 2005 (AI-254)
+               --  Ada 2005 (AI-254)
 
-            if Present (Access_To_Subprogram_Definition
-                         (Discriminant_Type (Discr)))
-              and then Protected_Present (Access_To_Subprogram_Definition
-                                           (Discriminant_Type (Discr)))
-            then
-               Discr_Type :=
-                 Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
+               if Present (Access_To_Subprogram_Definition
+                            (Discriminant_Type (Discr)))
+                 and then Protected_Present (Access_To_Subprogram_Definition
+                                              (Discriminant_Type (Discr)))
+               then
+                  Discr_Type :=
+                    Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
+               end if;
             end if;
-
          else
             Find_Type (Discriminant_Type (Discr));
             Discr_Type := Etype (Discriminant_Type (Discr));

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 817cba97bea6bd70143d442106fba4b920587183..62ebaa34fc26c00497a63ae3996ea642715a1d25 100644 (file)
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -8128,25 +8128,14 @@ package body Sem_Ch8 is
                if Ekind (Base_Type (T_Name)) = E_Task_Type then
 
                   --  In Ada 2005, a task name can be used in an access
-                  --  definition within its own body. It cannot be used
-                  --  in the discriminant part of the task declaration,
-                  --  nor anywhere else in the declaration because entries
-                  --  cannot have access parameters.
+                  --  definition within its own body.
 
                   if Ada_Version >= Ada_2005
                     and then Nkind (Parent (N)) = N_Access_Definition
                   then
                      Set_Entity (N, T_Name);
                      Set_Etype  (N, T_Name);
-
-                     if Has_Completion (T_Name) then
-                        return;
-
-                     else
-                        Error_Msg_N
-                          ("task type cannot be used as type mark " &
-                           "within its own declaration", N);
-                     end if;
+                     return;
 
                   else
                      Error_Msg_N