-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2018, 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 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;
-- 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 (Proc_Body : Node_Id; E : Entity_Id);
- -- Reset the scope of declarations and blocks at the top level of Proc_Body
- -- to be E. Used after expanding entry bodies into their corresponding
- -- procedures. This is needed during unnesting to determine whether a
- -- body geenrated for an entry or an accept alternative includes uplevel
- -- references.
+ 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
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)),
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 --
Next_Decl := Next (Decl);
- if Nkind (Decl) = N_Pragma then
+ -- 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;
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
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 (
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);
-- 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
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,
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)),
Make_Defining_Identifier (Eloc,
New_External_Name (Chars (Ename), 'A', Num_Accept));
- -- Link the acceptor to the original receiving entry.
+ -- Link the acceptor to the original receiving entry
Set_Ekind (PB_Ent, E_Procedure);
Set_Receiving_Entry (PB_Ent, Eent);
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;
----------------------------------------
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;
-- Reset_Scopes_To --
---------------------
- procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is
-
+ 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 unsure proper generation of uplevel
+ -- 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);
-- 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 Nkind (N) = N_Block_Statement
+ if N /= Bod
+ and then Nkind (N) = N_Block_Statement
and then Present (Identifier (N))
then
Set_Scope (Entity (Identifier (N)), E);
-- Ditto for a package declaration or a full type declaration, etc.
- elsif Nkind (N) = N_Package_Declaration
- or else Nkind (N) in N_Declaration
- or else Nkind (N) in N_Renaming_Declaration
+ 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 = Proc_Body then
+ elsif N = Bod then
-- Scan declarations in new body. Declarations in the statement
-- part will be handled during later traversal.
Next (Decl);
end loop;
- elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then
+ 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;
-- Start of processing for Reset_Scopes_To
begin
- Reset_Scopes (Proc_Body);
+ Reset_Scopes (Bod);
end Reset_Scopes_To;
----------------------
projects / thirdparty / gcc.git / blobdiff