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> 2011-10-13 Geert Bosch <bosch@adacore.com>
* a-ngrear.adb (Solve): Make generic and move to * 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 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); procedure Build_Master (Ptr_Typ : Entity_Id);
-- Create the master associated with Def_Id -- Create the master associated with Ptr_Typ
------------------ ------------------
-- Build_Master -- -- 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 begin
-- Anonymous access types are created for the components of the -- Anonymous access types are created for the components of the
-- record parameter for an entry declaration. No master is created -- record parameter for an entry declaration. No master is created
-- for such a type. -- for such a type.
if Has_Task (Designated_Type (Def_Id)) if Comes_From_Source (N)
and then Comes_From_Source (N) and then Has_Task (Desig_Typ)
then then
Build_Master_Entity (Def_Id); Build_Master_Entity (Ptr_Typ);
Build_Master_Renaming (Parent (Def_Id), Def_Id); Build_Master_Renaming (Ptr_Typ);
-- Create a class-wide master because a Master_Id must be generated -- Create a class-wide master because a Master_Id must be generated
-- for access-to-limited-class-wide types whose root may be extended -- 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 -- Note: This code covers access-to-limited-interfaces because they
-- can be used to reference tasks implementing them. -- can be used to reference tasks implementing them.
elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) elsif Is_Limited_Class_Wide_Type (Desig_Typ)
and then Is_Limited_Type (Designated_Type (Def_Id))
and then Tasking_Allowed and then Tasking_Allowed
-- Do not create a class-wide master for types whose convention is -- 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 -- Because the convention appears after we have done the
-- processing for type Ref. -- processing for type Ref.
and then Convention (Designated_Type (Def_Id)) /= Convention_Java and then Convention (Desig_Typ) /= Convention_Java
and then Convention (Designated_Type (Def_Id)) /= Convention_CIL and then Convention (Desig_Typ) /= Convention_CIL
then then
Build_Class_Wide_Master (Def_Id); Build_Class_Wide_Master (Ptr_Typ);
end if; end if;
end Build_Master; 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 -- Start of processing for Expand_N_Full_Type_Declaration
begin begin
@ -4240,7 +4244,7 @@ package body Exp_Ch3 is
if First then if First then
Build_Master_Entity (Def_Id); Build_Master_Entity (Def_Id);
Build_Master_Renaming (N, Typ); Build_Master_Renaming (Typ);
M_Id := Master_Id (Typ); M_Id := Master_Id (Typ);
First := False; First := False;
@ -5174,23 +5178,30 @@ package body Exp_Ch3 is
--------------------------------- ---------------------------------
procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) 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 begin
-- Find all access types declared in the current scope, whose -- Find all access types in the current scope whose designated type is
-- designated type is Def_Id. If it does not have a Master_Id, -- Def_Id and build master renamings for them.
-- create one now.
while Present (T) loop while Present (Ptr_Typ) loop
if Is_Access_Type (T) if Is_Access_Type (Ptr_Typ)
and then Designated_Type (T) = Def_Id and then Designated_Type (Ptr_Typ) = Def_Id
and then No (Master_Id (T)) and then No (Master_Id (Ptr_Typ))
then then
-- Ensure that the designated type has a master
Build_Master_Entity (Def_Id); 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; end if;
Next_Entity (T); Next_Entity (Ptr_Typ);
end loop; end loop;
end Expand_Previous_Access_Type; 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; Function_Id : Entity_Id;
Master_Actual : Node_Id) Master_Actual : Node_Id)
is is
Loc : constant Source_Ptr := Sloc (Function_Call); Loc : constant Source_Ptr := Sloc (Function_Call);
Actual : Node_Id := Master_Actual; Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id));
Actual : Node_Id := Master_Actual;
begin begin
-- No such extra parameters are needed if there are no tasks -- 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; return;
end if; end if;
@ -4590,6 +4591,7 @@ package body Exp_Ch6 is
Par_Func : constant Entity_Id := Par_Func : constant Entity_Id :=
Return_Applies_To (Return_Statement_Entity (N)); Return_Applies_To (Return_Statement_Entity (N));
Result_Subt : constant Entity_Id := Etype (Par_Func);
Ret_Obj_Id : constant Entity_Id := Ret_Obj_Id : constant Entity_Id :=
First_Entity (Return_Statement_Entity (N)); First_Entity (Return_Statement_Entity (N));
Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); 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). -- built in place (though we plan to do so eventually).
if Present (HSS) if Present (HSS)
or else Is_Composite_Type (Etype (Par_Func)) or else Is_Composite_Type (Result_Subt)
or else No (Exp) or else No (Exp)
then then
if No (HSS) then if No (HSS) then
@ -4921,7 +4923,7 @@ package body Exp_Ch6 is
-- the case of result types with task parts. -- the case of result types with task parts.
if Is_Build_In_Place if Is_Build_In_Place
and then Has_Task (Etype (Par_Func)) and then Has_Task (Result_Subt)
then then
-- The return expression is an aggregate for a complex type which -- The return expression is an aggregate for a complex type which
-- contains tasks. This particular case is left unexpanded since -- contains tasks. This particular case is left unexpanded since
@ -4932,7 +4934,12 @@ package body Exp_Ch6 is
Expand_N_Aggregate (Exp); Expand_N_Aggregate (Exp);
end if; 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; end if;
-- Update the state of the function right before the object is -- 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_Typ : constant Entity_Id := Etype (Return_Obj_Id);
Return_Obj_Expr : constant Node_Id := Return_Obj_Expr : constant Node_Id :=
Expression (Ret_Obj_Decl); Expression (Ret_Obj_Decl);
Result_Subt : constant Entity_Id := Etype (Par_Func);
Constr_Result : constant Boolean := Constr_Result : constant Boolean :=
Is_Constrained (Result_Subt); Is_Constrained (Result_Subt);
Obj_Alloc_Formal : Entity_Id; 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. -- to handle properly the case of bounds that depend on discriminants.
-- If Cap is true, the result is capped according to Entry_Family_Bound. -- 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 procedure Extract_Dispatching_Call
(N : Node_Id; (N : Node_Id;
Call_Ent : out Entity_Id; Call_Ent : out Entity_Id;
@ -870,64 +882,33 @@ package body Exp_Ch9 is
-- Local variables -- Local variables
Decls : List_Id; Context : Node_Id;
Par : Node_Id; Context_Id : Entity_Id;
Decls : List_Id;
-- Start of processing for Build_Activation_Chain_Entity -- Start of processing for Build_Activation_Chain_Entity
begin begin
-- Traverse the parent chain looking for an enclosing construct which Find_Enclosing_Context (N, Context, Context_Id, Decls);
-- 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;
-- If an activation chain entity has not been declared already, create -- If an activation chain entity has not been declared already, create
-- one. -- one.
if Nkind (Par) = N_Extended_Return_Statement if Nkind (Context) = N_Extended_Return_Statement
or else No (Activation_Chain_Entity (Par)) or else No (Activation_Chain_Entity (Context))
then then
-- Since extended return statements do not store the entity of the -- Since extended return statements do not store the entity of the
-- chain, examine the return object declarations to avoid creating -- chain, examine the return object declarations to avoid creating
-- a duplicate. -- a duplicate.
if Nkind (Par) = N_Extended_Return_Statement if Nkind (Context) = N_Extended_Return_Statement
and then Has_Activation_Chain (Par) and then Has_Activation_Chain (Context)
then then
return; return;
end if; end if;
declare declare
Loc : constant Source_Ptr := Sloc (Context);
Chain : Entity_Id; Chain : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
@ -943,19 +924,29 @@ package body Exp_Ch9 is
-- Activate_Tasks. Task activation is the responsibility of the -- Activate_Tasks. Task activation is the responsibility of the
-- caller. -- caller.
if Nkind (Par) /= N_Extended_Return_Statement then if Nkind (Context) /= N_Extended_Return_Statement then
Set_Activation_Chain_Entity (Par, Chain); Set_Activation_Chain_Entity (Context, Chain);
end if; end if;
Decl := Decl :=
Make_Object_Declaration (Sloc (Par), Make_Object_Declaration (Loc,
Defining_Identifier => Chain, Defining_Identifier => Chain,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (Par))); New_Reference_To (RTE (RE_Activation_Chain), Loc));
Prepend_To (Decls, Decl); 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;
end if; end if;
end Build_Activation_Chain_Entity; end Build_Activation_Chain_Entity;
@ -1189,8 +1180,7 @@ package body Exp_Ch9 is
Subtype_Mark => New_Reference_To (Standard_Integer, Loc), Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Name => Name_Id); Name => Name_Id);
Insert_Before (Related_Node, Ren_Decl); Insert_Action (Related_Node, Ren_Decl);
Analyze (Ren_Decl);
Set_Master_Id (Typ, Master_Id); Set_Master_Id (Typ, Master_Id);
end Build_Class_Wide_Master; end Build_Class_Wide_Master;
@ -2885,43 +2875,51 @@ package body Exp_Ch9 is
-- Build_Master_Entity -- -- Build_Master_Entity --
------------------------- -------------------------
procedure Build_Master_Entity procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
(Id : Entity_Id; Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
Use_Current : Boolean := False) Context : Node_Id;
is Context_Id : Entity_Id;
Loc : constant Source_Ptr := Sloc (Id); Decl : Node_Id;
Context : Node_Id; Decls : List_Id;
Master_Decl : Node_Id; Par : Node_Id;
Master_Scop : Entity_Id;
begin begin
if Use_Current then if Is_Itype (Obj_Or_Typ) then
Master_Scop := Current_Scope; Par := Associated_Node_For_Itype (Obj_Or_Typ);
else else
Master_Scop := Find_Master_Scope (Id); Par := Parent (Obj_Or_Typ);
end if; end if;
-- Do not create a master if the enclosing scope already has one or if -- When creating a master for a record component which is either a task
-- there is no task hierarchy. -- 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) or else Restriction_Active (No_Task_Hierarchy)
then then
return; return;
end if; 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: -- Create a master, generate:
-- _Master : constant Master_Id := Current_Master.all; -- _Master : constant Master_Id := Current_Master.all;
Master_Decl := Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster), Make_Defining_Identifier (Loc, Name_uMaster),
@ -2931,29 +2929,43 @@ package body Exp_Ch9 is
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc))); New_Reference_To (RTE (RE_Current_Master), Loc)));
Insert_Before (Context, Master_Decl); -- The master is inserted at the start of the declarative list of the
Analyze (Master_Decl); -- 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 if Context_Id /= Current_Scope then
Context := Parent (Context); 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 -- Mark the enclosing scope and its associated construct as being task
-- environment task is our effective master, so nothing to mark. -- 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, if Nkind_In (Context, N_Block_Statement,
N_Subprogram_Body, N_Subprogram_Body,
N_Task_Body) N_Task_Body)
then then
Set_Is_Task_Master (Context, True); Set_Is_Task_Master (Context);
return; exit;
elsif Nkind (Parent (Context)) = N_Subunit then elsif Nkind (Parent (Context)) = N_Subunit then
Context := Corresponding_Stub (Parent (Context)); Context := Corresponding_Stub (Parent (Context));
end if; end if;
Context := Parent (Context);
end loop; end loop;
end Build_Master_Entity; end Build_Master_Entity;
@ -2961,8 +2973,12 @@ package body Exp_Ch9 is
-- Build_Master_Renaming -- -- Build_Master_Renaming --
--------------------------- ---------------------------
procedure Build_Master_Renaming (N : Node_Id; Typ : Entity_Id) is procedure Build_Master_Renaming
Loc : constant Source_Ptr := Sloc (N); (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_Decl : Node_Id;
Master_Id : Entity_Id; Master_Id : Entity_Id;
@ -2973,9 +2989,22 @@ package body Exp_Ch9 is
return; return;
end if; 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 := Master_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
New_External_Name (Chars (Typ), 'M')); New_External_Name (Chars (Ptr_Typ), 'M'));
Master_Decl := Master_Decl :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
@ -2983,10 +3012,11 @@ package body Exp_Ch9 is
Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc),
Name => Make_Identifier (Loc, Name_uMaster)); Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (N, Master_Decl); Insert_Action (Context, Master_Decl);
Analyze (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; end Build_Master_Renaming;
----------------------------------------- -----------------------------------------
@ -4404,7 +4434,7 @@ package body Exp_Ch9 is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Chain, Defining_Identifier => Chain,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))), New_Reference_To (RTE (RE_Activation_Chain), Loc))),
@ -12017,6 +12047,94 @@ package body Exp_Ch9 is
Make_Integer_Literal (Loc, 0))); Make_Integer_Literal (Loc, 0)));
end Family_Size; 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 -- -- 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 -- protected type. The statements are wrapped inside a block due to a local
-- declaration. -- declaration.
procedure Build_Master_Entity procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
(Id : Entity_Id;
Use_Current : Boolean := False);
-- Given the name of an object or a type which is either a task, contains -- 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 -- tasks or designates tasks, create a _master in the appropriate scope
-- which captures the value of Current_Master. Mark the enclosing body as -- which captures the value of Current_Master. Mark the nearest enclosing
-- being a task master. A _master is built to avoid multiple expensive -- body or block as being a task master.
-- calls to Current_Master and to facilitate object initialization. Flag
-- Use_Current ensures that the master scope is the current scope.
procedure Build_Master_Renaming (N : Node_Id; Typ : Entity_Id); procedure Build_Master_Renaming
-- Given an access type Typ and a declaration N of a designated type that (Ptr_Typ : Entity_Id;
-- is either a task or contains tasks, create a renaming of the form: 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 -- where _master denotes the task master of the enclosing context. Ins_Nod
-- renaming declaration is inserted before N. -- is used to provide a specific insertion node for the renaming.
function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id; function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id;
-- A subprogram body without a previous spec that appears in a protected -- 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:: * Stack Related Facilities::
* Verifying Properties Using gnatcheck:: * Verifying Properties Using gnatcheck::
* Creating Sample Bodies Using gnatstub:: * Creating Sample Bodies Using gnatstub::
* Creating Test Drivers Using gnattest:: * Creating Unit Tests Using gnattest::
* Generating Ada Bindings for C and C++ headers:: * Generating Ada Bindings for C and C++ headers::
* Other Utility Programs:: * Other Utility Programs::
* Running and Debugging Ada Programs:: * Running and Debugging Ada Programs::
@ -469,18 +469,18 @@ Sample Bodies Using gnatstub
* Running gnatstub:: * Running gnatstub::
* Switches for gnatstub:: * Switches for gnatstub::
Creating Test Drivers Using gnattest Creating Unit Tests Using gnattest
* Running gnattest:: * Running gnattest::
* Switches for gnattest:: * Switches for gnattest::
* Project Attributes for gnattest:: * Project Attributes for gnattest::
* Simple Test Driver:: * Simple Example::
* Setting Up and Tearing Down Testing Environment:: * Setting Up and Tearing Down Testing Environment::
* Reusing Previously Written Tests:: * Regenerating Tests::
* Default Test Behavior:: * Default Test Behavior::
* Testing Primitive Operations of Tagged Types:: * Testing Primitive Operations of Tagged Types::
* Test Inheritance:: * Test Inheritance::
* Liskov Substitution Principle Check:: * Tagged Types Substitutability Testing::
* Testing with Contracts:: * Testing with Contracts::
* Additional Tests:: * Additional Tests::
* Current Limitations:: * 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. a utility that generates empty but compilable bodies for library units.
@item @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. a utility that generates unit testing templates for library units.
@item @item
@ -17666,38 +17666,40 @@ Verbose mode: generate version information.
@end table @end table
@c ********************************* @c *********************************
@node Creating Test Drivers Using gnattest @node Creating Unit Tests Using gnattest
@chapter Creating Test Drivers Using @command{gnattest} @chapter Creating Unit Tests Using @command{gnattest}
@findex gnattest @findex gnattest
@noindent @noindent
@command{gnattest} is an ASIS-based utility that creates template tests @command{gnattest} is an ASIS-based utility that creates unit tests stubs
(test stubs) as well as test driver infrastructure (harness) for unit testing as well as a test driver infrastructure (harness). @command{gnattest} creates
of Ada source code. 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 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, 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 those units should be among source files of the project or of other projects
imported by this one. imported by this one.
Generated stubs and harness are based on AUnit testing framework. AUnit Generated stubs and harness are based on the AUnit testing framework. AUnit is
framework is an Ada adaptation of Java and C++ unit testing frameworks. an Ada adaptation of the xxxUnit testing frameworks similar to JUnit for Java or
While it is advised that gnattest users read AUnit manual, deep knowledge CppUnit for C++. While it is advised that gnattest users read AUnit manual, deep
of AUnit is not necessary for using gnattest. For correct operation of knowledge of AUnit is not necessary for using gnattest. For correct operation of
@command{gnattest} AUnit should be installed on default project path. @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 @menu
* Running gnattest:: * Running gnattest::
* Switches for gnattest:: * Switches for gnattest::
* Project Attributes for gnattest:: * Project Attributes for gnattest::
* Simple Test Driver:: * Simple Example::
* Setting Up and Tearing Down Testing Environment:: * Setting Up and Tearing Down Testing Environment::
* Reusing Previously Written Tests:: * Regenerating Tests::
* Default Test Behavior:: * Default Test Behavior::
* Testing Primitive Operations of Tagged Types:: * Testing Primitive Operations of Tagged Types::
* Test Inheritance:: * Test Inheritance::
* Liskov Substitution Principle Check:: * Tagged Types Substitutability Testing::
* Testing with Contracts:: * Testing with Contracts::
* Additional Tests:: * Additional Tests::
* Current Limitations:: * 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 @command{gnattest} has the command-line interface of the form
@smallexample @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) @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 @end smallexample
@noindent @noindent
@ -17720,8 +17722,9 @@ where
@table @var @table @var
@item -Pprojname @item -Pprojname
specifies the project that allow locating the source files. If no [filenames] 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. are provided on the command line, all project sources are used as input. This
switch is mandatory.
@item --harness-dir=dirname @item --harness-dir=dirname
specifies directory to put harness packages and project file for the test 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 @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 @node Switches for gnattest
@section Switches for @command{gnattest} @section Switches for @command{gnattest}
@ -17797,7 +17829,7 @@ will be created by default.
@end table @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 @node Project Attributes for gnattest
@section Project Attributes for @command{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 Other @command{gnattest} switches can also be passed via the project
file as an attribute list called GNATtest_Switches. file as an attribute list called GNATtest_Switches.
@node Simple Test Driver @node Simple Example
@section Simple Test Driver @section Simple Example
@noindent @noindent
@command{gnattest} works with package specifications. The basic functionality Let's take a very simple example using the first @command{gnattest} example
of @command{gnattest} is creating one test stub per one subprogram declared
in package specification. This can be observes on a very simple example
located at located at
@smallexample @smallexample
examples/lib1 <install_prefix>/share/examples/gnattest/lib1
@end smallexample @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 @smallexample
$ gnattest --harness-dir=driver -Plib1.gpr $ gnattest --harness-dir=driver -Plib1.gpr
@end smallexample @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 @smallexample
$ cd driver $ cd driver
@ -17870,12 +17900,12 @@ Since no special output option was specified the test package Lib1.Tests
is located in is located in
@smallexample @smallexample
examples/lib1/src/tests <install_prefix>/share/examples/gnattest/lib1/src/tests
@end smallexample @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 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. subprogram it corresponds. All the test routines have separated bodies.
The test routine locates at lib1-tests-test_inc_5eaee3.adb has a single The test routine locates at lib1-tests-test_inc_5eaee3.adb has a single
statement - procedure Assert. It has two arguments: the boolean expression 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. is false.
That is where actual testing code should be written after a proper setup. 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 @smallexample @c ada
Assert (Inc (1) = 2, "wrong incrementation"); 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, be used to perform necessary initialization and finalization,
memory allocation etc. memory allocation etc.
@node Reusing Previously Written Tests @node Regenerating Tests
@section Reusing Previously Written Tests @section Regenerating Tests
@noindent @noindent
Bodies of test routines and env_mgmt packages are never overridden after they 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 have been 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 names and order of its parameters are the same, the old test routine will
fit in it's place. 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 and body of function Dec in lib1.ads and lib1.adb, running
@command{gnattest} on the project and then running the test driver: @command{gnattest} on the project and then running the test driver:
@ -17925,7 +17955,11 @@ gprbuild -Ptest_driver
test_runner test_runner
@end smallexample @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 @node Default Test Behavior
@section 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 Passing it to the driver generated on the first example
@smallexample @smallexample
test_runer --stub-default=pass test_runner --stub-default=pass
@end smallexample @end smallexample
makes both tests pass, even the unimplemented one. 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 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 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 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 discriminants, the User_Set_Up only has a commented template of setting
up the fixture since filling th discriminant with actual value is up up the fixture since filling the discriminant with actual value is up
to the user. to the user.
The knowledge of the structure if test types allows to have additional testing 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 @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 inheritance of tests take place. An example of such inheritance can be
shown by running the test driver generated for second example. As previously shown by running the test driver generated for second example. As previously
mentioned, actual tests are already written for this example. 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 routine for function Speed has been inherited and ran against objects of the
derived type. derived type.
@node Liskov Substitution Principle Check @node Tagged Types Substitutability Testing
@section Liskov Substitution Principle Check @section Tagged Types Substitutability Testing
@noindent @noindent
Liskov substitution principle (LSP) is a principle in object-oriented Tagged Types Substitutability Testing is a way of verifying by testing
programming. It states that, in a computer program if S is a subtype of T, 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 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 of type S may be substituted for objects of type T), without altering any of
the desirable properties of that program. 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. Verifying LSP by testing consists in running all the unit tests associated with
The overriding function Adjust_Speed in package Speed2 removes the the primitives of a given tagged type with objects of its derived types.
functionality of the overridden function. Gnattest has a special option to run
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 overridden parent tests against objects of the type which have overriding
primitives. 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 "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). 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 @smallexample
cd examples/lib3 cd examples/lib3

12
gcc/ada/projects.texi
View File

@ -2015,8 +2015,16 @@ end Work;
@end smallexample @end smallexample
@noindent @noindent
An extending project retains all the switches specified in the All packages that are not declared in the extending project are inherited from
extended project. 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 @menu
* Project Hierarchy Extension:: * 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. -- proper Master for the created tasks.
if Nkind (Related_Nod) = N_Object_Declaration if Nkind (Related_Nod) = N_Object_Declaration
and then Expander_Active and then Expander_Active
then then
if Is_Interface (Desig_Type) if Is_Interface (Desig_Type)
and then Is_Limited_Record (Desig_Type) and then Is_Limited_Record (Desig_Type)
@ -899,10 +899,9 @@ package body Sem_Ch3 is
elsif Has_Task (Desig_Type) elsif Has_Task (Desig_Type)
and then Comes_From_Source (Related_Nod) and then Comes_From_Source (Related_Nod)
and then not Restriction_Active (No_Task_Hierarchy)
then then
Build_Master_Entity (Defining_Identifier (Related_Nod), True); Build_Master_Entity (Defining_Identifier (Related_Nod));
Build_Master_Renaming (Related_Nod, Anon_Type); Build_Master_Renaming (Anon_Type);
end if; end if;
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 if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
declare declare
Result_Subt : constant Entity_Id := Etype (E); 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); pragma Warnings (Off, Discard);
Formal_Typ : Entity_Id;
begin begin
-- In the case of functions with unconstrained result subtypes, -- 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 -- master of the tasks to be created, and the caller's activation
-- chain. -- chain.
if Has_Task (Available_View (Result_Subt)) then if Has_Task (Full_Subt) then
Discard := Discard :=
Add_Extra_Formal Add_Extra_Formal
(E, RTE (RE_Master_Id), (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 -- All build-in-place functions get an extra formal that will be
-- passed the address of the return object within the caller. -- passed the address of the return object within the caller.
declare Formal_Typ :=
Formal_Type : constant Entity_Id := Create_Itype (E_Anonymous_Access_Type, E, Scope_Id => Scope (E));
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);
-- Ada 2005 (AI-50217): Propagate the attribute that indicates Set_Directly_Designated_Type (Formal_Typ, Result_Subt);
-- the designated type comes from the limited view (for Set_Etype (Formal_Typ, Formal_Typ);
-- back-end purposes). 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 := Layout_Type (Formal_Typ);
Add_Extra_Formal
(E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access)); Discard :=
end; Add_Extra_Formal
(E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access));
end; end;
end if; end if;
end Create_Extra_Formals; end Create_Extra_Formals;

65
gcc/ada/sem_util.adb
View File

@ -7345,6 +7345,33 @@ package body Sem_Util is
end if; end if;
end Is_Fully_Initialized_Variant; 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 -- -- Is_Iterator --
----------------- -----------------
@ -7415,33 +7442,6 @@ package body Sem_Util is
end if; end if;
end Is_LHS; 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 -- -- Is_Library_Level_Entity --
----------------------------- -----------------------------
@ -7462,6 +7462,17 @@ package body Sem_Util is
return Enclosing_Dynamic_Scope (E) = Standard_Standard; return Enclosing_Dynamic_Scope (E) = Standard_Standard;
end Is_Library_Level_Entity; 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 -- -- 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, -- A library-level declaration is one that is accessible from Standard,
-- i.e. a library unit or an entity declared in a library package. -- 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; function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
-- Determines whether Expr is a reference to a variable or IN OUT mode -- Determines whether Expr is a reference to a variable or IN OUT mode
-- parameter of the current enclosing subprogram. -- parameter of the current enclosing subprogram.