Such subprograms are not protected and have convention Intrinsic to
ensure that their 'Access isn't taken as per RM 6.3.1(10/2).
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-12 Arnaud Charlet <char...@adacore.com>
gcc/ada/
* exp_ch6.adb (Expand_N_Subprogram_Declaration): Do nothing for
a subprogram declared in a protected body.
* exp_ch9.ads, exp_ch9.adb
(Build_Private_Protected_Declaration): Moved to sem_ch6.adb.
(Expand_N_Protected_Body): Do nothing for a subprogram declared
in a protected body.
* sem_ch6.adb (Build_Internal_Protected_Declaration): Moved from
exp_ch9.adb and renamed and fixed to ensure in particular that
such subprograms have convention Intrinsic and have no protected
version.
(Analyze_Subprogram_Body_Helper): Call
Build_Internal_Protected_Declaration.
(Move_Pragmas): Moved up and merged with the more general
version from Build_Private_Protected_Declaration. We only want
to copy selected pragmas, most pragmas are not suitable for a
copy on the spec.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -6346,19 +6346,6 @@ package body Exp_Ch6 is
Analyze (Prot_Decl);
Freeze_Before (N, Prot_Id);
Set_Protected_Body_Subprogram (Subp, Prot_Id);
-
- -- Create protected operation as well. Even though the operation
- -- is only accessible within the body, it is possible to make it
- -- available outside of the protected object by using 'Access to
- -- provide a callback, so build protected version in all cases.
-
- Prot_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
- Insert_Before (Prot_Bod, Prot_Decl);
- Analyze (Prot_Decl);
-
Pop_Scope;
end if;
--- gcc/ada/exp_ch9.adb
+++ gcc/ada/exp_ch9.adb
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
@@ -56,7 +55,6 @@ with Sem_Ch11; use Sem_Ch11;
with Sem_Ch13; use Sem_Ch13;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -3491,177 +3489,6 @@ package body Exp_Ch9 is
Set_Master_Id (Ptr_Typ, Master_Id);
end Build_Master_Renaming;
- -----------------------------------------
- -- Build_Private_Protected_Declaration --
- -----------------------------------------
-
- function Build_Private_Protected_Declaration
- (N : Node_Id) return Entity_Id
- is
- procedure Analyze_Pragmas (From : Node_Id);
- -- Analyze all pragmas which follow arbitrary node From
-
- procedure Move_Pragmas (From : Node_Id; To : Node_Id);
- -- Find all suitable source pragmas at the top of subprogram body From's
- -- declarations and insert them after arbitrary node To.
- --
- -- Very similar to Move_Pragmas in sem_ch6 ???
-
- ---------------------
- -- Analyze_Pragmas --
- ---------------------
-
- procedure Analyze_Pragmas (From : Node_Id) is
- Decl : Node_Id;
-
- begin
- Decl := Next (From);
- while Present (Decl) loop
- if Nkind (Decl) = N_Pragma then
- Analyze_Pragma (Decl);
-
- -- No candidate pragmas are available for analysis
-
- else
- exit;
- end if;
-
- Next (Decl);
- end loop;
- end Analyze_Pragmas;
-
- ------------------
- -- Move_Pragmas --
- ------------------
-
- procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
- Decl : Node_Id;
- Insert_Nod : Node_Id;
- Next_Decl : Node_Id;
-
- begin
- pragma Assert (Nkind (From) = N_Subprogram_Body);
-
- -- The pragmas are moved in an order-preserving fashion
-
- Insert_Nod := To;
-
- -- Inspect the declarations of the subprogram body and relocate all
- -- candidate pragmas.
-
- Decl := First (Declarations (From));
- while Present (Decl) loop
-
- -- Preserve the following declaration for iteration purposes, due
- -- to possible relocation of a pragma.
-
- Next_Decl := Next (Decl);
-
- -- We add an exception here for Unreferenced pragmas since the
- -- internally generated spec gets analyzed within
- -- Build_Private_Protected_Declaration and will lead to spurious
- -- warnings due to the way references are checked.
-
- if Nkind (Decl) = N_Pragma
- and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced
- then
- Remove (Decl);
- Insert_After (Insert_Nod, Decl);
- Insert_Nod := Decl;
-
- -- Skip internally generated code
-
- elsif not Comes_From_Source (Decl) then
- null;
-
- -- No candidate pragmas are available for relocation
-
- else
- exit;
- end if;
-
- Decl := Next_Decl;
- end loop;
- end Move_Pragmas;
-
- -- Local variables
-
- Body_Id : constant Entity_Id := Defining_Entity (N);
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
- Formal : Entity_Id;
- Formals : List_Id;
- Spec : Node_Id;
- Spec_Id : Entity_Id;
-
- -- Start of processing for Build_Private_Protected_Declaration
-
- begin
- Formal := First_Formal (Body_Id);
-
- -- The protected operation always has at least one formal, namely the
- -- object itself, but it is only placed in the parameter list if
- -- expansion is enabled.
-
- if Present (Formal) or else Expander_Active then
- Formals := Copy_Parameter_List (Body_Id);
- else
- Formals := No_List;
- end if;
-
- Spec_Id :=
- Make_Defining_Identifier (Sloc (Body_Id),
- Chars => Chars (Body_Id));
-
- -- Indicate that the entity comes from source, to ensure that cross-
- -- reference information is properly generated. The body itself is
- -- rewritten during expansion, and the body entity will not appear in
- -- calls to the operation.
-
- Set_Comes_From_Source (Spec_Id, True);
-
- if Nkind (Specification (N)) = N_Procedure_Specification then
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Spec_Id,
- Parameter_Specifications => Formals);
- else
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Spec_Id,
- Parameter_Specifications => Formals,
- Result_Definition =>
- New_Occurrence_Of (Etype (Body_Id), Loc));
- end if;
-
- Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
- Set_Corresponding_Body (Decl, Body_Id);
- Set_Corresponding_Spec (N, Spec_Id);
-
- Insert_Before (N, Decl);
-
- -- Associate all aspects and pragmas of the body with the spec. This
- -- ensures that these annotations apply to the initial declaration of
- -- the subprogram body.
-
- Move_Aspects (From => N, To => Decl);
- Move_Pragmas (From => N, To => Decl);
-
- Analyze (Decl);
-
- -- The analysis of the spec may generate pragmas which require manual
- -- analysis. Since the generation of the spec and the relocation of the
- -- annotations is driven by the expansion of the stand-alone body, the
- -- pragmas will not be analyzed in a timely manner. Do this now.
-
- Analyze_Pragmas (Decl);
-
- Set_Convention (Spec_Id, Convention_Protected);
- Set_Has_Completion (Spec_Id);
-
- return Spec_Id;
- end Build_Private_Protected_Declaration;
-
---------------------------
-- Build_Protected_Entry --
---------------------------
@@ -8630,6 +8457,7 @@ package body Exp_Ch9 is
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
Op_Body : Node_Id;
+ Op_Decl : Node_Id;
Op_Id : Entity_Id;
function Build_Dispatching_Subprogram_Body
@@ -8766,51 +8594,46 @@ package body Exp_Ch9 is
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
- -- Build the corresponding protected operation. It may
- -- appear that this is needed only if this is a visible
- -- operation of the type, or if it is an interrupt handler,
- -- and this was the strategy used previously in GNAT.
-
- -- However, the operation may be exported through a 'Access
- -- to an external caller. This is the common idiom in code
- -- that uses the Ada 2005 Timing_Events package. As a result
- -- we need to produce the protected body for both visible
- -- and private operations, as well as operations that only
- -- have a body in the source, and for which we create a
- -- declaration in the protected body itself.
+ -- Build the corresponding protected operation. This is
+ -- needed only if this is a public or private operation of
+ -- the type.
if Present (Corresponding_Spec (Op_Body)) then
- if Lock_Free_Active then
- New_Op_Body :=
- Build_Lock_Free_Protected_Subprogram_Body
- (Op_Body, Pid, Specification (New_Op_Body));
- else
- New_Op_Body :=
- Build_Protected_Subprogram_Body
- (Op_Body, Pid, Specification (New_Op_Body));
- end if;
-
- Insert_After (Current_Node, New_Op_Body);
- Analyze (New_Op_Body);
-
- Current_Node := New_Op_Body;
-
- -- Generate an overriding primitive operation body for
- -- this subprogram if the protected type implements an
- -- interface.
-
- if Ada_Version >= Ada_2005
- and then
- Present (Interfaces (Corresponding_Record_Type (Pid)))
- then
- Disp_Op_Body :=
- Build_Dispatching_Subprogram_Body
- (Op_Body, Pid, New_Op_Body);
-
- Insert_After (Current_Node, Disp_Op_Body);
- Analyze (Disp_Op_Body);
-
- Current_Node := Disp_Op_Body;
+ Op_Decl :=
+ Unit_Declaration_Node (Corresponding_Spec (Op_Body));
+
+ if Nkind (Parent (Op_Decl)) = N_Protected_Definition then
+ if Lock_Free_Active then
+ New_Op_Body :=
+ Build_Lock_Free_Protected_Subprogram_Body
+ (Op_Body, Pid, Specification (New_Op_Body));
+ else
+ New_Op_Body :=
+ Build_Protected_Subprogram_Body (
+ Op_Body, Pid, Specification (New_Op_Body));
+ end if;
+
+ Insert_After (Current_Node, New_Op_Body);
+ Analyze (New_Op_Body);
+ Current_Node := New_Op_Body;
+
+ -- Generate an overriding primitive operation body for
+ -- this subprogram if the protected type implements
+ -- an interface.
+
+ if Ada_Version >= Ada_2005
+ and then Present (Interfaces (
+ Corresponding_Record_Type (Pid)))
+ then
+ Disp_Op_Body :=
+ Build_Dispatching_Subprogram_Body (
+ Op_Body, Pid, New_Op_Body);
+
+ Insert_After (Current_Node, Disp_Op_Body);
+ Analyze (Disp_Op_Body);
+
+ Current_Node := Disp_Op_Body;
+ end if;
end if;
end if;
end if;
--- gcc/ada/exp_ch9.ads
+++ gcc/ada/exp_ch9.ads
@@ -72,17 +72,6 @@ package Exp_Ch9 is
-- where _master denotes the task master of the enclosing context. Ins_Nod
-- is used to provide a specific insertion node for the renaming.
- function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id;
- -- A subprogram body without a previous spec that appears in a protected
- -- body must be expanded separately to create a subprogram declaration
- -- for it, in order to resolve internal calls to it from other protected
- -- operations. It would seem that no locking version of the operation is
- -- needed, but in fact, in Ada 2005 the subprogram may be used in a call-
- -- back, and therefore a protected version of the operation must be
- -- generated as well.
- --
- -- Possibly factor this with Exp_Dist.Copy_Specification ???
-
function Build_Protected_Sub_Specification
(N : Node_Id;
Prot_Typ : Entity_Id;
--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -2504,6 +2504,15 @@ package body Sem_Ch6 is
-- because it is specified directly on the body, or because it is
-- inherited from the enclosing subprogram or package.
+ function Build_Internal_Protected_Declaration
+ (N : Node_Id) return Entity_Id;
+ -- A subprogram body without a previous spec that appears in a protected
+ -- body must be expanded separately to create a subprogram declaration
+ -- for it, in order to resolve internal calls to it from other protected
+ -- operations.
+ --
+ -- Possibly factor this with Exp_Dist.Copy_Specification ???
+
procedure Build_Subprogram_Declaration;
-- Create a matching subprogram declaration for subprogram body N
@@ -2552,6 +2561,12 @@ package body Sem_Ch6 is
-- the not-yet-frozen types referenced by the simple return statement
-- of the function as formally frozen.
+ procedure Move_Pragmas (From : Node_Id; To : Node_Id);
+ -- Find all suitable source pragmas at the top of subprogram body
+ -- From's declarations and move them after arbitrary node To.
+ -- One exception is pragma SPARK_Mode which is copied rather than moved,
+ -- as it applies to the body too.
+
procedure Restore_Limited_Views (Restore_List : Elist_Id);
-- Undo the transformation done by Exchange_Limited_Views.
@@ -2664,68 +2679,129 @@ package body Sem_Ch6 is
return SPARK_Mode = On;
end Body_Has_SPARK_Mode_On;
- ----------------------------------
- -- Build_Subprogram_Declaration --
- ----------------------------------
+ ------------------------------------------
+ -- Build_Internal_Protected_Declaration --
+ ------------------------------------------
- procedure Build_Subprogram_Declaration is
- procedure Move_Pragmas (From : Node_Id; To : Node_Id);
- -- Relocate certain categorization pragmas from the declarative list
- -- of subprogram body From and insert them after node To. The pragmas
- -- in question are:
- -- Ghost
- -- Volatile_Function
- -- Also copy pragma SPARK_Mode if present in the declarative list
- -- of subprogram body From and insert it after node To. This pragma
- -- should not be moved, as it applies to the body too.
+ function Build_Internal_Protected_Declaration
+ (N : Node_Id) return Entity_Id
+ is
+ procedure Analyze_Pragmas (From : Node_Id);
+ -- Analyze all pragmas which follow arbitrary node From
- ------------------
- -- Move_Pragmas --
- ------------------
+ ---------------------
+ -- Analyze_Pragmas --
+ ---------------------
- procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
- Decl : Node_Id;
- Next_Decl : Node_Id;
+ procedure Analyze_Pragmas (From : Node_Id) is
+ Decl : Node_Id;
begin
- pragma Assert (Nkind (From) = N_Subprogram_Body);
-
- -- The destination node must be part of a list, as the pragmas are
- -- inserted after it.
-
- pragma Assert (Is_List_Member (To));
-
- -- Inspect the declarations of the subprogram body looking for
- -- specific pragmas.
-
- Decl := First (Declarations (N));
+ Decl := Next (From);
while Present (Decl) loop
- Next_Decl := Next (Decl);
-
if Nkind (Decl) = N_Pragma then
- if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
- Insert_After (To, New_Copy_Tree (Decl));
+ Analyze_Pragma (Decl);
- elsif Nam_In (Pragma_Name_Unmapped (Decl),
- Name_Ghost,
- Name_Volatile_Function)
- then
- Remove (Decl);
- Insert_After (To, Decl);
- end if;
+ -- No candidate pragmas are available for analysis
+
+ else
+ exit;
end if;
- Decl := Next_Decl;
+ Next (Decl);
end loop;
- end Move_Pragmas;
+ end Analyze_Pragmas;
-- Local variables
+ Body_Id : constant Entity_Id := Defining_Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ Formals : List_Id;
+ Spec : Node_Id;
+ Spec_Id : Entity_Id;
+
+ -- Start of processing for Build_Internal_Protected_Declaration
+
+ begin
+ Formal := First_Formal (Body_Id);
+
+ -- The protected operation always has at least one formal, namely the
+ -- object itself, but it is only placed in the parameter list if
+ -- expansion is enabled.
+
+ if Present (Formal) or else Expander_Active then
+ Formals := Copy_Parameter_List (Body_Id);
+ else
+ Formals := No_List;
+ end if;
+
+ Spec_Id :=
+ Make_Defining_Identifier (Sloc (Body_Id),
+ Chars => Chars (Body_Id));
+
+ -- Indicate that the entity comes from source, to ensure that cross-
+ -- reference information is properly generated. The body itself is
+ -- rewritten during expansion, and the body entity will not appear in
+ -- calls to the operation.
+
+ Set_Comes_From_Source (Spec_Id, True);
+
+ if Nkind (Specification (N)) = N_Procedure_Specification then
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Formals);
+ else
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Formals,
+ Result_Definition =>
+ New_Occurrence_Of (Etype (Body_Id), Loc));
+ end if;
+
+ Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+ Set_Corresponding_Body (Decl, Body_Id);
+ Set_Corresponding_Spec (N, Spec_Id);
+
+ Insert_Before (N, Decl);
+
+ -- Associate all aspects and pragmas of the body with the spec. This
+ -- ensures that these annotations apply to the initial declaration of
+ -- the subprogram body.
+
+ Move_Aspects (From => N, To => Decl);
+ Move_Pragmas (From => N, To => Decl);
+
+ Analyze (Decl);
+
+ -- The analysis of the spec may generate pragmas which require manual
+ -- analysis. Since the generation of the spec and the relocation of
+ -- the annotations is driven by the expansion of the stand-alone
+ -- body, the pragmas will not be analyzed in a timely manner. Do this
+ -- now.
+
+ Analyze_Pragmas (Decl);
+
+ -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2)
+ -- ensuring in particular that 'Access is illegal.
+
+ Set_Convention (Spec_Id, Convention_Intrinsic);
+ Set_Has_Completion (Spec_Id);
+
+ return Spec_Id;
+ end Build_Internal_Protected_Declaration;
+
+ ----------------------------------
+ -- Build_Subprogram_Declaration --
+ ----------------------------------
+
+ procedure Build_Subprogram_Declaration is
Decl : Node_Id;
Subp_Decl : Node_Id;
- -- Start of processing for Build_Subprogram_Declaration
-
begin
-- Create a matching subprogram spec using the profile of the body.
-- The structure of the tree is identical, but has new entities for
@@ -3376,6 +3452,77 @@ package body Sem_Ch6 is
return Result;
end Mask_Unfrozen_Types;
+ ------------------
+ -- Move_Pragmas --
+ ------------------
+
+ procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
+ Decl : Node_Id;
+ Insert_Nod : Node_Id;
+ Next_Decl : Node_Id;
+
+ begin
+ pragma Assert (Nkind (From) = N_Subprogram_Body);
+
+ -- The pragmas are moved in an order-preserving fashion
+
+ Insert_Nod := To;
+
+ -- Inspect the declarations of the subprogram body and relocate all
+ -- candidate pragmas.
+
+ Decl := First (Declarations (From));
+ while Present (Decl) loop
+
+ -- Preserve the following declaration for iteration purposes, due
+ -- to possible relocation of a pragma.
+
+ Next_Decl := Next (Decl);
+
+ if Nkind (Decl) = N_Pragma then
+ -- Copy pragma SPARK_Mode if present in the declarative list
+ -- of subprogram body From and insert it after node To. This
+ -- pragma should not be moved, as it applies to the body too.
+
+ if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
+ Insert_After (Insert_Nod, New_Copy_Tree (Decl));
+
+ -- Move relevant pragmas to the spec
+
+ elsif Nam_In (Pragma_Name_Unmapped (Decl),
+ Name_Depends,
+ Name_Ghost,
+ Name_Global,
+ Name_Pre,
+ Name_Precondition,
+ Name_Post,
+ Name_Refined_Depends,
+ Name_Refined_Global,
+ Name_Refined_Post,
+ Name_Inline,
+ Name_Pure_Function,
+ Name_Volatile_Function)
+ then
+ Remove (Decl);
+ Insert_After (Insert_Nod, Decl);
+ Insert_Nod := Decl;
+ end if;
+
+ -- Skip internally generated code
+
+ elsif not Comes_From_Source (Decl) then
+ null;
+
+ -- No candidate pragmas are available for relocation
+
+ else
+ exit;
+ end if;
+
+ Decl := Next_Decl;
+ end loop;
+ end Move_Pragmas;
+
---------------------------
-- Restore_Limited_Views --
---------------------------
@@ -3668,6 +3815,8 @@ package body Sem_Ch6 is
-- are legal and can be processed ahead of the body.
-- We make two copies of the given spec, one for the new
-- declaration, and one for the body.
+ -- ??? This should be conditioned on front-end inlining rather
+ -- than GNATprove_Mode.
if No (Spec_Id) and then GNATprove_Mode
@@ -3708,7 +3857,7 @@ package body Sem_Ch6 is
Build_Subprogram_Declaration;
-- If this is a function that returns a constrained array, and
- -- we are generating SPARK_For_C, create subprogram declaration
+ -- we are generating C code, create subprogram declaration
-- to simplify subsequent C generation.
elsif No (Spec_Id)
@@ -3795,15 +3944,15 @@ package body Sem_Ch6 is
-- Deal with special case of a fully private operation in the body of
-- the protected type. We must create a declaration for the subprogram,
- -- in order to attach the protected subprogram that will be used in
- -- internal calls. We exclude compiler generated bodies from the
- -- expander since the issue does not arise for those cases.
+ -- in order to attach the subprogram that will be used in internal
+ -- calls. We exclude compiler generated bodies from the expander since
+ -- the issue does not arise for those cases.
if No (Spec_Id)
and then Comes_From_Source (N)
and then Is_Protected_Type (Current_Scope)
then
- Spec_Id := Build_Private_Protected_Declaration (N);
+ Spec_Id := Build_Internal_Protected_Declaration (N);
end if;
-- If we are generating C and this is a function returning a constrained
