+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):
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
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;
New_Prag : Node_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
- Par_Type : Entity_Id;
Prim : Entity_Id;
begin
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.
-- 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 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 Nkind (New_Spec) = N_Procedure_Specification
+ and then Null_Present (New_Spec)
+ then
+ Insert_After_And_Analyze (Par_R, New_Decl);
- 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));
- end if;
+ -- Build body as wrapper to a call to the already built
+ -- class-wide clone.
- 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))));
+ New_Body :=
+ Build_Class_Wide_Clone_Call
+ (Loc, Decls, Par_Prim, New_Spec);
- Insert_After (Parent (R), New_Proc);
- Analyze (New_Proc);
+ Insert_List_After_And_Analyze
+ (Par_R, New_List (New_Decl, New_Body));
+ end if;
end;
Needs_Wrapper := False;
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.
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.
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
(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.
("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;
-- 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
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.
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 --
-----------------------------
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);
-- 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;
projects / gcc.git / commitdiff