git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2011-10-13  Cyrille Comar  <comar@adacore.com>

	* gnat_ugn.texi: Minor editing.

2011-10-13  Vincent Celier  <celier@adacore.com>

	* projects.texi: Add documentation on packages and attributes
	that are inherited from a project being extended into the
	extended project.

2011-10-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Build_Master): Rewritten.
	(Expand_N_Full_Type_Declaration): Reformat the declarative
	region. Update the call to Build_Master_Renaming.
	(Expand_Previous_Access_Type): Rewritten.
	* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call):
	Add local constant Result_Subt and update related usage.
	(Expand_N_Extended_Return_Statement): Add local constant
	Result_Subt and update related usage.
	* exp_ch9.adb (Build_Activation_Chain): Rewritten to use the
	new context detection mechanism.
	(Build_Class_Wide_Master):
	Use Insert_Action to add the renaming into the tree.
	(Build_Master_Entity): Rewritten to use the new context detection
	mechanism.
	(Build_Master_Renaming): Add formal parameter Ins_Nod
	and related usage. Use Insert_Action to add the renaming into the
	tree.
	(Find_Enclosing_Context): New subsidiary routine. Rather
	than relying on enclosing scopes, this routine looks at the
	tree structure to figure out the proper context for a _master
	or a _chain. This approach eliminates the issues with transient
	scopes which have not been converted into blocks.
	* exp_ch9.ads (Build_Master_Entity): Change parameter profile
	to better reflect the new usage. Update the related comment.
	(Build_Master_Renaming): Add formal parameter Ins_Nod. Update
	the comment on usage.
	* sem_ch3.adb (Access_Definition): Update the calls to
	Build_Master_Entity and Build_Master_Renaming.
	* sem_ch6.adb (Create_Extra_Formals): Add local variable
	Full_Subt. Code reformatting.
	* sem_util.adb (Is_Iterator): Alphabetized.
	(Is_LHS): Alphabetized.
	(Is_Limited_Class_Wide_Type): New routine.
	* sem_util.ads (Is_Limited_Class_Wide_Type): New routine.

From-SVN: r179913
This commit is contained in:
Arnaud Charlet 2011-10-13 13:00:13 +02:00
parent a5917ffb2c
commit 1a36a0cd69
11 changed files with 495 additions and 249 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
gcc/ada/ChangeLog
View File

@ -1,3 +1,50 @@
2011-10-13 Cyrille Comar <comar@adacore.com>
* gnat_ugn.texi: Minor editing.
2011-10-13 Vincent Celier <celier@adacore.com>
* projects.texi: Add documentation on packages and attributes
that are inherited from a project being extended into the
extended project.
2011-10-13 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Build_Master): Rewritten.
(Expand_N_Full_Type_Declaration): Reformat the declarative
region. Update the call to Build_Master_Renaming.
(Expand_Previous_Access_Type): Rewritten.
* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call):
Add local constant Result_Subt and update related usage.
(Expand_N_Extended_Return_Statement): Add local constant
Result_Subt and update related usage.
* exp_ch9.adb (Build_Activation_Chain): Rewritten to use the
new context detection mechanism.
(Build_Class_Wide_Master):
Use Insert_Action to add the renaming into the tree.
(Build_Master_Entity): Rewritten to use the new context detection
mechanism.
(Build_Master_Renaming): Add formal parameter Ins_Nod
and related usage. Use Insert_Action to add the renaming into the
tree.
(Find_Enclosing_Context): New subsidiary routine. Rather
than relying on enclosing scopes, this routine looks at the
tree structure to figure out the proper context for a _master
or a _chain. This approach eliminates the issues with transient
scopes which have not been converted into blocks.
* exp_ch9.ads (Build_Master_Entity): Change parameter profile
to better reflect the new usage. Update the related comment.
(Build_Master_Renaming): Add formal parameter Ins_Nod. Update
the comment on usage.
* sem_ch3.adb (Access_Definition): Update the calls to
Build_Master_Entity and Build_Master_Renaming.
* sem_ch6.adb (Create_Extra_Formals): Add local variable
Full_Subt. Code reformatting.
* sem_util.adb (Is_Iterator): Alphabetized.
(Is_LHS): Alphabetized.
(Is_Limited_Class_Wide_Type): New routine.
* sem_util.ads (Is_Limited_Class_Wide_Type): New routine.
2011-10-13 Geert Bosch <bosch@adacore.com>
* a-ngrear.adb (Solve): Make generic and move to

65
gcc/ada/exp_ch3.adb
View File

@ -4124,29 +4124,27 @@ package body Exp_Ch3 is
------------------------------------
procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
B_Id : constant Entity_Id := Base_Type (Def_Id);
FN : Node_Id;
Par_Id : Entity_Id;
procedure Build_Master (Def_Id : Entity_Id);
-- Create the master associated with Def_Id
procedure Build_Master (Ptr_Typ : Entity_Id);
-- Create the master associated with Ptr_Typ
------------------
-- Build_Master --
------------------
procedure Build_Master (Def_Id : Entity_Id) is
procedure Build_Master (Ptr_Typ : Entity_Id) is
Desig_Typ : constant Entity_Id := Designated_Type (Ptr_Typ);
begin
-- Anonymous access types are created for the components of the
-- record parameter for an entry declaration. No master is created
-- for such a type.
if Has_Task (Designated_Type (Def_Id))
and then Comes_From_Source (N)
if Comes_From_Source (N)
and then Has_Task (Desig_Typ)
then
Build_Master_Entity (Def_Id);
Build_Master_Renaming (Parent (Def_Id), Def_Id);
Build_Master_Entity (Ptr_Typ);
Build_Master_Renaming (Ptr_Typ);
-- Create a class-wide master because a Master_Id must be generated
-- for access-to-limited-class-wide types whose root may be extended
@ -4155,8 +4153,7 @@ package body Exp_Ch3 is
-- Note: This code covers access-to-limited-interfaces because they
-- can be used to reference tasks implementing them.
elsif Is_Class_Wide_Type (Designated_Type (Def_Id))
and then Is_Limited_Type (Designated_Type (Def_Id))
elsif Is_Limited_Class_Wide_Type (Desig_Typ)
and then Tasking_Allowed
-- Do not create a class-wide master for types whose convention is
@ -4174,13 +4171,20 @@ package body Exp_Ch3 is
-- Because the convention appears after we have done the
-- processing for type Ref.
and then Convention (Designated_Type (Def_Id)) /= Convention_Java
and then Convention (Designated_Type (Def_Id)) /= Convention_CIL
and then Convention (Desig_Typ) /= Convention_Java
and then Convention (Desig_Typ) /= Convention_CIL
then
Build_Class_Wide_Master (Def_Id);
Build_Class_Wide_Master (Ptr_Typ);
end if;
end Build_Master;
-- Local declarations
Def_Id : constant Entity_Id := Defining_Identifier (N);
B_Id : constant Entity_Id := Base_Type (Def_Id);
FN : Node_Id;
Par_Id : Entity_Id;
-- Start of processing for Expand_N_Full_Type_Declaration
begin
@ -4240,7 +4244,7 @@ package body Exp_Ch3 is
if First then
Build_Master_Entity (Def_Id);
Build_Master_Renaming (N, Typ);
Build_Master_Renaming (Typ);
M_Id := Master_Id (Typ);
First := False;
@ -5174,23 +5178,30 @@ package body Exp_Ch3 is
---------------------------------
procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
T : Entity_Id := First_Entity (Current_Scope);
Ptr_Typ : Entity_Id := First_Entity (Current_Scope);
begin
-- Find all access types declared in the current scope, whose
-- designated type is Def_Id. If it does not have a Master_Id,
-- create one now.
-- Find all access types in the current scope whose designated type is
-- Def_Id and build master renamings for them.
while Present (T) loop
if Is_Access_Type (T)
and then Designated_Type (T) = Def_Id
and then No (Master_Id (T))
while Present (Ptr_Typ) loop
if Is_Access_Type (Ptr_Typ)
and then Designated_Type (Ptr_Typ) = Def_Id
and then No (Master_Id (Ptr_Typ))
then
-- Ensure that the designated type has a master
Build_Master_Entity (Def_Id);
Build_Master_Renaming (Parent (Def_Id), T);
-- Private and incomplete types complicate the insertion of master
-- renamings because the access type may precede the full view of
-- the designated type. For this reason, the master renamings are
-- inserted relative to the designated type.
Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
end if;
Next_Entity (T);
Next_Entity (Ptr_Typ);
end loop;
end Expand_Previous_Access_Type;

20
gcc/ada/exp_ch6.adb
View File

@ -477,13 +477,14 @@ package body Exp_Ch6 is
Function_Id : Entity_Id;
Master_Actual : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Actual : Node_Id := Master_Actual;
Loc : constant Source_Ptr := Sloc (Function_Call);
Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
Actual : Node_Id := Master_Actual;
begin
-- No such extra parameters are needed if there are no tasks
if not Has_Task (Available_View (Etype (Function_Id))) then
if not Has_Task (Result_Subt) then
return;
end if;
@ -4590,6 +4591,7 @@ package body Exp_Ch6 is
Par_Func : constant Entity_Id :=
Return_Applies_To (Return_Statement_Entity (N));
Result_Subt : constant Entity_Id := Etype (Par_Func);
Ret_Obj_Id : constant Entity_Id :=
First_Entity (Return_Statement_Entity (N));
Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
@ -4894,7 +4896,7 @@ package body Exp_Ch6 is
-- built in place (though we plan to do so eventually).
if Present (HSS)
or else Is_Composite_Type (Etype (Par_Func))
or else Is_Composite_Type (Result_Subt)
or else No (Exp)
then
if No (HSS) then
@ -4921,7 +4923,7 @@ package body Exp_Ch6 is
-- the case of result types with task parts.
if Is_Build_In_Place
and then Has_Task (Etype (Par_Func))
and then Has_Task (Result_Subt)
then
-- The return expression is an aggregate for a complex type which
-- contains tasks. This particular case is left unexpanded since
@ -4932,7 +4934,12 @@ package body Exp_Ch6 is
Expand_N_Aggregate (Exp);
end if;
Append_To (Stmts, Move_Activation_Chain);
-- Do not move the activation chain if the return object does not
-- contain tasks.
if Has_Task (Etype (Ret_Obj_Id)) then
Append_To (Stmts, Move_Activation_Chain);
end if;
end if;
-- Update the state of the function right before the object is
@ -5031,7 +5038,6 @@ package body Exp_Ch6 is
Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id);
Return_Obj_Expr : constant Node_Id :=
Expression (Ret_Obj_Decl);
Result_Subt : constant Entity_Id := Etype (Par_Func);
Constr_Result : constant Boolean :=
Is_Constrained (Result_Subt);
Obj_Alloc_Formal : Entity_Id;

292
gcc/ada/exp_ch9.adb
View File

@ -346,6 +346,18 @@ package body Exp_Ch9 is
-- to handle properly the case of bounds that depend on discriminants.
-- If Cap is true, the result is capped according to Entry_Family_Bound.
procedure Find_Enclosing_Context
(N : Node_Id;
Context : out Node_Id;
Context_Id : out Entity_Id;
Context_Decls : out List_Id);
-- Subsidiary routine to procedures Build_Activation_Chain_Entity and
-- Build_Master_Entity. Given an arbitrary node in the tree, find the
-- nearest enclosing body, block, package or return statement and return
-- its constituents. Context is the enclosing construct, Context_Id is
-- the scope of Context_Id and Context_Decls is the declarative list of
-- Context.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
@ -870,64 +882,33 @@ package body Exp_Ch9 is
-- Local variables
Decls : List_Id;
Par : Node_Id;
Context : Node_Id;
Context_Id : Entity_Id;
Decls : List_Id;
-- Start of processing for Build_Activation_Chain_Entity
begin
-- Traverse the parent chain looking for an enclosing construct which
-- contains an activation chain variable. The construct is either a
-- body, a block, or an extended return.
Par := Parent (N);
while not Nkind_In (Par, N_Block_Statement,
N_Entry_Body,
N_Extended_Return_Statement,
N_Package_Body,
N_Package_Declaration,
N_Subprogram_Body,
N_Task_Body)
loop
Par := Parent (Par);
end loop;
-- When the enclosing construct is a package body, the activation chain
-- variable is declared in the body, but the Activation_Chain_Entity is
-- attached to the spec.
if Nkind (Par) = N_Package_Body then
Decls := Declarations (Par);
Par := Unit_Declaration_Node (Corresponding_Spec (Par));
elsif Nkind (Par) = N_Package_Declaration then
Decls := Visible_Declarations (Specification (Par));
elsif Nkind (Par) = N_Extended_Return_Statement then
Decls := Return_Object_Declarations (Par);
else
Decls := Declarations (Par);
end if;
Find_Enclosing_Context (N, Context, Context_Id, Decls);
-- If an activation chain entity has not been declared already, create
-- one.
if Nkind (Par) = N_Extended_Return_Statement
or else No (Activation_Chain_Entity (Par))
if Nkind (Context) = N_Extended_Return_Statement
or else No (Activation_Chain_Entity (Context))
then
-- Since extended return statements do not store the entity of the
-- chain, examine the return object declarations to avoid creating
-- a duplicate.
if Nkind (Par) = N_Extended_Return_Statement
and then Has_Activation_Chain (Par)
if Nkind (Context) = N_Extended_Return_Statement
and then Has_Activation_Chain (Context)
then
return;
end if;
declare
Loc : constant Source_Ptr := Sloc (Context);
Chain : Entity_Id;
Decl : Node_Id;
@ -943,19 +924,29 @@ package body Exp_Ch9 is
-- Activate_Tasks. Task activation is the responsibility of the
-- caller.
if Nkind (Par) /= N_Extended_Return_Statement then
Set_Activation_Chain_Entity (Par, Chain);
if Nkind (Context) /= N_Extended_Return_Statement then
Set_Activation_Chain_Entity (Context, Chain);
end if;
Decl :=
Make_Object_Declaration (Sloc (Par),
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (Par)));
New_Reference_To (RTE (RE_Activation_Chain), Loc));
Prepend_To (Decls, Decl);
Analyze (Decl);
-- Ensure that the _chain appears in the proper scope of the
-- context.
if Context_Id /= Current_Scope then
Push_Scope (Context_Id);
Analyze (Decl);
Pop_Scope;
else
Analyze (Decl);
end if;
end;
end if;
end Build_Activation_Chain_Entity;
@ -1189,8 +1180,7 @@ package body Exp_Ch9 is
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Name => Name_Id);
Insert_Before (Related_Node, Ren_Decl);
Analyze (Ren_Decl);
Insert_Action (Related_Node, Ren_Decl);
Set_Master_Id (Typ, Master_Id);
end Build_Class_Wide_Master;
@ -2885,43 +2875,51 @@ package body Exp_Ch9 is
-- Build_Master_Entity --
-------------------------
procedure Build_Master_Entity
(Id : Entity_Id;
Use_Current : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (Id);
Context : Node_Id;
Master_Decl : Node_Id;
Master_Scop : Entity_Id;
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
Context : Node_Id;
Context_Id : Entity_Id;
Decl : Node_Id;
Decls : List_Id;
Par : Node_Id;
begin
if Use_Current then
Master_Scop := Current_Scope;
if Is_Itype (Obj_Or_Typ) then
Par := Associated_Node_For_Itype (Obj_Or_Typ);
else
Master_Scop := Find_Master_Scope (Id);
Par := Parent (Obj_Or_Typ);
end if;
-- Do not create a master if the enclosing scope already has one or if
-- there is no task hierarchy.
-- When creating a master for a record component which is either a task
-- or access-to-task, the enclosing record is the master scope and the
-- proper insertion point is the component list.
if Has_Master_Entity (Master_Scop)
if Is_Record_Type (Current_Scope) then
Context := Par;
Context_Id := Current_Scope;
Decls := List_Containing (Context);
-- Default case for object declarations and access types. Note that the
-- context is updated to the nearest enclosing body, block, package or
-- return statement.
else
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
-- Do not create a master if one already exists or there is no task
-- hierarchy.
if Has_Master_Entity (Context_Id)
or else Restriction_Active (No_Task_Hierarchy)
then
return;
end if;
-- Determine the proper context to insert the master
if Is_Access_Type (Id) and then Is_Itype (Id) then
Context := Associated_Node_For_Itype (Id);
else
Context := Parent (Id);
end if;
-- Create a master, generate:
-- _Master : constant Master_Id := Current_Master.all;
Master_Decl :=
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
@ -2931,29 +2929,43 @@ package body Exp_Ch9 is
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
Insert_Before (Context, Master_Decl);
Analyze (Master_Decl);
-- The master is inserted at the start of the declarative list of the
-- context.
-- Mark enclosing scope and its associated construct as task masters
Prepend_To (Decls, Decl);
Set_Has_Master_Entity (Master_Scop);
-- In certain cases where transient scopes are involved, the immediate
-- scope is not always the proper master scope. Ensure that the master
-- declaration and entity appear in the same context.
while Nkind (Context) /= N_Compilation_Unit loop
Context := Parent (Context);
if Context_Id /= Current_Scope then
Push_Scope (Context_Id);
Analyze (Decl);
Pop_Scope;
else
Analyze (Decl);
end if;
-- If we fall off the top, we are at the outer level, and the
-- environment task is our effective master, so nothing to mark.
-- Mark the enclosing scope and its associated construct as being task
-- masters.
Set_Has_Master_Entity (Context_Id);
while Present (Context)
and then Nkind (Context) /= N_Compilation_Unit
loop
if Nkind_In (Context, N_Block_Statement,
N_Subprogram_Body,
N_Task_Body)
then
Set_Is_Task_Master (Context, True);
return;
Set_Is_Task_Master (Context);
exit;
elsif Nkind (Parent (Context)) = N_Subunit then
Context := Corresponding_Stub (Parent (Context));
end if;
Context := Parent (Context);
end loop;
end Build_Master_Entity;
@ -2961,8 +2973,12 @@ package body Exp_Ch9 is
-- Build_Master_Renaming --
---------------------------
procedure Build_Master_Renaming (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
procedure Build_Master_Renaming
(Ptr_Typ : Entity_Id;
Ins_Nod : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Ptr_Typ);
Context : Node_Id;
Master_Decl : Node_Id;
Master_Id : Entity_Id;
@ -2973,9 +2989,22 @@ package body Exp_Ch9 is
return;
end if;
-- Determine the proper context to insert the master renaming
if Present (Ins_Nod) then
Context := Ins_Nod;
elsif Is_Itype (Ptr_Typ) then
Context := Associated_Node_For_Itype (Ptr_Typ);
else
Context := Parent (Ptr_Typ);
end if;
-- Generate:
-- <Ptr_Typ>M : Master_Id renames _Master;
Master_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Typ), 'M'));
New_External_Name (Chars (Ptr_Typ), 'M'));
Master_Decl :=
Make_Object_Renaming_Declaration (Loc,
@ -2983,10 +3012,11 @@ package body Exp_Ch9 is
Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc),
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (N, Master_Decl);
Analyze (Master_Decl);
Insert_Action (Context, Master_Decl);
Set_Master_Id (Typ, Master_Id);
-- The renamed master now services the access type
Set_Master_Id (Ptr_Typ, Master_Id);
end Build_Master_Renaming;
-----------------------------------------
@ -4404,7 +4434,7 @@ package body Exp_Ch9 is
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
@ -12017,6 +12047,94 @@ package body Exp_Ch9 is
Make_Integer_Literal (Loc, 0)));
end Family_Size;
----------------------------
-- Find_Enclosing_Context --
----------------------------
procedure Find_Enclosing_Context
(N : Node_Id;
Context : out Node_Id;
Context_Id : out Entity_Id;
Context_Decls : out List_Id)
is
begin
-- Traverse the parent chain looking for an enclosing body, block,
-- package or return statement.
Context := Parent (N);
while not Nkind_In (Context, N_Block_Statement,
N_Entry_Body,
N_Extended_Return_Statement,
N_Package_Body,
N_Package_Declaration,
N_Subprogram_Body,
N_Task_Body)
loop
Context := Parent (Context);
end loop;
-- Extract the constituents of the context
if Nkind (Context) = N_Extended_Return_Statement then
Context_Decls := Return_Object_Declarations (Context);
Context_Id := Return_Statement_Entity (Context);
-- Package declarations and bodies use a common library-level activation
-- chain or task master, therefore return the package declaration as the
-- proper carrier for the appropriate flag.
elsif Nkind (Context) = N_Package_Body then
Context_Decls := Declarations (Context);
Context_Id := Corresponding_Spec (Context);
Context := Parent (Context_Id);
if Nkind (Context) = N_Defining_Program_Unit_Name then
Context := Parent (Parent (Context));
else
Context := Parent (Context);
end if;
elsif Nkind (Context) = N_Package_Declaration then
Context_Decls := Visible_Declarations (Specification (Context));
Context_Id := Defining_Unit_Name (Specification (Context));
if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
Context_Id := Defining_Identifier (Context_Id);
end if;
else
Context_Decls := Declarations (Context);
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
elsif Nkind (Context) = N_Entry_Body then
Context_Id := Defining_Identifier (Context);
elsif Nkind (Context) = N_Subprogram_Body then
if Present (Corresponding_Spec (Context)) then
Context_Id := Corresponding_Spec (Context);
else
Context_Id := Defining_Unit_Name (Specification (Context));
if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
Context_Id := Defining_Identifier (Context_Id);
end if;
end if;
elsif Nkind (Context) = N_Task_Body then
Context_Id := Corresponding_Spec (Context);
else
raise Program_Error;
end if;
end if;
pragma Assert (Present (Context));
pragma Assert (Present (Context_Id));
pragma Assert (Present (Context_Decls));
end Find_Enclosing_Context;
-----------------------
-- Find_Master_Scope --
-----------------------

24
gcc/ada/exp_ch9.ads
View File

@ -60,24 +60,22 @@ package Exp_Ch9 is
-- protected type. The statements are wrapped inside a block due to a local
-- declaration.
procedure Build_Master_Entity
(Id : Entity_Id;
Use_Current : Boolean := False);
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
-- tasks or designates tasks, create a _master in the appropriate scope
-- which captures the value of Current_Master. Mark the enclosing body as
-- being a task master. A _master is built to avoid multiple expensive
-- calls to Current_Master and to facilitate object initialization. Flag
-- Use_Current ensures that the master scope is the current scope.
-- which captures the value of Current_Master. Mark the nearest enclosing
-- body or block as being a task master.
procedure Build_Master_Renaming (N : Node_Id; Typ : Entity_Id);
-- Given an access type Typ and a declaration N of a designated type that
-- is either a task or contains tasks, create a renaming of the form:
procedure Build_Master_Renaming
(Ptr_Typ : Entity_Id;
Ins_Nod : Node_Id := Empty);
-- Given an access type Ptr_Typ whose designated type is either a task or
-- contains tasks, create a renaming of the form:
--
-- TypM : Master_Id renames _Master;
-- <Ptr_Typ>M : Master_Id renames _Master;
--
-- where _master denotes the task master of the enclosing context. The
-- renaming declaration is inserted before N.
-- where _master denotes the task master of the enclosing context. Ins_Nod
-- is used to provide a specific insertion node for the renaming.
function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id;
-- A subprogram body without a previous spec that appears in a protected

164
gcc/ada/gnat_ugn.texi
View File

@ -192,7 +192,7 @@ AdaCore@*
* Stack Related Facilities::
* Verifying Properties Using gnatcheck::
* Creating Sample Bodies Using gnatstub::
* Creating Test Drivers Using gnattest::
* Creating Unit Tests Using gnattest::
* Generating Ada Bindings for C and C++ headers::
* Other Utility Programs::
* Running and Debugging Ada Programs::
@ -469,18 +469,18 @@ Sample Bodies Using gnatstub
* Running gnatstub::
* Switches for gnatstub::
Creating Test Drivers Using gnattest
Creating Unit Tests Using gnattest
* Running gnattest::
* Switches for gnattest::
* Project Attributes for gnattest::
* Simple Test Driver::
* Simple Example::
* Setting Up and Tearing Down Testing Environment::
* Reusing Previously Written Tests::
* Regenerating Tests::
* Default Test Behavior::
* Testing Primitive Operations of Tagged Types::
* Test Inheritance::
* Liskov Substitution Principle Check::
* Tagged Types Substitutability Testing::
* Testing with Contracts::
* Additional Tests::
* Current Limitations::
@ -831,7 +831,7 @@ a utility that checks Ada code against a set of rules.
a utility that generates empty but compilable bodies for library units.
@item
@ref{Creating Test Drivers Using gnattest}, discusses @code{gnattest},
@ref{Creating Unit Tests Using gnattest}, discusses @code{gnattest},
a utility that generates unit testing templates for library units.
@item
@ -17666,38 +17666,40 @@ Verbose mode: generate version information.
@end table
@c *********************************
@node Creating Test Drivers Using gnattest
@chapter Creating Test Drivers Using @command{gnattest}
@node Creating Unit Tests Using gnattest
@chapter Creating Unit Tests Using @command{gnattest}
@findex gnattest
@noindent
@command{gnattest} is an ASIS-based utility that creates template tests
(test stubs) as well as test driver infrastructure (harness) for unit testing
of Ada source code.
@command{gnattest} is an ASIS-based utility that creates unit tests stubs
as well as a test driver infrastructure (harness). @command{gnattest} creates
a stub for each visible subprogram in the packages under consideration when
they do not exist already.
In order to process source files from the project, @command{gnattest} has to
semantically analyze these Ada sources. Therefore, test templates can only be
semantically analyze these Ada sources. Therefore, test stubs can only be
generated for legal Ada units. If a unit is dependent on some other units,
those units should be among source files of the project or of other projects
imported by this one.
Generated stubs and harness are based on AUnit testing framework. AUnit
framework is an Ada adaptation of Java and C++ unit testing frameworks.
While it is advised that gnattest users read AUnit manual, deep knowledge
of AUnit is not necessary for using gnattest. For correct operation of
@command{gnattest} AUnit should be installed on default project path.
Generated stubs and harness are based on the AUnit testing framework. AUnit is
an Ada adaptation of the xxxUnit testing frameworks similar to JUnit for Java or
CppUnit for C++. While it is advised that gnattest users read AUnit manual, deep
knowledge of AUnit is not necessary for using gnattest. For correct operation of
@command{gnattest} AUnit should be installed and aunit.gpr must be on the
project path. This happens automatically when Aunit is installed at its default
location.
@menu
* Running gnattest::
* Switches for gnattest::
* Project Attributes for gnattest::
* Simple Test Driver::
* Simple Example::
* Setting Up and Tearing Down Testing Environment::
* Reusing Previously Written Tests::
* Regenerating Tests::
* Default Test Behavior::
* Testing Primitive Operations of Tagged Types::
* Test Inheritance::
* Liskov Substitution Principle Check::
* Tagged Types Substitutability Testing::
* Testing with Contracts::
* Additional Tests::
* Current Limitations::
@ -17710,9 +17712,9 @@ of AUnit is not necessary for using gnattest. For correct operation of
@command{gnattest} has the command-line interface of the form
@smallexample
@c $ gnattest @var{-Pprojname} @ovar{switches} @var{filename} @ovar{directory}
@c $ gnattest @var{-Pprojname} @ovar{switches} @ovar{filename} @ovar{directory}
@c Expanding @ovar macro inline (explanation in macro def comments)
$ gnattest @var{-Pprojname} @r{[}@var{--harness-dir=dirname}@r{]} @r{[}@var{switches}@r{]} @var{filename} @r{[}-cargs @var{gcc_switches}@r{]}
$ gnattest @var{-Pprojname} @r{[}@var{--harness-dir=dirname}@r{]} @r{[}@var{switches}@r{]} @r{[}@var{filename}@r{]} @r{[}-cargs @var{gcc_switches}@r{]}
@end smallexample
@noindent
@ -17720,8 +17722,9 @@ where
@table @var
@item -Pprojname
specifies the project that allow locating the source files. If no [filenames]
are provided on the command line, all project sources are used as input.
specifies the project that allow locating the source files. When no [filenames]
are provided on the command line, all project sources are used as input. This
switch is mandatory.
@item --harness-dir=dirname
specifies directory to put harness packages and project file for the test
@ -17746,6 +17749,35 @@ is an optional sequence of switches as described in the next section
@end table
@command{gnattest} results can be found in two different places.
@itemize @bullet
@item automatic harness
the harnessing code which is located in the harness-dir as specified on the
comand line or in the project file. All this code is generated completely
automatically and can be destroyed and regenerated at will. It is not
recommended to modify manually this code since it might be overridden
easily. The entry point in this harnessing code is the project file called
@command{test_driver.gpr}. Tests can be compiled and run using a command
such as:
@smallexample
gnatmake -P<harness-dir>/test_driver
test_runner
@end smallexample
@item actual unit test stubs
a test stub for each visible subprogram is created in a separate file, if it
doesn't exist already. By default, those separate test files are located in a
"tests" directory that is created in the directory containing the source file
itself. if it is not appropriate to create the tests in subdirs of the source,
option @option{--separate-root} can be used. So let say for instance that
a source file my_unit.ads in directory src contains a visible subprogram Proc.
Then, the corresponding unit test will be found in file
src/tests/my_unit-tests-proc_<code>.adb. <code> is an signature encoding used to
differentiate test names in case of overloading.
@end itemize
@node Switches for gnattest
@section Switches for @command{gnattest}
@ -17797,7 +17829,7 @@ will be created by default.
@end table
Separate root ans subdir output modes cannot be used at the same time.
@option{--separate_root} and @option{--subdir} switches are mutually exclusive.
@node Project Attributes for gnattest
@section Project Attributes for @command{gnattest}
@ -17837,27 +17869,25 @@ All those attributes can be overridden from command line if needed.
Other @command{gnattest} switches can also be passed via the project
file as an attribute list called GNATtest_Switches.
@node Simple Test Driver
@section Simple Test Driver
@node Simple Example
@section Simple Example
@noindent
@command{gnattest} works with package specifications. The basic functionality
of @command{gnattest} is creating one test stub per one subprogram declared
in package specification. This can be observes on a very simple example
Let's take a very simple example using the first @command{gnattest} example
located at
@smallexample
examples/lib1
<install_prefix>/share/examples/gnattest/lib1
@end smallexample
This is a simple package containing one subprogram. By running gnattest
This project contains a simple package containing one subprogram. By running gnattest
@smallexample
$ gnattest --harness-dir=driver -Plib1.gpr
@end smallexample
a test driver is created. It can be compiled and run:
a test driver is created in dir "driver". It can be compiled and run:
@smallexample
$ cd driver
@ -17870,12 +17900,12 @@ Since no special output option was specified the test package Lib1.Tests
is located in
@smallexample
examples/lib1/src/tests
<install_prefix>/share/examples/gnattest/lib1/src/tests
@end smallexample
For each package containing testable subprograms a child test package is
For each package containing visible subprograms, a child test package is
generated. It contains one test routine per tested subprogram. Each
declaration of test subprogram has a comment cpecifying to which tested
declaration of test subprogram has a comment specifying to which tested
subprogram it corresponds. All the test routines have separated bodies.
The test routine locates at lib1-tests-test_inc_5eaee3.adb has a single
statement - procedure Assert. It has two arguments: the boolean expression
@ -17883,7 +17913,7 @@ which we want to check and the diagnosis message to display if the condition
is false.
That is where actual testing code should be written after a proper setup.
An actual check can be performed by replacing the stubbing code with
An actual check can be performed by replacing the assert statement with
@smallexample @c ada
Assert (Inc (1) = 2, "wrong incrementation");
@ -17904,17 +17934,17 @@ User_Tear_Down is called after each test routine. Those two procedures can
be used to perform necessary initialization and finalization,
memory allocation etc.
@node Reusing Previously Written Tests
@section Reusing Previously Written Tests
@node Regenerating Tests
@section Regenerating Tests
@noindent
Bodies of test routines and env_mgmt packages are never overridden after they
were created once. As long as the name of the subprogram, full expanded Ada
names and order of it's parameters are the same, the old test routine will
fit in it's place.
have been created once. As long as the name of the subprogram, full expanded Ada
names and order of its parameters are the same, the old test routine will
fit in it's place and no test stub will be generated for this subprogram.
This can be demonstrated with the presious example. By uncommenting declaration
This can be demonstrated with the previous example. By uncommenting declaration
and body of function Dec in lib1.ads and lib1.adb, running
@command{gnattest} on the project and then running the test driver:
@ -17925,7 +17955,11 @@ gprbuild -Ptest_driver
test_runner
@end smallexample
the old test is not replaced with a stub neither lost.
the old test is not replaced with a stub neither lost but a new test stub is
created for function Dec.
The only way for regenerating tests stubs is t oremove the previously created
tests.
@node Default Test Behavior
@section Default Test Behavior
@ -17946,7 +17980,7 @@ passed to gnattest when generating the test driver.
Passing it to the driver generated on the first example
@smallexample
test_runer --stub-default=pass
test_runner --stub-default=pass
@end smallexample
makes both tests pass, even the unimplemented one.
@ -17993,8 +18027,8 @@ Thus test types repeat the hierarchy of tested types.
The User_Set_Up procedure of Env_Mgmt package corresponding to a test package
of primitive operations of type T assigns Fixture with a reference to an
object of that exact type T. Notice however, that if the tagged type has
discriminants, the User_Set_Up does has only a commented template of setting
up the fixture since filling th discriminant with actual value is up
discriminants, the User_Set_Up only has a commented template of setting
up the fixture since filling the discriminant with actual value is up
to the user.
The knowledge of the structure if test types allows to have additional testing
@ -18005,7 +18039,7 @@ without additional effort. Those possibilities are described below.
@noindent
Since test type hierarchy repeats the hierarchy of tested types, the
Since test type hierarchy mimics the hierarchy of tested types, the
inheritance of tests take place. An example of such inheritance can be
shown by running the test driver generated for second example. As previously
mentioned, actual tests are already written for this example.
@ -18020,20 +18054,32 @@ There are 6 passed tests while there are only 5 testable subprograms. Test
routine for function Speed has been inherited and ran against objects of the
derived type.
@node Liskov Substitution Principle Check
@section Liskov Substitution Principle Check
@node Tagged Types Substitutability Testing
@section Tagged Types Substitutability Testing
@noindent
Liskov substitution principle (LSP) is a principle in object-oriented
programming. It states that, in a computer program if S is a subtype of T,
Tagged Types Substitutability Testing is a way of verifying by testing
the Liskov substitution principle (LSP). LSP is a principle stating that if
S is a subtype of T (in Ada, S is a derived type of tagged type T),
then objects of type T may be replaced with objects of type S (i.e., objects
of type S may be substitutes for objects of type T), without altering any of
the desirable properties of that program.
of type S may be substituted for objects of type T), without altering any of
the desirable properties of the program. When the properties of the program are
expressed in the form of subprogram pre & postconditions, LSP is formulated
as relations between the pre & post of primitive operations and the pre & post
of theirs derived operations. The pre of a derived operation should not be
stronger that the original pre, and the post of the derived operation should not
be weaker than the original post. Those relations insure that verifying if a
dyspatching call is safe can be done just with the pre & post of the root
operation.
In the example used for previous section there clearly have a violation of LSP.
The overriding function Adjust_Speed in package Speed2 removes the
functionality of the overridden function. Gnattest has a special option to run
Verifying LSP by testing consists in running all the unit tests associated with
the primitives of a given tagged type with objects of its derived types.
In the example used by the previous section there clearly have a violation of LSP.
The overriding primitive Adjust_Speed in package Speed2 removes the
functionality of the overridden primitive and thus doesn't respect LSP.
Gnattest has a special option to run
overridden parent tests against objects of the type which have overriding
primitives.
@ -18059,7 +18105,7 @@ that have composition of pre- and postcondition of the subprogram an
"requires" and "ensures" of the Test_Case (depending on the mode pre- and post
either count for Nominal mode or do not for Robustness mode).
The thirg example demonstrates how it works:
The third example demonstrates how it works:
@smallexample
cd examples/lib3

12
gcc/ada/projects.texi
View File

@ -2015,8 +2015,16 @@ end Work;
@end smallexample
@noindent
An extending project retains all the switches specified in the
extended project.
All packages that are not declared in the extending project are inherited from
the project being extended, with their attributes, with the exception of
@code{Linker'Linker_Options} which is never inherited. In particular, an
extending project retains all the switches specified in the project being
extended.
At the project level, if they are not declared in the extending project, some
attributes are inherited from the project being extended. They are:
@code{Languages}, @code{Main} (for a root non library project) and
@code{Library_Name} (for a project extending a library project)
@menu
* Project Hierarchy Extension::

7
gcc/ada/sem_ch3.adb
View File

@ -887,7 +887,7 @@ package body Sem_Ch3 is
-- proper Master for the created tasks.
if Nkind (Related_Nod) = N_Object_Declaration
and then Expander_Active
and then Expander_Active
then
if Is_Interface (Desig_Type)
and then Is_Limited_Record (Desig_Type)
@ -899,10 +899,9 @@ package body Sem_Ch3 is
elsif Has_Task (Desig_Type)
and then Comes_From_Source (Related_Nod)
and then not Restriction_Active (No_Task_Hierarchy)
then
Build_Master_Entity (Defining_Identifier (Related_Nod), True);
Build_Master_Renaming (Related_Nod, Anon_Type);
Build_Master_Entity (Defining_Identifier (Related_Nod));
Build_Master_Renaming (Anon_Type);
end if;
end if;

44
gcc/ada/sem_ch6.adb
View File

@ -6461,9 +6461,11 @@ package body Sem_Ch6 is
if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
declare
Result_Subt : constant Entity_Id := Etype (E);
Full_Subt : constant Entity_Id := Available_View (Result_Subt);
Discard : Entity_Id;
Discard : Entity_Id;
pragma Warnings (Off, Discard);
Formal_Typ : Entity_Id;
begin
-- In the case of functions with unconstrained result subtypes,
@ -6510,7 +6512,7 @@ package body Sem_Ch6 is
-- master of the tasks to be created, and the caller's activation
-- chain.
if Has_Task (Available_View (Result_Subt)) then
if Has_Task (Full_Subt) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Master_Id),
@ -6524,31 +6526,27 @@ package body Sem_Ch6 is
-- All build-in-place functions get an extra formal that will be
-- passed the address of the return object within the caller.
declare
Formal_Type : constant Entity_Id :=
Create_Itype
(E_Anonymous_Access_Type, E,
Scope_Id => Scope (E));
begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt);
Set_Etype (Formal_Type, Formal_Type);
Set_Depends_On_Private
(Formal_Type, Has_Private_Component (Formal_Type));
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
Set_Is_Access_Constant (Formal_Type, False);
Formal_Typ :=
Create_Itype (E_Anonymous_Access_Type, E, Scope_Id => Scope (E));
-- Ada 2005 (AI-50217): Propagate the attribute that indicates
-- the designated type comes from the limited view (for
-- back-end purposes).
Set_Directly_Designated_Type (Formal_Typ, Result_Subt);
Set_Etype (Formal_Typ, Formal_Typ);
Set_Depends_On_Private
(Formal_Typ, Has_Private_Component (Formal_Typ));
Set_Is_Public (Formal_Typ, Is_Public (Scope (Formal_Typ)));
Set_Is_Access_Constant (Formal_Typ, False);
Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
-- Ada 2005 (AI-50217): Propagate the attribute that indicates
-- the designated type comes from the limited view (for back-end
-- purposes).
Layout_Type (Formal_Type);
Set_From_With_Type (Formal_Typ, From_With_Type (Result_Subt));
Discard :=
Add_Extra_Formal
(E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
end;
Layout_Type (Formal_Typ);
Discard :=
Add_Extra_Formal
(E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access));
end;
end if;
end Create_Extra_Formals;

65
gcc/ada/sem_util.adb
View File

@ -7345,6 +7345,33 @@ package body Sem_Util is
end if;
end Is_Fully_Initialized_Variant;
----------------------------
-- Is_Inherited_Operation --
----------------------------
function Is_Inherited_Operation (E : Entity_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Parent (E));
begin
pragma Assert (Is_Overloadable (E));
return Kind = N_Full_Type_Declaration
or else Kind = N_Private_Extension_Declaration
or else Kind = N_Subtype_Declaration
or else (Ekind (E) = E_Enumeration_Literal
and then Is_Derived_Type (Etype (E)));
end Is_Inherited_Operation;
-------------------------------------
-- Is_Inherited_Operation_For_Type --
-------------------------------------
function Is_Inherited_Operation_For_Type
(E : Entity_Id; Typ : Entity_Id) return Boolean
is
begin
return Is_Inherited_Operation (E)
and then Etype (Parent (E)) = Typ;
end Is_Inherited_Operation_For_Type;
-----------------
-- Is_Iterator --
-----------------
@ -7415,33 +7442,6 @@ package body Sem_Util is
end if;
end Is_LHS;
----------------------------
-- Is_Inherited_Operation --
----------------------------
function Is_Inherited_Operation (E : Entity_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Parent (E));
begin
pragma Assert (Is_Overloadable (E));
return Kind = N_Full_Type_Declaration
or else Kind = N_Private_Extension_Declaration
or else Kind = N_Subtype_Declaration
or else (Ekind (E) = E_Enumeration_Literal
and then Is_Derived_Type (Etype (E)));
end Is_Inherited_Operation;
-------------------------------------
-- Is_Inherited_Operation_For_Type --
-------------------------------------
function Is_Inherited_Operation_For_Type
(E : Entity_Id; Typ : Entity_Id) return Boolean
is
begin
return Is_Inherited_Operation (E)
and then Etype (Parent (E)) = Typ;
end Is_Inherited_Operation_For_Type;
-----------------------------
-- Is_Library_Level_Entity --
-----------------------------
@ -7462,6 +7462,17 @@ package body Sem_Util is
return Enclosing_Dynamic_Scope (E) = Standard_Standard;
end Is_Library_Level_Entity;
--------------------------------
-- Is_Limited_Class_Wide_Type --
--------------------------------
function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
begin
return
Is_Class_Wide_Type (Typ)
and then Is_Limited_Type (Typ);
end Is_Limited_Class_Wide_Type;
---------------------------------
-- Is_Local_Variable_Reference --
---------------------------------

4
gcc/ada/sem_util.ads
View File

@ -846,6 +846,10 @@ package Sem_Util is
-- A library-level declaration is one that is accessible from Standard,
-- i.e. a library unit or an entity declared in a library package.
function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean;
-- Given an arbitrary type, determine whether it is a limited class-wide
-- type.
function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
-- Determines whether Expr is a reference to a variable or IN OUT mode
-- parameter of the current enclosing subprogram.