+2011-08-29 Matthew Heaney <heaney@adacore.com>
+
+ * a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Splice_Subtree): Only check
+ for sibling when common parent.
+
+2011-08-29 Thomas Quinot <quinot@adacore.com>
+
+ * get_scos.adb: Literals of Pragma_Id are pragma names prefixed with
+ "pragma_".
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Enable freeze actions
+ for the return type when in ASIS mode.
+
+2011-08-29 Vincent Celier <celier@adacore.com>
+
+ * make.adb (Gnatmake): Get the default search dirs, then the target
+ parameters after getting the Builder switches, as the Builder switches
+ may include --RTS= and that could change the default search dirs.
+
+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Make_Adjust_Call): Rewrite to mimic the structure of
+ Make_Final_Call. Move the processing for class-wide types before the
+ processing for derivations from [Limited_]Controlled.
+ (Make_Final_Call): Move the processing for class-wide types before the
+ processing for derivations from [Limited_]Controlled.
+ * s-stposu.adb (Allocate_Any_Controlled): Correct the membership check.
+ Add code to account for alignments larger than the list header. Add a
+ comment illustrating the structure of the allocated object + padding +
+ header.
+ (Deallocate_Any_Controlled): Add code to account for alignments larger
+ than the list header.
+
+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.
+
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* a-fihema.ads, a-fihema.adb: Unit removed.
end if;
if Target'Address = Source'Address then
- if Before = No_Element then
- if Target.Nodes (Position.Node).Next <= 0 then -- last child
+ if Target.Nodes (Position.Node).Parent = Parent.Node then
+ if Before = No_Element then
+ if Target.Nodes (Position.Node).Next <= 0 then -- last child
+ return;
+ end if;
+
+ elsif Position.Node = Before.Node then
return;
- end if;
- elsif Position.Node = Before.Node then
- return;
+ elsif Target.Nodes (Position.Node).Next = Before.Node then
+ return;
+ end if;
end if;
if Target.Busy > 0 then
raise Constraint_Error with "Position cursor designates root";
end if;
- if Before = No_Element then
- if Container.Nodes (Position.Node).Next <= 0 then -- last child
+ if Container.Nodes (Position.Node).Parent = Parent.Node then
+ if Before = No_Element then
+ if Container.Nodes (Position.Node).Next <= 0 then -- last child
+ return;
+ end if;
+
+ elsif Position.Node = Before.Node then
return;
- end if;
- elsif Position.Node = Before.Node then
- return;
+ elsif Container.Nodes (Position.Node).Next = Before.Node then
+ return;
+ end if;
end if;
if Container.Busy > 0 then
Target_Count : Count_Type;
begin
+ -- This is a utility operation to do the heavy lifting associated with
+ -- splicing a subtree from one tree to another. Note that "splicing"
+ -- is a bit of a misnomer here in the case of a bounded tree, because
+ -- the elements must be copied from the source to the target.
+
if Target.Count > Target.Capacity - Source_Count then
raise Capacity_Error -- ???
with "Source count exceeds available storage on Target";
pragma Assert (Target_Count = Source_Count);
+ -- Now link the newly-allocated subtree into the target.
+
Insert_Subtree_Node
(Container => Target,
Subtree => Target_Subtree,
Target.Count := Target.Count + Target_Count;
+ -- The manipulation of the Target container is complete. Now we remove
+ -- the subtree from the Source container.
+
+ Remove_Subtree (Source, Position); -- unlink the subtree
+
-- As with Copy_Subtree, operation Deallocate_Subtree returns a count of
-- the number of nodes it deallocates, but it works by incrementing the
-- value passed in. We must therefore initialize the count before
Source_Count := 0;
- Deallocate_Children (Source, Position, Source_Count);
+ Deallocate_Subtree (Source, Position, Source_Count);
pragma Assert (Source_Count = Target_Count);
Source.Count := Source.Count - Source_Count;
end if;
if Target'Address = Source'Address then
- if Position.Node = Before.Node
- or else Position.Node.Next = Before.Node
- then
- return;
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
end if;
if Target.Busy > 0 then
raise Constraint_Error with "Position cursor designates root";
end if;
- if Position.Node = Before.Node
- or else Position.Node.Next = Before.Node
- then
- return;
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
end if;
if Container.Busy > 0 then
end if;
if Target'Address = Source'Address then
- if Position.Node = Before.Node
- or else Position.Node.Next = Before.Node
- then
- return;
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
end if;
if Target.Busy > 0 then
raise Constraint_Error with "Position cursor designates root";
end if;
- if Position.Node = Before.Node
- or else Position.Node.Next = Before.Node
- then
- return;
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
end if;
if Container.Busy > 0 then
Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
end if;
- -- For types that are both controlled and have controlled components,
- -- generate a call to Deep_Adjust.
-
- elsif Is_Controlled (Utyp)
- and then Has_Controlled_Component (Utyp)
- then
- Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
-
- -- For types that are not controlled themselves, but contain controlled
- -- components or can be extended by types with controlled components,
- -- create a call to Deep_Adjust.
+ -- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
+ or else Is_Interface (Typ)
or else Has_Controlled_Component (Utyp)
then
if Is_Tagged_Type (Utyp) then
Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
end if;
- -- For types that are derived from Controlled and do not have controlled
- -- components, build a call to Adjust.
+ -- Derivations from [Limited_]Controlled
+
+ elsif Is_Controlled (Utyp) then
+ if Has_Controlled_Component (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+ else
+ Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ end if;
+
+ -- Tagged types
+
+ elsif Is_Tagged_Type (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
else
- Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ raise Program_Error;
end if;
if Present (Adj_Id) then
-- have discriminants and contain variant parts. Generate:
--
-- begin
- -- Root_Controlled (V).Finalized := False;
- --
-- begin
-- [Deep_]Adjust (V.Comp_1);
-- exception
-- Raised : Boolean := False;
--
-- begin
- -- if Root_Controlled (V).Finalized then
- -- return;
- -- end if;
- --
-- if F then
-- begin
-- Finalize (V); -- If applicable
-- end if;
-- end;
--
- -- Root_Controlled (V).Finalized := True;
- --
-- if Raised then
-- Raise_From_Controlled_Object (E, Abort);
-- end if;
-- Raised : Boolean := False;
-- begin
- -- Root_Controlled (V).Finalized := False;
-
-- <adjust statements>
-- if Raised then
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
end if;
- -- Derivations from [Limited_]Controlled
-
- elsif Is_Controlled (Utyp) then
- if Has_Controlled_Component (Utyp) then
- Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
- else
- Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
- end if;
-
-- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
end if;
+ -- Derivations from [Limited_]Controlled
+
+ elsif Is_Controlled (Utyp) then
+ if Has_Controlled_Component (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+ else
+ Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ end if;
+
-- Tagged types
elsif Is_Tagged_Type (Utyp) then
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 |
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
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
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);
Skipc;
begin
- Pid := Pragma_Id'Value (Buf (1 .. N));
+ Pid :=
+ Pragma_Id'Value ("pragma_" & Buf (1 .. N));
exception
when Constraint_Error =>
-- are not supposed to change.
Osint.Source_File_Data (Cache => True);
- Osint.Add_Default_Search_Dirs;
+
Queue_Library_Project_Sources;
end if;
("nothing to do for a main project that is externally built");
end if;
- -- Get the target parameters, which are only needed for a couple of
- -- cases in gnatmake. Protect against an exception, such as the case of
- -- system.ads missing from the library, and fail gracefully.
-
- begin
- Targparm.Get_Target_Parameters;
- exception
- when Unrecoverable_Error =>
- Make_Failed ("*** make failed.");
- end;
-
-- Special processing for VM targets
if Targparm.VM_Target /= No_VM then
Compute_Builder => Is_First_Main,
Current_Work_Dir => Current_Work_Dir.all);
- Is_First_Main := False;
+ if Is_First_Main then
+ -- Put the default source dirs in the source path only now,
+ -- so that we take the correct ones in the case when --RTS= is
+ -- specified in the Builder switches.
+
+ Osint.Add_Default_Search_Dirs;
+
+ -- Get the target parameters, which are only needed for a couple
+ -- of cases in gnatmake. Protect against an exception, such as the
+ -- case of system.ads missing from the library, and fail
+ -- gracefully.
+
+ begin
+ Targparm.Get_Target_Parameters;
+ exception
+ when Unrecoverable_Error =>
+ Make_Failed ("*** make failed.");
+ end;
+
+ Is_First_Main := False;
+ end if;
+
Executable_Obsolete := False;
Compute_Executable
-- --
-- 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- --
(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);
-- FORMAL_TYPE_DEFINITION ::=
-- FORMAL_PRIVATE_TYPE_DEFINITION
+ -- | FORMAL_INCOMPLETE_TYPE_DEFINITION
-- | FORMAL_DERIVED_TYPE_DEFINITION
-- | FORMAL_DISCRETE_TYPE_DEFINITION
-- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION
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;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True)
is
- -- ??? This membership test gives the wrong result when Pool has
- -- subpools.
-
Is_Subpool_Allocation : constant Boolean :=
- Pool in Root_Storage_Pool_With_Subpools;
+ Pool in Root_Storage_Pool_With_Subpools'Class;
Master : Finalization_Master_Ptr := null;
N_Addr : Address;
N_Size : Storage_Count;
Subpool : Subpool_Handle := null;
+ Header_And_Padding : Storage_Offset;
+ -- This offset includes the size of a FM_Node plus any additional
+ -- padding due to a larger alignment.
+
begin
-- Step 1: Pool-related runtime checks
Master := Context_Master;
end if;
- -- Step 2: Master-related runtime checks
+ -- Step 2: Master-related runtime checks and size calculations
-- Allocation of a descendant from [Limited_]Controlled, a class-wide
-- object or a record with controlled components.
raise Program_Error with "allocation after finalization started";
end if;
- -- The size must acount for the hidden header preceding the object
+ -- The size must acount for the hidden header preceding the object.
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
+
+ if Alignment > Header_Size then
+ Header_And_Padding := Alignment;
+ else
+ Header_And_Padding := Header_Size;
+ end if;
- N_Size := Storage_Size + Header_Size;
+ N_Size := Storage_Size + Header_And_Padding;
-- Non-controlled allocation
if Is_Controlled then
-- Map the allocated memory into a FM_Node record. This converts the
- -- top of the allocated bits into a list header.
-
- N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+ -- top of the allocated bits into a list header. If there is padding
+ -- due to larger alignment, the header is placed right next to the
+ -- object:
+
+ -- N_Addr N_Ptr
+ -- | |
+ -- V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
+
+ N_Ptr :=
+ Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
- Addr := N_Addr + Header_Offset;
+ Addr := N_Addr + Header_And_Padding;
else
Addr := N_Addr;
end if;
N_Ptr : FM_Node_Ptr;
N_Size : Storage_Count;
+ Header_And_Padding : Storage_Offset;
+ -- This offset includes the size of a FM_Node plus any additional
+ -- padding due to a larger alignment.
+
begin
-- Step 1: Detachment
if Is_Controlled then
+ if Alignment > Header_Size then
+ Header_And_Padding := Alignment;
+ else
+ Header_And_Padding := Header_Size;
+ end if;
- -- Move the address from the object to the beginning of the list
- -- header.
-
- N_Addr := Addr - Header_Offset;
+ -- N_Addr N_Ptr Addr (from input)
+ -- | | |
+ -- V V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
-- Convert the bits preceding the object into a list header
- N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+ N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
-- Detach the object from the related finalization master. This
-- action does not need to know the prior context used during
Detach (N_Ptr);
+ -- Move the address from the object to the beginning of the list
+ -- header.
+
+ N_Addr := Addr - Header_And_Padding;
+
-- The size of the deallocated object must include the size of the
-- hidden list header.
- N_Size := Storage_Size + Header_Size;
+ N_Size := Storage_Size + Header_And_Padding;
else
N_Addr := Addr;
N_Size := Storage_Size;
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 |
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);
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;
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 --
----------------------------------------
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);
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
end if;
end Validate_Derived_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 --
- ------------------------------------
+ ----------------------------------------
+ -- Validate_Discriminated_Formal_Type --
+ ----------------------------------------
- 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);
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;
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);
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
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;
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;
-- expand the freeze actions that include the bodies. In particular,
-- extra formals for accessibility or for return-in-place may need
-- to be generated. Freeze nodes, if any, are inserted before the
- -- current body.
+ -- current body. These freeze actions are also needed in ASIS mode
+ -- to enable the proper back-annotations.
if not Is_Frozen (Spec_Id)
- and then Expander_Active
+ and then
+ (Expander_Active or else ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
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;
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
(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
(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
-- 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
-- | 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 --
-- 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 --
---------------------------------------------
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,
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)
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 <>");
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 (';');
projects / gcc.git / commitdiff