Skip to content

R
riscv-gcc-1
Commit d3cb4cc0 by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r178184
parent d3f70b35
Showing with 344 additions and 99 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/a-cbmutr.adb
......@@ -2676,13 +2676,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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
......@@ -2769,13 +2774,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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
......@@ -2809,6 +2819,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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";
......@@ -2830,6 +2845,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
pragma Assert (Target_Count = Source_Count);
-- Now link the newly-allocated subtree into the target.
Insert_Subtree_Node
(Container => Target,
Subtree => Target_Subtree,
......@@ -2838,6 +2855,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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
......@@ -2845,7 +2867,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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;
......
gcc/ada/a-cimutr.adb
......@@ -2101,10 +2101,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
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
......@@ -2199,10 +2203,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
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
......
gcc/ada/a-comutr.adb
......@@ -2147,10 +2147,14 @@ package body Ada.Containers.Multiway_Trees is
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
......@@ -2245,10 +2249,14 @@ package body Ada.Containers.Multiway_Trees is
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
......
gcc/ada/exp_ch7.adb
......@@ -4560,19 +4560,10 @@ package body Exp_Ch7 is
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
......@@ -4581,11 +4572,22 @@ package body Exp_Ch7 is
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
......@@ -5493,8 +5495,6 @@ package body Exp_Ch7 is
-- have discriminants and contain variant parts. Generate:
--
-- begin
-- Root_Controlled (V).Finalized := False;
--
-- begin
-- [Deep_]Adjust (V.Comp_1);
-- exception
......@@ -5559,10 +5559,6 @@ package body Exp_Ch7 is
-- Raised : Boolean := False;
--
-- begin
-- if Root_Controlled (V).Finalized then
-- return;
-- end if;
--
-- if F then
-- begin
-- Finalize (V); -- If applicable
......@@ -5626,8 +5622,6 @@ package body Exp_Ch7 is
-- end if;
-- end;
--
-- Root_Controlled (V).Finalized := True;
--
-- if Raised then
-- Raise_From_Controlled_Object (E, Abort);
-- end if;
......@@ -6040,8 +6034,6 @@ package body Exp_Ch7 is
-- Raised : Boolean := False;
-- begin
-- Root_Controlled (V).Finalized := False;
-- <adjust statements>
-- if Raised then
......@@ -6846,15 +6838,6 @@ package body Exp_Ch7 is
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)
......@@ -6867,6 +6850,15 @@ package body Exp_Ch7 is
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
......
gcc/ada/exp_util.adb
......@@ -3349,6 +3349,7 @@ package body Exp_Util is
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 |
......
gcc/ada/freeze.adb
......@@ -1259,6 +1259,13 @@ package body Freeze is
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 @@ package body Freeze is
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 @@ package body Freeze is
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);
......
gcc/ada/get_scos.adb
......@@ -306,7 +306,8 @@ begin
Skipc;
begin
Pid := Pragma_Id'Value (Buf (1 .. N));
Pid :=
Pragma_Id'Value ("pragma_" & Buf (1 .. N));
exception
when Constraint_Error =>
......
gcc/ada/make.adb
......@@ -5908,7 +5908,7 @@ package body Make is
-- are not supposed to change.
Osint.Source_File_Data (Cache => True);
Osint.Add_Default_Search_Dirs;
Queue_Library_Project_Sources;
end if;
......@@ -5931,17 +5931,6 @@ package body Make is
("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
......@@ -6116,7 +6105,28 @@ package body Make is
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
......
gcc/ada/par-ch12.adb
......@@ -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 @@ package body Ch12 is
(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 @@ package body Ch12 is
-- 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 @@ package body Ch12 is
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;
......
gcc/ada/s-stposu.adb
......@@ -91,11 +91,8 @@ package body System.Storage_Pools.Subpools is
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;
......@@ -103,6 +100,10 @@ package body System.Storage_Pools.Subpools is
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
......@@ -165,7 +166,7 @@ package body System.Storage_Pools.Subpools is
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.
......@@ -179,9 +180,17 @@ package body System.Storage_Pools.Subpools is
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
......@@ -211,9 +220,23 @@ package body System.Storage_Pools.Subpools is
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
......@@ -233,7 +256,7 @@ package body System.Storage_Pools.Subpools is
-- 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;
......@@ -273,19 +296,34 @@ package body System.Storage_Pools.Subpools is
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
......@@ -293,10 +331,15 @@ package body System.Storage_Pools.Subpools is
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;
......
gcc/ada/sem.adb
......@@ -674,6 +674,7 @@ package body Sem is
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 |
......
gcc/ada/sem_ch6.adb
......@@ -2344,10 +2344,12 @@ package body Sem_Ch6 is
-- 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.
......
gcc/ada/sem_ch7.adb
......@@ -1195,9 +1195,11 @@ package body Sem_Ch7 is
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 @@ package body Sem_Ch7 is
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
......
gcc/ada/sinfo.adb
......@@ -2930,6 +2930,7 @@ package body Sinfo is
(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 @@ package body Sinfo is
(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
......
gcc/ada/sinfo.ads
......@@ -6209,6 +6209,7 @@ package Sinfo is
-- 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,6 +6235,12 @@ package Sinfo is
-- | 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 @@ package Sinfo is
-- 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 @@ package Sinfo is
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 @@ package Sinfo is
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)
......
gcc/ada/sprint.adb
......@@ -1801,6 +1801,11 @@ package body Sprint is
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 @@ package body Sprint is
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 (';');
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment