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 <schonb...@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.
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 (';');
