-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, 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 Einfo; use Einfo;
with Elists; use Elists;
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;
(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.
-- ...
-- <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
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)),
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
--------------------------------
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;
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 --
-------------------------------------
-- 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
-- reference will have been rewritten.
if Expander_Active then
+
+ -- 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
Cond_Id : Entity_Id;
Entry_Body : Node_Id;
- Func_Body : Node_Id;
- pragma Warnings (Off, Func_Body);
+ Func_Body : Node_Id := Empty;
-- Start of processing for Expand_Entry_Barrier
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.
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,
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);
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
-- 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;
+
+ if Has_Pragma_No_Inline (Subp) then
+ Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp));
+ end if;
end Check_Inlining;
---------------------------
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;
Obj_Def : Node_Id;
Object_Comp : Node_Id;
Priv : Node_Id;
- Rec_Decl : 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)));
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 :=
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;
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.
+ -- pragma is present.
- if Has_Rep_Item
+ if Has_Rep_Pragma
(TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
then
Append_To (Cdecls,
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;
----------------------------------------
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;
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
+ elsif Has_Rep_Pragma
(Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
then
Append_To (Args,
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.
- Has_Param := True;
+ 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;
+ 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 --
----------------------
projects / thirdparty / gcc.git / blobdiff