Google Git
Sign in
gnu / gcc / 57ea00136418991e847e46a6946a81a1df70c9a4 / . / gcc / ada / exp_ch9.adb
blob: 9f02d518a977f460f6a4d909cc070049638fea3d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 9 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Hostparm;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Types; use Types;
with Uintp; use Uintp;
with Opt;
package body Exp_Ch9 is
-----------------------
-- Local Subprograms --
-----------------------
function Actual_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Tsk : Entity_Id) return Node_Id;
-- Compute the index position for an entry call. Tsk is the target
-- task. If the bounds of some entry family depend on discriminants,
-- the expression computed by this function uses the discriminants
-- of the target task.
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
Prot : Entity_Id) return List_Id;
-- For an entry family and its barrier function, we define a local entity
-- that maps the index in the call into the entry index into the object:
--
-- I : constant Index_Type := Index_Type'Val (
-- E - <<index of first family member>> +
-- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
procedure Add_Object_Pointer
(Decls : List_Id;
Pid : Entity_Id;
Loc : Source_Ptr);
-- Prepend an object pointer declaration to the declaration list
-- Decls. This object pointer is initialized to a type conversion
-- of the System.Address pointer passed to entry barrier functions
-- and entry body procedures.
function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler.
-- Used both for simple accept statements and for accept alternatives in
-- select statements. Astat is the accept statement.
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id;
-- Build the function body returning the value of the barrier expression
-- for the specified entry body.
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
-- Build a specification for a function implementing
-- the protected entry barrier of the specified entry body.
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Node_Id;
Loc : Source_Ptr) return Node_Id;
-- Common to tasks and protected types. Copy discriminant specifications,
-- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected type).
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
Loc : Source_Ptr) return Node_Id;
-- Compute number of entries for concurrent object. This is a count of
-- simple entries, followed by an expression that computes the length
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
-- Build subprogram declaration for previous one
function Build_Protected_Entry
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id;
-- Build the procedure implementing the statement sequence of
-- the specified entry body.
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
-- Build a specification for a procedure implementing
-- the statement sequence of the specified entry body.
-- Add attributes associating it with the entry defining identifier
-- Ent_Id.
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected
-- subprogram. Its statement sequence first defers abortion, then locks
-- the associated protected object, and then enters a block that contains
-- a call to the unprotected version of the subprogram (for details, see
-- Build_Unprotected_Subprogram_Body). This block statement requires
-- a cleanup handler that unlocks the object in all cases.
-- (see Exp_Ch7.Expand_Cleanup_Actions).
function Build_Protected_Spec
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
Ident : Entity_Id) return List_Id;
-- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
-- Subprogram_Type. Builds signature of protected subprogram, adding the
-- formal that corresponds to the object itself. For an access to protected
-- subprogram, there is no object type to specify, so the additional
-- parameter has type Address and mode In. An indirect call through such
-- a pointer converts the address to a reference to the actual object.
-- The object is a limited record and therefore a by_reference type.
function Build_Selected_Name
(Prefix, Selector : Name_Id;
Append_Char : Character := ' ') return Name_Id;
-- Build a name in the form of Prefix__Selector, with an optional
-- character appended. This is used for internal subprograms generated
-- for operations of protected types, including barrier functions. In
-- order to simplify the work of the debugger, the prefix includes the
-- characters PT. For the subprograms generated for entry bodies and
-- entry barriers, the generated name includes a sequence number that
-- makes names unique in the presence of entry overloading. This is
-- necessary because entry body procedures and barrier functions all
-- have the same signature.
procedure Build_Simple_Entry_Call
(N : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id);
-- Some comments here would be useful ???
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
-- This routine constructs a specification for the procedure that we will
-- build for the task body for task type T. The spec has the form:
--
-- procedure tnameB (_Task : access tnameV);
--
-- where name is the character name taken from the task type entity that
-- is passed as the argument to the procedure, and tnameV is the task
-- value type that is associated with the task type.
function Build_Unprotected_Subprogram_Body
(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, 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.
procedure Collect_Entry_Families
(Loc : Source_Ptr;
Cdecls : List_Id;
Current_Node : in out Node_Id;
Conctyp : Entity_Id);
-- For each entry family in a concurrent type, create an anonymous array
-- type of the right size, and add a component to the corresponding_record.
function Family_Offset
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) for two entry family indices. Hi is the index in
-- an accept statement, or the upper bound in the discrete subtype of
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is
-- the concurrent type of the entry.
function Family_Size
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
-- a family, and handle properly the superflat case. This is equivalent
-- to the use of 'Length on the index type, but must use Family_Offset
-- to handle properly the case of bounds that depend on discriminants.
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object,
-- the entry name, and the entry family index.
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id;
-- Searches the task or protected definition T for the first occurrence
-- of the pragma whose name is given by P. The caller has ensured that
-- the pragma is present in the task definition. A special case is that
-- when P is Name_uPriority, the call will also find Interrupt_Priority.
-- ??? Should be implemented with the rep item chain mechanism.
procedure Update_Prival_Subtypes (N : Node_Id);
-- The actual subtypes of the privals will differ from the type of the
-- private declaration in the original protected type, if the protected
-- type has discriminants or if the prival has constrained components.
-- This is because the privals are generated out of sequence w.r.t. the
-- analysis of a protected body. After generating the bodies for protected
-- operations, we set correctly the type of all references to privals, by
-- means of a recursive tree traversal, which is heavy-handed but
-- correct.
-----------------------------
-- Actual_Index_Expression --
-----------------------------
function Actual_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Tsk : Entity_Id) return Node_Id
is
Ttyp : constant Entity_Id := Etype (Tsk);
Expr : Node_Id;
Num : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Prev : Entity_Id;
S : Node_Id;
function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
-- Compute difference between bounds of entry family.
--------------------------
-- Actual_Family_Offset --
--------------------------
function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- Replace a reference to a discriminant with a selected component
-- denoting the discriminant of the target task.
-----------------------------
-- Actual_Discriminant_Ref --
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant Entity_Id := Etype (Bound);
B : Node_Id;
begin
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
if Nkind (Bound) = N_Attribute_Reference then
return Bound;
else
B := New_Copy_Tree (Bound);
end if;
else
B :=
Make_Selected_Component (Sloc,
Prefix => New_Copy_Tree (Tsk),
Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
Analyze_And_Resolve (B, Typ);
end if;
return
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
Expressions => New_List (B));
end Actual_Discriminant_Ref;
-- Start of processing for Actual_Family_Offset
begin
return
Make_Op_Subtract (Sloc,
Left_Opnd => Actual_Discriminant_Ref (Hi),
Right_Opnd => Actual_Discriminant_Ref (Lo));
end Actual_Family_Offset;
-- Start of processing for Actual_Index_Expression
begin
-- The queues of entries and entry families appear in textual
-- order in the associated record. The entry index is computed as
-- the sum of the number of queues for all entries that precede the
-- designated one, to which is added the index expression, if this
-- expression denotes a member of a family.
-- The following is a place holder for the count of simple entries.
Num := Make_Integer_Literal (Sloc, 1);
-- We construct an expression which is a series of addition
-- operations. See comments in Entry_Index_Expression, which is
-- identical in structure.
if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Num,
Right_Opnd =>
Actual_Family_Offset (
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S)));
else
Expr := Num;
end if;
-- Now add lengths of preceding entries and entry families.
Prev := First_Entity (Ttyp);
while Chars (Prev) /= Chars (Ent)
or else (Ekind (Prev) /= Ekind (Ent))
or else not Sem_Ch6.Type_Conformant (Ent, Prev)
loop
if Ekind (Prev) = E_Entry then
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
S :=
Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
Lo := Type_Low_Bound (S);
Hi := Type_High_Bound (S);
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Expr,
Right_Opnd =>
Make_Op_Add (Sloc,
Left_Opnd =>
Actual_Family_Offset (Hi, Lo),
Right_Opnd =>
Make_Integer_Literal (Sloc, 1)));
-- Other components are anonymous types to be ignored.
else
null;
end if;
Next_Entity (Prev);
end loop;
return Expr;
end Actual_Index_Expression;
----------------------------------
-- Add_Discriminal_Declarations --
----------------------------------
procedure Add_Discriminal_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr)
is
D : Entity_Id;
begin
if Has_Discriminants (Typ) then
D := First_Discriminant (Typ);
while Present (D) loop
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Discriminal (D),
Subtype_Mark => New_Reference_To (Etype (D), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Chars (D)))));
Next_Discriminant (D);
end loop;
end if;
end Add_Discriminal_Declarations;
------------------------
-- Add_Object_Pointer --
------------------------
procedure Add_Object_Pointer
(Decls : List_Id;
Pid : Entity_Id;
Loc : Source_Ptr)
is
Obj_Ptr : Node_Id;
begin
-- Prepend the declaration of _object. This must be first in the
-- declaration list, since it is used by the discriminal and
-- prival declarations.
-- ??? An attempt to make this a renaming was unsuccessful.
--
-- type poVP is access poV;
-- _object : poVP := poVP!O;
Obj_Ptr :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
(Chars (Corresponding_Record_Type (Pid)), 'P'));
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
Object_Definition => New_Reference_To (Obj_Ptr, Loc),
Expression =>
Unchecked_Convert_To (Obj_Ptr,
Make_Identifier (Loc, Name_uO))));
Prepend_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Obj_Ptr,
Type_Definition => Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (Corresponding_Record_Type (Pid), Loc))));
end Add_Object_Pointer;
------------------------------
-- Add_Private_Declarations --
------------------------------
procedure Add_Private_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr)
is
Def : constant Node_Id := Protected_Definition (Parent (Typ));
Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ));
P : Node_Id;
Pdef : Entity_Id;
begin
pragma Assert (Nkind (Def) = N_Protected_Definition);
if Present (Private_Declarations (Def)) then
P := First (Private_Declarations (Def));
while Present (P) loop
if Nkind (P) = N_Component_Declaration then
Pdef := Defining_Identifier (P);
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Prival (Pdef),
Subtype_Mark => New_Reference_To (Etype (Pdef), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Chars (Pdef)))));
end if;
Next (P);
end loop;
end if;
-- One more "prival" for the object itself, with the right protection
-- type.
declare
Protection_Type : RE_Id;
begin
if Has_Attach_Handler (Typ) then
if Restricted_Profile then
if Has_Entries (Typ) then
Protection_Type := RE_Protection_Entry;
else
Protection_Type := RE_Protection;
end if;
else
Protection_Type := RE_Static_Interrupt_Protection;
end if;
elsif Has_Interrupt_Handler (Typ) then
Protection_Type := RE_Dynamic_Interrupt_Protection;
elsif Has_Entries (Typ) then
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
then
Protection_Type := RE_Protection_Entries;
else
Protection_Type := RE_Protection_Entry;
end if;
else
Protection_Type := RE_Protection;
end if;
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Object_Ref (Body_Ent),
Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Name_uObject))));
end;
end Add_Private_Declarations;
-----------------------
-- Build_Accept_Body --
-----------------------
function Build_Accept_Body (Astat : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Astat);
Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
New_S : Node_Id;
Hand : Node_Id;
Call : Node_Id;
Ohandle : Node_Id;
begin
-- At the end of the statement sequence, Complete_Rendezvous is called.
-- A label skipping the Complete_Rendezvous, and all other
-- accept processing, has already been added for the expansion
-- of requeue statements.
Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
-- If exception handlers are present, then append Complete_Rendezvous
-- calls to the handlers, and construct the required outer block.
if Present (Exception_Handlers (Stats)) then
Hand := First (Exception_Handlers (Stats));
while Present (Hand) loop
Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
Next (Hand);
end loop;
New_S :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Stats)));
else
New_S := Stats;
end if;
-- At this stage we know that the new statement sequence does not
-- have an exception handler part, so we supply one to call
-- Exceptional_Complete_Rendezvous. This handler is
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
-- We handle Abort_Signal to make sure that we properly catch the abort
-- case and wake up the caller.
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
Set_Exception_Handlers (New_S,
New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Exceptional_Complete_Rendezvous), Loc),
Parameter_Associations => New_List (
Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Loc))))))));
Set_Parent (New_S, Astat); -- temp parent for Analyze call
Analyze_Exception_Handlers (Exception_Handlers (New_S));
Expand_Exception_Handlers (New_S);
-- Exceptional_Complete_Rendezvous must be called with abort
-- still deferred, which is the case for a "when all others" handler.
return New_S;
end Build_Accept_Body;
-----------------------------------
-- Build_Activation_Chain_Entity --
-----------------------------------
procedure Build_Activation_Chain_Entity (N : Node_Id) is
P : Node_Id;
B : Node_Id;
Decls : List_Id;
begin
-- Loop to find enclosing construct containing activation chain variable
P := Parent (N);
while Nkind (P) /= N_Subprogram_Body
and then Nkind (P) /= N_Package_Declaration
and then Nkind (P) /= N_Package_Body
and then Nkind (P) /= N_Block_Statement
and then Nkind (P) /= N_Task_Body
loop
P := Parent (P);
end loop;
-- If we are in a package body, the activation chain variable is
-- allocated in the corresponding spec. First, we save the package
-- body node because we enter the new entity in its Declarations list.
B := P;
if Nkind (P) = N_Package_Body then
P := Unit_Declaration_Node (Corresponding_Spec (P));
Decls := Declarations (B);
elsif Nkind (P) = N_Package_Declaration then
Decls := Visible_Declarations (Specification (B));
else
Decls := Declarations (B);
end if;
-- If activation chain entity not already declared, declare it
if No (Activation_Chain_Entity (P)) then
Set_Activation_Chain_Entity
(P, Make_Defining_Identifier (Sloc (N), Name_uChain));
Prepend_To (Decls,
Make_Object_Declaration (Sloc (P),
Defining_Identifier => Activation_Chain_Entity (P),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
Analyze (First (Decls));
end if;
end Build_Activation_Chain_Entity;
----------------------------
-- Build_Barrier_Function --
----------------------------
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
Index_Spec : constant Node_Id := Entry_Index_Specification
(Ent_Formals);
Op_Decls : constant List_Id := New_List;
Bdef : Entity_Id;
Bspec : Node_Id;
begin
Bdef :=
Make_Defining_Identifier (Loc, Chars (Barrier_Function (Ent)));
Bspec := Build_Barrier_Function_Specification (Bdef, Loc);
-- <object pointer declaration>
-- <discriminant renamings>
-- <private object renamings>
-- Add discriminal and private renamings. These names have
-- already been used to expand references to discriminants
-- and private data.
Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc);
Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc);
Add_Object_Pointer (Op_Decls, Pid, Loc);
-- If this is the barrier for an entry family, the entry index is
-- visible in the body of the barrier. Create a local variable that
-- converts the entry index (which is the last formal of the barrier
-- function) into the appropriate offset into the entry array. The
-- entry index constant must be set, as for the entry body, so that
-- local references to the entry index are correctly replaced with
-- the local variable. This parallels what is done for entry bodies.
if Present (Index_Spec) then
declare
Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec);
Index_Con : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('J'));
begin
Set_Entry_Index_Constant (Index_Id, Index_Con);
Append_List_To (Op_Decls,
Index_Constant_Declaration (N, Index_Id, Pid));
end;
end if;
-- Note: the condition in the barrier function needs to be properly
-- processed for the C/Fortran boolean possibility, but this happens
-- automatically since the return statement does this normalization.
return
Make_Subprogram_Body (Loc,
Specification => Bspec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression => Condition (Ent_Formals)))));
end Build_Barrier_Function;
------------------------------------------
-- Build_Barrier_Function_Specification --
------------------------------------------
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
begin
return Make_Function_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc));
end Build_Barrier_Function_Specification;
--------------------------
-- Build_Call_With_Task --
--------------------------
function Build_Call_With_Task
(N : Node_Id;
E : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (E, Loc),
Parameter_Associations => New_List (Concurrent_Ref (N)));
end Build_Call_With_Task;
--------------------------------
-- Build_Corresponding_Record --
--------------------------------
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (Chars (Ctyp), 'V'));
Disc : Entity_Id;
Dlist : List_Id;
New_Disc : Entity_Id;
Cdecls : List_Id;
begin
Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
Set_Ekind (Rec_Ent, E_Record_Type);
Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
Set_Is_Concurrent_Record_Type (Rec_Ent, True);
Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
-- Use discriminals to create list of discriminants for record, and
-- create new discriminals for use in default expressions, etc. It is
-- worth noting that a task discriminant gives rise to 5 entities;
-- a) The original discriminant.
-- b) The discriminal for use in the task.
-- c) The discriminant of the corresponding record.
-- d) The discriminal for the init proc of the corresponding record.
-- e) The local variable that renames the discriminant in the procedure
-- for the task body.
-- In fact the discriminals b) are used in the renaming declarations
-- for e). See details in einfo (Handling of Discriminants).
if Present (Discriminant_Specifications (N)) then
Dlist := New_List;
Disc := First_Discriminant (Ctyp);
while Present (Disc) loop
New_Disc := CR_Discriminant (Disc);
Append_To (Dlist,
Make_Discriminant_Specification (Loc,
Defining_Identifier => New_Disc,
Discriminant_Type =>
New_Occurrence_Of (Etype (Disc), Loc),
Expression =>
New_Copy (Discriminant_Default_Value (Disc))));
Next_Discriminant (Disc);
end loop;
else
Dlist := No_List;
end if;
-- Now we can construct the record type declaration. Note that this
-- record is limited, reflecting the underlying limitedness of the
-- task or protected object that it represents, and ensuring for
-- example that it is properly passed by reference.
return
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Rec_Ent,
Discriminant_Specifications => Dlist,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Cdecls),
Limited_Present => True));
end Build_Corresponding_Record;
----------------------------------
-- Build_Entry_Count_Expression --
----------------------------------
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
Loc : Source_Ptr) return Node_Id
is
Eindx : Nat;
Ent : Entity_Id;
Ecount : Node_Id;
Comp : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Typ : Entity_Id;
begin
Ent := First_Entity (Concurrent_Type);
Eindx := 0;
-- Count number of non-family entries
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Eindx := Eindx + 1;
end if;
Next_Entity (Ent);
end loop;
Ecount := Make_Integer_Literal (Loc, Eindx);
-- Loop through entry families building the addition nodes
Ent := First_Entity (Concurrent_Type);
Comp := First (Component_List);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
Next (Comp);
end loop;
Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Type_High_Bound (Typ);
Lo := Type_Low_Bound (Typ);
Ecount :=
Make_Op_Add (Loc,
Left_Opnd => Ecount,
Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type));
end if;
Next_Entity (Ent);
end loop;
return Ecount;
end Build_Entry_Count_Expression;
---------------------------
-- Build_Find_Body_Index --
---------------------------
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
E_Typ : Entity_Id;
Has_F : Boolean := False;
Index : Nat;
If_St : Node_Id := Empty;
Lo : Node_Id;
Hi : Node_Id;
Decls : List_Id := New_List;
Ret : Node_Id;
Spec : Node_Id;
Siz : Node_Id := Empty;
procedure Add_If_Clause (Expr : Node_Id);
-- Add test for range of current entry.
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If a bound of an entry is given by a discriminant, retrieve the
-- actual value of the discriminant from the enclosing object.
-------------------
-- Add_If_Clause --
-------------------
procedure Add_If_Clause (Expr : Node_Id) is
Cond : Node_Id;
Stats : constant List_Id :=
New_List (
Make_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, Index + 1)));
begin
-- Index for current entry body.
Index := Index + 1;
-- Compute total length of entry queues so far.
if No (Siz) then
Siz := Expr;
else
Siz :=
Make_Op_Add (Loc,
Left_Opnd => Siz,
Right_Opnd => Expr);
end if;
Cond :=
Make_Op_Le (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uE),
Right_Opnd => Siz);
-- Map entry queue indices in the range of the current family
-- into the current index, that designates the entry body.
if No (If_St) then
If_St :=
Make_Implicit_If_Statement (Typ,
Condition => Cond,
Then_Statements => Stats,
Elsif_Parts => New_List);
Ret := If_St;
else
Append (
Make_Elsif_Part (Loc,
Condition => Cond,
Then_Statements => Stats),
Elsif_Parts (If_St));
end if;
end Add_If_Clause;
------------------------------
-- Convert_Discriminant_Ref --
------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
B : Node_Id;
begin
if Is_Entity_Name (Bound)
and then Ekind (Entity (Bound)) = E_Discriminant
then
B :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
Make_Explicit_Dereference (Loc,
Make_Identifier (Loc, Name_uObject))),
Selector_Name => Make_Identifier (Loc, Chars (Bound)));
Set_Etype (B, Etype (Entity (Bound)));
else
B := New_Copy_Tree (Bound);
end if;
return B;
end Convert_Discriminant_Ref;
-- Start of processing for Build_Find_Body_Index
begin
Spec := Build_Find_Body_Index_Spec (Typ);
Ent := First_Entity (Typ);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
Has_F := True;
exit;
end if;
Next_Entity (Ent);
end loop;
if not Has_F then
-- If the protected type has no entry families, there is a one-one
-- correspondence between entry queue and entry body.
Ret :=
Make_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_uE));
else
-- Suppose entries e1, e2, ... have size l1, l2, ... we generate
-- the following:
--
-- if E <= l1 then return 1;
-- elsif E <= l1 + l2 then return 2;
-- ...
Index := 0;
Siz := Empty;
Ent := First_Entity (Typ);
Add_Object_Pointer (Decls, Typ, Loc);
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Add_If_Clause (Make_Integer_Literal (Loc, 1));
elsif Ekind (Ent) = E_Entry_Family then
E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ));
end if;
Next_Entity (Ent);
end loop;
if Index = 1 then
Decls := New_List;
Ret :=
Make_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1));
elsif Nkind (Ret) = N_If_Statement then
-- Ranges are in increasing order, so last one doesn't need a
-- guard.
declare
Nod : constant Node_Id := Last (Elsif_Parts (Ret));
begin
Remove (Nod);
Set_Else_Statements (Ret, Then_Statements (Nod));
end;
end if;
end if;
return
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
--------------------------------
-- Build_Find_Body_Index_Spec --
--------------------------------
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
-------------------------
-- Build_Master_Entity --
-------------------------
procedure Build_Master_Entity (E : Entity_Id) is
Loc : constant Source_Ptr := Sloc (E);
P : Node_Id;
Decl : Node_Id;
begin
-- Nothing to do if we already built a master entity for this scope
-- or if there is no task hierarchy.
if Has_Master_Entity (Scope (E))
or else Restrictions (No_Task_Hierarchy)
then
return;
end if;
-- Otherwise first build the master entity
-- _Master : constant Master_Id := Current_Master.all;
-- and insert it just before the current declaration
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
Expression =>
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
P := Parent (E);
Insert_Before (P, Decl);
Analyze (Decl);
Set_Has_Master_Entity (Scope (E));
-- Now mark the containing scope as a task master
while Nkind (P) /= N_Compilation_Unit loop
P := Parent (P);
-- If we fall off the top, we are at the outer level, and the
-- environment task is our effective master, so nothing to mark.
if Nkind (P) = N_Task_Body
or else Nkind (P) = N_Block_Statement
or else Nkind (P) = N_Subprogram_Body
then
Set_Is_Task_Master (P, True);
return;
elsif Nkind (Parent (P)) = N_Subunit then
P := Corresponding_Stub (Parent (P));
end if;
end loop;
end Build_Master_Entity;
---------------------------
-- Build_Protected_Entry --
---------------------------
function Build_Protected_Entry
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Decls : constant List_Id := New_List;
Edef : Entity_Id;
Espec : Node_Id;
Op_Stats : List_Id;
Ohandle : Node_Id;
Complete : Node_Id;
begin
Edef :=
Make_Defining_Identifier (Loc,
Chars => Chars (Protected_Body_Subprogram (Ent)));
Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc);
-- <object pointer declaration>
-- Add object pointer declaration. This is needed by the
-- discriminal and prival renamings, which should already
-- have been inserted into the declaration list.
Add_Object_Pointer (Op_Decls, Pid, Loc);
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
else
Complete :=
New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
end if;
Op_Stats := New_List (
Make_Block_Statement (Loc,
Declarations => Declarations (N),
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N)),
Make_Procedure_Call_Statement (Loc,
Name => Complete,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access))));
if Restrictions (No_Exception_Handlers) then
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Op_Stats));
else
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete :=
New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
else
Complete := New_Reference_To (
RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
end if;
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Op_Stats,
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => Complete,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access),
Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Loc)))))))));
end if;
end Build_Protected_Entry;
-----------------------------------------
-- Build_Protected_Entry_Specification --
-----------------------------------------
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
P : Entity_Id;
begin
P := Make_Defining_Identifier (Loc, Name_uP);
if Present (Ent_Id) then
Append_Elmt (P, Accept_Address (Ent_Id));
end if;
return Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => P,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
end Build_Protected_Entry_Specification;
--------------------------
-- Build_Protected_Spec --
--------------------------
function Build_Protected_Spec
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
Ident : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Formal : Entity_Id;
New_Plist : List_Id;
New_Param : Node_Id;
begin
New_Plist := New_List;
Formal := First_Formal (Ident);
while Present (Formal) loop
New_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
Parameter_Type =>
New_Reference_To (Etype (Formal), Loc));
if Unprotected then
Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
end if;
Append (New_Param, New_Plist);
Next_Formal (Formal);
end loop;
-- If the subprogram is a procedure and the context is not an access
-- to protected subprogram, the parameter is in-out. Otherwise it is
-- an in parameter.
Prepend_To (New_Plist,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
In_Present => True,
Out_Present =>
(Etype (Ident) = Standard_Void_Type
and then not Is_RTE (Obj_Type, RE_Address)),
Parameter_Type => New_Reference_To (Obj_Type, Loc)));
return New_Plist;
end Build_Protected_Spec;
---------------------------------------
-- Build_Protected_Sub_Specification --
---------------------------------------
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
Unprotected : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
Protnm : constant Name_Id := Chars (Prottyp);
Ident : Entity_Id;
Nam : Name_Id;
New_Plist : List_Id;
Append_Char : Character;
New_Spec : Node_Id;
begin
if Ekind
(Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
then
Decl := Unit_Declaration_Node (Corresponding_Spec (N));
else
Decl := N;
end if;
Ident := Defining_Unit_Name (Specification (Decl));
Nam := Chars (Ident);
New_Plist := Build_Protected_Spec
(Decl, Corresponding_Record_Type (Prottyp),
Unprotected, Ident);
if Unprotected then
Append_Char := 'N';
else
Append_Char := 'P';
end if;
if Nkind (Specification (Decl)) = N_Procedure_Specification then
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Protnm, Nam, Append_Char)),
Parameter_Specifications => New_Plist);
else
New_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Protnm, Nam, Append_Char)),
Parameter_Specifications => New_Plist,
Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec));
return New_Spec;
end if;
end Build_Protected_Sub_Specification;
-------------------------------------
-- Build_Protected_Subprogram_Body --
-------------------------------------
function Build_Protected_Subprogram_Body
(N : Node_Id;
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;
Unlock_Name : Node_Id;
Unlock_Stmt : Node_Id;
Service_Name : Node_Id;
Service_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;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
-----------------------
-- 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 a
-- raise statement of any kind in the sequence of statements N
---------------------
-- 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 := N;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
-- Indicate whether N is a subprogram call or a raise statement
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Procedure_Call_Statement
or else Nkind (N) = N_Function_Call
or else Nkind (N) = N_Raise_Statement
or else Nkind (N) = N_Raise_Constraint_Error
or else Nkind (N) = N_Raise_Program_Error
or else Nkind (N) = N_Raise_Storage_Error;
end Is_Call_Or_Raise;
-- Start of processing for Has_Side_Effect
begin
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
-- 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;
-- Start of processing for Build_Protected_Subprogram_Body
begin
Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec :=
Build_Protected_Sub_Specification (N,
Pid, Unprotected => False);
-- Build a list of the formal parameters of the protected
-- version of the subprogram to use as the actual parameters
-- of the unprotected version.
Uactuals := New_List;
Pformal := First (Parameter_Specifications (P_Op_Spec));
while Present (Pformal) loop
Append (
Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))),
Uactuals);
Next (Pformal);
end loop;
-- Make a call to the unprotected version of the subprogram
-- built above for use by the protected version built below.
if Nkind (Op_Spec) = N_Function_Specification then
if Exc_Safe then
R := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt := Make_Return_Statement (Loc,
Expression => New_Reference_To (R, Loc));
else
Unprot_Call := Make_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
else
Unprot_Call := Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
end if;
-- Wrap call in block that will be covered by an at_end handler.
if not Exc_Safe then
Unprot_Call := Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
end if;
-- Make the protected subprogram body. This locks the protected
-- object and calls the unprotected version of the subprogram.
-- If the protected object is controlled (i.e it has entries or
-- needs finalization for interrupt handling), call Lock_Entries,
-- except if the protected object follows the Ravenscar profile, in
-- which case call Lock_Entry, otherwise call the simplified version,
-- Lock.
if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid)
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
else
Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
end if;
else
Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
Unlock_Name := New_Reference_To (RTE (RE_Unlock), Loc);
Service_Name := Empty;
end if;
Object_Parm :=
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
Lock_Stmt := Make_Procedure_Call_Statement (Loc,
Name => Lock_Name,
Parameter_Associations => New_List (Object_Parm));
if Abort_Allowed then
Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List),
Lock_Stmt);
else
Stmts := New_List (Lock_Stmt);
end if;
if not Exc_Safe then
Append (Unprot_Call, Stmts);
else
if Nkind (Op_Spec) = N_Function_Specification then
Pre_Stmts := Stmts;
Stmts := Empty_List;
else
Append (Unprot_Call, Stmts);
end if;
if Service_Name /= Empty then
Service_Stmt := Make_Procedure_Call_Statement (Loc,
Name => Service_Name,
Parameter_Associations =>
New_List (New_Copy_Tree (Object_Parm)));
Append (Service_Stmt, Stmts);
end if;
Unlock_Stmt :=
Make_Procedure_Call_Statement (Loc,
Name => Unlock_Name,
Parameter_Associations => New_List (
New_Copy_Tree (Object_Parm)));
Append (Unlock_Stmt, Stmts);
if Abort_Allowed then
Append (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => Empty_List),
Stmts);
end if;
if Nkind (Op_Spec) = N_Function_Specification then
Append (Return_Stmt, Stmts);
Append (Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)), Pre_Stmts);
Stmts := Pre_Stmts;
end if;
end if;
Sub_Body :=
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => P_Op_Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
if not Exc_Safe then
Set_Is_Protected_Subprogram_Body (Sub_Body);
end if;
return Sub_Body;
end Build_Protected_Subprogram_Body;
-------------------------------------
-- Build_Protected_Subprogram_Call --
-------------------------------------
procedure Build_Protected_Subprogram_Call
(N : Node_Id;
Name : Node_Id;
Rec : Node_Id;
External : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (N);
Sub : constant Entity_Id := Entity (Name);
New_Sub : Node_Id;
Params : List_Id;
begin
if External then
New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
else
New_Sub :=
New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
end if;
if Present (Parameter_Associations (N)) then
Params := New_Copy_List_Tree (Parameter_Associations (N));
else
Params := New_List;
end if;
Prepend (Rec, Params);
if Ekind (Sub) = E_Procedure then
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Sub,
Parameter_Associations => Params));
else
pragma Assert (Ekind (Sub) = E_Function);
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Sub,
Parameter_Associations => Params));
end if;
if External
and then Nkind (Rec) = N_Unchecked_Type_Conversion
and then Is_Entity_Name (Expression (Rec))
and then Is_Shared_Passive (Entity (Expression (Rec)))
then
Add_Shared_Var_Lock_Procs (N);
end if;
end Build_Protected_Subprogram_Call;
-------------------------
-- Build_Selected_Name --
-------------------------
function Build_Selected_Name
(Prefix, Selector : Name_Id;
Append_Char : Character := ' ') return Name_Id
is
Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
Select_Len : Natural;
begin
Get_Name_String (Selector);
Select_Len := Name_Len;
Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
Get_Name_String (Prefix);
-- If scope is anonymous type, discard suffix to recover name of
-- single protected object. Otherwise use protected type name.
if Name_Buffer (Name_Len) = 'T' then
Name_Len := Name_Len - 1;
end if;
Name_Buffer (Name_Len + 1) := 'P';
Name_Buffer (Name_Len + 2) := 'T';
Name_Buffer (Name_Len + 3) := '_';
Name_Buffer (Name_Len + 4) := '_';
Name_Len := Name_Len + 4;
for J in 1 .. Select_Len loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Select_Buffer (J);
end loop;
if Append_Char /= ' ' then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Append_Char;
end if;
return Name_Find;
end Build_Selected_Name;
-----------------------------
-- Build_Simple_Entry_Call --
-----------------------------
-- A task entry call is converted to a call to Call_Simple
-- declare
-- P : parms := (parm, parm, parm);
-- begin
-- Call_Simple (acceptor-task, entry-index, P'Address);
-- parm := P.param;
-- parm := P.param;
-- ...
-- end;
-- Here Pnn is an aggregate of the type constructed for the entry to hold
-- the parameters, and the constructed aggregate value contains either the
-- parameters or, in the case of non-elementary types, references to these
-- parameters. Then the address of this aggregate is passed to the runtime
-- routine, along with the task id value and the task entry index value.
-- Pnn is only required if parameters are present.
-- The assignments after the call are present only in the case of in-out
-- or out parameters for elementary types, and are used to assign back the
-- resulting values of such parameters.
-- Note: the reason that we insert a block here is that in the context
-- of selects, conditional entry calls etc. the entry call statement
-- appears on its own, not as an element of a list.
-- A protected entry call is converted to a Protected_Entry_Call:
-- declare
-- P : E1_Params := (param, param, param);
-- Pnn : Boolean;
-- Bnn : Communications_Block;
-- declare
-- P : E1_Params := (param, param, param);
-- Bnn : Communications_Block;
-- begin
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call;
-- Block => Bnn);
-- parm := P.param;
-- parm := P.param;
-- ...
-- end;
procedure Build_Simple_Entry_Call
(N : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id)
is
begin
Expand_Call (N);
-- Convert entry call to Call_Simple call
declare
Loc : constant Source_Ptr := Sloc (N);
Parms : constant List_Id := Parameter_Associations (N);
Stats : constant List_Id := New_List;
Pdecl : Node_Id;
Xdecl : Node_Id;
Decls : List_Id;
Conctyp : Node_Id;
Ent : Entity_Id;
Ent_Acc : Entity_Id;
P : Entity_Id;
X : Entity_Id;
Plist : List_Id;
Parm1 : Node_Id;
Parm2 : Node_Id;
Parm3 : Node_Id;
Call : Node_Id;
Actual : Node_Id;
Formal : Node_Id;
N_Node : Node_Id;
N_Var : Node_Id;
Comm_Name : Entity_Id;
begin
-- Simple entry and entry family cases merge here
Ent := Entity (Ename);
Ent_Acc := Entry_Parameters_Type (Ent);
Conctyp := Etype (Concval);
-- If prefix is an access type, dereference to obtain the task type
if Is_Access_Type (Conctyp) then
Conctyp := Designated_Type (Conctyp);
end if;
-- Special case for protected subprogram calls.
if Is_Protected_Type (Conctyp)
and then Is_Subprogram (Entity (Ename))
then
Build_Protected_Subprogram_Call
(N, Ename, Convert_Concurrent (Concval, Conctyp));
Analyze (N);
return;
end if;
-- First parameter is the Task_Id value from the task value or the
-- Object from the protected object value, obtained by selecting
-- the _Task_Id or _Object from the result of doing an unchecked
-- conversion to convert the value to the corresponding record type.
Parm1 := Concurrent_Ref (Concval);
-- Second parameter is the entry index, computed by the routine
-- provided for this purpose. The value of this expression is
-- assigned to an intermediate variable to assure that any entry
-- family index expressions are evaluated before the entry
-- parameters.
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else not Is_Protected_Type (Conctyp)
or else Number_Entries (Conctyp) > 1
then
X := Make_Defining_Identifier (Loc, Name_uX);
Xdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => X,
Object_Definition =>
New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
Expression => Actual_Index_Expression (
Loc, Entity (Ename), Index, Concval));
Decls := New_List (Xdecl);
Parm2 := New_Reference_To (X, Loc);
else
Xdecl := Empty;
Decls := New_List;
Parm2 := Empty;
end if;
-- The third parameter is the packaged parameters. If there are
-- none, then it is just the null address, since nothing is passed
if No (Parms) then
Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
P := Empty;
-- Case of parameters present, where third argument is the address
-- of a packaged record containing the required parameter values.
else
-- First build a list of parameter values, which are
-- references to objects of the parameter types.
Plist := New_List;
Actual := First_Actual (N);
Formal := First_Formal (Ent);
while Present (Actual) loop
-- If it is a by_copy_type, copy it to a new variable. The
-- packaged record has a field that points to this variable.
if Is_By_Copy_Type (Etype (Actual)) then
N_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('J')),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (Etype (Formal), Loc));
-- We have to make an assignment statement separate for
-- the case of limited type. We can not assign it unless
-- the Assignment_OK flag is set first.
if Ekind (Formal) /= E_Out_Parameter then
N_Var :=
New_Reference_To (Defining_Identifier (N_Node), Loc);
Set_Assignment_OK (N_Var);
Append_To (Stats,
Make_Assignment_Statement (Loc,
Name => N_Var,
Expression => Relocate_Node (Actual)));
end if;
Append (N_Node, Decls);
Append_To (Plist,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
New_Reference_To (Defining_Identifier (N_Node), Loc)));
else
Append_To (Plist,
Make_Reference (Loc, Prefix => Relocate_Node (Actual)));
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
-- Now build the declaration of parameters initialized with the
-- aggregate containing this constructed parameter list.
P := Make_Defining_Identifier (Loc, Name_uP);
Pdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => P,
Object_Definition =>
New_Reference_To (Designated_Type (Ent_Acc), Loc),
Expression =>
Make_Aggregate (Loc, Expressions => Plist));
Parm3 :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Reference_To (P, Loc));
Append (Pdecl, Decls);
end if;
-- Now we can create the call, case of protected type
if Is_Protected_Type (Conctyp) then
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
then
-- Change the type of the index declaration
Set_Object_Definition (Xdecl,
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
-- Some additional declarations for protected entry calls
if No (Decls) then
Decls := New_List;
end if;
-- Bnn : Communications_Block;
Comm_Name :=
Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Comm_Name,
Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- 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);
Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
Parm2,
Parm3,
New_Reference_To (RTE (RE_Simple_Call), Loc),
New_Occurrence_Of (Comm_Name, Loc)));
else
-- Protected_Single_Entry_Call (
-- Object => po._object'Access,
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call);
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
Parm3,
New_Reference_To (RTE (RE_Simple_Call), Loc)));
end if;
-- Case of task type
else
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
Parameter_Associations => New_List (Parm1, Parm2, Parm3));
end if;
Append_To (Stats, Call);
-- If there are out or in/out parameters by copy
-- add assignment statements for the result values.
if Present (Parms) then
Actual := First_Actual (N);
Formal := First_Formal (Ent);
Set_Assignment_OK (Actual);
while Present (Actual) loop
if Is_By_Copy_Type (Etype (Actual))
and then Ekind (Formal) /= E_In_Parameter
then
N_Node :=
Make_Assignment_Statement (Loc,
Name => New_Copy (Actual),
Expression =>
Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc,
Prefix => New_Reference_To (P, Loc),
Selector_Name =>
Make_Identifier (Loc, Chars (Formal)))));
-- In all cases (including limited private types) we
-- want the assignment to be valid.
Set_Assignment_OK (Name (N_Node));
-- If the call is the triggering alternative in an
-- asynchronous select, or the entry_call alternative
-- of a conditional entry call, the assignments for in-out
-- parameters are incorporated into the statement list
-- that follows, so that there are executed only if the
-- entry call succeeds.
if (Nkind (Parent (N)) = N_Triggering_Alternative
and then N = Triggering_Statement (Parent (N)))
or else
(Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N)))
then
if No (Statements (Parent (N))) then
Set_Statements (Parent (N), New_List);
end if;
Prepend (N_Node, Statements (Parent (N)));
else
Insert_After (Call, N_Node);
end if;
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
end if;
-- Finally, create block and analyze it
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats)));
Analyze (N);
end;
end Build_Simple_Entry_Call;
--------------------------------
-- Build_Task_Activation_Call --
--------------------------------
procedure Build_Task_Activation_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Chain : Entity_Id;
Call : Node_Id;
Name : Node_Id;
P : Node_Id;
begin
-- Get the activation chain entity. Except in the case of a package
-- body, this is in the node that w as passed. For a package body, we
-- have to find the corresponding package declaration node.
if Nkind (N) = N_Package_Body then
P := Corresponding_Spec (N);
loop
P := Parent (P);
exit when Nkind (P) = N_Package_Declaration;
end loop;
Chain := Activation_Chain_Entity (P);
else
Chain := Activation_Chain_Entity (N);
end if;
if Present (Chain) then
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
else
Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
end if;
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)));
if Nkind (N) = N_Package_Declaration then
if Present (Corresponding_Body (N)) then
null;
elsif Present (Private_Declarations (Specification (N))) then
Append (Call, Private_Declarations (Specification (N)));
else
Append (Call, Visible_Declarations (Specification (N)));
end if;
else
if Present (Handled_Statement_Sequence (N)) then
-- The call goes at the start of the statement sequence, but
-- after the start of exception range label if one is present.
declare
Stm : Node_Id;
begin
Stm := First (Statements (Handled_Statement_Sequence (N)));
if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
Next (Stm);
end if;
Insert_Before (Stm, Call);
end;
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call)));
end if;
end if;
Analyze (Call);
Check_Task_Activation (N);
end if;
end Build_Task_Activation_Call;
-------------------------------
-- Build_Task_Allocate_Block --
-------------------------------
procedure Build_Task_Allocate_Block
(Actions : List_Id;
N : Node_Id;
Args : List_Id)
is
T : constant Entity_Id := Entity (Expression (N));
Init : constant Entity_Id := Base_Init_Proc (T);
Loc : constant Source_Ptr := Sloc (N);
Chain : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_uChain);
Blkent : Entity_Id;
Block : Node_Id;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => New_List (
-- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
-- Init (Args);
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args),
-- Activate_Tasks (_Chain);
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Chain, Loc),
Attribute_Name => Name_Unchecked_Access))))),
Has_Created_Identifier => True,
Is_Task_Allocation_Block => True);
Append_To (Actions,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Block));
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
end Build_Task_Allocate_Block;
-----------------------------------------------
-- Build_Task_Allocate_Block_With_Init_Stmts --
-----------------------------------------------
procedure Build_Task_Allocate_Block_With_Init_Stmts
(Actions : List_Id;
N : Node_Id;
Init_Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Chain : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_uChain);
Blkent : Entity_Id;
Block : Node_Id;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Append_To (Init_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Chain, Loc),
Attribute_Name => Name_Unchecked_Access))));
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => New_List (
-- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
Has_Created_Identifier => True,
Is_Task_Allocation_Block => True);
Append_To (Actions,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Block));
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
end Build_Task_Allocate_Block_With_Init_Stmts;
-----------------------------------
-- Build_Task_Proc_Specification --
-----------------------------------
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (T);
Nam : constant Name_Id := Chars (T);
Tdec : constant Node_Id := Declaration_Node (T);
Ent : Entity_Id;
begin
Ent :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Nam, 'B'));
Set_Is_Internal (Ent);
-- Associate the procedure with the task, if this is the declaration
-- (and not the body) of the procedure.
if No (Task_Body_Procedure (Tdec)) then
Set_Task_Body_Procedure (Tdec, Ent);
end if;
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Ent,
Parameter_Specifications =>
New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Reference_To
(Corresponding_Record_Type (T), Loc)))));
end Build_Task_Proc_Specification;
---------------------------------------
-- Build_Unprotected_Subprogram_Body --
---------------------------------------
function Build_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
N_Op_Spec : Node_Id;
Op_Decls : List_Id;
begin
-- Make an unprotected version of the subprogram for use
-- within the same object, with a new name and an additional
-- parameter representing the object.
Op_Decls := Declarations (N);
N_Op_Spec :=
Build_Protected_Sub_Specification
(N, Pid, Unprotected => True);
return
Make_Subprogram_Body (Loc,
Specification => N_Op_Spec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N));
end Build_Unprotected_Subprogram_Body;
----------------------------
-- Collect_Entry_Families --
----------------------------
procedure Collect_Entry_Families
(Loc : Source_Ptr;
Cdecls : List_Id;
Current_Node : in out Node_Id;
Conctyp : Entity_Id)
is
Efam : Entity_Id;
Efam_Decl : Node_Id;
Efam_Type : Entity_Id;
begin
Efam := First_Entity (Conctyp);
while Present (Efam) loop
if Ekind (Efam) = E_Entry_Family then
Efam_Type :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F'));
Efam_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Efam_Type,
Type_Definition =>
Make_Unconstrained_Array_Definition (Loc,
Subtype_Marks => (New_List (
New_Occurrence_Of (
Base_Type
(Etype (Discrete_Subtype_Definition
(Parent (Efam)))), Loc))),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (Standard_Character, Loc))));
Insert_After (Current_Node, Efam_Decl);
Current_Node := Efam_Decl;
Analyze (Efam_Decl);
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Efam)),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Efam_Type, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
New_Occurrence_Of
(Etype (Discrete_Subtype_Definition
(Parent (Efam))), Loc)))))));
end if;
Next_Entity (Efam);
end loop;
end Collect_Entry_Families;
--------------------
-- Concurrent_Ref --
--------------------
-- The expression returned for a reference to a concurrent
-- object has the form:
-- taskV!(name)._Task_Id
-- for a task, and
-- objectV!(name)._Object
-- for a protected object.
-- For the case of an access to a concurrent object,
-- there is an extra explicit dereference:
-- taskV!(name.all)._Task_Id
-- objectV!(name.all)._Object
-- here taskV and objectV are the types for the associated records, which
-- contain the required _Task_Id and _Object fields for tasks and
-- protected objects, respectively.
-- For the case of a task type name, the expression is
-- Self;
-- i.e. a call to the Self function which returns precisely this Task_Id
-- For the case of a protected type name, the expression is
-- objectR
-- which is a renaming of the _object field of the current object
-- object record, passed into protected operations as a parameter.
function Concurrent_Ref (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
Ntyp : constant Entity_Id := Etype (N);
Dtyp : Entity_Id;
Sel : Name_Id;
function Is_Current_Task (T : Entity_Id) return Boolean;
-- Check whether the reference is to the immediately enclosing task
-- type, or to an outer one (rare but legal).
---------------------
-- Is_Current_Task --
---------------------
function Is_Current_Task (T : Entity_Id) return Boolean is
Scop : Entity_Id;
begin
Scop := Current_Scope;
while Present (Scop)
and then Scop /= Standard_Standard
loop
if Scop = T then
return True;
elsif Is_Task_Type (Scop) then
return False;
-- If this is a procedure nested within the task type, we must
-- assume that it can be called from an inner task, and therefore
-- cannot treat it as a local reference.
elsif Is_Overloadable (Scop)
and then In_Open_Scopes (T)
then
return False;
else
Scop := Scope (Scop);
end if;
end loop;
-- We know that we are within the task body, so should have
-- found it in scope.
raise Program_Error;
end Is_Current_Task;
-- Start of processing for Concurrent_Ref
begin
if Is_Access_Type (Ntyp) then
Dtyp := Designated_Type (Ntyp);
if Is_Protected_Type (Dtyp) then
Sel := Name_uObject;
else
Sel := Name_uTask_Id;
end if;
return
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
Make_Explicit_Dereference (Loc, N)),
Selector_Name => Make_Identifier (Loc, Sel));
elsif Is_Entity_Name (N)
and then Is_Concurrent_Type (Entity (N))
then
if Is_Task_Type (Entity (N)) then
if Is_Current_Task (Entity (N)) then
return
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Self), Loc));
else
declare
Decl : Node_Id;
T_Self : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
T_Body : constant Node_Id
:= Parent (Corresponding_Body (Parent (Entity (N))));
begin
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => T_Self,
Object_Definition =>
New_Occurrence_Of (RTE (RO_ST_Task_ID), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Self), Loc)));
Prepend (Decl, Declarations (T_Body));
Analyze (Decl);
Set_Scope (T_Self, Entity (N));
return New_Occurrence_Of (T_Self, Loc);
end;
end if;
else
pragma Assert (Is_Protected_Type (Entity (N)));
return
New_Reference_To (
Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))),
Loc);
end if;
else
pragma Assert (Is_Concurrent_Type (Ntyp));
if Is_Protected_Type (Ntyp) then
Sel := Name_uObject;
else
Sel := Name_uTask_Id;
end if;
return
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
New_Copy_Tree (N)),
Selector_Name => Make_Identifier (Loc, Sel));
end if;
end Concurrent_Ref;
------------------------
-- Convert_Concurrent --
------------------------
function Convert_Concurrent
(N : Node_Id;
Typ : Entity_Id) return Node_Id
is
begin
if not Is_Concurrent_Type (Typ) then
return N;
else
return
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
New_Copy_Tree (N));
end if;
end Convert_Concurrent;
----------------------------
-- Entry_Index_Expression --
----------------------------
function Entry_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Ttyp : Entity_Id) return Node_Id
is
Expr : Node_Id;
Num : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Prev : Entity_Id;
S : Node_Id;
begin
-- The queues of entries and entry families appear in textual
-- order in the associated record. The entry index is computed as
-- the sum of the number of queues for all entries that precede the
-- designated one, to which is added the index expression, if this
-- expression denotes a member of a family.
-- The following is a place holder for the count of simple entries.
Num := Make_Integer_Literal (Sloc, 1);
-- We construct an expression which is a series of addition
-- operations. The first operand is the number of single entries that
-- precede this one, the second operand is the index value relative
-- to the start of the referenced family, and the remaining operands
-- are the lengths of the entry families that precede this entry, i.e.
-- the constructed expression is:
-- number_simple_entries +
-- (s'pos (index-value) - s'pos (family'first)) + 1 +
-- family'length + ...
-- where index-value is the given index value, and s is the index
-- subtype (we have to use pos because the subtype might be an
-- enumeration type preventing direct subtraction).
-- Note that the task entry array is one-indexed.
-- The upper bound of the entry family may be a discriminant, so we
-- retrieve the lower bound explicitly to compute offset, rather than
-- using the index subtype which may mention a discriminant.
if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Num,
Right_Opnd =>
Family_Offset (
Sloc,
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S),
Ttyp));
else
Expr := Num;
end if;
-- Now add lengths of preceding entries and entry families.
Prev := First_Entity (Ttyp);
while Chars (Prev) /= Chars (Ent)
or else (Ekind (Prev) /= Ekind (Ent))
or else not Sem_Ch6.Type_Conformant (Ent, Prev)
loop
if Ekind (Prev) = E_Entry then
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
S :=
Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
Lo := Type_Low_Bound (S);
Hi := Type_High_Bound (S);
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Expr,
Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp));
-- Other components are anonymous types to be ignored.
else
null;
end if;
Next_Entity (Prev);
end loop;
return Expr;
end Entry_Index_Expression;
---------------------------
-- Establish_Task_Master --
---------------------------
procedure Establish_Task_Master (N : Node_Id) is
Call : Node_Id;
begin
if Restrictions (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
Prepend_To (Declarations (N), Call);
Analyze (Call);
end if;
end Establish_Task_Master;
--------------------------------
-- Expand_Accept_Declarations --
--------------------------------
-- Part of the expansion of an accept statement involves the creation of
-- a declaration that can be referenced from the statement sequence of
-- the accept:
-- Ann : Address;
-- This declaration is inserted immediately before the accept statement
-- and it is important that it be inserted before the statements of the
-- statement sequence are analyzed. Thus it would be too late to create
-- this declaration in the Expand_N_Accept_Statement routine, which is
-- why there is a separate procedure to be called directly from Sem_Ch9.
-- Ann is used to hold the address of the record containing the parameters
-- (see Expand_N_Entry_Call for more details on how this record is built).
-- References to the parameters do an unchecked conversion of this address
-- to a pointer to the required record type, and then access the field that
-- holds the value of the required parameter. The entity for the address
-- variable is held as the top stack element (i.e. the last element) of the
-- Accept_Address stack in the corresponding entry entity, and this element
-- must be set in place before the statements are processed.
-- The above description applies to the case of a stand alone accept
-- statement, i.e. one not appearing as part of a select alternative.
-- For the case of an accept that appears as part of a select alternative
-- of a selective accept, we must still create the declaration right away,
-- since Ann is needed immediately, but there is an important difference:
-- The declaration is inserted before the selective accept, not before
-- the accept statement (which is not part of a list anyway, and so would
-- not accommodate inserted declarations)
-- We only need one address variable for the entire selective accept. So
-- the Ann declaration is created only for the first accept alternative,
-- and subsequent accept alternatives reference the same Ann variable.
-- We can distinguish the two cases by seeing whether the accept statement
-- is part of a list. If not, then it must be in an accept alternative.
-- To expand the requeue statement, a label is provided at the end of
-- the accept statement or alternative of which it is a part, so that
-- the statement can be skipped after the requeue is complete.
-- This label is created here rather than during the expansion of the
-- accept statement, because it will be needed by any requeue
-- statements within the accept, which are expanded before the
-- accept.
procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ann : Entity_Id := Empty;
Adecl : Node_Id;
Lab_Id : Node_Id;
Lab : Node_Id;
Ldecl : Node_Id;
Ldecl2 : Node_Id;
begin
if Expander_Active then
-- If we have no handled statement sequence, then build a dummy
-- sequence consisting of a null statement. This is only done if
-- pragma FIFO_Within_Priorities is specified. The issue here is
-- that even a null accept body has an effect on the called task
-- in terms of its position in the queue, so we cannot optimize
-- the context switch away. However, if FIFO_Within_Priorities
-- is not active, the optimization is legitimate, since we can
-- say that our dispatching policy (i.e. the default dispatching
-- policy) reorders the queue to be the same as just before the
-- call. In the absence of a specified dispatching policy, we are
-- allowed to modify queue orders for a given priority at will!
if Opt.Task_Dispatching_Policy = 'F' and then
not Present (Handled_Statement_Sequence (N))
then
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
end if;
-- Create and declare two labels to be placed at the end of the
-- accept statement. The first label is used to allow requeues to
-- skip the remainder of entry processing. The second label is
-- used to skip the remainder of entry processing if the rendezvous
-- completes in the middle of the accept body.
if Present (Handled_Statement_Sequence (N)) then
Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
Set_Entity (Lab_Id,
Make_Defining_Identifier (Loc, Chars (Lab_Id)));
Lab := Make_Label (Loc, Lab_Id);
Ldecl :=
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Lab_Id),
Label_Construct => Lab);
Append (Lab, Statements (Handled_Statement_Sequence (N)));
Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
Set_Entity (Lab_Id,
Make_Defining_Identifier (Loc, Chars (Lab_Id)));
Lab := Make_Label (Loc, Lab_Id);
Ldecl2 :=
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Lab_Id),
Label_Construct => Lab);
Append (Lab, Statements (Handled_Statement_Sequence (N)));
else
Ldecl := Empty;
Ldecl2 := Empty;
end if;
-- Case of stand alone accept statement
if Is_List_Member (N) then
if Present (Handled_Statement_Sequence (N)) then
Ann :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
Adecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ann,
Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc));
Insert_Before (N, Adecl);
Analyze (Adecl);
Insert_Before (N, Ldecl);
Analyze (Ldecl);
Insert_Before (N, Ldecl2);
Analyze (Ldecl2);
end if;
-- Case of accept statement which is in an accept alternative
else
declare
Acc_Alt : constant Node_Id := Parent (N);
Sel_Acc : constant Node_Id := Parent (Acc_Alt);
Alt : Node_Id;
begin
pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
-- ??? Consider a single label for select statements.
if Present (Handled_Statement_Sequence (N)) then
Prepend (Ldecl2,
Statements (Handled_Statement_Sequence (N)));
Analyze (Ldecl2);
Prepend (Ldecl,
Statements (Handled_Statement_Sequence (N)));
Analyze (Ldecl);
end if;
-- Find first accept alternative of the selective accept. A
-- valid selective accept must have at least one accept in it.
Alt := First (Select_Alternatives (Sel_Acc));
while Nkind (Alt) /= N_Accept_Alternative loop
Next (Alt);
end loop;
-- If we are the first accept statement, then we have to
-- create the Ann variable, as for the stand alone case,
-- except that it is inserted before the selective accept.
-- Similarly, a label for requeue expansion must be
-- declared.
if N = Accept_Statement (Alt) then
Ann :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Adecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ann,
Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc));
Insert_Before (Sel_Acc, Adecl);
Analyze (Adecl);
-- If we are not the first accept statement, then find the
-- Ann variable allocated by the first accept and use it.
else
Ann :=
Node (Last_Elmt (Accept_Address
(Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
end if;
end;
end if;
-- Merge here with Ann either created or referenced, and Adecl
-- pointing to the corresponding declaration. Remaining processing
-- is the same for the two cases.
if Present (Ann) then
Append_Elmt (Ann, Accept_Address (Ent));
Set_Needs_Debug_Info (Ann);
end if;
-- Create renaming declarations for the entry formals. Each
-- reference to a formal becomes a dereference of a component
-- of the parameter block, whose address is held in Ann.
-- These declarations are eventually inserted into the accept
-- block, and analyzed there so that they have the proper scope
-- for gdb and do not conflict with other declarations.
if Present (Parameter_Specifications (N))
and then Present (Handled_Statement_Sequence (N))
then
declare
Formal : Entity_Id;
New_F : Entity_Id;
Comp : Entity_Id;
Decl : Node_Id;
begin
New_Scope (Ent);
Formal := First_Formal (Ent);
while Present (Formal) loop
Comp := Entry_Component (Formal);
New_F :=
Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
Set_Etype (New_F, Etype (Formal));
Set_Scope (New_F, Ent);
Set_Needs_Debug_Info (New_F); -- That's the whole point.
if Ekind (Formal) = E_In_Parameter then
Set_Ekind (New_F, E_Constant);
else
Set_Ekind (New_F, E_Variable);
Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
end if;
Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => New_F,
Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
Name =>
Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Entry_Parameters_Type (Ent),
New_Reference_To (Ann, Loc)),
Selector_Name =>
New_Reference_To (Comp, Loc))));
if No (Declarations (N)) then
Set_Declarations (N, New_List);
end if;
Append (Decl, Declarations (N));
Set_Renamed_Object (Formal, New_F);
Next_Formal (Formal);
end loop;
End_Scope;
end;
end if;
end if;
end Expand_Accept_Declarations;
---------------------------------------------
-- Expand_Access_Protected_Subprogram_Type --
---------------------------------------------
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Comps : List_Id;
T : constant Entity_Id := Defining_Identifier (N);
D_T : constant Entity_Id := Designated_Type (T);
D_T2 : constant Entity_Id := Make_Defining_Identifier
(Loc, New_Internal_Name ('D'));
E_T : constant Entity_Id := Make_Defining_Identifier
(Loc, New_Internal_Name ('E'));
P_List : constant List_Id := Build_Protected_Spec
(N, RTE (RE_Address), False, D_T);
Decl1 : Node_Id;
Decl2 : Node_Id;
Def1 : Node_Id;
begin
-- Create access to protected subprogram with full signature.
if Nkind (Type_Definition (N)) = N_Access_Function_Definition then
Def1 :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications => P_List,
Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N))));
else
Def1 :=
Make_Access_Procedure_Definition (Loc,
Parameter_Specifications => P_List);
end if;
Decl1 :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => D_T2,
Type_Definition => Def1);
Insert_After (N, Decl1);
-- Create Equivalent_Type, a record with two components for an
-- an access to object an an access to subprogram.
Comps := New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Address), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
Decl2 :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => E_T,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Comps)));
Insert_After (Decl1, Decl2);
Set_Equivalent_Type (T, E_T);
end Expand_Access_Protected_Subprogram_Type;
--------------------------
-- Expand_Entry_Barrier --
--------------------------
procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Prot : constant Entity_Id := Scope (Ent);
Spec_Decl : constant Node_Id := Parent (Prot);
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
Func : Node_Id;
B_F : Node_Id;
Body_Decl : Node_Id;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("entry barrier", N);
return;
end if;
-- The body of the entry barrier must be analyzed in the context of
-- the protected object, but its scope is external to it, just as any
-- other unprotected version of a protected operation. The specification
-- has been produced when the protected type declaration was elaborated.
-- We build the body, insert it in the enclosing scope, but analyze it
-- in the current context. A more uniform approach would be to treat a
-- barrier just as a protected function, and discard the protected
-- 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);
Body_Decl := Parent (Corresponding_Body (Spec_Decl));
if Nkind (Parent (Body_Decl)) = N_Subunit then
Body_Decl := Corresponding_Stub (Parent (Body_Decl));
end if;
Insert_Before_And_Analyze (Body_Decl, B_F);
Update_Prival_Subtypes (B_F);
Set_Privals (Spec_Decl, N, Loc);
Set_Discriminals (Spec_Decl);
Set_Scope (Func, Scope (Prot));
else
Analyze (Cond);
end if;
-- The Ravenscar profile restricts barriers to simple variables
-- declared within the protected object. We also allow Boolean
-- constants, since these appear in several published examples
-- and are also allowed by the Aonix compiler.
-- Note that after analysis variables in this context will be
-- replaced by the corresponding prival, that is to say a renaming
-- of a selected component of the form _Object.Var. If expansion is
-- disabled, as within a generic, we check that the entity appears in
-- the current scope.
if Is_Entity_Name (Cond) then
if Entity (Cond) = Standard_False
or else
Entity (Cond) = Standard_True
then
return;
elsif not Expander_Active
and then Scope (Entity (Cond)) = Current_Scope
then
return;
-- Check for case of _object.all.field (note that the explicit
-- dereference gets inserted by analyze/expand of _object.field)
elsif Present (Renamed_Object (Entity (Cond)))
and then
Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
and then
Chars
(Prefix
(Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
then
return;
end if;
end if;
-- It is not a boolean variable or literal, so check the restriction
Check_Restriction (Boolean_Entry_Barriers, Cond);
end Expand_Entry_Barrier;
------------------------------------
-- Expand_Entry_Body_Declarations --
------------------------------------
procedure Expand_Entry_Body_Declarations (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Index_Spec : Node_Id;
begin
if Expander_Active then
-- Expand entry bodies corresponding to entry families
-- by assigning a placeholder for the constant that will
-- be used to expand references to the entry index parameter.
Index_Spec :=
Entry_Index_Specification (Entry_Body_Formal_Part (N));
if Present (Index_Spec) then
Set_Entry_Index_Constant (
Defining_Identifier (Index_Spec),
Make_Defining_Identifier (Loc, New_Internal_Name ('J')));
end if;
end if;
end Expand_Entry_Body_Declarations;
------------------------------
-- Expand_N_Abort_Statement --
------------------------------
-- Expand abort T1, T2, .. Tn; into:
-- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
procedure Expand_N_Abort_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Tlist : constant List_Id := Names (N);
Count : Nat;
Aggr : Node_Id;
Tasknm : Node_Id;
begin
Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
Count := 0;
Tasknm := First (Tlist);
while Present (Tasknm) loop
Count := Count + 1;
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Count)),
Expression => Concurrent_Ref (Tasknm)));
Next (Tasknm);
end loop;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc),
Parameter_Associations => New_List (
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc),
Expression => Aggr))));
Analyze (N);
end Expand_N_Abort_Statement;
-------------------------------
-- Expand_N_Accept_Statement --
-------------------------------
-- This procedure handles expansion of accept statements that stand
-- alone, i.e. they are not part of an accept alternative. The expansion
-- of accept statement in accept alternatives is handled by the routines
-- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
-- following description applies only to stand alone accept statements.
-- If there is no handled statement sequence, or only null statements,
-- then this is called a trivial accept, and the expansion is:
-- Accept_Trivial (entry-index)
-- If there is a handled statement sequence, then the expansion is:
-- Ann : Address;
-- {Lnn : Label}
-- begin
-- begin
-- Accept_Call (entry-index, Ann);
-- Renaming_Declarations for formals
-- <statement sequence from N_Accept_Statement node>
-- Complete_Rendezvous;
-- <<Lnn>>
--
-- exception
-- when ... =>
-- <exception handler from N_Accept_Statement node>
-- Complete_Rendezvous;
-- when ... =>
-- <exception handler from N_Accept_Statement node>
-- Complete_Rendezvous;
-- ...
-- end;
-- exception
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
-- end;
-- The first three declarations were already inserted ahead of the
-- accept statement by the Expand_Accept_Declarations procedure, which
-- was called directly from the semantics during analysis of the accept.
-- statement, before analyzing its contained statements.
-- The declarations from the N_Accept_Statement, as noted in Sinfo, come
-- from possible expansion activity (the original source of course does
-- not have any declarations associated with the accept statement, since
-- an accept statement has no declarative part). In particular, if the
-- expander is active, the first such declaration is the declaration of
-- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
--
-- The two blocks are merged into a single block if the inner block has
-- no exception handlers, but otherwise two blocks are required, since
-- exceptions might be raised in the exception handlers of the inner
-- block, and Exceptional_Complete_Rendezvous must be called.
procedure Expand_N_Accept_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Stats : constant Node_Id := Handled_Statement_Sequence (N);
Ename : constant Node_Id := Entry_Direct_Name (N);
Eindx : constant Node_Id := Entry_Index (N);
Eent : constant Entity_Id := Entity (Ename);
Acstack : constant Elist_Id := Accept_Address (Eent);
Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
Ttyp : constant Entity_Id := Etype (Scope (Eent));
Blkent : Entity_Id;
Call : Node_Id;
Block : Node_Id;
function Null_Statements (Stats : List_Id) return Boolean;
-- Check for null statement sequence (i.e a list of labels and
-- null statements)
function Null_Statements (Stats : List_Id) return Boolean is
Stmt : Node_Id;
begin
Stmt := First (Stats);
while Nkind (Stmt) /= N_Empty
and then (Nkind (Stmt) = N_Null_Statement
or else
Nkind (Stmt) = N_Label)
loop
Next (Stmt);
end loop;
return Nkind (Stmt) = N_Empty;
end Null_Statements;
-- Start of processing for Expand_N_Accept_Statement
begin
-- If accept statement is not part of a list, then its parent must be
-- an accept alternative, and, as described above, we do not do any
-- expansion for such accept statements at this level.
if not Is_List_Member (N) then
pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
return;
-- Trivial accept case (no statement sequence, or null statements).
-- If the accept statement has declarations, then just insert them
-- before the procedure call.
-- We avoid this optimization when FIFO_Within_Priorities is active,
-- since it is not correct according to annex D semantics. The problem
-- is that the call is required to reorder the acceptors position on
-- its ready queue, even though there is nothing to be done. However,
-- if no policy is specified, then we decide that our dispatching
-- policy always reorders the queue right after the RV to look the
-- way they were just before the RV. Since we are allowed to freely
-- reorder same-priority queues (this is part of what dispatching
-- policies are all about), the optimization is legitimate.
elsif Opt.Task_Dispatching_Policy /= 'F'
and then (No (Stats) or else Null_Statements (Statements (Stats)))
then
-- Remove declarations for renamings, because the parameter block
-- will not be assigned.
declare
D : Node_Id;
Next_D : Node_Id;
begin
D := First (Declarations (N));
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
Remove (D);
end if;
D := Next_D;
end loop;
end;
if Present (Declarations (N)) then
Insert_Actions (N, Declarations (N));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc),
Parameter_Associations => New_List (
Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
Analyze (N);
-- Discard Entry_Address that was created for it, so it will not be
-- emitted if this accept statement is in the statement part of a
-- delay alternative.
if Present (Stats) then
Remove_Last_Elmt (Acstack);
end if;
-- Case of statement sequence present
else
-- Construct the block, using the declarations from the accept
-- statement if any to initialize the declarations of the block.
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Set_Ekind (Blkent, E_Block);
Set_Etype (Blkent, Standard_Void_Type);
Set_Scope (Blkent, Current_Scope);
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => Declarations (N),
Handled_Statement_Sequence => Build_Accept_Body (N));
-- Prepend call to Accept_Call to main statement sequence
-- If the accept has exception handlers, the statement sequence
-- is wrapped in a block. Insert call and renaming declarations
-- in the declarations of the block, so they are elaborated before
-- the handlers.
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Accept_Call), Loc),
Parameter_Associations => New_List (
Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
New_Reference_To (Ann, Loc)));
if Parent (Stats) = N then
Prepend (Call, Statements (Stats));
else
Set_Declarations
(Parent (Stats),
New_List (Call));
end if;
Analyze (Call);
New_Scope (Blkent);
declare
D : Node_Id;
Next_D : Node_Id;
Typ : Entity_Id;
begin
D := First (Declarations (N));
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
-- The renaming declarations for the formals were
-- created during analysis of the accept statement,
-- and attached to the list of declarations. Place
-- them now in the context of the accept block or
-- subprogram.
Remove (D);
Typ := Entity (Subtype_Mark (D));
Insert_After (Call, D);
Analyze (D);
-- If the formal is class_wide, it does not have an
-- actual subtype. The analysis of the renaming declaration
-- creates one, but we need to retain the class-wide
-- nature of the entity.
if Is_Class_Wide_Type (Typ) then
Set_Etype (Defining_Identifier (D), Typ);
end if;
end if;
D := Next_D;
end loop;
end;
End_Scope;
-- Replace the accept statement by the new block
Rewrite (N, Block);
Analyze (N);
-- Last step is to unstack the Accept_Address value
Remove_Last_Elmt (Acstack);
end if;
end Expand_N_Accept_Statement;
----------------------------------
-- Expand_N_Asynchronous_Select --
----------------------------------
-- This procedure assumes that the trigger statement is an entry
-- call. A delay alternative should already have been expanded
-- into an entry call to the appropriate delay object Wait entry.
-- If the trigger is a task entry call, the select is implemented
-- with Task_Entry_Call:
-- declare
-- B : Boolean;
-- C : Boolean;
-- P : parms := (parm, parm, parm);
-- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
-- procedure _clean is
-- begin
-- ...
-- Cancel_Task_Entry_Call (C);
-- ...
-- end _clean;
-- begin
-- Abort_Defer;
-- Task_Entry_Call
-- (acceptor-task,
-- entry-index,
-- P'Address,
-- Asynchronous_Call,
-- B);
-- begin
-- begin
-- Abort_Undefer;
-- abortable-part
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- parm := P.param;
-- parm := P.param;
-- ...
-- if not C then
-- triggered-statements
-- end if;
-- end;
-- Note that Build_Simple_Entry_Call is used to expand the entry
-- of the asynchronous entry call (by the
-- Expand_N_Entry_Call_Statement procedure) as follows:
-- declare
-- P : parms := (parm, parm, parm);
-- begin
-- Call_Simple (acceptor-task, entry-index, P'Address);
-- parm := P.param;
-- parm := P.param;
-- ...
-- end;
-- so the task at hand is to convert the latter expansion into the former
-- If the trigger is a protected entry call, the select is
-- implemented with Protected_Entry_Call:
-- declare
-- P : E1_Params := (param, param, param);
-- Bnn : Communications_Block;
-- begin
-- declare
-- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
-- procedure _clean is
-- begin
-- ...
-- if Enqueued (Bnn) then
-- Cancel_Protected_Entry_Call (Bnn);
-- end if;
-- ...
-- end _clean;
-- begin
-- begin
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Asynchronous_Call;
-- Block => Bnn);
-- if Enqueued (Bnn) then
-- <abortable part>
-- end if;
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
-- exception
-- when Abort_Signal =>
-- Abort_Undefer;
-- null;
-- end;
-- if not Cancelled (Bnn) then
-- triggered statements
-- end if;
-- end;
-- Build_Simple_Entry_Call is used to expand the all to a simple
-- protected entry call:
-- declare
-- P : E1_Params := (param, param, param);
-- Bnn : Communications_Block;
-- begin
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call;
-- Block => Bnn);
-- parm := P.param;
-- parm := P.param;
-- ...
-- end;
-- The job is to convert this to the asynchronous form.
-- If the trigger is a delay statement, it will have been expanded
-- into a call to one of the GNARL delay procedures. This routine
-- will convert this into a protected entry call on a delay object
-- and then continue processing as for a protected entry call trigger.
-- This requires declaring a Delay_Block object and adding a pointer
-- to this object to the parameter list of the delay procedure to form
-- the parameter list of the entry call. This object is used by
-- the runtime to queue the delay request.
-- For a description of the use of P and the assignments after the
-- call, see Expand_N_Entry_Call_Statement.
procedure Expand_N_Asynchronous_Select (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Trig : constant Node_Id := Triggering_Alternative (N);
Abrt : constant Node_Id := Abortable_Part (N);
Tstats : constant List_Id := Statements (Trig);
Astats : constant List_Id := Statements (Abrt);
Ecall : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
Hdle : List_Id;
Decls : List_Id;
Decl : Node_Id;
Parms : List_Id;
Parm : Node_Id;
Call : Node_Id;
Stmts : List_Id;
Enqueue_Call : Node_Id;
Stmt : Node_Id;
B : Entity_Id;
Pdef : Entity_Id;
Dblock_Ent : Entity_Id;
N_Orig : Node_Id;
Abortable_Block : Node_Id;
Cancel_Param : Entity_Id;
Blkent : Entity_Id;
Target_Undefer : RE_Id;
Undefer_Args : List_Id := No_List;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Ecall := Triggering_Statement (Trig);
-- The arguments in the call may require dynamic allocation, and the
-- call statement may have been transformed into a block. The block
-- may contain additional declarations for internal entities, and the
-- original call is found by sequential search.
if Nkind (Ecall) = N_Block_Statement then
Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
while Nkind (Ecall) /= N_Procedure_Call_Statement
and then Nkind (Ecall) /= N_Entry_Call_Statement
loop
Next (Ecall);
end loop;
end if;
-- If a delay was used as a trigger, it will have been expanded
-- into a procedure call. Convert it to the appropriate sequence of
-- statements, similar to what is done for a task entry call.
-- Note that this currently supports only Duration, Real_Time.Time,
-- and Calendar.Time.
if Nkind (Ecall) = N_Procedure_Call_Statement then
-- Add a Delay_Block object to the parameter list of the
-- delay procedure to form the parameter list of the Wait
-- entry call.
Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
Pdef := Entity (Name (Ecall));
if Is_RTE (Pdef, RO_CA_Delay_For) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
end if;
Append_To (Parameter_Associations (Ecall),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Dblock_Ent, Loc),
Attribute_Name => Name_Unchecked_Access));
-- Create the inner block to protect the abortable part.
Hdle := New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
-- Append call to if Enqueue (When, DB'Unchecked_Access) then
Rewrite (Ecall,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => Enqueue_Call,
Parameter_Associations => Parameter_Associations (Ecall)),
Then_Statements =>
New_List (Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => Hdle)))));
Stmts := New_List (Ecall);
-- Construct statement sequence for new block
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Timed_Out), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Dblock_Ent, Loc),
Attribute_Name => Name_Unchecked_Access))),
Then_Statements => Tstats));
-- The result is the new block
Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent);
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Dblock_Ent,
Aliased_Present => True,
Object_Definition => New_Reference_To (
RTE (RE_Delay_Block), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
return;
else
N_Orig := N;
end if;
Extract_Entry (Ecall, Concval, Ename, Index);
Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
Stmts := Statements (Handled_Statement_Sequence (Ecall));
Decls := Declarations (Ecall);
if Is_Protected_Type (Etype (Concval)) then
-- Get the declarations of the block expanded from the entry call
Decl := First (Decls);
while Present (Decl)
and then (Nkind (Decl) /= N_Object_Declaration
or else not Is_RTE
(Etype (Object_Definition (Decl)), RE_Communication_Block))
loop
Next (Decl);
end loop;
pragma Assert (Present (Decl));
Cancel_Param := Defining_Identifier (Decl);
-- Change the mode of the Protected_Entry_Call call.
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Asynchronous_Call;
-- Block => Bnn);
Stmt := First (Stmts);
-- Skip assignments to temporaries created for in-out parameters.
-- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ???
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Call := Stmt;
Parm := First (Parameter_Associations (Call));
while Present (Parm)
and then not Is_RTE (Etype (Parm), RE_Call_Modes)
loop
Next (Parm);
end loop;
pragma Assert (Present (Parm));
Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Analyze (Parm);
-- Append an if statement to execute the abortable part.
-- if Enqueued (Bnn) then
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Enqueued), Loc),
Parameter_Associations => New_List (
New_Reference_To (Cancel_Param, Loc))),
Then_Statements => Astats));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
-- For the JVM call Update_Exception instead of Abort_Undefer.
-- See 4jexcept.ads for an explanation.
if Hostparm.Java_VM then
Target_Undefer := RE_Update_Exception;
Undefer_Args :=
New_List (Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Current_Target_Exception), Loc)));
else
Target_Undefer := RE_Abort_Undefer;
end if;
Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
-- exception
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
-- when Abort_Signal =>
-- Abort_Undefer.all;
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (Target_Undefer), Loc),
Parameter_Associations => Undefer_Args)))))),
-- if not Cancelled (Bnn) then
-- triggered statements
-- end if;
Make_Implicit_If_Statement (N,
Condition => Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cancel_Param, Loc)))),
Then_Statements => Tstats));
-- Asynchronous task entry call
else
if No (Decls) then
Decls := New_List;
end if;
B := Make_Defining_Identifier (Loc, Name_uB);
-- Insert declaration of B in declarations of existing block
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
-- Insert declaration of C in declarations of existing block
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Cancel_Param,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
-- Remove and save the call to Call_Simple.
Stmt := First (Stmts);
-- Skip assignments to temporaries created for in-out parameters.
-- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ???
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Call := Stmt;
-- Create the inner block to protect the abortable part.
Hdle := New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
Insert_After (Call,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => Hdle)));
-- Create new call statement
Parms := Parameter_Associations (Call);
Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Append_To (Parms, New_Reference_To (B, Loc));
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Parms));
-- Construct statement sequence for new block
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Op_Not (Loc,
New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats));
-- Protected the call against abortion
Prepend_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List));
end if;
Set_Entry_Cancel_Parameter (Blkent, Cancel_Param);
-- The result is the new block
Rewrite (N_Orig,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N_Orig);
end Expand_N_Asynchronous_Select;
-------------------------------------
-- Expand_N_Conditional_Entry_Call --
-------------------------------------
-- The conditional task entry call is converted to a call to
-- Task_Entry_Call:
-- declare
-- B : Boolean;
-- P : parms := (parm, parm, parm);
-- begin
-- Task_Entry_Call
-- (acceptor-task,
-- entry-index,
-- P'Address,
-- Conditional_Call,
-- B);
-- parm := P.param;
-- parm := P.param;
-- ...
-- if B then
-- normal-statements
-- else
-- else-statements
-- end if;
-- end;
-- For a description of the use of P and the assignments after the
-- call, see Expand_N_Entry_Call_Statement. Note that the entry call
-- of the conditional entry call has already been expanded (by the
-- Expand_N_Entry_Call_Statement procedure) as follows:
-- declare
-- P : parms := (parm, parm, parm);
-- begin
-- ... info for in-out parameters
-- Call