This implements the AI under the -gnat2020 switch, which extends the
set of calls that can be made during the elaboration of library units
subject to the aspect/pragma Preelaborate, beyond the existing ones
to static functions. Calls to certain functions that are essentially
unchecked conversions are now allowed.
This makes it possible to portably write address clauses of the form:
for Var'Address use System.Storage_Elements.To_Address (...);
in preelaborated library units, provided that the actual parameter
passed to the To_Address function is itself preelaborable.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-12 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* rtsfind.ads (RTU_Id): Add System_Address_To_Access_Conversions.
* sem_elab.adb (Elaboration_Phase_Active): Alphabetize.
(Finalize_All_Data_Structures): Likewise.
(Error_Preelaborated_Call): New procedure.
(Build_Call_Marker): Set Is_Preelaborable_Call flag in marker.
(Build_Access_Marker): Likewise.
(Build_Subprogram_Invocation): Likewise.
(Build_Task_Activation): Likewise.
(Check_Preelaborated_Call): Return when the call is preelaborable.
Call Error_Preelaborated_Call to give the error otherwise.
(Check_Elab_Call): Likewise.
* sem_util.adb (Is_Preelaborable_Function): New predicate.
(Is_Non_Preelaborable_Construct.Visit): Recurse on the
Explicit_Actual_Parameter field of N_Parameter_Association.
(Is_Non_Preelaborable_Construct.Visit_Subexpression): In Ada 2020,
for a call to a preelaborable function, visit the parameter list;
otherwise, raise Non_Preelaborable exception.
(Is_Preelaborable_Construct): Likewise, but recursively check the
parameters instead and return false upon failure, otherwise true.
* sinfo.ads (Is_Preelaborable_Call): New flag in call marker nodes.
(Is_Preelaborable_Call): New inline function.
(Set_Is_Preelaborable_Call): New inline procedure.
* sinfo.adb (Is_Preelaborable_Call): New inline function.
(Set_Is_Preelaborable_Call): New inline procedure.--- gcc/ada/rtsfind.ads
+++ gcc/ada/rtsfind.ads
@@ -173,6 +173,7 @@ package Rtsfind is
-- Children of System
System_Address_Image,
+ System_Address_To_Access_Conversions,
System_Arith_64,
System_AST_Handling,
System_Assertions,
--- gcc/ada/sem_elab.adb
+++ gcc/ada/sem_elab.adb
@@ -1952,6 +1952,18 @@ package body Sem_Elab is
pragma Inline (Compilation_Unit);
-- Return the N_Compilation_Unit node of unit Unit_Id
+ function Elaboration_Phase_Active return Boolean;
+ pragma Inline (Elaboration_Phase_Active);
+ -- Determine whether the elaboration phase of the compilation has started
+
+ procedure Error_Preelaborated_Call (N : Node_Id);
+ -- Give an error or warning for a non-static/non-preelaborable call in a
+ -- preelaborated unit.
+
+ procedure Finalize_All_Data_Structures;
+ pragma Inline (Finalize_All_Data_Structures);
+ -- Destroy all internal data structures
+
function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
pragma Inline (Find_Enclosing_Instance);
-- Find the declaration or body of the nearest expanded instance which
@@ -1972,14 +1984,6 @@ package body Sem_Elab is
-- Return the type of subprogram Subp_Id's first formal parameter. If the
-- subprogram lacks formal parameters, return Empty.
- function Elaboration_Phase_Active return Boolean;
- pragma Inline (Elaboration_Phase_Active);
- -- Determine whether the elaboration phase of the compilation has started
-
- procedure Finalize_All_Data_Structures;
- pragma Inline (Finalize_All_Data_Structures);
- -- Destroy all internal data structures
-
function Has_Body (Pack_Decl : Node_Id) return Boolean;
pragma Inline (Has_Body);
-- Determine whether package declaration Pack_Decl has a corresponding body
@@ -3745,6 +3749,15 @@ package body Sem_Elab is
Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
Set_Target (Marker, Subp_Id);
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020 then
+ Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N));
+ else
+ Set_Is_Preelaborable_Call (Marker, False);
+ end if;
+
-- The marker is inserted prior to the original call. This placement has
-- several desirable effects:
@@ -4878,6 +4891,8 @@ package body Sem_Elab is
(Marker, Elaboration_Checks_OK (Attr_Rep));
Set_Is_Elaboration_Warnings_OK_Node
(Marker, Elaboration_Warnings_OK (Attr_Rep));
+ Set_Is_Preelaborable_Call
+ (Marker, False);
Set_Is_Source_Call
(Marker, Comes_From_Source (Attr));
Set_Is_SPARK_Mode_On_Node
@@ -8838,6 +8853,29 @@ package body Sem_Elab is
return Elaboration_Phase = Active;
end Elaboration_Phase_Active;
+ ------------------------------
+ -- Error_Preelaborated_Call --
+ ------------------------------
+
+ procedure Error_Preelaborated_Call (N : Node_Id) is
+ begin
+ -- This is a warning in GNAT mode allowing such calls to be used in the
+ -- predefined library units with appropriate care.
+
+ Error_Msg_Warn := GNAT_Mode;
+
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020 then
+ Error_Msg_N
+ ("<<non-preelaborable call not allowed in preelaborated unit", N);
+ else
+ Error_Msg_N
+ ("<<non-static call not allowed in preelaborated unit", N);
+ end if;
+ end Error_Preelaborated_Call;
+
----------------------------------
-- Finalize_All_Data_Structures --
----------------------------------
@@ -11894,6 +11932,7 @@ package body Sem_Elab is
Set_Is_Elaboration_Checks_OK_Node (Marker, False);
Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
Set_Is_Ignored_Ghost_Node (Marker, False);
+ Set_Is_Preelaborable_Call (Marker, False);
Set_Is_Source_Call (Marker, False);
Set_Is_SPARK_Mode_On_Node (Marker, False);
@@ -11933,6 +11972,7 @@ package body Sem_Elab is
Set_Is_Elaboration_Checks_OK_Node (Marker, False);
Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
Set_Is_Ignored_Ghost_Node (Marker, False);
+ Set_Is_Preelaborable_Call (Marker, False);
Set_Is_Source_Call (Marker, False);
Set_Is_SPARK_Mode_On_Node (Marker, False);
@@ -13758,6 +13798,11 @@ package body Sem_Elab is
if not Is_Source_Call (Call) then
return;
+ -- Nothing to do when the call is preelaborable by definition
+
+ elsif Is_Preelaborable_Call (Call) then
+ return;
+
-- Library-level calls are always considered because they are part of
-- the associated unit's elaboration actions.
@@ -13779,13 +13824,10 @@ package body Sem_Elab is
return;
end if;
- -- The call appears within a preelaborated unit. Emit a warning only
- -- for internal uses, otherwise this is an error.
+ -- If the call appears within a preelaborated unit, give an error
if In_Preelaborated_Context (Call) then
- Error_Msg_Warn := GNAT_Mode;
- Error_Msg_N
- ("<<non-static call not allowed in preelaborated unit", Call);
+ Error_Preelaborated_Call (Call);
end if;
end Check_Preelaborated_Call;
@@ -17506,17 +17548,17 @@ package body Sem_Elab is
-- Complain if ref that comes from source in preelaborated unit
-- and we are not inside a subprogram (i.e. we are in elab code).
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are
+ -- essentially unchecked conversions are preelaborable.
+
if Comes_From_Source (N)
and then In_Preelaborated_Unit
and then not In_Inlined_Body
and then Nkind (N) /= N_Attribute_Reference
+ and then not (Ada_Version >= Ada_2020
+ and then Is_Preelaborable_Construct (N))
then
- -- This is a warning in GNAT mode allowing such calls to be
- -- used in the predefined library with appropriate care.
-
- Error_Msg_Warn := GNAT_Mode;
- Error_Msg_N
- ("<<non-static call not allowed in preelaborated unit", N);
+ Error_Preelaborated_Call (N);
return;
end if;
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -133,6 +133,10 @@ package body Sem_Util is
-- components in the selected variant to determine whether all of them
-- have a default.
+ function Is_Preelaborable_Function (Id : Entity_Id) return Boolean;
+ -- Ada 2020: Determine whether the specified function is suitable as the
+ -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
+
type Null_Status_Kind is
(Is_Null,
-- This value indicates that a subexpression is known to have a null
@@ -16485,6 +16489,9 @@ package body Sem_Util is
Visit (Discrete_Subtype_Definition (Nod));
+ when N_Parameter_Association =>
+ Visit (Explicit_Actual_Parameter (N));
+
when N_Protected_Definition =>
-- End_Label is left out because it is not relevant for
@@ -16650,6 +16657,21 @@ package body Sem_Util is
Visit_List (Actions (Expr));
Visit (Expression (Expr));
+ when N_Function_Call =>
+
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are
+ -- essentially unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020
+ and then Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
+ and then Is_Preelaborable_Function (Entity (Name (Expr)))
+ then
+ Visit_List (Parameter_Associations (Expr));
+ else
+ raise Non_Preelaborable;
+ end if;
+
when N_If_Expression =>
Visit_List (Expressions (Expr));
@@ -17781,6 +17803,30 @@ package body Sem_Util is
elsif Nkind (N) = N_Null then
return True;
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ elsif Ada_Version >= Ada_2020
+ and then Nkind (N) = N_Function_Call
+ and then Is_Entity_Name (Name (N))
+ and then Is_Preelaborable_Function (Entity (Name (N)))
+ then
+ declare
+ A : Node_Id;
+ begin
+ A := First_Actual (N);
+
+ while Present (A) loop
+ if not Is_Preelaborable_Construct (A) then
+ return False;
+ end if;
+
+ Next_Actual (A);
+ end loop;
+ end;
+
+ return True;
+
-- Otherwise the construct is not preelaborable
else
@@ -17788,6 +17834,50 @@ package body Sem_Util is
end if;
end Is_Preelaborable_Construct;
+ -------------------------------
+ -- Is_Preelaborable_Function --
+ -------------------------------
+
+ function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is
+ SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions;
+ Scop : constant Entity_Id := Scope (Id);
+
+ begin
+ -- Small optimization: every allowed function has convention Intrinsic
+ -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
+
+ if not Is_Intrinsic_Subprogram (Id)
+ and then Convention (Id) /= Convention_Intrinsic
+ then
+ return False;
+ end if;
+
+ -- An instance of Unchecked_Conversion
+
+ if Is_Unchecked_Conversion_Instance (Id) then
+ return True;
+ end if;
+
+ -- A function declared in System.Storage_Elements
+
+ if Is_RTU (Scop, System_Storage_Elements) then
+ return True;
+ end if;
+
+ -- The functions To_Pointer and To_Address declared in an instance of
+ -- System.Address_To_Access_Conversions (they are the only ones).
+
+ if Ekind (Scop) = E_Package
+ and then Nkind (Parent (Scop)) = N_Package_Specification
+ and then Present (Generic_Parent (Parent (Scop)))
+ and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Preelaborable_Function;
+
---------------------------------
-- Is_Protected_Self_Reference --
---------------------------------
--- gcc/ada/sinfo.adb
+++ gcc/ada/sinfo.adb
@@ -2096,6 +2096,14 @@ package body Sinfo is
return Flag13 (N);
end Is_Power_Of_2_For_Shift;
+ function Is_Preelaborable_Call
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ return Flag7 (N);
+ end Is_Preelaborable_Call;
+
function Is_Prefixed_Call
(N : Node_Id) return Boolean is
begin
@@ -5563,6 +5571,14 @@ package body Sinfo is
Set_Flag13 (N, Val);
end Set_Is_Power_Of_2_For_Shift;
+ procedure Set_Is_Preelaborable_Call
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ Set_Flag7 (N, Val);
+ end Set_Is_Preelaborable_Call;
+
procedure Set_Is_Prefixed_Call
(N : Node_Id; Val : Boolean := True) is
begin
--- gcc/ada/sinfo.ads
+++ gcc/ada/sinfo.ads
@@ -1849,6 +1849,10 @@ package Sinfo is
-- conditions holds, and the flag is set, then the division or
-- multiplication can be (and is) converted to a shift.
+ -- Is_Preelaborable_Call (Flag7-Sem)
+ -- Present in call marker nodes. Set when the related call is non-static
+ -- but preelaborable.
+
-- Is_Prefixed_Call (Flag17-Sem)
-- This flag is set in a selected component within a generic unit, if
-- it resolves to a prefixed call to a primitive operation. The flag
@@ -7830,6 +7834,7 @@ package Sinfo is
-- Is_Source_Call (Flag4-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Dispatching_Call (Flag6-Sem)
+ -- Is_Preelaborable_Call (Flag7-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
------------------------
@@ -9767,6 +9772,9 @@ package Sinfo is
function Is_Power_Of_2_For_Shift
(N : Node_Id) return Boolean; -- Flag13
+ function Is_Preelaborable_Call
+ (N : Node_Id) return Boolean; -- Flag7
+
function Is_Prefixed_Call
(N : Node_Id) return Boolean; -- Flag17
@@ -10870,6 +10878,9 @@ package Sinfo is
procedure Set_Is_Power_Of_2_For_Shift
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Is_Preelaborable_Call
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
procedure Set_Is_Prefixed_Call
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -13395,6 +13406,7 @@ package Sinfo is
pragma Inline (Is_Null_Loop);
pragma Inline (Is_Overloaded);
pragma Inline (Is_Power_Of_2_For_Shift);
+ pragma Inline (Is_Preelaborable_Call);
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
pragma Inline (Is_Qualified_Universal_Literal);
@@ -13758,6 +13770,7 @@ package Sinfo is
pragma Inline (Set_Is_Null_Loop);
pragma Inline (Set_Is_Overloaded);
pragma Inline (Set_Is_Power_Of_2_For_Shift);
+ pragma Inline (Set_Is_Preelaborable_Call);
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Is_Qualified_Universal_Literal);
