Patchwork [Ada] Implementation of AI05-213 : formal incomplete types

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 10:02 a.m.
Message ID <20110829100237.GA19643@adacore.com>
Download mbox | patch
Permalink /patch/112008/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 10:02 a.m.
Ada2012 introduce a new kind of formal type definition. An incomplete formal
type can be instantiated with any actual (as long as discriminants and tagged 
nature conform).  The actual for a formal incomplete type is not frozen by
the instance itself.

The following must compile quietly in Ada2012 mode:

---
procedure test1 is
   generic
      type Later;
   package G is
      X : Integer;
   end G;

   package Inst is new G (Integer);
    generic
       type Latest is tagged;
    package G2 is
       It : Float;
    end;
 
    type TT is tagged null record;
    package Inst2 is new G2 (TT);

    package Inner is
       type T;
       package Inst3 is new G (T);
       type T is array (1..10) of integer;
    private
   end Inner;

    package Inner2 is
       type T is private;
       package Inst3 is new G (T);
    private
       type T is array (1..10) of integer;
   end Inner2;
begin
  null;
end;

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

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb: New node kind
	N_Formal_Incomplete_Type_Definition, related flags.
	par-ch12.adb (P_Formal_Type_Declaration, G_Formal_Type_Definition):
	Parse formal incomplete types.
	* sem.adb (Analyze): Formal_Incomplete_Type_Definitions are handled in
	sem_ch12.
	* sem_ch7.adb (Analyze_Package_Specification, Unit_Requires_Body):
	Formal incomplete types do not need completion.
	* sem_ch12.adb (Analyze_Formal_Incomplete_Type,
	Validate_Incomplete_Type_Instance): New procedures to handle formal
	incomplete types.
	* freeze.adb (Freeze_Entity): Do not freeze the subtype of an actual
	that corresponds to a formal incomplete type.
	* sprint.adb: Handle formal incomplete type declarations.
	* exp_util.adb (Insert_Actions): An incomplete_type_definition is not
	an insertion point.

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 178183)
+++ exp_util.adb	(working copy)
@@ -3349,6 +3349,7 @@ 
                N_Formal_Ordinary_Fixed_Point_Definition |
                N_Formal_Package_Declaration             |
                N_Formal_Private_Type_Definition         |
+               N_Formal_Incomplete_Type_Definition      |
                N_Formal_Signed_Integer_Type_Definition  |
                N_Function_Call                          |
                N_Function_Specification                 |
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 178162)
+++ sinfo.adb	(working copy)
@@ -2930,6 +2930,7 @@ 
       (N : Node_Id) return Boolean is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Incomplete_Type_Definition
         or else NT (N).Nkind = N_Formal_Private_Type_Definition
         or else NT (N).Nkind = N_Incomplete_Type_Declaration
         or else NT (N).Nkind = N_Private_Type_Declaration
@@ -5971,6 +5972,7 @@ 
       (N : Node_Id; Val : Boolean := True) is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Incomplete_Type_Definition
         or else NT (N).Nkind = N_Formal_Private_Type_Definition
         or else NT (N).Nkind = N_Incomplete_Type_Declaration
         or else NT (N).Nkind = N_Private_Type_Declaration
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 178162)
+++ sinfo.ads	(working copy)
@@ -6209,6 +6209,7 @@ 
       --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
       --      is FORMAL_TYPE_DEFINITION
       --        [ASPECT_SPECIFICATIONS];
+      --  | type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged]
 
       --  N_Formal_Type_Declaration
       --  Sloc points to TYPE
@@ -6234,7 +6235,13 @@ 
       --  | FORMAL_ARRAY_TYPE_DEFINITION
       --  | FORMAL_ACCESS_TYPE_DEFINITION
       --  | FORMAL_INTERFACE_TYPE_DEFINITION
+      --  | FORMAL_INCOMPLETE_TYPE_DEFINITION
 
+      --  The Ada2012 syntax introduces two new non-terminals;
+      --  Formal_[Complete_| Incomplete_] Type_Declaration just to introduce
+      --  the later category. Here we introduce an incomplete type definition
+      --  in order to preserve as much as possible the existing structure.
+
       ---------------------------------------------
       -- 12.5.1  Formal Private Type Definition --
       ---------------------------------------------
@@ -6268,6 +6275,17 @@ 
       --  Synchronized_Present (Flag7)
       --  Interface_List (List2) (set to No_List if none)
 
+      ------------------------------------------------
+      -- 12.5.1  Formal Incomplete  Type Definition --
+      ------------------------------------------------
+
+      --  FORMAL_INCOMPLETE_TYPE_DEFINITION ::=
+      --  [tagged]
+
+      --  N_Formal_Incomplete_Type_Definition
+      --  Sloc points to identifier of parent
+      --  Tagged_Present (Flag15)
+
       ---------------------------------------------
       -- 12.5.2  Formal Discrete Type Definition --
       ---------------------------------------------
@@ -7805,6 +7823,7 @@ 
       N_Formal_Ordinary_Fixed_Point_Definition,
       N_Formal_Package_Declaration,
       N_Formal_Private_Type_Definition,
+      N_Formal_Incomplete_Type_Definition,
       N_Formal_Signed_Integer_Type_Definition,
       N_Freeze_Entity,
       N_Generic_Association,
@@ -11320,6 +11339,13 @@ 
         4 => False,   --  unused
         5 => False),  --  unused
 
+     N_Formal_Incomplete_Type_Definition =>
+       (1 => False,   --  unused
+        2 => False,   --  unused
+        3 => False,   --  unused
+        4 => False,   --  unused
+        5 => False),  --  unused
+
      N_Formal_Derived_Type_Definition =>
        (1 => False,   --  unused
         2 => True,    --  Interface_List (List2)
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb	(revision 178155)
+++ sem_ch7.adb	(working copy)
@@ -1195,9 +1195,11 @@ 
       while Present (E) loop
 
          --  Check on incomplete types
+         --  AI05-213 : a formal incomplete type has no completion.
 
          if Ekind (E) = E_Incomplete_Type
            and then No (Full_View (E))
+           and then not Is_Generic_Type (E)
          then
             Error_Msg_N ("no declaration in visible part for incomplete}", E);
          end if;
@@ -2585,7 +2587,9 @@ 
                and then Unit_Requires_Body (E))
 
            or else
-             (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
+             (Ekind (E) = E_Incomplete_Type
+               and then No (Full_View (E))
+               and then not Is_Generic_Type (E))
 
            or else
             ((Ekind (E) = E_Task_Type or else
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 178155)
+++ sem_ch12.adb	(working copy)
@@ -342,6 +342,9 @@ 
       Def : Node_Id);
    --  Creates a new private type, which does not require completion
 
+   procedure Analyze_Formal_Incomplete_Type (T   : Entity_Id; Def : Node_Id);
+   --  Ada2012 : Creates a new incomplete type, whose actual does not freeze.
+
    procedure Analyze_Generic_Formal_Part (N : Node_Id);
 
    procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
@@ -1300,9 +1303,14 @@ 
                        Assoc);
 
                      --  An instantiation is a freeze point for the actuals,
-                     --  unless this is a rewritten formal package.
+                     --  unless this is a rewritten formal package, and
+                     --  unless it is an Ada2012 formal incomplete type.
 
-                     if Nkind (I_Node) /= N_Formal_Package_Declaration then
+                     if Nkind (I_Node) /= N_Formal_Package_Declaration
+                       and then
+                         Ekind (Defining_Identifier (Analyzed_Formal)) /=
+                           E_Incomplete_Type
+                     then
                         Append_Elmt (Entity (Match), Actual_Types);
                      end if;
                   end if;
@@ -2361,6 +2369,26 @@ 
       Set_RM_Size   (T, RM_Size (Standard_Integer));
    end Analyze_Formal_Private_Type;
 
+   ------------------------------------
+   -- Analyze_Formal_Incomplete_Type --
+   ------------------------------------
+
+   procedure Analyze_Formal_Incomplete_Type
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+   begin
+      Enter_Name (T);
+      Set_Ekind (T, E_Incomplete_Type);
+      Set_Etype (T, T);
+
+      if Tagged_Present (Def) then
+         Set_Is_Tagged_Type (T);
+         Make_Class_Wide_Type (T);
+         Set_Direct_Primitive_Operations (T, New_Elmt_List);
+      end if;
+   end Analyze_Formal_Incomplete_Type;
+
    ----------------------------------------
    -- Analyze_Formal_Signed_Integer_Type --
    ----------------------------------------
@@ -2594,6 +2622,9 @@ 
          when N_Formal_Derived_Type_Definition         =>
             Analyze_Formal_Derived_Type (N, T, Def);
 
+         when N_Formal_Incomplete_Type_Definition         =>
+            Analyze_Formal_Incomplete_Type (T, Def);
+
          when N_Formal_Discrete_Type_Definition        =>
             Analyze_Formal_Discrete_Type (T, Def);
 
@@ -9447,9 +9478,13 @@ 
       procedure Validate_Access_Type_Instance;
       procedure Validate_Derived_Type_Instance;
       procedure Validate_Derived_Interface_Type_Instance;
+      procedure Validate_Discriminated_Formal_Type;
       procedure Validate_Interface_Type_Instance;
       procedure Validate_Private_Type_Instance;
+      procedure Validate_Incomplete_Type_Instance;
       --  These procedures perform validation tests for the named case
+      --  Validate_Discriminated_Formal_Type is shared by formal private
+      --  types and Ada2012 formal incomplete types.
 
       function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
       --  Check that base types are the same and that the subtypes match
@@ -10272,73 +10307,17 @@ 
          end if;
       end Validate_Derived_Type_Instance;
 
-      --------------------------------------
-      -- Validate_Interface_Type_Instance --
-      --------------------------------------
+      ----------------------------------------
+      -- Validate_Discriminated_Formal_Type --
+      ----------------------------------------
 
-      procedure Validate_Interface_Type_Instance is
-      begin
-         if not Is_Interface (Act_T) then
-            Error_Msg_NE
-              ("actual for formal interface type must be an interface",
-                Actual, Gen_T);
-
-         elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
-           or else
-             Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
-           or else
-             Is_Protected_Interface (A_Gen_T) /=
-               Is_Protected_Interface (Act_T)
-           or else
-             Is_Synchronized_Interface (A_Gen_T) /=
-               Is_Synchronized_Interface (Act_T)
-         then
-            Error_Msg_NE
-              ("actual for interface& does not match (RM 12.5.5(4))",
-               Actual, Gen_T);
-         end if;
-      end Validate_Interface_Type_Instance;
-
-      ------------------------------------
-      -- Validate_Private_Type_Instance --
-      ------------------------------------
-
-      procedure Validate_Private_Type_Instance is
+      procedure Validate_Discriminated_Formal_Type is
          Formal_Discr : Entity_Id;
          Actual_Discr : Entity_Id;
          Formal_Subt  : Entity_Id;
 
       begin
-         if Is_Limited_Type (Act_T)
-           and then not Is_Limited_Type (A_Gen_T)
-         then
-            Error_Msg_NE
-              ("actual for non-limited & cannot be a limited type", Actual,
-               Gen_T);
-            Explain_Limited_Type (Act_T, Actual);
-            Abandon_Instantiation (Actual);
-
-         elsif Known_To_Have_Preelab_Init (A_Gen_T)
-           and then not Has_Preelaborable_Initialization (Act_T)
-         then
-            Error_Msg_NE
-              ("actual for & must have preelaborable initialization", Actual,
-               Gen_T);
-
-         elsif Is_Indefinite_Subtype (Act_T)
-            and then not Is_Indefinite_Subtype (A_Gen_T)
-            and then Ada_Version >= Ada_95
-         then
-            Error_Msg_NE
-              ("actual for & must be a definite subtype", Actual, Gen_T);
-
-         elsif not Is_Tagged_Type (Act_T)
-           and then Is_Tagged_Type (A_Gen_T)
-         then
-            Error_Msg_NE
-              ("actual for & must be a tagged type", Actual, Gen_T);
-
-         elsif Has_Discriminants (A_Gen_T) then
+         if Has_Discriminants (A_Gen_T) then
             if not Has_Discriminants (Act_T) then
                Error_Msg_NE
                  ("actual for & must have discriminants", Actual, Gen_T);
@@ -10403,9 +10382,89 @@ 
                   Abandon_Instantiation (Actual);
                end if;
             end if;
+         end if;
+      end Validate_Discriminated_Formal_Type;
 
+      ---------------------------------------
+      -- Validate_Incomplete_Type_Instance --
+      ---------------------------------------
+
+      procedure Validate_Incomplete_Type_Instance is
+      begin
+         if not Is_Tagged_Type (Act_T)
+           and then Is_Tagged_Type (A_Gen_T)
+         then
+            Error_Msg_NE
+              ("actual for & must be a tagged type", Actual, Gen_T);
          end if;
 
+         Validate_Discriminated_Formal_Type;
+      end Validate_Incomplete_Type_Instance;
+
+      --------------------------------------
+      -- Validate_Interface_Type_Instance --
+      --------------------------------------
+
+      procedure Validate_Interface_Type_Instance is
+      begin
+         if not Is_Interface (Act_T) then
+            Error_Msg_NE
+              ("actual for formal interface type must be an interface",
+                Actual, Gen_T);
+
+         elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
+           or else
+             Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
+           or else
+             Is_Protected_Interface (A_Gen_T) /=
+               Is_Protected_Interface (Act_T)
+           or else
+             Is_Synchronized_Interface (A_Gen_T) /=
+               Is_Synchronized_Interface (Act_T)
+         then
+            Error_Msg_NE
+              ("actual for interface& does not match (RM 12.5.5(4))",
+               Actual, Gen_T);
+         end if;
+      end Validate_Interface_Type_Instance;
+
+      ------------------------------------
+      -- Validate_Private_Type_Instance --
+      ------------------------------------
+
+      procedure Validate_Private_Type_Instance is
+      begin
+         if Is_Limited_Type (Act_T)
+           and then not Is_Limited_Type (A_Gen_T)
+         then
+            Error_Msg_NE
+              ("actual for non-limited & cannot be a limited type", Actual,
+               Gen_T);
+            Explain_Limited_Type (Act_T, Actual);
+            Abandon_Instantiation (Actual);
+
+         elsif Known_To_Have_Preelab_Init (A_Gen_T)
+           and then not Has_Preelaborable_Initialization (Act_T)
+         then
+            Error_Msg_NE
+              ("actual for & must have preelaborable initialization", Actual,
+               Gen_T);
+
+         elsif Is_Indefinite_Subtype (Act_T)
+            and then not Is_Indefinite_Subtype (A_Gen_T)
+            and then Ada_Version >= Ada_95
+         then
+            Error_Msg_NE
+              ("actual for & must be a definite subtype", Actual, Gen_T);
+
+         elsif not Is_Tagged_Type (Act_T)
+           and then Is_Tagged_Type (A_Gen_T)
+         then
+            Error_Msg_NE
+              ("actual for & must be a tagged type", Actual, Gen_T);
+         end if;
+
+         Validate_Discriminated_Formal_Type;
          Ancestor := Gen_T;
       end Validate_Private_Type_Instance;
 
@@ -10463,7 +10522,13 @@ 
                       and then
                          Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
          then
-            if Is_Class_Wide_Type (Act_T)
+            --  If the formal is an incomplete type, the actual can be
+            --  incomplete as well.
+
+            if Ekind (A_Gen_T) = E_Incomplete_Type then
+               null;
+
+            elsif Is_Class_Wide_Type (Act_T)
               or else No (Full_View (Act_T))
             then
                Error_Msg_N ("premature use of incomplete type", Actual);
@@ -10486,8 +10551,15 @@ 
            and then not Is_Derived_Type (Act_T)
            and then No (Full_View (Root_Type (Act_T)))
          then
-            Error_Msg_N ("premature use of private type", Actual);
+            --  If the formal is an incomplete type, the actual can be
+            --  private or incomplete as well.
 
+            if Ekind (A_Gen_T) = E_Incomplete_Type then
+               null;
+            else
+               Error_Msg_N ("premature use of private type", Actual);
+            end if;
+
          elsif Has_Private_Component (Act_T) then
             Error_Msg_N
               ("premature use of type with private component", Actual);
@@ -10528,6 +10600,9 @@ 
             when N_Formal_Private_Type_Definition =>
                Validate_Private_Type_Instance;
 
+            when N_Formal_Incomplete_Type_Definition =>
+               Validate_Incomplete_Type_Instance;
+
             when N_Formal_Derived_Type_Definition =>
                Validate_Derived_Type_Instance;
 
@@ -10642,7 +10717,10 @@ 
             Set_Generic_Parent_Type (Decl_Node, Ancestor);
          end if;
 
-      elsif Nkind (Def) = N_Formal_Private_Type_Definition then
+      elsif Nkind_In (Def,
+        N_Formal_Private_Type_Definition,
+        N_Formal_Incomplete_Type_Definition)
+      then
          Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
       end if;
 
Index: sem.adb
===================================================================
--- sem.adb	(revision 178155)
+++ sem.adb	(working copy)
@@ -674,6 +674,7 @@ 
            N_Formal_Modular_Type_Definition         |
            N_Formal_Ordinary_Fixed_Point_Definition |
            N_Formal_Private_Type_Definition         |
+           N_Formal_Incomplete_Type_Definition      |
            N_Formal_Signed_Integer_Type_Definition  |
            N_Function_Specification                 |
            N_Generic_Association                    |
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 178183)
+++ freeze.adb	(working copy)
@@ -1259,6 +1259,13 @@ 
 
                End_Package_Scope (E);
 
+               if Is_Generic_Instance (E)
+                 and then Has_Delayed_Freeze (E)
+               then
+                  Set_Has_Delayed_Freeze (E, False);
+                  Expand_N_Package_Declaration (Unit_Declaration_Node (E));
+               end if;
+
             elsif Ekind (E) in Task_Kind
               and then
                 (Nkind (Parent (E)) = N_Task_Type_Declaration
@@ -2297,6 +2304,17 @@ 
       elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
          return No_List;
 
+      --  AI05-0213: a formal incomplete type does not freeze the actual.
+      --  In the instance, the same applies to the subtype that renames
+      --  the actual.
+
+      elsif Is_Private_Type (E)
+        and then Is_Generic_Actual_Type (E)
+        and then No (Full_View (Base_Type (E)))
+        and then Ada_Version >= Ada_2012
+      then
+         return No_List;
+
       --  Do not freeze a global entity within an inner scope created during
       --  expansion. A call to subprogram E within some internal procedure
       --  (a stream attribute for example) might require freezing E, but the
@@ -2385,6 +2403,7 @@ 
                if Nkind (Ritem) = N_Aspect_Specification
                  and then Entity (Ritem) = E
                  and then Is_Delayed_Aspect (Ritem)
+                 and then Scope (E) = Current_Scope
                then
                   Aitem := Aspect_Rep_Item (Ritem);
 
Index: par-ch12.adb
===================================================================
--- par-ch12.adb	(revision 178155)
+++ par-ch12.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -531,10 +531,39 @@ 
            (Decl_Node, P_Known_Discriminant_Part_Opt);
       end if;
 
-      T_Is;
+      if Token = Tok_Semicolon then
 
+         --  Ada2012 :  incomplete formal type
+
+         Scan; -- past semicolon
+
+         if Ada_Version < Ada_2012 then
+            Error_Msg_N
+              ("`formal incomplete type` is an Ada 2012 feature", Decl_Node);
+            Error_Msg_N
+              ("\unit must be compiled with -gnat2012 switch", Decl_Node);
+         end if;
+
+         Set_Formal_Type_Definition
+           (Decl_Node,
+             New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr));
+         return Decl_Node;
+
+      else
+         T_Is;
+      end if;
+
       Def_Node := P_Formal_Type_Definition;
 
+      if Nkind (Def_Node) = N_Formal_Incomplete_Type_Definition
+        and then Ada_Version < Ada_2012
+      then
+         Error_Msg_N
+           ("`formal incomplete type` is an Ada 2012 feature", Decl_Node);
+         Error_Msg_N
+           ("\unit must be compiled with -gnat2012 switch", Decl_Node);
+      end if;
+
       if Def_Node /= Error then
          Set_Formal_Type_Definition (Decl_Node, Def_Node);
          P_Aspect_Specifications (Decl_Node);
@@ -563,6 +592,7 @@ 
 
    --  FORMAL_TYPE_DEFINITION ::=
    --    FORMAL_PRIVATE_TYPE_DEFINITION
+   --  | FORMAL_INCOMPLETE_TYPE_DEFINITION
    --  | FORMAL_DERIVED_TYPE_DEFINITION
    --  | FORMAL_DISCRETE_TYPE_DEFINITION
    --  | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION
@@ -704,10 +734,22 @@ 
                return Error;
             end if;
 
-         when Tok_Private |
-              Tok_Tagged  =>
+         when Tok_Private  =>
             return P_Formal_Private_Type_Definition;
 
+         when  Tok_Tagged  =>
+            if Next_Token_Is (Tok_Semicolon) then
+               Typedef_Node :=
+                 New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr);
+               Set_Tagged_Present (Typedef_Node);
+
+               Scan;  --  past tagged
+               return Typedef_Node;
+
+            else
+               return P_Formal_Private_Type_Definition;
+            end if;
+
          when Tok_Range =>
             return P_Formal_Signed_Integer_Type_Definition;
 
Index: sprint.adb
===================================================================
--- sprint.adb	(revision 178155)
+++ sprint.adb	(working copy)
@@ -1801,6 +1801,11 @@ 
 
             Write_Str_With_Col_Check_Sloc ("private");
 
+         when N_Formal_Incomplete_Type_Definition =>
+            if Tagged_Present (Node) then
+               Write_Str_With_Col_Check ("is tagged ");
+            end if;
+
          when N_Formal_Signed_Integer_Type_Definition =>
             Write_Str_With_Col_Check_Sloc ("range <>");
 
@@ -1814,7 +1819,12 @@ 
                Write_Str_With_Col_Check ("(<>)");
             end if;
 
-            Write_Str_With_Col_Check (" is ");
+            if Nkind (Formal_Type_Definition (Node)) /=
+                N_Formal_Incomplete_Type_Definition
+            then
+               Write_Str_With_Col_Check (" is ");
+            end if;
+
             Sprint_Node (Formal_Type_Definition (Node));
             Write_Char (';');