This patch completes the implementation of AI12-0220, which adds
contracts to Access_To_Subprogram types. Attributes 'Old and 'Result are
properly supported, and the needed subprogram wrapper is built before
the contract aspects on the access type are analyzed, to simplify
semantic checks.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-17 Ed Schonberg <schonb...@adacore.com>
gcc/ada/
* sem_ch3.adb (Analyze_Full_Type_Declaration): For an
access_to_subprogram declaration that has aspect specifications,
call Build_Access_ Subprogram_Wrapper at once, so that pre- and
postcondition aspects are analyzed in the context of a
subprogram declaration.
(Build_Access_Subprogram_Wrapper): Examine aspect specifications
of an Access_To_Subprogram declaration. If pre- or
postconditions are declared for it, create declaration for
subprogram wrapper and add the corresponding aspect
specifications to it. Replace occurrences of the type name by
that of the generated subprogram, so that attributes 'Old and
'Result can appear in a postcondition.
* exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Moved
here from sem_prag.adb.
* exp_ch3.ads (Build_Access_Subprogram_Wrapper_Body): Visible
subprogram.
* sem_prag.adb (Build_Access_Subprogram_Wrapper / _Body): Moved
to sem_ch3.adb and exp_ch3.adb.--- gcc/ada/exp_ch3.adb
+++ gcc/ada/exp_ch3.adb
@@ -515,6 +515,78 @@ package body Exp_Ch3 is
end loop;
end Adjust_Discriminants;
+ ------------------------------------------
+ -- Build_Access_Subprogram_Wrapper_Body --
+ ------------------------------------------
+
+ procedure Build_Access_Subprogram_Wrapper_Body
+ (Decl : Node_Id;
+ New_Decl : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Actuals : constant List_Id := New_List;
+ Type_Def : constant Node_Id := Type_Definition (Decl);
+ Type_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Spec_Node : constant Node_Id :=
+ New_Copy_Tree (Specification (New_Decl));
+
+ Act : Node_Id;
+ Body_Node : Node_Id;
+ Call_Stmt : Node_Id;
+ Ptr : Entity_Id;
+ begin
+ if not Expander_Active then
+ return;
+ end if;
+
+ Set_Defining_Unit_Name (Spec_Node,
+ Make_Defining_Identifier
+ (Loc, Chars (Defining_Unit_Name (Spec_Node))));
+
+ -- Create List of actuals for indirect call. The last
+ -- parameter of the subprogram is the access value itself.
+
+ Act := First (Parameter_Specifications (Spec_Node));
+
+ while Present (Act) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
+ Next (Act);
+ exit when Act = Last (Parameter_Specifications (Spec_Node));
+ end loop;
+
+ Ptr :=
+ Defining_Identifier
+ (Last (Parameter_Specifications (Spec_Node)));
+
+ if Nkind (Type_Def) = N_Access_Procedure_Definition then
+ Call_Stmt := Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference
+ (Loc, New_Occurrence_Of (Ptr, Loc)),
+ Parameter_Associations => Actuals);
+ else
+ Call_Stmt := Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => Make_Explicit_Dereference
+ (Loc, New_Occurrence_Of (Ptr, Loc)),
+ Parameter_Associations => Actuals));
+ end if;
+
+ Body_Node := Make_Subprogram_Body (Loc,
+ Specification => Spec_Node,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call_Stmt)));
+
+ -- Place body in list of freeze actions for the type.
+
+ Ensure_Freeze_Node (Type_Id);
+ Append_Freeze_Actions (Type_Id, New_List (Body_Node));
+ end Build_Access_Subprogram_Wrapper_Body;
+
---------------------------
-- Build_Array_Init_Proc --
---------------------------
--- gcc/ada/exp_ch3.ads
+++ gcc/ada/exp_ch3.ads
@@ -46,6 +46,17 @@ package Exp_Ch3 is
procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record
+ procedure Build_Access_Subprogram_Wrapper_Body
+ (Decl : Node_Id;
+ New_Decl : Node_Id);
+ -- Build the wrapper body, which holds the indirect call through
+ -- an access_to_subprogram, and whose expansion incorporates the
+ -- contracts of the access type declaration. Called from Build_
+ -- Access_Subprogram_Wrapper.
+ -- Building the wrapper is done during analysis to perform proper
+ -- semantic checks on the relevant aspects. The wrapper body could
+ -- be simplified to a null body when expansion is disabled ???
+
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Builds function which checks whether the component name is consistent
-- with the current discriminants. N is the full type declaration node,
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -92,6 +92,11 @@ package body Sem_Ch3 is
-- abstract interface types implemented by a record type or a derived
-- record type.
+ procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id);
+ -- When an access_to_subprogram type has pre/postconditions, we
+ -- build a subprogram that includes these contracts and is invoked
+ -- by any indirect call through the corresponding access type.
+
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
@@ -3136,6 +3141,17 @@ package body Sem_Ch3 is
Validate_Access_Type_Declaration (T, N);
+ -- If the type has contracts, we create the corresponding
+ -- wrapper at once, before analyzing the aspect
+ -- specifications, so that pre/postconditions can be
+ -- handled directly on the generated wrapper.
+
+ if Ada_Version >= Ada_2020
+ and then Present (Aspect_Specifications (N))
+ then
+ Build_Access_Subprogram_Wrapper (N);
+ end if;
+
when N_Access_To_Object_Definition =>
Access_Type_Declaration (T, Def);
@@ -6447,6 +6463,146 @@ package body Sem_Ch3 is
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
+ -------------------------------------
+ -- Build_Access_Subprogram_Wrapper --
+ -------------------------------------
+
+ procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Id : constant Entity_Id := Defining_Identifier (Decl);
+ Type_Def : constant Node_Id := Type_Definition (Decl);
+ Specs : constant List_Id :=
+ Parameter_Specifications (Type_Def);
+ Profile : constant List_Id := New_List;
+ Subp : constant Entity_Id := Make_Temporary (Loc, 'A');
+
+ Contracts : constant List_Id := New_List;
+ Form_P : Node_Id;
+ New_P : Node_Id;
+ New_Decl : Node_Id;
+ Spec : Node_Id;
+
+ procedure Replace_Type_Name (Expr : Node_Id);
+ -- In the expressions for contract aspects, replace
+ -- occurrences of the access type with the name of the
+ -- subprogram entity, as needed, e.g. for 'Result.
+ -- Apects that are not contracts 9e.g. Size or Aligment)
+ -- remain on the originsl access type declaration.
+ -- What about expanded names denoting formals, whose prefix
+ -- in the source is the type name ???
+
+ -----------------------
+ -- Replace_Type_Name --
+ -----------------------
+
+ procedure Replace_Type_Name (Expr : Node_Id) is
+ function Process (N : Node_Id) return Traverse_Result;
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (N))
+ and then Chars (Prefix (N)) = Chars (Id)
+ then
+ Set_Prefix (N, Make_Identifier (Sloc (N), Chars (Subp)));
+ end if;
+
+ return OK;
+ end Process;
+
+ procedure Traverse is new Traverse_Proc (Process);
+ begin
+ Traverse (Expr);
+ end Replace_Type_Name;
+
+ begin
+ if Ekind_In (Id, E_Access_Subprogram_Type,
+ E_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Subprogram_Type)
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("illegal pre/postcondition on access type", Decl);
+ return;
+ end if;
+
+ declare
+ Asp : Node_Id;
+ A_Id : Aspect_Id;
+ Cond : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ Asp := First (Aspect_Specifications (Decl));
+ while Present (Asp) loop
+ A_Id := Get_Aspect_Id (Chars (Identifier (Asp)));
+ if A_Id = Aspect_Pre or else A_Id = Aspect_Post then
+ Cond := Asp;
+ Expr := Expression (Cond);
+ Replace_Type_Name (Expr);
+ Next (Asp);
+
+ Remove (Cond);
+ Append (Cond, Contracts);
+
+ else
+ Next (Asp);
+ end if;
+ end loop;
+ end;
+
+ -- If there are no contract aspects, no need for a wrapper.
+
+ if Is_Empty_List (Contracts) then
+ return;
+ end if;
+
+ Form_P := First (Specs);
+
+ while Present (Form_P) loop
+ New_P := New_Copy_Tree (Form_P);
+ Set_Defining_Identifier (New_P,
+ Make_Defining_Identifier
+ (Loc, Chars (Defining_Identifier (Form_P))));
+ Append (New_P, Profile);
+ Next (Form_P);
+ end loop;
+
+ -- Add to parameter specifications the access parameter that
+ -- is passed in from an indirect call.
+
+ Append (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
+ Parameter_Type => New_Occurrence_Of (Id, Loc)),
+ Profile);
+
+ if Nkind (Type_Def) = N_Access_Procedure_Definition then
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile);
+ else
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile,
+ Result_Definition =>
+ New_Copy_Tree
+ (Result_Definition (Type_Definition (Decl))));
+ end if;
+
+ New_Decl :=
+ Make_Subprogram_Declaration (Loc, Specification => Spec);
+ Set_Aspect_Specifications (New_Decl, Contracts);
+
+ Insert_After (Decl, New_Decl);
+ Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp);
+ Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl);
+ end Build_Access_Subprogram_Wrapper;
+
-------------------------------
-- Build_Derived_Access_Type --
-------------------------------
--- gcc/ada/sem_prag.adb
+++ gcc/ada/sem_prag.adb
@@ -4533,185 +4533,6 @@ package body Sem_Prag is
-- a class-wide precondition only if one of its ancestors has an
-- explicit class-wide precondition.
- procedure Build_Access_Subprogram_Wrapper
- (Decl : Node_Id;
- Prag : Node_Id);
- -- When an access_to_subprogram type has pre/postconditions, we
- -- build a subprogram that includes these contracts and is invoked
- -- by any indirect call through the corresponding access type.
-
- procedure Build_Access_Subprogram_Wrapper_Body
- (Decl : Node_Id;
- New_Decl : Node_Id);
- -- Build the wrapper body, which holds the indirect call through
- -- an access_to_subprogram, and whose expansion incorporates the
- -- contracts of the access type declaration.
-
- -------------------------------------
- -- Build_Access_Subprogram_Wrapper --
- -------------------------------------
-
- procedure Build_Access_Subprogram_Wrapper
- (Decl : Node_Id;
- Prag : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Decl);
- Id : constant Entity_Id := Defining_Identifier (Decl);
- Type_Def : constant Node_Id := Type_Definition (Decl);
- Specs : constant List_Id := Parameter_Specifications (Type_Def);
- Profile : constant List_Id := New_List;
-
- Form_P : Node_Id;
- New_P : Node_Id;
- New_Decl : Node_Id;
- Spec : Node_Id;
- Subp : Entity_Id;
-
- begin
- if Ekind_In (Id, E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Subprogram_Type)
- then
- null;
-
- else
- Error_Msg_N
- ("illegal pre/postcondition on access type", N);
- return;
- end if;
-
- Subp := Make_Temporary (Loc, 'A');
- Form_P := First (Specs);
-
- while Present (Form_P) loop
- New_P := New_Copy_Tree (Form_P);
- Set_Defining_Identifier (New_P,
- Make_Defining_Identifier
- (Loc, Chars (Defining_Identifier (Form_P))));
- Append (New_P, Profile);
- Next (Form_P);
- end loop;
-
- -- Add to parameter specifications the access parameter that
- -- is passed from an indirect call.
-
- Append (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'P'),
- Parameter_Type => New_Occurrence_Of (Id, Loc)),
- Profile);
-
- if Nkind (Type_Def) = N_Access_Procedure_Definition then
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Subp,
- Parameter_Specifications => Profile);
- else
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Subp,
- Parameter_Specifications => Profile,
- Result_Definition =>
- New_Copy_Tree
- (Result_Definition (Type_Definition (Decl))));
- end if;
-
- New_Decl :=
- Make_Subprogram_Declaration (Loc, Specification => Spec);
- Set_Aspect_Specifications (New_Decl,
- New_Copy_List_Tree (Aspect_Specifications (Decl)));
-
- declare
- Asp : Node_Id;
-
- begin
- Asp := First (Aspect_Specifications (New_Decl));
- while Present (Asp) loop
- Set_Aspect_Rep_Item (Asp, Empty);
- Set_Entity (Asp, Empty);
- Set_Analyzed (Asp, False);
- Next (Asp);
- end loop;
- end;
-
- Insert_After (Prag, New_Decl);
- Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp);
- Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl);
- end Build_Access_Subprogram_Wrapper;
-
- ------------------------------------------
- -- Build_Access_Subprogram_Wrapper_Body --
- ------------------------------------------
-
- procedure Build_Access_Subprogram_Wrapper_Body
- (Decl : Node_Id;
- New_Decl : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Decl);
- Actuals : constant List_Id := New_List;
- Type_Def : constant Node_Id := Type_Definition (Decl);
- Type_Id : constant Entity_Id := Defining_Identifier (Decl);
- Spec_Node : constant Node_Id :=
- New_Copy_Tree (Specification (New_Decl));
-
- Act : Node_Id;
- Body_Node : Node_Id;
- Call_Stmt : Node_Id;
- Ptr : Entity_Id;
- begin
- if not Expander_Active then
- return;
- end if;
-
- Set_Defining_Unit_Name (Spec_Node,
- Make_Defining_Identifier
- (Loc, Chars (Defining_Unit_Name (Spec_Node))));
-
- -- Create List of actuals for indirect call. The last
- -- parameter of the subprogram is the access value itself.
-
- Act := First (Parameter_Specifications (Spec_Node));
-
- while Present (Act) loop
- Append_To (Actuals,
- Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
- Next (Act);
- exit when Act = Last (Parameter_Specifications (Spec_Node));
- end loop;
-
- Ptr :=
- Defining_Identifier
- (Last (Parameter_Specifications (Spec_Node)));
-
- if Nkind (Type_Def) = N_Access_Procedure_Definition then
- Call_Stmt := Make_Procedure_Call_Statement (Loc,
- Name =>
- Make_Explicit_Dereference
- (Loc, New_Occurrence_Of (Ptr, Loc)),
- Parameter_Associations => Actuals);
- else
- Call_Stmt := Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name => Make_Explicit_Dereference
- (Loc, New_Occurrence_Of (Ptr, Loc)),
- Parameter_Associations => Actuals));
- end if;
-
- Body_Node := Make_Subprogram_Body (Loc,
- Specification => Spec_Node,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call_Stmt)));
-
- -- Place body in list of freeze actions for the type.
-
- Ensure_Freeze_Node (Type_Id);
- Append_Freeze_Actions (Type_Id, New_List (Body_Node));
- end Build_Access_Subprogram_Wrapper_Body;
-
-----------------------------
-- Inherits_Class_Wide_Pre --
-----------------------------
@@ -4953,17 +4774,11 @@ package body Sem_Prag is
then
null;
- elsif Ada_Version >= Ada_2020
- and then Nkind (Subp_Decl) = N_Full_Type_Declaration
- then
-
- -- Access_To_Subprogram type has pre/postconditions.
- -- Build wrapper subprogram to carry the contract items.
-
- Build_Access_Subprogram_Wrapper (Subp_Decl, N);
- return;
+ -- Access_To_Subprogram type can have pre/postconditions, but
+ -- these are trasnfered to the generated subprogram wrapper and
+ -- analyzed there.
- -- Otherwise the placement is illegal
+ -- Otherwise the placement of the pragma is illegal
else
Pragma_Misplaced;
