OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_util.adb, [...] (Build_Class_Wide_Clone_Body): Build body of subprogram that has a class-wide condition that contains calls to...

Browse Source 
2017-04-27  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb, sem_util.ads (Build_Class_Wide_Clone_Body):
	Build body of subprogram that has a class-wide condition that
	contains calls to other primitives.
	(Build_Class_Wide_Clone_Call); Build a call to the common
	class-wide clone of a subprogram with classwide conditions. The
	body of the subprogram becomes a wrapper for a call to the
	clone. The inherited operation becomes a similar wrapper to which
	modified conditions apply, and the call to the clone includes
	the proper conversion in a call the parent operation.
	(Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id): For a
	subprogram that has a classwide condition that contains calls to
	other primitives, build an internal subprogram that is invoked
	through a type-specific wrapper for all inherited subprograms
	that may have a modified condition.
	* sem_prag.adb (Check_References): If subprogram has a classwide
	condition, create entity for corresponding clone, to be invoked
	through wrapper subprograns.
	(Analyze_Pre_Post_Condition_In_Decl_Part): Do not emit error
	message about placement if pragma isi internally generated.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): If subprogram has
	a classwide clone, build body of clone as copy of original body,
	and rewrite original body as a wrapper as a wrapper for a call to
	the clone, so that it incorporates the original pre/postconditions
	of the subprogram.
	* freeze.adb (Check_Inherited_Conditions): For an inherited
	subprogram that inherits a classwide condition, build spec and
	body of corresponding wrapper so that call to inherited operation
	gets the modified conditions.
	* contracts.adb (Analyze_Contracts): If analysis of classwide
	condition has created a clone for a primitive operation, analyze
	declaration of clone.

From-SVN: r247313
This commit is contained in:
Ed Schonberg 2017-04-27 10:20:36 +00:00 committed by Arnaud Charlet
parent c1025b4e6f
commit aaa0a838e6
7 changed files with 325 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
2017-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb, sem_util.ads (Build_Class_Wide_Clone_Body):
Build body of subprogram that has a class-wide condition that
contains calls to other primitives.
(Build_Class_Wide_Clone_Call); Build a call to the common
class-wide clone of a subprogram with classwide conditions. The
body of the subprogram becomes a wrapper for a call to the
clone. The inherited operation becomes a similar wrapper to which
modified conditions apply, and the call to the clone includes
the proper conversion in a call the parent operation.
(Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id): For a
subprogram that has a classwide condition that contains calls to
other primitives, build an internal subprogram that is invoked
through a type-specific wrapper for all inherited subprograms
that may have a modified condition.
* sem_prag.adb (Check_References): If subprogram has a classwide
condition, create entity for corresponding clone, to be invoked
through wrapper subprograns.
(Analyze_Pre_Post_Condition_In_Decl_Part): Do not emit error
message about placement if pragma isi internally generated.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): If subprogram has
a classwide clone, build body of clone as copy of original body,
and rewrite original body as a wrapper as a wrapper for a call to
the clone, so that it incorporates the original pre/postconditions
of the subprogram.
* freeze.adb (Check_Inherited_Conditions): For an inherited
subprogram that inherits a classwide condition, build spec and
body of corresponding wrapper so that call to inherited operation
gets the modified conditions.
* contracts.adb (Analyze_Contracts): If analysis of classwide
condition has created a clone for a primitive operation, analyze
declaration of clone.
2017-04-27 Steve Baird <baird@adacore.com>
* exp_util.adb (Build_Allocate_Deallocate_Proc):

20
gcc/ada/contracts.adb
View File

@ -384,9 +384,23 @@ package body Contracts is
N_Generic_Subprogram_Declaration,
N_Subprogram_Declaration)
then
Analyze_Entry_Or_Subprogram_Contract
(Subp_Id => Defining_Entity (Decl),
Freeze_Id => Freeze_Id);
declare
Subp_Id : constant Entity_Id := Defining_Entity (Decl);
begin
Analyze_Entry_Or_Subprogram_Contract (Subp_Id, Freeze_Id);
-- If analysis of a classwide pre/postcondition indicates
-- that a class-wide clone is needed, analyze its declaration
-- now. Its body is created when the body of the original
-- operation is analyzed (and rewritten).
if Is_Subprogram (Subp_Id)
and then Present (Class_Wide_Clone (Subp_Id))
then
Analyze (Unit_Declaration_Node (Class_Wide_Clone (Subp_Id)));
end if;
end;
-- Entry or subprogram bodies

94
gcc/ada/freeze.adb
View File

@ -55,7 +55,6 @@ with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
@ -1408,7 +1407,6 @@ package body Freeze is
New_Prag : Node_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
Par_Type : Entity_Id;
Prim : Entity_Id;
begin
@ -1459,7 +1457,6 @@ package body Freeze is
if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
Par_Prim := Alias (Prim);
Par_Type := Find_Dispatching_Type (Par_Prim);
-- Analyze the contract items of the parent operation, before
-- they are rewritten when inherited.
@ -1505,80 +1502,53 @@ package body Freeze is
-- one, and whose inherited expression has been updated above.
-- These expressions are the arguments of pragmas that are part
-- of the declarations of the wrapper. The wrapper holds a single
-- statement that is a call to the parent primitive, where the
-- statement that is a call to the class-wide clone, where the
-- controlling actuals are conversions to the corresponding type
-- in the parent primitive:
-- procedure New_Prim (F1 : T1.; ...) is
-- pragma Check (Precondition, Expr);
-- procedure New_Prim (F1 : T1; ...);
-- procedure New_Prim (F1 : T1; ...) is
-- pragma Check (Precondition, Expr);
-- begin
-- Par_Prim (Par_Type (F1) ..);
-- Par_Prim_Clone (Par_Type (F1), ...);
-- end;
-- If the primitive is a function the statement is a call
-- If the primitive is a function the statement is a return
-- statement with a call.
declare
Loc : constant Source_Ptr := Sloc (R);
Actuals : List_Id;
Call : Node_Id;
Formal : Entity_Id;
New_F_Spec : Node_Id;
New_Formal : Entity_Id;
New_Proc : Node_Id;
New_Spec : Node_Id;
Loc : constant Source_Ptr := Sloc (R);
Par_R : constant Node_Id := Parent (R);
New_Body : Node_Id;
New_Decl : Node_Id;
New_Spec : Node_Id;
begin
Actuals := Empty_List;
New_Spec := Build_Overriding_Spec (Par_Prim, R);
Formal := First_Formal (Par_Prim);
New_F_Spec := First (Parameter_Specifications (New_Spec));
New_Spec := Build_Overriding_Spec (Par_Prim, R);
New_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => New_Spec);
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
-- Insert the declaration and the body of the wrapper after
-- type declaration that generates inherited operation. For
-- a null procedure, the declaration implies a null body.
-- If controlling argument, add conversion
if Nkind (New_Spec) = N_Procedure_Specification
and then Null_Present (New_Spec)
then
Insert_After_And_Analyze (Par_R, New_Decl);
if Etype (Formal) = Par_Type then
Append_To (Actuals,
Make_Type_Conversion (Loc,
New_Occurrence_Of (Par_Type, Loc),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
end if;
Next_Formal (Formal);
Next (New_F_Spec);
end loop;
if Ekind (Par_Prim) = E_Procedure then
Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Par_Prim, Loc),
Parameter_Associations => Actuals);
else
Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Par_Prim, Loc),
Parameter_Associations => Actuals));
-- Build body as wrapper to a call to the already built
-- class-wide clone.
New_Body :=
Build_Class_Wide_Clone_Call
(Loc, Decls, Par_Prim, New_Spec);
Insert_List_After_And_Analyze
(Par_R, New_List (New_Decl, New_Body));
end if;
New_Proc :=
Make_Subprogram_Body (Loc,
Specification => New_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call),
End_Label => Make_Identifier (Loc, Chars (Prim))));
Insert_After (Parent (R), New_Proc);
Analyze (New_Proc);
end;
Needs_Wrapper := False;

21
gcc/ada/sem_ch6.adb
View File

@ -415,7 +415,7 @@ package body Sem_Ch6 is
Orig_N := Original_Node (N);
Remove_Aspects (Orig_N);
-- Propagate any pragmas that apply to the expression function to the
-- Propagate any pragmas that apply to expression function to the
-- proper body when the expression function acts as a completion.
-- Aspects are automatically transfered because of node rewriting.
@ -3624,6 +3624,25 @@ package body Sem_Ch6 is
end if;
end if;
-- If the subprogram has a class-wide clone, build its body as a copy
-- of the original body, and rewrite body of original subprogram as a
-- wrapper that calls the clone.
if Present (Spec_Id)
and then Present (Class_Wide_Clone (Spec_Id))
and then (Comes_From_Source (N) or else Was_Expression_Function (N))
then
Build_Class_Wide_Clone_Body (Spec_Id, N);
-- This is the new body for the existing primitive operation
Rewrite (N, Build_Class_Wide_Clone_Call
(Sloc (N), New_List, Spec_Id, Parent (Spec_Id)));
Set_Has_Completion (Spec_Id, False);
Analyze (N);
return;
end if;
-- Place subprogram on scope stack, and make formals visible. If there
-- is a spec, the visible entity remains that of the spec.

37
gcc/ada/sem_prag.adb
View File

@ -4424,6 +4424,14 @@ package body Sem_Prag is
end if;
end;
-- A renaming declaration may inherit a generated pragma, its
-- placement comes from expansion, not from source.
elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
and then not Comes_From_Source (N)
then
null;
-- Otherwise the placement is illegal
else
@ -23949,6 +23957,9 @@ package body Sem_Prag is
(N : Node_Id;
Freeze_Id : Entity_Id := Empty)
is
Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
Disp_Typ : Entity_Id;
-- The dispatching type of the subprogram subject to the pre- or
-- postcondition.
@ -23995,6 +24006,18 @@ package body Sem_Prag is
("operation in class-wide condition must be primitive "
& "of &", Nod, Disp_Typ);
end if;
-- Otherwise we have a call to an overridden primitive, and
-- we will create a common class-wide clone for the body of
-- original operation and its eventual inherited versions.
-- If the original operation dispatches on result it is
-- never inherited and there is no need for a clone.
elsif not Is_Abstract_Subprogram (Spec_Id)
and then No (Class_Wide_Clone (Spec_Id))
and then not Has_Controlling_Result (Spec_Id)
then
Build_Class_Wide_Clone_Decl (Spec_Id);
end if;
end;
@ -24027,10 +24050,7 @@ package body Sem_Prag is
-- Local variables
Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
-- Save the Ghost mode to restore on exit
@ -24116,6 +24136,15 @@ package body Sem_Prag is
End_Scope;
end if;
-- If analysis of the condition indicates that a class-wide clone
-- has been created, build and analyze its declaration.
if Is_Subprogram (Spec_Id)
and then Present (Class_Wide_Clone (Spec_Id))
then
Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
end if;
-- Currently it is not possible to inline pre/postconditions on a
-- subprogram subject to pragma Inline_Always.

143
gcc/ada/sem_util.adb
View File

@ -1164,6 +1164,141 @@ package body Sem_Util is
return Empty;
end Build_Actual_Subtype_Of_Component;
---------------------------------
-- Build_Class_Wide_Clone_Body --
---------------------------------
procedure Build_Class_Wide_Clone_Body
(Spec_Id : Entity_Id;
Bod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Bod);
Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
Clone_Body : Node_Id;
begin
-- The declaration of the class-wide clone was created when the
-- corresponding class-wide condition was analyzed.
Clone_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Parent (Clone_Id)),
Declarations => Declarations (Bod),
Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
-- The new operation is internal and overriding indicators do not apply
-- (the original primitive may have carried one).
Set_Must_Override (Specification (Clone_Body), False);
Insert_Before (Bod, Clone_Body);
Analyze (Clone_Body);
end Build_Class_Wide_Clone_Body;
---------------------------------
-- Build_Class_Wide_Clone_Call --
---------------------------------
function Build_Class_Wide_Clone_Call
(Loc : Source_Ptr;
Decls : List_Id;
Spec_Id : Entity_Id;
Spec : Node_Id) return Node_Id
is
Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
Actuals : List_Id;
Call : Node_Id;
Formal : Entity_Id;
New_Body : Node_Id;
New_F_Spec : Entity_Id;
New_Formal : Entity_Id;
begin
Actuals := Empty_List;
Formal := First_Formal (Spec_Id);
New_F_Spec := First (Parameter_Specifications (Spec));
-- Build parameter association for call to class-wide clone.
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
-- If controlling argument and operation is inherited, add conversion
-- to parent type for the call.
if Etype (Formal) = Par_Type
and then not Is_Empty_List (Decls)
then
Append_To (Actuals,
Make_Type_Conversion (Loc,
New_Occurrence_Of (Par_Type, Loc),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
end if;
Next_Formal (Formal);
Next (New_F_Spec);
end loop;
if Ekind (Spec_Id) = E_Procedure then
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Clone_Id, Loc),
Parameter_Associations => Actuals);
else
Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Clone_Id, Loc),
Parameter_Associations => Actuals));
end if;
New_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call),
End_Label => Make_Identifier (Loc, Chars (Spec_Id))));
return New_Body;
end Build_Class_Wide_Clone_Call;
---------------------------------
-- Build_Class_Wide_Clone_Decl --
---------------------------------
procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Spec_Id);
Clone_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Spec_Id), Suffix => "CL"));
Decl : Node_Id;
Spec : Node_Id;
begin
Spec := Copy_Subprogram_Spec (Parent (Spec_Id));
Set_Must_Override (Spec, False);
Set_Must_Not_Override (Spec, False);
Set_Defining_Unit_Name (Spec, Clone_Id);
Decl := Make_Subprogram_Declaration (Loc, Spec);
Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id)));
-- Link clone to original subprogram, for use when building body and
-- wrapper call to inherited operation.
Set_Class_Wide_Clone (Spec_Id, Clone_Id);
end Build_Class_Wide_Clone_Decl;
-----------------------------
-- Build_Component_Subtype --
-----------------------------
@ -5245,6 +5380,14 @@ package body Sem_Util is
Result := New_Copy_Tree (Spec);
-- However, the spec of a null procedure carries the corresponding null
-- statement of the body (created by the parser), and this cannot be
-- shared with the new subprogram spec.
if Nkind (Result) = N_Procedure_Specification then
Set_Null_Statement (Result, Empty);
end if;
-- Create a new entity for the defining unit name
Def_Id := Defining_Unit_Name (Result);

46
gcc/ada/sem_util.ads
View File

@ -209,6 +209,52 @@ package Sem_Util is
-- Determine whether a selected component has a type that depends on
-- discriminants, and build actual subtype for it if so.
-- Handling of inherited primitives whose ancestor have class-wide
-- pre/post conditions.
-- If a primitive operation of a parent type has a class-wide pre/post
-- condition that includes calls to other primitives, and that operation
-- is inherited by a descendant type that also overrides some of these
-- other primitives, the condition that applies to the inherited
-- operation has a modified condition in which the overridden primitives
-- have been replaced by the primitives of the descendent type. A call
-- to the inherited operation cannot be simply a call to the parent
-- operation (with an appropriate conversion) as is the case for other
-- inherited operations, but must appear with a wrapper subprogram to which
-- the modified conditions apply. Furthermore the call to the parent
-- operation must not be subject to the original class-wide condition,
-- given that modified conditions apply. To implement these semantics
-- economically we create a subprogram body (a "class-wide clone") to
-- which no pre/postconditions apply, and we create bodies for the
-- original and the inherited operation that have their respective
-- pre/post conditions and simply call the clone. The following operations
-- take care of constructing declaration and body of the clone, and
-- building the calls to it within the appropriate wrappers.
procedure Build_Class_Wide_Clone_Body
(Spec_Id : Entity_Id;
Bod : Node_Id);
-- Build body of subprogram that has a class-wide condition that contains
-- calls to other primitives. Spec_Id is the Id of the subprogram, and B
-- is its source body, which becomes the body of the clone.
function Build_Class_Wide_Clone_Call
(Loc : Source_Ptr;
Decls : List_Id;
Spec_Id : Entity_Id;
Spec : Node_Id) return Node_Id;
-- Build a call to the common class-wide clone of a subprogram with
-- class-wide conditions. The body of the subprogram becomes a wrapper
-- for a call to the clone. The inherited operation becomes a similar
-- wrapper to which modified conditions apply, and the call to the
-- clone includes the proper conversion in a call the parent operation.
procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id);
-- For a subprogram that has a clas-wide condition that contains calls
-- to other primitives, build an internal subprogram that is invoked
-- through a type-specific wrapper for all inherited subprograms that
-- may have a modified condition.
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id;