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 --
---------------------------
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,
-- 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;
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);
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 --
-------------------------------
-- 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 --
-----------------------------
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;
projects / gcc.git / commitdiff