Patchwork [Ada] Ada2012-A162 incomplete type completed by partial view

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 18, 2010, 1:59 p.m.
Message ID <20101018135907.GA29888@adacore.com>
Download mbox | patch
Permalink /patch/68192/
State New
Headers show

Comments

Arnaud Charlet - Oct. 18, 2010, 1:59 p.m.
This patch incorporates the support for this new Ada 2012
feature. Incomplete types are made more useful by allowing
them to be completed by private types and private extensions.
The following test must compile without errors:

package Test_AI162 is
   type T1;

   type T2 (X : access T1) is private;
   type T1 (X : access T2) is private;
private
   type T2 (X : access T1) is record null; end record;
   type T1 (X : access T2) is record null; end record;
end;

Command: gcc -c -gnat12 test_ai162.adb

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-18  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.ads (Find_Type_Name): Add documentation.
	* sem_ch3.adb (Analyze_Full_Type_Declaration): Code cleanup because the
	propagation of the class-wide entity is now done by routine
	Find_Type_Name to factorize this code.
	(Analyze_Private_Extension_Declaration): Handle private type that
	completes an incomplete type.
	(Tag_Mismatch): Add error message for tag mismatch in a private type
	declaration that completes an incomplete type.
	(Find_Type_Name): Handle completion of incomplete type by means of
	a private declaration. Generate an error if a tagged incomplete type
	is completed by an untagged private type.
	* sem_ch7.adb (New_Private_Type): Handle private type that completes an
	incomplete type.
	* einfo.ads (Full_View): Add documentation.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165618)
+++ sem_ch3.adb	(working copy)
@@ -2171,24 +2171,10 @@  package body Sem_Ch3 is
       --  imported through a LIMITED WITH clause, it appears as incomplete
       --  but has no full view.
 
-      --  If the incomplete view is tagged, a class_wide type has been
-      --  created already. Use it for the full view as well, to prevent
-      --  multiple incompatible class-wide types that may be  created for
-      --  self-referential anonymous access components.
-
       if Ekind (Prev) = E_Incomplete_Type
         and then Present (Full_View (Prev))
       then
          T := Full_View (Prev);
-
-         if Is_Tagged_Type (Prev)
-           and then Present (Class_Wide_Type (Prev))
-         then
-            Set_Ekind (T, Ekind (Prev));         --  will be reset later
-            Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
-            Set_Etype (Class_Wide_Type (T), T);
-         end if;
-
       else
          T := Prev;
       end if;
@@ -3605,7 +3591,26 @@  package body Sem_Ch3 is
       end if;
 
       Generate_Definition (T);
-      Enter_Name (T);
+
+      if Ada_Version < Ada_2012 then
+         Enter_Name (T);
+
+      --  Ada 2012 (AI05-0162): Enter the name in the current scope handling
+      --  case of private type that completes an incomplete type.
+
+      else
+         declare
+            Prev : Entity_Id;
+
+         begin
+            Prev := Find_Type_Name (N);
+
+            pragma Assert (Prev = T
+              or else (Ekind (Prev) = E_Incomplete_Type
+                         and then Present (Full_View (Prev))
+                         and then Full_View (Prev) = T));
+         end;
+      end if;
 
       Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
       Parent_Base := Base_Type (Parent_Type);
@@ -14085,11 +14090,25 @@  package body Sem_Ch3 is
       procedure Tag_Mismatch is
       begin
          if Sloc (Prev) < Sloc (Id) then
-            Error_Msg_NE
-              ("full declaration of } must be a tagged type ", Id, Prev);
+            if Ada_Version >= Ada_2012
+              and then Nkind (N) = N_Private_Type_Declaration
+            then
+               Error_Msg_NE
+                 ("declaration of private } must be a tagged type ", Id, Prev);
+            else
+               Error_Msg_NE
+                 ("full declaration of } must be a tagged type ", Id, Prev);
+            end if;
          else
-            Error_Msg_NE
-              ("full declaration of } must be a tagged type ", Prev, Id);
+            if Ada_Version >= Ada_2012
+              and then Nkind (N) = N_Private_Type_Declaration
+            then
+               Error_Msg_NE
+                 ("declaration of private } must be a tagged type ", Prev, Id);
+            else
+               Error_Msg_NE
+                 ("full declaration of } must be a tagged type ", Prev, Id);
+            end if;
          end if;
       end Tag_Mismatch;
 
@@ -14100,21 +14119,35 @@  package body Sem_Ch3 is
 
       Prev := Current_Entity_In_Scope (Id);
 
-      if Present (Prev) then
+      --  New type declaration
+
+      if No (Prev) then
+         Enter_Name (Id);
+         return Id;
 
-         --  Previous declaration exists. Error if not incomplete/private case
-         --  except if previous declaration is implicit, etc. Enter_Name will
-         --  emit error if appropriate.
+      --  Previous declaration exists
 
+      else
          Prev_Par := Parent (Prev);
 
+         --  Error if not incomplete/private case except if previous
+         --  declaration is implicit, etc. Enter_Name will emit error if
+         --  appropriate.
+
          if not Is_Incomplete_Or_Private_Type (Prev) then
             Enter_Name (Id);
             New_Id := Id;
 
+         --  Check invalid completion of private or incomplete type
+
          elsif not Nkind_In (N, N_Full_Type_Declaration,
                                 N_Task_Type_Declaration,
                                 N_Protected_Type_Declaration)
+           and then
+             (Ada_Version < Ada_2012
+                or else not Is_Incomplete_Type (Prev)
+                or else not Nkind_In (N, N_Private_Type_Declaration,
+                                         N_Private_Extension_Declaration))
          then
             --  Completion must be a full type declarations (RM 7.3(4))
 
@@ -14136,7 +14169,11 @@  package body Sem_Ch3 is
 
          --  Case of full declaration of incomplete type
 
-         elsif Ekind (Prev) = E_Incomplete_Type then
+         elsif Ekind (Prev) = E_Incomplete_Type
+           and then (Ada_Version < Ada_2012
+                       or else No (Full_View (Prev))
+                       or else not Is_Private_Type (Full_View (Prev)))
+         then
 
             --  Indicate that the incomplete declaration has a matching full
             --  declaration. The defining occurrence of the incomplete
@@ -14153,9 +14190,34 @@  package body Sem_Ch3 is
             Set_Is_Internal (Id);
             New_Id := Prev;
 
+            --  If the incomplete view is tagged, a class_wide type has been
+            --  created already. Use it for the private type as well, in order
+            --  to prevent multiple incompatible class-wide types that may be
+            --  created for self-referential anonymous access components.
+
+            if Is_Tagged_Type (Prev)
+              and then Present (Class_Wide_Type (Prev))
+            then
+               Set_Ekind (Id, Ekind (Prev));         --  will be reset later
+               Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
+               Set_Etype (Class_Wide_Type (Id), Id);
+            end if;
+
          --  Case of full declaration of private type
 
          else
+            --  If the private type was a completion of an incomplete type then
+            --  update Prev to reference the private type
+
+            if Ada_Version >= Ada_2012
+              and then Ekind (Prev) = E_Incomplete_Type
+              and then Present (Full_View (Prev))
+              and then Is_Private_Type (Full_View (Prev))
+            then
+               Prev := Full_View (Prev);
+               Prev_Par := Parent (Prev);
+            end if;
+
             if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
                if Etype (Prev) /= Prev then
 
@@ -14273,14 +14335,30 @@  package body Sem_Ch3 is
 
          if Is_Type (Prev)
            and then (Is_Tagged_Type (Prev)
-                      or else Present (Class_Wide_Type (Prev)))
+                       or else Present (Class_Wide_Type (Prev)))
          then
+            --  Ada 2012 (AI05-0162): A private type may be the completion of
+            --  an incomplete type
+
+            if Ada_Version >= Ada_2012
+              and then Is_Incomplete_Type (Prev)
+              and then Nkind_In (N, N_Private_Type_Declaration,
+                                    N_Private_Extension_Declaration)
+            then
+               --  No need to check private extensions since they are tagged
+
+               if Nkind (N) = N_Private_Type_Declaration
+                 and then not Tagged_Present (N)
+               then
+                  Tag_Mismatch;
+               end if;
+
             --  The full declaration is either a tagged type (including
             --  a synchronized type that implements interfaces) or a
             --  type extension, otherwise this is an error.
 
-            if Nkind_In (N, N_Task_Type_Declaration,
-                            N_Protected_Type_Declaration)
+            elsif Nkind_In (N, N_Task_Type_Declaration,
+                               N_Protected_Type_Declaration)
             then
                if No (Interface_List (N))
                  and then not Error_Posted (N)
@@ -14315,12 +14393,6 @@  package body Sem_Ch3 is
          end if;
 
          return New_Id;
-
-      else
-         --  New type declaration
-
-         Enter_Name (Id);
-         return Id;
       end if;
    end Find_Type_Name;
 
Index: sem_ch3.ads
===================================================================
--- sem_ch3.ads	(revision 165610)
+++ sem_ch3.ads	(working copy)
@@ -157,7 +157,10 @@  package Sem_Ch3 is
    function Find_Type_Name (N : Node_Id) return Entity_Id;
    --  Enter the identifier in a type definition, or find the entity already
    --  declared, in the case of the full declaration of an incomplete or
-   --  private type.
+   --  private type. If the previous declaration is tagged then the class-wide
+   --  entity is propagated to the identifier to prevent multiple incompatible
+   --  class-wide types that may be created for self-referential anonymous
+   --  access components.
 
    function Get_Discriminant_Value
      (Discriminant       : Entity_Id;
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb	(revision 165618)
+++ sem_ch7.adb	(working copy)
@@ -1919,7 +1919,25 @@  package body Sem_Ch7 is
 
    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
    begin
-      Enter_Name (Id);
+      if Ada_Version < Ada_2012 then
+         Enter_Name (Id);
+
+      --  Ada 2012 (AI05-0162): Enter the name in the current scope handling
+      --  private type that completes an incomplete type.
+
+      else
+         declare
+            Prev : Entity_Id;
+
+         begin
+            Prev := Find_Type_Name (N);
+
+            pragma Assert (Prev = Id
+              or else (Ekind (Prev) = E_Incomplete_Type
+                         and then Present (Full_View (Prev))
+                         and then Full_View (Prev) = Id));
+         end;
+      end if;
 
       if Limited_Present (Def) then
          Set_Ekind (Id, E_Limited_Private_Type);
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165634)
+++ einfo.ads	(working copy)
@@ -1283,7 +1283,10 @@  package Einfo is
 --       Present in all type and subtype entities and in deferred constants.
 --       References the entity for the corresponding full type declaration.
 --       For all types other than private and incomplete types, this field
---       always contains Empty. See also Underlying_Type.
+--       always contains Empty. If an incomplete type E1 is completed by a
+--       private type E2 whose full type declaration entity is E3 then the
+--       full view of E1 is E2, and the full view of E2 is E3. See also
+--       Underlying_Type.
 
 --    Generic_Homonym (Node11)
 --       Present in generic packages. The generic homonym is the entity of