-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
-with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch11; use Sem_Ch11;
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;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch9 is
(N : Node_Id;
Pid : Node_Id) return Node_Id;
-- This routine constructs the unprotected version of a protected
- -- subprogram body, which is contains all of the code in the original,
+ -- subprogram body, which contains all of the code in the original,
-- unexpanded body. This is the version of the protected subprogram that is
-- called from all protected operations on the same object, including the
-- protected version of the same subprogram.
-- same parameter names and the same resolved types, but with new entities
-- for the formals.
+ function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean;
+ -- Return whether a secondary stack for the task T should be created by the
+ -- expander. The secondary stack for a task will be created by the expander
+ -- if the size of the stack has been specified by the Secondary_Stack_Size
+ -- representation aspect and either the No_Implicit_Heap_Allocations or
+ -- No_Implicit_Task_Allocations restrictions are in effect and the
+ -- No_Secondary_Stack restriction is not.
+
procedure Debug_Private_Data_Declarations (Decls : List_Id);
-- Decls is a list which may contain the declarations created by Install_
-- Private_Data_Declarations. All generated entities are marked as needing
-- a null trailing statement with the given Loc (which is the sloc of
-- the accept, delay, or entry call statement). There might not be any
-- generated code for the accept, delay, or entry call itself (the effect
- -- of these statements is part of the general processsing done for the
+ -- of these statements is part of the general processing done for the
-- enclosing selective accept, timed entry call, or asynchronous select),
-- and the null statement is there to carry the sloc of that statement to
-- the back-end for trace-based coverage analysis purposes.
-- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
-- parameter _E.
- function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
- -- Tell whether a given subprogram cannot raise an exception
-
function Is_Potentially_Large_Family
(Base_Index : Entity_Id;
Conctyp : Entity_Id;
-- ...
-- <actualN> := P.<formalN>;
+ procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id);
+ -- Reset the scope of declarations and blocks at the top level of Bod to
+ -- be E. Bod is either a block or a subprogram body. Used after expanding
+ -- various kinds of entry bodies into their corresponding constructs. This
+ -- is needed during unnesting to determine whether a body generated for an
+ -- entry or an accept alternative includes uplevel references.
+
function Trivial_Accept_OK return Boolean;
-- If there is no DO-END block for an accept, or if the DO-END block has
-- only null statements, then it is possible to do the Rendezvous with much
-- The name of the formal that holds the address of the parameter block
-- for the call.
- Comp : Entity_Id;
- Decl : Node_Id;
- Formal : Entity_Id;
- New_F : Entity_Id;
- Renamed_Formal : Node_Id;
+ Comp : Entity_Id;
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ New_F : Entity_Id;
+ Renamed_Formal : Node_Id;
begin
Formal := First_Formal (Ent);
Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
- Statements => New_List (
+ Statements => New_List (
Make_Procedure_Call_Statement (Sloc (Stats),
Name => New_Occurrence_Of (
RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name (Prag), Name_Postcondition,
- Name_Precondition)
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Postcondition, Name_Precondition)
and then Is_Checked (Prag)
then
Has_Pragma := True;
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- if Pragma_Name_Mapped (Prag) = Name_Contract_Cases
+ if Pragma_Name (Prag) = Name_Contract_Cases
and then Is_Checked (Prag)
then
Has_Pragma := True;
Iface_Op_Param := Next (Iface_Op_Param);
end if;
- Wrapper_Param := First (Wrapper_Params);
+ Wrapper_Param := First (Wrapper_Params);
while Present (Iface_Op_Param)
and then Present (Wrapper_Param)
loop
------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- B : Node_Id;
+ B : Node_Id;
begin
if Is_Entity_Name (Bound)
Ekind (Corresponding_Spec (N)) = E_Procedure;
-- Indicates if N is a protected procedure body
- Block_Decls : List_Id;
+ Block_Decls : List_Id := No_List;
Try_Write : Entity_Id;
Desired_Comp : Entity_Id;
Decl : Node_Id;
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
- -- Do not create a master if one already exists or there is no task
- -- hierarchy.
+ -- Nothing to do if the context already has a master
+
+ if Has_Master_Entity (Context_Id) then
+ return;
+
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
- if Has_Master_Entity (Context_Id)
+ elsif Restriction_Active (No_Tasking)
or else Restriction_Active (No_Task_Hierarchy)
then
return;
Master_Id : Entity_Id;
begin
- -- Nothing to do if there is no task hierarchy
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
- if Restriction_Active (No_Task_Hierarchy) then
+ if Restriction_Active (No_Tasking)
+ or else Restriction_Active (No_Task_Hierarchy)
+ then
return;
end if;
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);
- Body_Id : constant Entity_Id := Defining_Entity (N);
Decl : Node_Id;
- Plist : List_Id;
Formal : Entity_Id;
- New_Spec : Node_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);
-- expansion is enabled.
if Present (Formal) or else Expander_Active then
- Plist := Copy_Parameter_List (Body_Id);
+ Formals := Copy_Parameter_List (Body_Id);
else
- Plist := No_List;
+ 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
- New_Spec :=
+ Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Sloc (Body_Id),
- Chars => Chars (Body_Id)),
- Parameter_Specifications =>
- Plist);
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Formals);
else
- New_Spec :=
+ Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Sloc (Body_Id),
- Chars => Chars (Body_Id)),
- Parameter_Specifications => Plist,
+ 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 => New_Spec);
+ Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+ Set_Corresponding_Body (Decl, Body_Id);
+ Set_Corresponding_Spec (N, Spec_Id);
+
Insert_Before (N, Decl);
- Spec_Id := Defining_Unit_Name (New_Spec);
- -- 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.
+ -- 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);
- Set_Comes_From_Source (Spec_Id, True);
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);
- Set_Convention (Spec_Id, Convention_Protected);
+
return Spec_Id;
end Build_Private_Protected_Declaration;
Bod_Stmts : List_Id;
Complete : Node_Id;
Ohandle : Node_Id;
+ Proc_Body : Node_Id;
EH_Loc : Source_Ptr;
-- Used for the exception handler, inserted at end of the body
Declarations => Decls,
Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
+ -- Analyze now and reset scopes for declarations so that Scope fields
+ -- currently denoting the entry will now denote the block scope, and
+ -- the block's scope will be set to the new procedure entity.
+
+ Analyze_Statements (Bod_Stmts);
+
+ Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id);
+
+ Reset_Scopes_To
+ (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts))));
+
case Corresponding_Runtime_Package (Pid) is
when System_Tasking_Protected_Objects_Entries =>
Append_To (Bod_Stmts,
raise Program_Error;
end case;
- -- When exceptions can not be propagated, we never need to call
+ -- When exceptions cannot be propagated, we never need to call
-- Exception_Complete_Entry_Body.
if No_Exception_Handlers_Set then
-- Create body of entry procedure. The renaming declarations are
-- placed ahead of the block that contains the actual entry body.
- return
+ Proc_Body :=
Make_Subprogram_Body (Loc,
Specification => Bod_Spec,
Declarations => Bod_Decls,
Make_Implicit_Exception_Handler (EH_Loc,
Exception_Choices => New_List (Ohandle),
- Statements => New_List (
+ Statements => New_List (
Make_Procedure_Call_Statement (EH_Loc,
Name => Complete,
Parameter_Associations => New_List (
Name =>
New_Occurrence_Of
(RTE (RE_Get_GNAT_Exception), Loc)))))))));
+
+ Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
+ return Proc_Body;
end if;
end Build_Protected_Entry;
if Unprotected then
Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
+ Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
end if;
Append (New_Param, New_Plist);
Set_Original_Protected_Subprogram (New_Id, Def_Id);
end if;
+ -- Link the protected or unprotected version to the original subprogram
+ -- it emulates.
+
+ Set_Ekind (New_Id, Ekind (Def_Id));
+ Set_Protected_Subprogram (New_Id, Def_Id);
+
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (N);
- Op_Spec : Node_Id;
- P_Op_Spec : Node_Id;
- Uactuals : List_Id;
- Pformal : Node_Id;
- Unprot_Call : Node_Id;
- Sub_Body : Node_Id;
- Lock_Name : Node_Id;
- Lock_Stmt : Node_Id;
- R : Node_Id;
- Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
- Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
- Stmts : List_Id;
- Object_Parm : Node_Id;
- Exc_Safe : Boolean;
- Lock_Kind : RE_Id;
+ Exc_Safe : constant Boolean := not Might_Raise (N);
+ -- True if N cannot raise an exception
- begin
- Op_Spec := Specification (N);
- Exc_Safe := Is_Exception_Safe (N);
-
- P_Op_Spec :=
- Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
+ Loc : constant Source_Ptr := Sloc (N);
+ Op_Spec : constant Node_Id := Specification (N);
+ P_Op_Spec : constant Node_Id :=
+ Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
+
+ Lock_Kind : RE_Id;
+ Lock_Name : Node_Id;
+ Lock_Stmt : Node_Id;
+ Object_Parm : Node_Id;
+ Pformal : Node_Id;
+ R : Node_Id;
+ Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
+ Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
+ Stmts : List_Id;
+ Sub_Body : Node_Id;
+ Uactuals : List_Id;
+ Unprot_Call : Node_Id;
+ begin
-- Build a list of the formal parameters of the protected version of
-- the subprogram to use as the actual parameters of the unprotected
-- version.
---------------------------------------------
procedure Build_Protected_Subprogram_Call_Cleanup
- (Op_Spec : Node_Id;
- Conc_Typ : Node_Id;
- Loc : Source_Ptr;
- Stmts : List_Id)
+ (Op_Spec : Node_Id;
+ Conc_Typ : Node_Id;
+ Loc : Source_Ptr;
+ Stmts : List_Id)
is
- Nam : Node_Id;
+ Nam : Node_Id;
begin
-- If the associated protected object has entries, a protected
-- If actual is an out parameter of a null-excluding
-- access type, there is access check on entry, so set
-- Suppress_Assignment_Checks on the generated statement
- -- that assigns the actual to the parameter block
+ -- that assigns the actual to the parameter block.
Set_Suppress_Assignment_Checks (Last (Stats));
end if;
-- Some additional statements for protected entry calls
- -- Protected_Entry_Call (
- -- Object => po._object'Access,
- -- E => <entry index>;
- -- Uninterpreted_Data => P'Address;
- -- Mode => Simple_Call;
- -- Block => Bnn);
+ -- Protected_Entry_Call
+ -- (Object => po._object'Access,
+ -- E => <entry index>;
+ -- Uninterpreted_Data => P'Address;
+ -- Mode => Simple_Call;
+ -- Block => Bnn);
Call :=
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (Comm_Name, Loc)));
when System_Tasking_Protected_Objects_Single_Entry =>
- -- Protected_Single_Entry_Call (
- -- Object => po._object'Access,
- -- Uninterpreted_Data => P'Address);
+
+ -- Protected_Single_Entry_Call
+ -- (Object => po._object'Access,
+ -- Uninterpreted_Data => P'Address);
Call :=
Make_Procedure_Call_Statement (Loc,
--------------------------------
procedure Build_Task_Activation_Call (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ function Activation_Call_Loc return Source_Ptr;
+ -- Find a suitable source location for the activation call
+
+ -------------------------
+ -- Activation_Call_Loc --
+ -------------------------
+
+ function Activation_Call_Loc return Source_Ptr is
+ begin
+ -- The activation call must carry the location of the "end" keyword
+ -- when the context is a package declaration.
+
+ if Nkind (N) = N_Package_Declaration then
+ return End_Keyword_Location (N);
+
+ -- Otherwise the activation call must carry the location of the
+ -- "begin" keyword.
+
+ else
+ return Begin_Keyword_Location (N);
+ end if;
+ end Activation_Call_Loc;
+
+ -- Local variables
+
Chain : Entity_Id;
Call : Node_Id;
+ Loc : Source_Ptr;
Name : Node_Id;
- P : Node_Id;
+ Owner : Node_Id;
+ Stmt : Node_Id;
+
+ -- Start of processing for Build_Task_Activation_Call
begin
-- For sequential elaboration policy, all the tasks will be activated at
if Partition_Elaboration_Policy = 'S' then
return;
- end if;
- -- Get the activation chain entity. Except in the case of a package
- -- body, this is in the node that was passed. For a package body, we
- -- have to find the corresponding package declaration node.
+ -- Do not create an activation call for a package spec if the package
+ -- has a completing body. The activation call will be inserted after
+ -- the "begin" of the body.
- if Nkind (N) = N_Package_Body then
- P := Corresponding_Spec (N);
- loop
- P := Parent (P);
- exit when Nkind (P) = N_Package_Declaration;
- end loop;
+ elsif Nkind (N) = N_Package_Declaration
+ and then Present (Corresponding_Body (N))
+ then
+ return;
+ end if;
- Chain := Activation_Chain_Entity (P);
+ -- Obtain the activation chain entity. Block statements, entry bodies,
+ -- subprogram bodies, and task bodies keep the entity in their nodes.
+ -- Package bodies on the other hand store it in the declaration of the
+ -- corresponding package spec.
- else
- Chain := Activation_Chain_Entity (N);
+ Owner := N;
+
+ if Nkind (Owner) = N_Package_Body then
+ Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
end if;
- if Present (Chain) then
- if Restricted_Profile then
- Name := New_Occurrence_Of
- (RTE (RE_Activate_Restricted_Tasks), Loc);
- else
- Name := New_Occurrence_Of
- (RTE (RE_Activate_Tasks), Loc);
- end if;
+ Chain := Activation_Chain_Entity (Owner);
- Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => Name,
- Parameter_Associations =>
- New_List (Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Chain, Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ -- Nothing to do when there are no tasks to activate. This is indicated
+ -- by a missing activation chain entity.
- if Nkind (N) = N_Package_Declaration then
- if Present (Corresponding_Body (N)) then
- null;
+ if No (Chain) then
+ return;
+ end if;
- elsif Present (Private_Declarations (Specification (N))) then
- Append (Call, Private_Declarations (Specification (N)));
+ -- The location of the activation call must be as close as possible to
+ -- the intended semantic location of the activation because the ABE
+ -- mechanism relies heavily on accurate locations.
- else
- Append (Call, Visible_Declarations (Specification (N)));
- end if;
+ Loc := Activation_Call_Loc;
- else
- if Present (Handled_Statement_Sequence (N)) then
+ if Restricted_Profile then
+ Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc);
+ else
+ Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc);
+ end if;
- -- The call goes at the start of the statement sequence after
- -- the start of exception range label if one is present.
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => Name,
+ Parameter_Associations =>
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Chain, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
- declare
- Stm : Node_Id;
+ if Nkind (N) = N_Package_Declaration then
+ if Present (Private_Declarations (Specification (N))) then
+ Append (Call, Private_Declarations (Specification (N)));
+ else
+ Append (Call, Visible_Declarations (Specification (N)));
+ end if;
- begin
- Stm := First (Statements (Handled_Statement_Sequence (N)));
+ else
+ -- The call goes at the start of the statement sequence after the
+ -- start of exception range label if one is present.
- -- A special case, skip exception range label if one is
- -- present (from front end zcx processing).
+ if Present (Handled_Statement_Sequence (N)) then
+ Stmt := First (Statements (Handled_Statement_Sequence (N)));
- if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
- Next (Stm);
- end if;
+ -- A special case, skip exception range label if one is present
+ -- (from front end zcx processing).
- -- Another special case, if the first statement is a block
- -- from optimization of a local raise to a goto, then the
- -- call goes inside this block.
+ if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
+ Next (Stmt);
+ end if;
- if Nkind (Stm) = N_Block_Statement
- and then Exception_Junk (Stm)
- then
- Stm :=
- First (Statements (Handled_Statement_Sequence (Stm)));
- end if;
+ -- Another special case, if the first statement is a block from
+ -- optimization of a local raise to a goto, then the call goes
+ -- inside this block.
- -- Insertion point is after any exception label pushes,
- -- since we want it covered by any local handlers.
+ if Nkind (Stmt) = N_Block_Statement
+ and then Exception_Junk (Stmt)
+ then
+ Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
+ end if;
- while Nkind (Stm) in N_Push_xxx_Label loop
- Next (Stm);
- end loop;
+ -- Insertion point is after any exception label pushes, since we
+ -- want it covered by any local handlers.
- -- Now we have the proper insertion point
+ while Nkind (Stmt) in N_Push_xxx_Label loop
+ Next (Stmt);
+ end loop;
- Insert_Before (Stm, Call);
- end;
+ -- Now we have the proper insertion point
- else
- Set_Handled_Statement_Sequence (N,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call)));
- end if;
+ Insert_Before (Stmt, Call);
+
+ else
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call)));
end if;
+ end if;
- Analyze (Call);
+ Analyze (Call);
+
+ if Legacy_Elaboration_Checks then
Check_Task_Activation (N);
end if;
end Build_Task_Activation_Call;
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
end if;
end Convert_Concurrent;
+ -------------------------------------
+ -- Create_Secondary_Stack_For_Task --
+ -------------------------------------
+
+ function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is
+ begin
+ return
+ (Restriction_Active (No_Implicit_Heap_Allocations)
+ or else Restriction_Active (No_Implicit_Task_Allocations))
+ and then not Restriction_Active (No_Secondary_Stack)
+ and then Has_Rep_Pragma
+ (T, Name_Secondary_Stack_Size, Check_Parents => False);
+ end Create_Secondary_Stack_For_Task;
+
-------------------------------------
-- Debug_Private_Data_Declarations --
-------------------------------------
--------------------------
procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
- Cond : constant Node_Id :=
- Condition (Entry_Body_Formal_Part (N));
+ Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N));
Prot : constant Entity_Id := Scope (Ent);
Spec_Decl : constant Node_Id := Parent (Prot);
- Func : Entity_Id := Empty;
- B_F : Node_Id;
- Body_Decl : Node_Id;
+
+ Func_Id : Entity_Id := Empty;
+ -- The entity of the barrier function
function Is_Global_Entity (N : Node_Id) return Traverse_Result;
-- Check whether entity in Barrier is external to protected type.
-- during expansion, it is ok. If expansion is not performed,
-- then Func is Empty so this test cannot succeed.
- if Scope (E) = Func then
+ if Scope (E) = Func_Id then
null;
-- A protected call from a barrier to another object is ok
-- this safe. This is a common (if dubious) idiom.
elsif S = Scope (Prot)
- and then Ekind_In (S, E_Package, E_Generic_Package)
+ and then Is_Package_Or_Generic_Package (S)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Nkind (Parent (Parent (E))) = N_Package_Body
then
Renamed : Node_Id;
begin
- -- Check for case of _object.all.field (note that the explicit
- -- dereference gets inserted by analyze/expand of _object.field).
+ -- Check if the name is a component of the protected object. If
+ -- the expander is active, the component has been transformed into a
+ -- renaming of _object.all.component. Original_Node is needed in case
+ -- validity checking is enabled, in which case the simple object
+ -- reference will have been rewritten.
if Expander_Active then
- Renamed := Renamed_Object (Entity (N));
+
+ -- The expanded name may have been constant folded in which case
+ -- the original node is not necessarily an entity name (e.g. an
+ -- indexed component).
+
+ if not Is_Entity_Name (Original_Node (N)) then
+ return False;
+ end if;
+
+ Renamed := Renamed_Object (Entity (Original_Node (N)));
return
Present (Renamed)
and then Nkind (Renamed) = N_Selected_Component
and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
else
- return Scope (Entity (N)) = Current_Scope;
+ return Is_Protected_Component (Entity (N));
end if;
end Is_Simple_Barrier_Name;
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
- when N_Expanded_Name |
- N_Identifier =>
+ when N_Expanded_Name
+ | N_Identifier
+ =>
if No (Entity (N)) then
return Abandon;
+
+ elsif Is_Universal_Numeric_Type (Entity (N)) then
+ return OK;
end if;
case Ekind (Entity (N)) is
- when E_Constant |
- E_Discriminant |
- E_Named_Integer |
- E_Named_Real |
- E_Enumeration_Literal =>
+ when E_Constant
+ | E_Discriminant
+ | E_Enumeration_Literal
+ | E_Named_Integer
+ | E_Named_Real
+ =>
return OK;
- when E_Component |
- E_Variable =>
-
- -- A variable in the protected type is expanded as a
- -- component.
+ when E_Component =>
+ return OK;
+ when E_Variable =>
if Is_Simple_Barrier_Name (N) then
return OK;
end if;
+ when E_Function =>
+
+ -- The count attribute has been transformed into run-time
+ -- calls.
+
+ if Is_RTE (Entity (N), RE_Protected_Count)
+ or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
+ then
+ return OK;
+ end if;
+
when others =>
null;
end case;
- when N_Integer_Literal |
- N_Real_Literal |
- N_Character_Literal =>
+ when N_Function_Call =>
+
+ -- Function call checks are carried out as part of the analysis
+ -- of the function call name.
+
+ return OK;
+
+ when N_Character_Literal
+ | N_Integer_Literal
+ | N_Real_Literal
+ =>
return OK;
- when N_Op_Boolean |
- N_Op_Not =>
+ when N_Op_Boolean
+ | N_Op_Not
+ =>
if Ekind (Entity (N)) = E_Operator then
return OK;
end if;
when N_Short_Circuit =>
return OK;
+ when N_Indexed_Component
+ | N_Selected_Component
+ =>
+ if not Is_Access_Type (Etype (Prefix (N))) then
+ return OK;
+ end if;
+
+ when N_Type_Conversion =>
+
+ -- Conversions to Universal_Integer will not raise constraint
+ -- errors.
+
+ if Cannot_Raise_Constraint_Error (N)
+ or else Etype (N) = Universal_Integer
+ then
+ return OK;
+ end if;
+
+ when N_Unchecked_Type_Conversion =>
+ return OK;
+
when others =>
null;
end case;
function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
+ -- Local variables
+
+ Cond_Id : Entity_Id;
+ Entry_Body : Node_Id;
+ Func_Body : Node_Id := Empty;
+
-- Start of processing for Expand_Entry_Barrier
begin
-- version of it because it is never called.
if Expander_Active then
- B_F := Build_Barrier_Function (N, Ent, Prot);
- Func := Barrier_Function (Ent);
- Set_Corresponding_Spec (B_F, Func);
+ Func_Body := Build_Barrier_Function (N, Ent, Prot);
+ Func_Id := Barrier_Function (Ent);
+ Set_Corresponding_Spec (Func_Body, Func_Id);
- Body_Decl := Parent (Corresponding_Body (Spec_Decl));
+ Entry_Body := Parent (Corresponding_Body (Spec_Decl));
- if Nkind (Parent (Body_Decl)) = N_Subunit then
- Body_Decl := Corresponding_Stub (Parent (Body_Decl));
+ if Nkind (Parent (Entry_Body)) = N_Subunit then
+ Entry_Body := Corresponding_Stub (Parent (Entry_Body));
end if;
- Insert_Before_And_Analyze (Body_Decl, B_F);
+ Insert_Before_And_Analyze (Entry_Body, Func_Body);
Set_Discriminals (Spec_Decl);
- Set_Scope (Func, Scope (Prot));
+ Set_Scope (Func_Id, Scope (Prot));
else
Analyze_And_Resolve (Cond, Any_Boolean);
-- scope.
if Is_Entity_Name (Cond) then
-
- -- A small optimization of useless renamings. If the scope of the
- -- entity of the condition is not the barrier function, then the
- -- condition does not reference any of the generated renamings
- -- within the function.
-
- if Expander_Active and then Scope (Entity (Cond)) /= Func then
- Set_Declarations (B_F, Empty_List);
+ Cond_Id := Entity (Cond);
+
+ -- Perform a small optimization of simple barrier functions. If the
+ -- scope of the condition's entity is not the barrier function, then
+ -- the condition does not depend on any of the generated renamings.
+ -- If this is the case, eliminate the renamings as they are useless.
+ -- This optimization is not performed when the condition was folded
+ -- and validity checks are in effect because the original condition
+ -- may have produced at least one check that depends on the generated
+ -- renamings.
+
+ if Expander_Active
+ and then Scope (Cond_Id) /= Func_Id
+ and then not Validity_Check_Operands
+ then
+ Set_Declarations (Func_Body, Empty_List);
end if;
- if Entity (Cond) = Standard_False
- or else
- Entity (Cond) = Standard_True
- then
+ if Cond_Id = Standard_False or else Cond_Id = Standard_True then
return;
elsif Is_Simple_Barrier_Name (Cond) then
Declarations => Declarations (N),
Handled_Statement_Sequence => Build_Accept_Body (N));
+ -- Reset the Scope of local entities associated with the accept
+ -- statement (that currently reference the entry scope) to the
+ -- block scope, to avoid having references to the locals treated
+ -- as up-level references.
+
+ Reset_Scopes_To (Block, Blkent);
+
-- For the analysis of the generated declarations, the parent node
-- must be properly set.
Insert_Before (N, Decl);
Analyze (Decl);
- -- Rewrite abortable part into a call to this procedure.
+ -- Rewrite abortable part into a call to this procedure
Astats :=
New_List (
Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
- -- Insert declaration of C in declarations of existing block
+ -- Insert the declaration of C in the declarations of the existing
+ -- block. The variable is initialized to something (True or False,
+ -- does not matter) to prevent CodePeer from complaining about a
+ -- possible read of an uninitialized variable.
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Cancel_Param,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)));
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc),
+ Has_Init_Expression => True));
-- Remove and save the call to Call_Simple
end if;
Analyze (N);
+
+ Reset_Scopes_To (N, Entity (Identifier (N)));
end Expand_N_Conditional_Entry_Call;
---------------------------------------
Proc : Entity_Id;
begin
- -- Try to use System.Relative_Delays.Delay_For only if available. This
- -- is the implementation used on restricted platforms when Ada.Calendar
- -- is not available.
+ -- Try to use Ada.Calendar.Delays.Delay_For if available.
- if RTE_Available (RO_RD_Delay_For) then
- Proc := RTE (RO_RD_Delay_For);
+ if RTE_Available (RO_CA_Delay_For) then
+ Proc := RTE (RO_CA_Delay_For);
- -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
- -- message if not available.
+ -- Otherwise, use System.Relative_Delays.Delay_For and emit an error
+ -- message if not available. This is the implementation used on
+ -- restricted platforms when Ada.Calendar is not available.
else
- Proc := RTE (RO_CA_Delay_For);
+ Proc := RTE (RO_RD_Delay_For);
end if;
Rewrite (N,
Op_Body := First (Declarations (N));
- -- The protected body is replaced with the bodies of its
- -- protected operations, and the declarations for internal objects
- -- that may have been created for entry family bounds.
+ -- The protected body is replaced with the bodies of its protected
+ -- operations, and the declarations for internal objects that may
+ -- have been created for entry family bounds.
Rewrite (N, Make_Null_Statement (Sloc (N)));
Analyze (N);
when N_Implicit_Label_Declaration =>
null;
- when N_Itype_Reference =>
- Insert_After (Current_Node, New_Copy (Op_Body));
+ when N_Call_Marker
+ | N_Itype_Reference
+ =>
+ New_Op_Body := New_Copy (Op_Body);
+ Insert_After (Current_Node, New_Op_Body);
+ Current_Node := New_Op_Body;
when N_Freeze_Entity =>
New_Op_Body := New_Copy (Op_Body);
when others =>
raise Program_Error;
-
end case;
Next (Op_Body);
-- type poV (discriminants) is record
-- _Object : aliased <kind>Protection
-- [(<entry count> [, <handler count>])];
- -- [entry_family : array (bounds) of Void;]
+ -- [entry_family : array (bounds) of Void;]
-- <private data fields>
-- end record;
Current_Node : Node_Id := N;
E_Count : Int;
Entries_Aggr : Node_Id;
+ Rec_Decl : Node_Id;
+ Rec_Id : Entity_Id;
procedure Check_Inlining (Subp : Entity_Id);
-- If the original operation has a pragma Inline, propagate the flag
-- to the internal body, for possible inlining later on. The source
-- operation is invisible to the back-end and is never actually called.
- function Discriminated_Size (Comp : Entity_Id) return Boolean;
- -- If a component size is not static then a warning will be emitted
- -- in Ravenscar or other restricted contexts. When a component is non-
- -- static because of a discriminant constraint we can specialize the
- -- warning by mentioning discriminants explicitly.
-
procedure Expand_Entry_Declaration (Decl : Node_Id);
-- Create the entry barrier and the procedure body for entry declaration
-- Decl. All generated subprograms are added to Entry_Bodies_Array.
function Static_Component_Size (Comp : Entity_Id) return Boolean;
-- When compiling under the Ravenscar profile, private components must
- -- have a static size, or else a protected object will require heap
+ -- have a static size, or else a protected object will require heap
-- allocation, violating the corresponding restriction. It is preferable
-- to make this check here, because it provides a better error message
-- than the back-end, which refers to the object as a whole.
-- For a protected operation that is an interrupt handler, add the
-- freeze action that will register it as such.
+ procedure Replace_Access_Definition (Comp : Node_Id);
+ -- If a private component of the type is an access to itself, this
+ -- is not a reference to the current instance, but an access type out
+ -- of which one might construct a list. If such a component exists, we
+ -- create an incomplete type for the equivalent record type, and
+ -- a named access type for it, that replaces the access definition
+ -- of the original component. This is similar to what is done for
+ -- records in Check_Anonymous_Access_Components, but simpler, because
+ -- the corresponding record type has no previous declaration.
+ -- This needs to be done only once, even if there are several such
+ -- access components. The following entity stores the constructed
+ -- access type.
+
+ Acc_T : Entity_Id := Empty;
+
--------------------
-- Check_Inlining --
--------------------
Set_Is_Inlined (Protected_Body_Subprogram (Subp));
Set_Is_Inlined (Subp, False);
end if;
- end Check_Inlining;
-
- ------------------------
- -- Discriminated_Size --
- ------------------------
-
- function Discriminated_Size (Comp : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Comp);
- Index : Node_Id;
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean;
- -- Check whether the bound of an index is non-static and does denote
- -- a discriminant, in which case any protected object of the type
- -- will have a non-static size.
-
- ----------------------
- -- Non_Static_Bound --
- ----------------------
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean is
- begin
- if Is_OK_Static_Expression (Bound) then
- return False;
-
- elsif Is_Entity_Name (Bound)
- and then Present (Discriminal_Link (Entity (Bound)))
- then
- return False;
-
- else
- return True;
- end if;
- end Non_Static_Bound;
-
- -- Start of processing for Discriminated_Size
-
- begin
- if not Is_Array_Type (Typ) then
- return False;
- end if;
-
- if Ekind (Typ) = E_Array_Subtype then
- Index := First_Index (Typ);
- while Present (Index) loop
- if Non_Static_Bound (Low_Bound (Index))
- or else Non_Static_Bound (High_Bound (Index))
- then
- return False;
- end if;
- Next_Index (Index);
- end loop;
-
- return True;
+ if Has_Pragma_No_Inline (Subp) then
+ Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp));
end if;
-
- return False;
- end Discriminated_Size;
+ end Check_Inlining;
---------------------------
-- Static_Component_Size --
Append_Freeze_Action (Prot_Proc, RTS_Call);
end Register_Handler;
+ -------------------------------
+ -- Replace_Access_Definition --
+ -------------------------------
+
+ procedure Replace_Access_Definition (Comp : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Comp);
+ Inc_T : Node_Id;
+ Inc_D : Node_Id;
+ Acc_Def : Node_Id;
+ Acc_D : Node_Id;
+
+ begin
+ if No (Acc_T) then
+ Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id));
+ Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T);
+ Acc_T := Make_Temporary (Loc, 'S');
+ Acc_Def :=
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication => New_Occurrence_Of (Inc_T, Loc));
+ Acc_D :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Acc_T,
+ Type_Definition => Acc_Def);
+
+ Insert_Before (Rec_Decl, Inc_D);
+ Analyze (Inc_D);
+
+ Insert_Before (Rec_Decl, Acc_D);
+ Analyze (Acc_D);
+ end if;
+
+ Set_Access_Definition (Comp, Empty);
+ Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc));
+ end Replace_Access_Definition;
+
-- Local variables
- Body_Arr : Node_Id;
- Body_Id : Entity_Id;
- Cdecls : List_Id;
- Comp : Node_Id;
- Expr : Node_Id;
- New_Priv : Node_Id;
- Obj_Def : Node_Id;
- Object_Comp : Node_Id;
- Priv : Node_Id;
- Rec_Decl : Node_Id;
- Sub : Node_Id;
+ Body_Arr : Node_Id;
+ Body_Id : Entity_Id;
+ Cdecls : List_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ New_Priv : Node_Id;
+ Obj_Def : Node_Id;
+ Object_Comp : Node_Id;
+ Priv : Node_Id;
+ Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration
return;
else
Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
+ Rec_Id := Defining_Identifier (Rec_Decl);
end if;
Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
elsif Restriction_Active (No_Implicit_Heap_Allocations) then
if not Discriminated_Size (Defining_Identifier (Priv))
then
- -- Any object of the type will be non-static.
+ -- Any object of the type will be non-static
Error_Msg_N ("component has non-static size??", Priv);
Error_Msg_NE
& "violate restriction "
& "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
else
-
- -- Object will be non-static if discriminants are.
+ -- Object will be non-static if discriminants are
Error_Msg_NE
("creation of protected object of type& with "
- & "non-static discriminants will violate"
- & " restriction No_Implicit_Heap_Allocations??",
+ & "non-static discriminants will violate "
+ & "restriction No_Implicit_Heap_Allocations??",
Priv, Prot_Typ);
end if;
then
if not Discriminated_Size (Defining_Identifier (Priv))
then
- -- Any object of the type will be non-static.
+ -- Any object of the type will be non-static
Error_Msg_N ("component has non-static size??", Priv);
Error_Msg_NE
& "No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
else
- -- Object will be non-static if discriminants are.
+ -- Object will be non-static if discriminants are
Error_Msg_NE
("creation of protected object of type& with "
- & "non-static discriminants will violate "
+ & "non-static discriminants will violate "
& "restriction "
& "No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
Access_Definition =>
New_Copy_Tree
(Access_Definition (Old_Comp), Discr_Map));
+
+ -- A self-reference in the private part becomes a
+ -- self-reference to the corresponding record.
+
+ if Entity (Subtype_Mark (Access_Definition (New_Comp)))
+ = Prot_Typ
+ then
+ Replace_Access_Definition (New_Comp);
+ end if;
end if;
New_Priv :=
Ritem := First_Rep_Item (Prot_Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name_Mapped (Ritem) = Name_Attach_Handler
+ and then Pragma_Name (Ritem) = Name_Attach_Handler
then
Num_Attach_Handler := Num_Attach_Handler + 1;
end if;
declare
Elmt : Elmt_Id;
Op : Entity_Id;
+ pragma Warnings (Off, Op);
begin
Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
Statements => New_List (
Make_Implicit_If_Statement (N,
- Condition => Cond,
+ Condition => Cond,
Then_Statements => New_List (
Make_Select_Call (
New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
Eloc : constant Source_Ptr := Sloc (Ename);
Eent : constant Entity_Id := Entity (Ename);
Index : constant Node_Id := Entry_Index (Acc_Stm);
+
+ Call : Node_Id;
+ Expr : Node_Id;
Null_Body : Node_Id;
- Proc_Body : Node_Id;
PB_Ent : Entity_Id;
- Expr : Node_Id;
- Call : Node_Id;
+ Proc_Body : Node_Id;
+
+ -- Start of processing for Add_Accept
begin
if No (Ann) then
Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
else
- Expr :=
- Entry_Index_Expression
- (Eloc, Eent, Index, Scope (Eent));
+ Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent));
end if;
if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
Make_Defining_Identifier (Eloc,
New_External_Name (Chars (Ename), 'A', Num_Accept));
+ -- Link the acceptor to the original receiving entry
+
+ Set_Ekind (PB_Ent, E_Procedure);
+ Set_Receiving_Entry (PB_Ent, Eent);
+
if Comes_From_Source (Alt) then
Set_Debug_Info_Needed (PB_Ent);
end if;
Handled_Statement_Sequence =>
Build_Accept_Body (Accept_Statement (Alt)));
+ Reset_Scopes_To (Proc_Body, PB_Ent);
+
-- During the analysis of the body of the accept statement, any
-- zero cost exception handler records were collected in the
-- Accept_Handler_Records field of the N_Accept_Alternative node.
Body_Decl : Node_Id;
Cdecls : List_Id;
Decl_Stack : Node_Id;
+ Decl_SS : Node_Id;
Elab_Decl : Node_Id;
Ent_Stack : Entity_Id;
Proc_Spec : Node_Id;
N := First (Visible_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
- and then Pragma_Name_Mapped (N) = Name_Relative_Deadline
+ and then Pragma_Name (N) = Name_Relative_Deadline
then
return N;
end if;
N := First (Private_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
- and then Pragma_Name_Mapped (N) = Name_Relative_Deadline
+ and then Pragma_Name (N) = Name_Relative_Deadline
then
return N;
end if;
Set_Analyzed (Task_Size);
else
- Task_Size := Relocate_Node (Expr_N);
+ Task_Size := New_Copy_Tree (Expr_N);
end if;
end;
end if;
+ -- Declare a static secondary stack if the conditions for a statically
+ -- generated stack are met.
+
+ if Create_Secondary_Stack_For_Task (TaskId) then
+ declare
+ Size_Expr : constant Node_Id :=
+ Expression (First (
+ Pragma_Argument_Associations (
+ Get_Rep_Pragma (TaskId,
+ Name_Secondary_Stack_Size))));
+
+ Stack_Size : Node_Id;
+
+ begin
+ -- The secondary stack is defined inside the corresponding
+ -- record. Therefore if the size of the stack is set by means
+ -- of a discriminant, we must reference the discriminant of the
+ -- corresponding record type.
+
+ if Nkind (Size_Expr) in N_Has_Entity
+ and then Present (Discriminal_Link (Entity (Size_Expr)))
+ then
+ Stack_Size :=
+ New_Occurrence_Of
+ (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))),
+ Loc);
+ Set_Parent (Stack_Size, Parent (Size_Expr));
+ Set_Etype (Stack_Size, Etype (Size_Expr));
+ Set_Analyzed (Stack_Size);
+
+ else
+ Stack_Size := New_Copy_Tree (Size_Expr);
+ end if;
+
+ -- Create the secondary stack for the task
+
+ Decl_SS :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => True,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Convert_To (RTE (RE_Size_Type),
+ Stack_Size))))));
+
+ Append_To (Cdecls, Decl_SS);
+ end;
+ end if;
+
-- Add components for entry families
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
Expression =>
Convert_To (RTE (RE_Size_Type),
- Relocate_Node (
+ New_Copy_Tree (
Expression (First (
Pragma_Argument_Associations (
Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
end if;
- -- Add the _Secondary_Stack_Size component if a
- -- Secondary_Stack_Size rep item is present.
+ -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
+ -- pragma is present.
- if Has_Rep_Item (TaskId, Name_Secondary_Stack_Size,
- Check_Parents => False)
+ if Has_Rep_Pragma
+ (TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
- Defining_Identifier =>
+ Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
Component_Definition =>
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
- -- not be added (deadlines are not allowed by the Ravenscar profile).
+ -- not be added (deadlines are not allowed by the Ravenscar profile),
+ -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
+ -- profile).
- if not Restricted_Profile
+ if (not Restricted_Profile or else Task_Dispatching_Policy = 'E')
and then Present (Taskdef)
and then Has_Relative_Deadline_Pragma (Taskdef)
then
Expression =>
Convert_To (RTE (RE_Time_Span),
- Relocate_Node (
+ New_Copy_Tree (
Expression (First (
Pragma_Argument_Associations (
Get_Relative_Deadline_Pragma (Taskdef))))))));
Call : Node_Id;
Call_Ent : Entity_Id;
Conc_Typ_Stmts : List_Id;
- Concval : Node_Id;
+ Concval : Node_Id := Empty; -- init to avoid warning
D_Alt : constant Node_Id := Delay_Alternative (N);
D_Conv : Node_Id;
D_Disc : Node_Id;
Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
Expression => D_Disc));
- -- Do the assignment at this stage only because the evaluation of the
- -- expression must not occur before (see ACVC C97302A).
-
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (D, Loc),
- Expression => D_Conv));
-
-- Parameter block processing
-- Manually create the parameter block for dispatching calls. In the
if Is_Disp_Select then
+ -- Compute the delay at this stage because the evaluation of its
+ -- expression must not occur earlier (see ACVC C97302A).
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (D, Loc),
+ Expression => D_Conv));
+
-- Tagged kind processing, generate:
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
Next (Stmt);
end loop;
- -- Do the assignment at this stage only because the evaluation
- -- of the expression must not occur before (see ACVC C97302A).
+ -- Compute the delay at this stage because the evaluation of
+ -- its expression must not occur earlier (see ACVC C97302A).
Insert_Before (Stmt,
Make_Assignment_Statement (Loc,
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
+
+ -- Some items in Decls used to be in the N_Block in E_Call that is
+ -- constructed in Expand_Entry_Call, and are now in the new Block
+ -- into which N has been rewritten. Adjust their scopes to reflect that.
+
+ if Nkind (E_Call) = N_Block_Statement then
+ Obj := First_Entity (Entity (Identifier (E_Call)));
+ while Present (Obj) loop
+ Set_Scope (Obj, Entity (Identifier (N)));
+ Next_Entity (Obj);
+ end loop;
+ end if;
+
+ Reset_Scopes_To (N, Entity (Identifier (N)));
end Expand_N_Timed_Entry_Call;
----------------------------------------
when others =>
raise Program_Error;
-
end case;
end loop;
end if;
-- If the type of the dispatching object is an access type then return
- -- an explicit dereference.
+ -- an explicit dereference of a copy of the object, and note that this
+ -- is the controlling actual of the call.
if Is_Access_Type (Etype (Object)) then
- Object := Make_Explicit_Dereference (Sloc (N), Object);
+ Object :=
+ Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
Analyze (Object);
+ Set_Is_Controlling_Actual (Object);
end if;
end Extract_Dispatching_Call;
Insert_Node := Decl;
end Add;
- --------------------------
- -- Replace_Discriminant --
- --------------------------
+ -------------------
+ -- Replace_Bound --
+ -------------------
function Replace_Bound (Bound : Node_Id) return Node_Id is
begin
Selector_Name => Make_Identifier (Loc, Chars (D))));
Add (Decl);
+ -- Set debug info needed on this renaming declaration even
+ -- though it does not come from source, so that the debugger
+ -- will get the right information for these generated names.
+
+ Set_Debug_Info_Needed (Discriminal (D));
+
Next_Discriminant (D);
end loop;
end;
Set_Ekind (Decl_Id, E_Variable);
end if;
- Set_Prival (Comp_Id, Decl_Id);
- Set_Prival_Link (Decl_Id, Comp_Id);
- Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
+ Set_Prival (Comp_Id, Decl_Id);
+ Set_Prival_Link (Decl_Id, Comp_Id);
+ Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
+ Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id));
-- Generate:
-- comp_name : comp_typ renames _object.comp_name;
High := Type_High_Bound (Etype (Index));
Low := Type_Low_Bound (Etype (Index));
- -- In the simple case the entry family is given by a subtype
- -- mark and the index constant has the same type.
+ -- In the simple case the entry family is given by a subtype mark
+ -- and the index constant has the same type.
if Is_Entity_Name (Original_Node (
Discrete_Subtype_Definition (Parent (Index))))
end if;
end Install_Private_Data_Declarations;
- -----------------------
- -- Is_Exception_Safe --
- -----------------------
-
- function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
-
- function Has_Side_Effect (N : Node_Id) return Boolean;
- -- Return True whenever encountering a subprogram call or raise
- -- statement of any kind in the sequence of statements
-
- ---------------------
- -- Has_Side_Effect --
- ---------------------
-
- -- What is this doing buried two levels down in exp_ch9. It seems like a
- -- generally useful function, and indeed there may be code duplication
- -- going on here ???
-
- function Has_Side_Effect (N : Node_Id) return Boolean is
- Stmt : Node_Id;
- Expr : Node_Id;
-
- function Is_Call_Or_Raise (N : Node_Id) return Boolean;
- -- Indicate whether N is a subprogram call or a raise statement
-
- ----------------------
- -- Is_Call_Or_Raise --
- ----------------------
-
- function Is_Call_Or_Raise (N : Node_Id) return Boolean is
- begin
- return Nkind_In (N, N_Procedure_Call_Statement,
- N_Function_Call,
- N_Raise_Statement,
- N_Raise_Constraint_Error,
- N_Raise_Program_Error,
- N_Raise_Storage_Error);
- end Is_Call_Or_Raise;
-
- -- Start of processing for Has_Side_Effect
-
- begin
- Stmt := N;
- while Present (Stmt) loop
- if Is_Call_Or_Raise (Stmt) then
- return True;
- end if;
-
- -- An object declaration can also contain a function call or a
- -- raise statement.
-
- if Nkind (Stmt) = N_Object_Declaration then
- Expr := Expression (Stmt);
-
- if Present (Expr) and then Is_Call_Or_Raise (Expr) then
- return True;
- end if;
- end if;
-
- Next (Stmt);
- end loop;
-
- return False;
- end Has_Side_Effect;
-
- -- Start of processing for Is_Exception_Safe
-
- begin
- -- When exceptions can't be propagated, the subprogram returns normally
-
- if No_Exception_Handlers_Set then
- return True;
- end if;
-
- -- If the checks handled by the back end are not disabled, we cannot
- -- ensure that no exception will be raised.
-
- if not Access_Checks_Suppressed (Empty)
- or else not Discriminant_Checks_Suppressed (Empty)
- or else not Range_Checks_Suppressed (Empty)
- or else not Index_Checks_Suppressed (Empty)
- or else Opt.Stack_Checking_Enabled
- then
- return False;
- end if;
-
- if Has_Side_Effect (First (Declarations (Subprogram)))
- or else
- Has_Side_Effect
- (First (Statements (Handled_Statement_Sequence (Subprogram))))
- then
- return False;
- else
- return True;
- end if;
- end Is_Exception_Safe;
-
---------------------------------
-- Is_Potentially_Large_Family --
---------------------------------
function Make_Initialize_Protection
(Protect_Rec : Entity_Id) return List_Id
is
- Loc : constant Source_Ptr := Sloc (Protect_Rec);
- P_Arr : Entity_Id;
- Pdec : Node_Id;
- Ptyp : constant Node_Id :=
- Corresponding_Concurrent_Type (Protect_Rec);
- Args : List_Id;
- L : constant List_Id := New_List;
- Has_Entry : constant Boolean := Has_Entries (Ptyp);
- Prio_Type : Entity_Id;
- Prio_Var : Entity_Id := Empty;
- Restricted : constant Boolean := Restricted_Profile;
+ Loc : constant Source_Ptr := Sloc (Protect_Rec);
+ P_Arr : Entity_Id;
+ Pdec : Node_Id;
+ Ptyp : constant Node_Id :=
+ Corresponding_Concurrent_Type (Protect_Rec);
+ Args : List_Id;
+ L : constant List_Id := New_List;
+ Has_Entry : constant Boolean := Has_Entries (Ptyp);
+ Prio_Type : Entity_Id;
+ Prio_Var : Entity_Id := Empty;
+ Restricted : constant Boolean := Restricted_Profile;
begin
-- We may need two calls to properly initialize the object, one to
Expression
(First (Pragma_Argument_Associations (Prio_Clause)));
- -- Get_Rep_Item returns either priority pragma.
+ -- Get_Rep_Item returns either priority pragma
- if Pragma_Name_Mapped (Prio_Clause) = Name_Priority then
+ if Pragma_Name (Prio_Clause) = Name_Priority then
Prio_Type := RTE (RE_Any_Priority);
else
Prio_Type := RTE (RE_Interrupt_Priority);
New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
end if;
+ -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
+
+ if Restricted_Profile and Task_Dispatching_Policy = 'E' then
+ Deadline_Floor : declare
+ Item : constant Node_Id :=
+ Get_Rep_Item
+ (Ptyp, Name_Deadline_Floor, Check_Parents => False);
+
+ Deadline : Node_Id;
+
+ begin
+ if Present (Item) then
+
+ -- Pragma Deadline_Floor
+
+ if Nkind (Item) = N_Pragma then
+ Deadline :=
+ Expression
+ (First (Pragma_Argument_Associations (Item)));
+
+ -- Attribute definition clause Deadline_Floor
+
+ else
+ pragma Assert
+ (Nkind (Item) = N_Attribute_Definition_Clause);
+
+ Deadline := Expression (Item);
+ end if;
+
+ Append_To (Args, Deadline);
+
+ -- Unusual case: default deadline
+
+ else
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
+ end if;
+ end Deadline_Floor;
+ end if;
+
-- Test for Compiler_Info parameter. This parameter allows entry body
-- procedures and barrier functions to be called from the runtime. It
-- is a pointer to the record generated by the compiler to represent
Called_Subp := RE_Initialize_Protection;
when others =>
- raise Program_Error;
+ raise Program_Error;
end case;
-- Entry_Queue_Maxes parameter. This is an access to an array of
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name_Mapped (Ritem) = Name_Attach_Handler
+ and then Pragma_Name (Ritem) = Name_Attach_Handler
then
declare
Handler : constant Node_Id :=
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- Priority rep item, in which case we take the value from the rep item.
+ -- Not used on Ravenscar_EDF profile.
- if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
- Append_To (Args,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uPriority)));
- else
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
+ if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then
+ if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => Make_Identifier (Loc, Name_uPriority)));
+ else
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
+ end if;
end if;
-- Optional Stack parameter
New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
end if;
- -- Secondary_Stack_Size parameter. Set Default_Secondary_Stack_Size
- -- unless there is a Secondary_Stack_Size rep item, in which case we
- -- take the value from the rep item. If the restriction
- -- No_Secondary_Stack is active then a size of 0 is passed regardless
- -- to prevent the allocation of the unused stack.
+ -- Secondary_Stack parameter used for restricted profiles
+
+ if Restricted_Profile then
+
+ -- If the secondary stack has been allocated by the expander then
+ -- pass its access pointer. Otherwise, pass null.
+
+ if Create_Secondary_Stack_For_Task (Ttyp) then
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uSecondary_Stack)),
+ Attribute_Name => Name_Unrestricted_Access));
+
+ else
+ Append_To (Args, Make_Null (Loc));
+ end if;
+ end if;
+
+ -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
+ -- is a Secondary_Stack_Size pragma, in which case take the value from
+ -- the pragma. If the restriction No_Secondary_Stack is active then a
+ -- size of 0 is passed regardless to prevent the allocation of the
+ -- unused stack.
if Restriction_Active (No_Secondary_Stack) then
Append_To (Args, Make_Integer_Literal (Loc, 0));
- elsif Has_Rep_Item (Ttyp, Name_Secondary_Stack_Size,
- Check_Parents => False)
+ elsif Has_Rep_Pragma
+ (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
then
Append_To (Args,
Make_Selected_Component (Loc,
New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
end if;
- if not Restricted_Profile then
+ if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then
-- Deadline parameter. If no Relative_Deadline pragma is present,
-- then the deadline is Time_Span_Zero. If a pragma is present, then
Append_To (Args,
New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
end if;
+ end if;
+
+ if not Restricted_Profile then
-- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
-- present, then the dispatching domain is null. If a rep item is
or else
(Nkind (Stmt) = N_Pragma
and then
- Nam_In (Pragma_Name (Stmt), Name_Unreferenced,
- Name_Unmodified,
- Name_Warnings)))
+ Nam_In (Pragma_Name_Unmapped (Stmt),
+ Name_Unreferenced,
+ Name_Unmodified,
+ Name_Warnings)))
loop
Next (Stmt);
end loop;
Object_Definition =>
New_Occurrence_Of (Etype (Formal), Loc)));
+ -- The object is initialized with an explicit assignment
+ -- later. Indicate that it does not need an initialization
+ -- to prevent spurious warnings if the type excludes null.
+
+ Set_No_Initialization (Last (Decls));
+
if Ekind (Formal) /= E_Out_Parameter then
-- Generate:
Expression => New_Copy_Tree (Actual)));
end if;
- -- Generate:
+ -- If the actual is not controlling, generate:
+
-- Jnn'unchecked_access
- Append_To (Params,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unchecked_Access,
- Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
+ -- and add it to aggegate for access to formals. Note that the
+ -- actual may be by-copy but still be a controlling actual if it
+ -- is an access to class-wide interface.
+
+ if not Is_Controlling_Actual (Actual) then
+ Append_To (Params,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
- Has_Param := True;
+ Has_Param := True;
+ end if;
-- The controlling parameter is omitted
end if;
end Parameter_Block_Unpack;
+ ---------------------
+ -- Reset_Scopes_To --
+ ---------------------
+
+ procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is
+ function Reset_Scope (N : Node_Id) return Traverse_Result;
+ -- Temporaries may have been declared during expansion of the procedure
+ -- created for an entry body or an accept alternative. Indicate that
+ -- their scope is the new body, to ensure proper generation of uplevel
+ -- references where needed during unnesting.
+
+ procedure Reset_Scopes is new Traverse_Proc (Reset_Scope);
+
+ -----------------
+ -- Reset_Scope --
+ -----------------
+
+ function Reset_Scope (N : Node_Id) return Traverse_Result is
+ Decl : Node_Id;
+
+ begin
+ -- If this is a block statement with an Identifier, it forms a scope,
+ -- so we want to reset its scope but not look inside.
+
+ if N /= Bod
+ and then Nkind (N) = N_Block_Statement
+ and then Present (Identifier (N))
+ then
+ Set_Scope (Entity (Identifier (N)), E);
+ return Skip;
+
+ -- Ditto for a package declaration or a full type declaration, etc.
+
+ elsif (Nkind (N) = N_Package_Declaration
+ and then N /= Specification (N))
+ or else Nkind (N) in N_Declaration
+ or else Nkind (N) in N_Renaming_Declaration
+ then
+ Set_Scope (Defining_Entity (N), E);
+ return Skip;
+
+ elsif N = Bod then
+
+ -- Scan declarations in new body. Declarations in the statement
+ -- part will be handled during later traversal.
+
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ Reset_Scopes (Decl);
+ Next (Decl);
+ end loop;
+
+ elsif Nkind (N) = N_Freeze_Entity then
+
+ -- Scan the actions associated with a freeze node, which may
+ -- actually be declarations with entities that need to have
+ -- their scopes reset.
+
+ Decl := First (Actions (N));
+ while Present (Decl) loop
+ Reset_Scopes (Decl);
+ Next (Decl);
+ end loop;
+
+ elsif N /= Bod and then Nkind (N) in N_Proper_Body then
+
+ -- A subprogram without a separate declaration may be encountered,
+ -- and we need to reset the subprogram's entity's scope.
+
+ if Nkind (N) = N_Subprogram_Body then
+ Set_Scope (Defining_Entity (Specification (N)), E);
+ end if;
+
+ return Skip;
+ end if;
+
+ return OK;
+ end Reset_Scope;
+
+ -- Start of processing for Reset_Scopes_To
+
+ begin
+ Reset_Scopes (Bod);
+ end Reset_Scopes_To;
+
----------------------
-- Set_Discriminals --
----------------------
when others =>
return False;
-
end case;
end Trivial_Accept_OK;
projects / thirdparty / gcc.git / blobdiff