| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 9 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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 3, 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 COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- 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 Aspects; use Aspects; |
| with Checks; use Checks; |
| with Contracts; use Contracts; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_Ch6; use Exp_Ch6; |
| with Exp_Ch11; use Exp_Ch11; |
| with Exp_Dbug; use Exp_Dbug; |
| with Exp_Sel; use Exp_Sel; |
| 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 Itypes; use Itypes; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Ch5; use Sem_Ch5; |
| with Sem_Ch6; use Sem_Ch6; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Ch9; use Sem_Ch9; |
| with Sem_Ch11; use Sem_Ch11; |
| with Sem_Ch13; use Sem_Ch13; |
| with Sem_Elab; use Sem_Elab; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Targparm; use Targparm; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| with Validsw; use Validsw; |
| |
| package body Exp_Ch9 is |
| |
| -- The following constant establishes the upper bound for the index of |
| -- an entry family. It is used to limit the allocated size of protected |
| -- types with defaulted discriminant of an integer type, when the bound |
| -- of some entry family depends on a discriminant. The limitation to entry |
| -- families of 128K should be reasonable in all cases, and is a documented |
| -- implementation restriction. |
| |
| Entry_Family_Bound : constant Pos := 2**16; |
| |
| ----------------------- |
| -- 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. |
| |
| procedure Add_Object_Pointer |
| (Loc : Source_Ptr; |
| Conc_Typ : Entity_Id; |
| Decls : List_Id); |
| -- 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. |
| |
| procedure Add_Formal_Renamings |
| (Spec : Node_Id; |
| Decls : List_Id; |
| Ent : Entity_Id; |
| Loc : Source_Ptr); |
| -- Create renaming declarations for the formals, inside the procedure that |
| -- implements an entry body. The renamings make the original names of the |
| -- formals accessible to gdb, and serve no other purpose. |
| -- Spec is the specification of the procedure being built. |
| -- Decls is the list of declarations to be enhanced. |
| -- Ent is the entity for the original entry body. |
| |
| 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 : Entity_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 |
| (Loc : Source_Ptr; |
| Def_Id : Entity_Id) 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 : Entity_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_Dispatching_Tag_Check |
| (K : Entity_Id; |
| N : Node_Id) return Node_Id; |
| -- Utility to create the tree to check whether the dispatching call in |
| -- a timed entry call, a conditional entry call, or an asynchronous |
| -- transfer of control is a call to a primitive of a non-synchronized type. |
| -- K is the temporary that holds the tagged kind of the target object, and |
| -- N is the enclosing construct. |
| |
| 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_Lock_Free_Protected_Subprogram_Body |
| (N : Node_Id; |
| Prot_Typ : Node_Id; |
| Unprot_Spec : Node_Id) return Node_Id; |
| -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is |
| -- the subprogram specification of the unprotected version of N. Transform |
| -- N such that it invokes the unprotected version of the body. |
| |
| function Build_Lock_Free_Unprotected_Subprogram_Body |
| (N : Node_Id; |
| Prot_Typ : Node_Id) return Node_Id; |
| -- N denotes a subprogram body of protected type Prot_Typ. Build a version |
| -- of N where the original statements of N are synchronized through atomic |
| -- actions such as compare and exchange. Prior to invoking this routine, it |
| -- has been established that N can be implemented in a lock-free fashion. |
| |
| function Build_Parameter_Block |
| (Loc : Source_Ptr; |
| Actuals : List_Id; |
| Formals : List_Id; |
| Decls : List_Id) return Entity_Id; |
| -- Generate an access type for each actual parameter in the list Actuals. |
| -- Create an encapsulating record that contains all the actuals and return |
| -- its type. Generate: |
| -- type Ann1 is access all <actual1-type> |
| -- ... |
| -- type AnnN is access all <actualN-type> |
| -- type Pnn is record |
| -- <formal1> : Ann1; |
| -- ... |
| -- <formalN> : AnnN; |
| -- end record; |
| |
| 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 |
| (Loc : Source_Ptr; |
| Def_Id : Entity_Id; |
| Ent_Id : Entity_Id) return Node_Id; |
| -- Build a specification for the procedure implementing the statements of |
| -- the specified entry body. Add attributes associating it with the entry |
| -- defining identifier Ent_Id. |
| |
| function Build_Protected_Spec |
| (N : Node_Id; |
| Obj_Type : Entity_Id; |
| Ident : Entity_Id; |
| Unprotected : Boolean := False) 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 parameter has |
| -- type Address and mode In. An indirect call through such a pointer will |
| -- convert the address to a reference to the actual object. The object is |
| -- a limited record and therefore a by_reference type. |
| |
| 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 abort, 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. For details, |
| -- see Exp_Ch7.Expand_Cleanup_Actions. |
| |
| function Build_Renamed_Formal_Declaration |
| (New_F : Entity_Id; |
| Formal : Entity_Id; |
| Comp : Entity_Id; |
| Renamed_Formal : Node_Id) return Node_Id; |
| -- Create a renaming declaration for a formal, within a protected entry |
| -- body or an accept body. The renamed object is a component of the |
| -- parameter block that is a parameter in the entry call. |
| -- |
| -- In Ada 2012, if the formal is an incomplete tagged type, the renaming |
| -- does not dereference the corresponding component to prevent an illegal |
| -- use of the incomplete type (AI05-0151). |
| |
| function Build_Selected_Name |
| (Prefix : Entity_Id; |
| Selector : Entity_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. 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); |
| -- Build the call corresponding to the task entry call. N is the task entry |
| -- call, Concval is the concurrent object, Ename is the entry name and |
| -- Index is the entry family index. |
| -- Note that N might be expanded into an N_Block_Statement if it gets |
| -- inlined. |
| |
| 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 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 Build_Wrapper_Bodies |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| N : Node_Id); |
| -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding |
| -- record of a concurrent type. N is the insertion node where all bodies |
| -- will be placed. This routine builds the bodies of the subprograms which |
| -- serve as an indirection mechanism to overriding primitives of concurrent |
| -- types, entries and protected procedures. Any new body is analyzed. |
| |
| procedure Build_Wrapper_Specs |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| N : in out Node_Id); |
| -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding |
| -- record of a concurrent type. N is the insertion node where all specs |
| -- will be placed. This routine builds the specs of the subprograms which |
| -- serve as an indirection mechanism to overriding primitives of concurrent |
| -- types, entries and protected procedures. Any new spec is analyzed. |
| |
| 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 Concurrent_Object |
| (Spec_Id : Entity_Id; |
| Conc_Typ : Entity_Id) return Entity_Id; |
| -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return |
| -- the entity associated with the concurrent object in the Protected_Body_ |
| -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity |
| -- denotes formal parameter _O, _object or _task. |
| |
| function Copy_Result_Type (Res : Node_Id) return Node_Id; |
| -- Copy the result type of a function specification, when building the |
| -- internal operation corresponding to a protected function, or when |
| -- expanding an access to protected function. If the result is an anonymous |
| -- access to subprogram itself, we need to create a new signature with the |
| -- same parameter names and the same resolved types, but with new entities |
| -- for the formals. |
| |
| function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; |
| -- Return whether a secondary stack for the task T should be created by the |
| -- expander. The secondary stack for a task will be created by the expander |
| -- if the size of the stack has been specified by the Secondary_Stack_Size |
| -- representation aspect and either the No_Implicit_Heap_Allocations or |
| -- No_Implicit_Task_Allocations restrictions are in effect and the |
| -- No_Secondary_Stack restriction is not. |
| |
| procedure Debug_Private_Data_Declarations (Decls : List_Id); |
| -- Decls is a list which may contain the declarations created by Install_ |
| -- Private_Data_Declarations. All generated entities are marked as needing |
| -- debug info and debug nodes are manually generation where necessary. This |
| -- step of the expansion must to be done after private data has been moved |
| -- to its final resting scope to ensure proper visibility of debug objects. |
| |
| procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); |
| -- If control flow optimizations are suppressed, and Alt is an accept, |
| -- delay, or entry call alternative with no trailing statements, insert |
| -- a null trailing statement with the given Loc (which is the sloc of |
| -- the accept, delay, or entry call statement). There might not be any |
| -- generated code for the accept, delay, or entry call itself (the effect |
| -- of these statements is part of the general processing done for the |
| -- enclosing selective accept, timed entry call, or asynchronous select), |
| -- and the null statement is there to carry the sloc of that statement to |
| -- the back-end for trace-based coverage analysis purposes. |
| |
| procedure Extract_Dispatching_Call |
| (N : Node_Id; |
| Call_Ent : out Entity_Id; |
| Object : out Entity_Id; |
| Actuals : out List_Id; |
| Formals : out List_Id); |
| -- Given a dispatching call, extract the entity of the name of the call, |
| -- its actual dispatching object, its actual parameters and the formal |
| -- parameters of the overridden interface-level version. If the type of |
| -- the dispatching object is an access type then an explicit dereference |
| -- is returned in Object. |
| |
| 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 Family_Offset |
| (Loc : Source_Ptr; |
| Hi : Node_Id; |
| Lo : Node_Id; |
| Ttyp : Entity_Id; |
| Cap : Boolean) return Node_Id; |
| -- Compute (Hi - Lo) for two entry family indexes. 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. If Cap is true, the result is capped according to |
| -- Entry_Family_Bound. |
| |
| function Family_Size |
| (Loc : Source_Ptr; |
| Hi : Node_Id; |
| Lo : Node_Id; |
| Ttyp : Entity_Id; |
| Cap : Boolean) 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. If |
| -- Cap is true, the result is capped according to Entry_Family_Bound. |
| |
| procedure Find_Enclosing_Context |
| (N : Node_Id; |
| Context : out Node_Id; |
| Context_Id : out Entity_Id; |
| Context_Decls : out List_Id); |
| -- Subsidiary routine to procedures Build_Activation_Chain_Entity and |
| -- Build_Master_Entity. Given an arbitrary node in the tree, find the |
| -- nearest enclosing body, block, package, or return statement and return |
| -- its constituents. Context is the enclosing construct, Context_Id is |
| -- the scope of Context_Id and Context_Decls is the declarative list of |
| -- Context. |
| |
| function Index_Object (Spec_Id : Entity_Id) return Entity_Id; |
| -- Given a subprogram identifier, return the entity which is associated |
| -- with the protection entry index in the Protected_Body_Subprogram or |
| -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal |
| -- parameter _E. |
| |
| function Is_Potentially_Large_Family |
| (Base_Index : Entity_Id; |
| Conctyp : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id) return Boolean; |
| -- Determine whether an entry family is potentially large because one of |
| -- its bounds denotes a discrminant. |
| |
| function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; |
| -- Determine whether Id is a function or a procedure and is marked as a |
| -- private primitive. |
| |
| function Null_Statements (Stats : List_Id) return Boolean; |
| -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. |
| -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well |
| -- to still count as null. Returns True for a null sequence. The argument |
| -- is the list of statements from the DO-END sequence. |
| |
| function Parameter_Block_Pack |
| (Loc : Source_Ptr; |
| Blk_Typ : Entity_Id; |
| Actuals : List_Id; |
| Formals : List_Id; |
| Decls : List_Id; |
| Stmts : List_Id) return Entity_Id; |
| -- Set the components of the generated parameter block with the values |
| -- of the actual parameters. Generate aliased temporaries to capture the |
| -- values for types that are passed by copy. Otherwise generate a reference |
| -- to the actual's value. Return the address of the aggregate block. |
| -- Generate: |
| -- Jnn1 : alias <formal-type1>; |
| -- Jnn1 := <actual1>; |
| -- ... |
| -- P : Blk_Typ := ( |
| -- Jnn1'unchecked_access; |
| -- <actual2>'reference; |
| -- ...); |
| |
| function Parameter_Block_Unpack |
| (Loc : Source_Ptr; |
| P : Entity_Id; |
| Actuals : List_Id; |
| Formals : List_Id) return List_Id; |
| -- Retrieve the values of the components from the parameter block and |
| -- assign then to the original actual parameters. Generate: |
| -- <actual1> := P.<formal1>; |
| -- ... |
| -- <actualN> := P.<formalN>; |
| |
| procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); |
| -- Reset the scope of declarations and blocks at the top level of Bod to |
| -- be E. Bod is either a block or a subprogram body. Used after expanding |
| -- various kinds of entry bodies into their corresponding constructs. This |
| -- is needed during unnesting to determine whether a body generated for an |
| -- entry or an accept alternative includes uplevel references. |
| |
| function Trivial_Accept_OK return Boolean; |
| -- If there is no DO-END block for an accept, or if the DO-END block has |
| -- only null statements, then it is possible to do the Rendezvous with much |
| -- less overhead using the Accept_Trivial routine in the run-time library. |
| -- However, this is not always a valid optimization. Whether it is valid or |
| -- not depends on the Task_Dispatching_Policy. The issue is whether a full |
| -- rescheduling action is required or not. In FIFO_Within_Priorities, such |
| -- a rescheduling is required, so this optimization is not allowed. This |
| -- function returns True if the optimization is permitted. |
| |
| ----------------------------- |
| -- 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 := Entry_Index_Type (Ent); |
| |
| -- First make sure the index is in range if requested. The index type |
| -- has been directly set on the prefix, see Resolve_Entry. |
| |
| if Do_Range_Check (Index) then |
| Generate_Range_Check |
| (Index, Etype (Prefix (Parent (Index))), CE_Range_Check_Failed); |
| end if; |
| |
| Expr := |
| Make_Op_Add (Sloc, |
| Left_Opnd => Num, |
| Right_Opnd => |
| Actual_Family_Offset ( |
| Make_Attribute_Reference (Sloc, |
| Attribute_Name => Name_Pos, |
| Prefix => New_Occurrence_Of (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 := Entry_Index_Type (Prev); |
| |
| -- The need for the following full view retrieval stems from this |
| -- complex case of nested generics and tasking: |
| |
| -- generic |
| -- type Formal_Index is range <>; |
| -- ... |
| -- package Outer is |
| -- type Index is private; |
| -- generic |
| -- ... |
| -- package Inner is |
| -- procedure P; |
| -- end Inner; |
| -- private |
| -- type Index is new Formal_Index range 1 .. 10; |
| -- end Outer; |
| |
| -- package body Outer is |
| -- task type T is |
| -- entry Fam (Index); -- (2) |
| -- entry E; |
| -- end T; |
| -- package body Inner is -- (3) |
| -- procedure P is |
| -- begin |
| -- T.E; -- (1) |
| -- end P; |
| -- end Inner; |
| -- ... |
| |
| -- We are currently building the index expression for the entry |
| -- call "T.E" (1). Part of the expansion must mention the range |
| -- of the discrete type "Index" (2) of entry family "Fam". |
| |
| -- However only the private view of type "Index" is available to |
| -- the inner generic (3) because there was no prior mention of |
| -- the type inside "Inner". This visibility requirement is |
| -- implicit and cannot be detected during the construction of |
| -- the generic trees and needs special handling. |
| |
| if In_Instance_Body |
| and then Is_Private_Type (S) |
| and then Present (Full_View (S)) |
| then |
| S := Full_View (S); |
| end if; |
| |
| 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_Formal_Renamings -- |
| -------------------------- |
| |
| procedure Add_Formal_Renamings |
| (Spec : Node_Id; |
| Decls : List_Id; |
| Ent : Entity_Id; |
| Loc : Source_Ptr) |
| is |
| Ptr : constant Entity_Id := |
| Defining_Identifier |
| (Next (First (Parameter_Specifications (Spec)))); |
| -- The name of the formal that holds the address of the parameter block |
| -- for the call. |
| |
| Comp : Entity_Id; |
| Decl : Node_Id; |
| Formal : Entity_Id; |
| New_F : Entity_Id; |
| Renamed_Formal : Node_Id; |
| |
| begin |
| Formal := First_Formal (Ent); |
| while Present (Formal) loop |
| Comp := Entry_Component (Formal); |
| New_F := |
| Make_Defining_Identifier (Sloc (Formal), |
| Chars => Chars (Formal)); |
| Set_Etype (New_F, Etype (Formal)); |
| Set_Scope (New_F, Ent); |
| |
| -- Now we set debug info needed on New_F even though it does not come |
| -- from source, so that the debugger will get the right information |
| -- for these generated names. |
| |
| Set_Debug_Info_Needed (New_F); |
| |
| if Ekind (Formal) = E_In_Parameter then |
| Mutate_Ekind (New_F, E_Constant); |
| else |
| Mutate_Ekind (New_F, E_Variable); |
| Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); |
| end if; |
| |
| Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); |
| |
| Renamed_Formal := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (Entry_Parameters_Type (Ent), |
| Make_Identifier (Loc, Chars (Ptr)))), |
| Selector_Name => New_Occurrence_Of (Comp, Loc)); |
| |
| Decl := |
| Build_Renamed_Formal_Declaration |
| (New_F, Formal, Comp, Renamed_Formal); |
| |
| Append (Decl, Decls); |
| Set_Renamed_Object (Formal, New_F); |
| Next_Formal (Formal); |
| end loop; |
| end Add_Formal_Renamings; |
| |
| ------------------------ |
| -- Add_Object_Pointer -- |
| ------------------------ |
| |
| procedure Add_Object_Pointer |
| (Loc : Source_Ptr; |
| Conc_Typ : Entity_Id; |
| Decls : List_Id) |
| is |
| Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); |
| Decl : Node_Id; |
| Obj_Ptr : Node_Id; |
| |
| begin |
| -- Create the renaming declaration for the Protection object of a |
| -- protected type. _Object is used by Complete_Entry_Body. |
| -- ??? An attempt to make this a renaming was unsuccessful. |
| |
| -- Build the entity for the access type |
| |
| Obj_Ptr := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Rec_Typ), 'P')); |
| |
| -- Generate: |
| -- _object : poVP := poVP!O; |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), |
| Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), |
| Expression => |
| Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); |
| Set_Debug_Info_Needed (Defining_Identifier (Decl)); |
| Prepend_To (Decls, Decl); |
| |
| -- Generate: |
| -- type poVP is access poV; |
| |
| Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Obj_Ptr, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (Rec_Typ, Loc))); |
| Set_Debug_Info_Needed (Defining_Identifier (Decl)); |
| Prepend_To (Decls, Decl); |
| end Add_Object_Pointer; |
| |
| ----------------------- |
| -- 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. The Sloc is copied from the last statement since it |
| -- is really part of this last statement. |
| |
| Call := |
| Build_Runtime_Call |
| (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); |
| Insert_Before (Last (Statements (Stats)), Call); |
| Analyze (Call); |
| |
| -- Ada 2022 (AI12-0279) |
| |
| if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) |
| and then RTE_Available (RE_Yield) |
| then |
| Insert_Action_After (Call, |
| Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Yield), Loc))); |
| end if; |
| |
| -- If exception handlers are present, then append Complete_Rendezvous |
| -- calls to the handlers, and construct the required outer block. As |
| -- above, the Sloc is copied from the last statement in the sequence. |
| |
| if Present (Exception_Handlers (Stats)) then |
| Hand := First (Exception_Handlers (Stats)); |
| while Present (Hand) loop |
| Call := |
| Build_Runtime_Call |
| (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); |
| Append (Call, Statements (Hand)); |
| Analyze (Call); |
| |
| -- Ada 2022 (AI12-0279) |
| |
| if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) |
| and then RTE_Available (RE_Yield) |
| then |
| Insert_Action_After (Call, |
| Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Yield), Loc))); |
| end if; |
| |
| 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. |
| |
| Call := |
| Make_Procedure_Call_Statement (Sloc (Stats), |
| Name => New_Occurrence_Of ( |
| RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), |
| Parameter_Associations => New_List ( |
| Make_Function_Call (Sloc (Stats), |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))); |
| |
| Ohandle := Make_Others_Choice (Loc); |
| Set_All_Others (Ohandle); |
| |
| Set_Exception_Handlers (New_S, |
| New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| Exception_Choices => New_List (Ohandle), |
| |
| Statements => New_List (Call)))); |
| |
| -- Ada 2022 (AI12-0279) |
| |
| if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) |
| and then RTE_Available (RE_Yield) |
| then |
| Insert_Action_After (Call, |
| Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Yield), Loc))); |
| end if; |
| |
| 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 |
| function Has_Activation_Chain (Stmt : Node_Id) return Boolean; |
| -- Determine whether an extended return statement has activation chain |
| |
| -------------------------- |
| -- Has_Activation_Chain -- |
| -------------------------- |
| |
| function Has_Activation_Chain (Stmt : Node_Id) return Boolean is |
| Decl : Node_Id; |
| |
| begin |
| Decl := First (Return_Object_Declarations (Stmt)); |
| while Present (Decl) loop |
| if Nkind (Decl) = N_Object_Declaration |
| and then Chars (Defining_Identifier (Decl)) = Name_uChain |
| then |
| return True; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| |
| return False; |
| end Has_Activation_Chain; |
| |
| -- Local variables |
| |
| Context : Node_Id; |
| Context_Id : Entity_Id; |
| Decls : List_Id; |
| |
| -- Start of processing for Build_Activation_Chain_Entity |
| |
| begin |
| -- No action needed if the run-time has no tasking support |
| |
| if Global_No_Tasking then |
| return; |
| end if; |
| |
| -- Activation chain is never used for sequential elaboration policy, see |
| -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). |
| |
| if Partition_Elaboration_Policy = 'S' then |
| return; |
| end if; |
| |
| Find_Enclosing_Context (N, Context, Context_Id, Decls); |
| |
| -- If activation chain entity has not been declared already, create one |
| |
| if Nkind (Context) = N_Extended_Return_Statement |
| or else No (Activation_Chain_Entity (Context)) |
| then |
| -- Since extended return statements do not store the entity of the |
| -- chain, examine the return object declarations to avoid creating |
| -- a duplicate. |
| |
| if Nkind (Context) = N_Extended_Return_Statement |
| and then Has_Activation_Chain (Context) |
| then |
| return; |
| end if; |
| |
| declare |
| Loc : constant Source_Ptr := Sloc (Context); |
| Chain : Entity_Id; |
| Decl : Node_Id; |
| |
| begin |
| Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); |
| |
| -- Note: An extended return statement is not really a task |
| -- activator, but it does have an activation chain on which to |
| -- store the tasks temporarily. On successful return, the tasks |
| -- on this chain are moved to the chain passed in by the caller. |
| -- We do not build an Activation_Chain_Entity for an extended |
| -- return statement, because we do not want to build a call to |
| -- Activate_Tasks. Task activation is the responsibility of the |
| -- caller. |
| |
| if Nkind (Context) /= N_Extended_Return_Statement then |
| Set_Activation_Chain_Entity (Context, Chain); |
| end if; |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Chain, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); |
| |
| Prepend_To (Decls, Decl); |
| |
| -- Ensure that _chain appears in the proper scope of the context |
| |
| if Context_Id /= Current_Scope then |
| Push_Scope (Context_Id); |
| Analyze (Decl); |
| Pop_Scope; |
| else |
| Analyze (Decl); |
| end if; |
| end; |
| end if; |
| end Build_Activation_Chain_Entity; |
| |
| ---------------------------- |
| -- Build_Barrier_Function -- |
| ---------------------------- |
| |
| function Build_Barrier_Function |
| (N : Node_Id; |
| Ent : Entity_Id; |
| Pid : Entity_Id) return Node_Id |
| is |
| Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); |
| Cond : constant Node_Id := Condition (Ent_Formals); |
| Loc : constant Source_Ptr := Sloc (Cond); |
| Func_Id : constant Entity_Id := Barrier_Function (Ent); |
| Op_Decls : constant List_Id := New_List; |
| Stmt : Node_Id; |
| Func_Body : Node_Id; |
| |
| begin |
| -- Add a declaration for the Protection object, renaming declarations |
| -- for the discriminals and privals and finally a declaration for the |
| -- entry family index (if applicable). |
| |
| Install_Private_Data_Declarations (Sloc (N), |
| Spec_Id => Func_Id, |
| Conc_Typ => Pid, |
| Body_Nod => N, |
| Decls => Op_Decls, |
| Barrier => True, |
| Family => Ekind (Ent) = E_Entry_Family); |
| |
| -- If compiling with -fpreserve-control-flow, make sure we insert an |
| -- IF statement so that the back-end knows to generate a conditional |
| -- branch instruction, even if the condition is just the name of a |
| -- boolean object. Note that Expand_N_If_Statement knows to preserve |
| -- such redundant IF statements under -fpreserve-control-flow |
| -- (whether coming from this routine, or directly from source). |
| |
| if Opt.Suppress_Control_Flow_Optimizations then |
| Stmt := |
| Make_Implicit_If_Statement (Cond, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| New_Occurrence_Of (Standard_True, Loc))), |
| |
| Else_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| New_Occurrence_Of (Standard_False, Loc)))); |
| |
| else |
| Stmt := Make_Simple_Return_Statement (Loc, Cond); |
| 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. |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Build_Barrier_Function_Specification (Loc, |
| Make_Defining_Identifier (Loc, Chars (Func_Id))), |
| Declarations => Op_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Stmt))); |
| Set_Is_Entry_Barrier_Function (Func_Body); |
| |
| return Func_Body; |
| end Build_Barrier_Function; |
| |
| ------------------------------------------ |
| -- Build_Barrier_Function_Specification -- |
| ------------------------------------------ |
| |
| function Build_Barrier_Function_Specification |
| (Loc : Source_Ptr; |
| Def_Id : Entity_Id) return Node_Id |
| is |
| begin |
| Set_Debug_Info_Needed (Def_Id); |
| |
| 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_Occurrence_Of (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uE), |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), |
| |
| Result_Definition => |
| New_Occurrence_Of (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_Occurrence_Of (E, Loc), |
| Parameter_Associations => New_List (Concurrent_Ref (N))); |
| end Build_Call_With_Task; |
| |
| ----------------------------- |
| -- Build_Class_Wide_Master -- |
| ----------------------------- |
| |
| procedure Build_Class_Wide_Master (Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Master_Decl : Node_Id; |
| Master_Id : Entity_Id; |
| Master_Scope : Entity_Id; |
| Name_Id : Node_Id; |
| Related_Node : Node_Id; |
| Ren_Decl : Node_Id; |
| |
| begin |
| -- No action needed if the run-time has no tasking support |
| |
| if Global_No_Tasking then |
| return; |
| end if; |
| |
| -- Find the declaration that created the access type, which is either a |
| -- type declaration, or an object declaration with an access definition, |
| -- in which case the type is anonymous. |
| |
| if Is_Itype (Typ) then |
| Related_Node := Associated_Node_For_Itype (Typ); |
| else |
| Related_Node := Parent (Typ); |
| end if; |
| |
| Master_Scope := Find_Master_Scope (Typ); |
| |
| -- Nothing to do if the master scope already contains a _master entity. |
| -- The only exception to this is the following scenario: |
| |
| -- Source_Scope |
| -- Transient_Scope_1 |
| -- _master |
| |
| -- Transient_Scope_2 |
| -- use of master |
| |
| -- In this case the source scope is marked as having the master entity |
| -- even though the actual declaration appears inside an inner scope. If |
| -- the second transient scope requires a _master, it cannot use the one |
| -- already declared because the entity is not visible. |
| |
| Name_Id := Make_Identifier (Loc, Name_uMaster); |
| Master_Decl := Empty; |
| |
| if not Has_Master_Entity (Master_Scope) |
| or else No (Current_Entity_In_Scope (Name_Id)) |
| then |
| declare |
| Ins_Nod : Node_Id; |
| |
| begin |
| Set_Has_Master_Entity (Master_Scope); |
| Master_Decl := Build_Master_Declaration (Loc); |
| |
| -- Ensure that the master declaration is placed before its use |
| |
| Ins_Nod := Find_Hook_Context (Related_Node); |
| while not Is_List_Member (Ins_Nod) loop |
| Ins_Nod := Parent (Ins_Nod); |
| end loop; |
| |
| Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl); |
| Analyze (Master_Decl); |
| |
| -- Mark the containing scope as a task master. Masters associated |
| -- with return statements are already marked at this stage (see |
| -- Analyze_Subprogram_Body). |
| |
| if Ekind (Current_Scope) /= E_Return_Statement then |
| declare |
| Par : Node_Id := Related_Node; |
| |
| begin |
| while Nkind (Par) /= N_Compilation_Unit loop |
| Par := Parent (Par); |
| |
| -- 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 (Par) in |
| N_Block_Statement | N_Subprogram_Body | N_Task_Body |
| then |
| Set_Is_Task_Master (Par); |
| exit; |
| end if; |
| end loop; |
| end; |
| end if; |
| end; |
| end if; |
| |
| Master_Id := |
| Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); |
| |
| -- Generate: |
| -- typeMnn renames _master; |
| |
| Ren_Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Master_Id, |
| Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), |
| Name => Name_Id); |
| |
| -- If the master is declared locally, add the renaming declaration |
| -- immediately after it, to prevent access-before-elaboration in the |
| -- back-end. |
| |
| if Present (Master_Decl) then |
| Insert_After (Master_Decl, Ren_Decl); |
| Analyze (Ren_Decl); |
| |
| else |
| Insert_Action (Related_Node, Ren_Decl); |
| end if; |
| |
| Set_Master_Id (Typ, Master_Id); |
| end Build_Class_Wide_Master; |
| |
| -------------------------------- |
| -- 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); |
| Mutate_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 tagged". It is "limited" to reflect the underlying |
| -- limitedness of the task or protected object that it represents, and |
| -- ensuring for example that it is properly passed by reference. It is |
| -- "tagged" to give support to dispatching calls through interfaces. We |
| -- propagate here the list of interfaces covered by the concurrent type |
| -- (Ada 2005: AI-345). |
| |
| 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), |
| Tagged_Present => |
| Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), |
| Interface_List => Interface_List (N), |
| Limited_Present => True)); |
| end Build_Corresponding_Record; |
| |
| --------------------------------- |
| -- Build_Dispatching_Tag_Check -- |
| --------------------------------- |
| |
| function Build_Dispatching_Tag_Check |
| (K : Entity_Id; |
| N : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| return |
| Make_Op_Or (Loc, |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (K, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), |
| |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (K, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); |
| end Build_Dispatching_Tag_Check; |
| |
| ---------------------------------- |
| -- 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; |
| Large : Boolean; |
| |
| begin |
| -- Count number of non-family entries |
| |
| Eindx := 0; |
| Ent := First_Entity (Concurrent_Type); |
| 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 := Entry_Index_Type (Ent); |
| Hi := Type_High_Bound (Typ); |
| Lo := Type_Low_Bound (Typ); |
| Large := Is_Potentially_Large_Family |
| (Base_Type (Typ), Concurrent_Type, Lo, Hi); |
| Ecount := |
| Make_Op_Add (Loc, |
| Left_Opnd => Ecount, |
| Right_Opnd => |
| Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| |
| return Ecount; |
| end Build_Entry_Count_Expression; |
| |
| ------------------------------ |
| -- Build_Master_Declaration -- |
| ------------------------------ |
| |
| function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is |
| Master_Decl : Node_Id; |
| |
| begin |
| -- Generate a dummy master if tasks or tasking hierarchies are |
| -- prohibited. |
| |
| -- _Master : constant Integer := Library_Task_Level; |
| |
| if not Tasking_Allowed |
| or else Restrictions.Set (No_Task_Hierarchy) |
| or else not RTE_Available (RE_Current_Master) |
| then |
| Master_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => |
| Make_Integer_Literal (Loc, Library_Task_Level)); |
| |
| -- Generate: |
| -- _master : constant Integer := Current_Master.all; |
| |
| else |
| Master_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => |
| Make_Explicit_Dereference (Loc, |
| New_Occurrence_Of (RTE (RE_Current_Master), Loc))); |
| end if; |
| |
| return Master_Decl; |
| end Build_Master_Declaration; |
| |
| --------------------------- |
| -- Build_Parameter_Block -- |
| --------------------------- |
| |
| function Build_Parameter_Block |
| (Loc : Source_Ptr; |
| Actuals : List_Id; |
| Formals : List_Id; |
| Decls : List_Id) return Entity_Id |
| is |
| Actual : Entity_Id; |
| Comp_Nam : Node_Id; |
| Comps : List_Id; |
| Formal : Entity_Id; |
| Has_Comp : Boolean := False; |
| Rec_Nam : Node_Id; |
| |
| begin |
| Actual := First (Actuals); |
| Comps := New_List; |
| Formal := Defining_Identifier (First (Formals)); |
| |
| while Present (Actual) loop |
| if not Is_Controlling_Actual (Actual) then |
| |
| -- Generate: |
| -- type Ann is access all <actual-type> |
| |
| Comp_Nam := Make_Temporary (Loc, 'A'); |
| Set_Is_Param_Block_Component_Type (Comp_Nam); |
| |
| Append_To (Decls, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Comp_Nam, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Constant_Present => Ekind (Formal) = E_In_Parameter, |
| Subtype_Indication => |
| New_Occurrence_Of (Etype (Actual), Loc)))); |
| |
| -- Generate: |
| -- Param : Ann; |
| |
| Append_To (Comps, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Chars (Formal)), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => |
| False, |
| Subtype_Indication => |
| New_Occurrence_Of (Comp_Nam, Loc)))); |
| |
| Has_Comp := True; |
| end if; |
| |
| Next_Actual (Actual); |
| Next_Formal_With_Extras (Formal); |
| end loop; |
| |
| Rec_Nam := Make_Temporary (Loc, 'P'); |
| |
| if Has_Comp then |
| |
| -- Generate: |
| -- type Pnn is record |
| -- Param1 : Ann1; |
| -- ... |
| -- ParamN : AnnN; |
| |
| -- where Pnn is a parameter wrapping record, Param1 .. ParamN are |
| -- the original parameter names and Ann1 .. AnnN are the access to |
| -- actual types. |
| |
| Append_To (Decls, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Rec_Nam, |
| Type_Definition => |
| Make_Record_Definition (Loc, |
| Component_List => |
| Make_Component_List (Loc, Comps)))); |
| else |
| -- Generate: |
| -- type Pnn is null record; |
| |
| Append_To (Decls, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Rec_Nam, |
| Type_Definition => |
| Make_Record_Definition (Loc, |
| Null_Present => True, |
| Component_List => Empty))); |
| end if; |
| |
| return Rec_Nam; |
| end Build_Parameter_Block; |
| |
| -------------------------------------- |
| -- Build_Renamed_Formal_Declaration -- |
| -------------------------------------- |
| |
| function Build_Renamed_Formal_Declaration |
| (New_F : Entity_Id; |
| Formal : Entity_Id; |
| Comp : Entity_Id; |
| Renamed_Formal : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (New_F); |
| Decl : Node_Id; |
| |
| begin |
| -- If the formal is a tagged incomplete type, it is already passed |
| -- by reference, so it is sufficient to rename the pointer component |
| -- that corresponds to the actual. Otherwise we need to dereference |
| -- the pointer component to obtain the actual. |
| |
| if Is_Incomplete_Type (Etype (Formal)) |
| and then Is_Tagged_Type (Etype (Formal)) |
| then |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => New_F, |
| Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), |
| Name => Renamed_Formal); |
| |
| else |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => New_F, |
| Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), |
| Name => |
| Make_Explicit_Dereference (Loc, Renamed_Formal)); |
| end if; |
| |
| return Decl; |
| end Build_Renamed_Formal_Declaration; |
| |
| -------------------------- |
| -- Build_Wrapper_Bodies -- |
| -------------------------- |
| |
| procedure Build_Wrapper_Bodies |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| N : Node_Id) |
| is |
| Rec_Typ : Entity_Id; |
| |
| function Build_Wrapper_Body |
| (Loc : Source_Ptr; |
| Subp_Id : Entity_Id; |
| Obj_Typ : Entity_Id; |
| Formals : List_Id) return Node_Id; |
| -- Ada 2005 (AI-345): Build the body that wraps a primitive operation |
| -- associated with a protected or task type. Subp_Id is the subprogram |
| -- name which will be wrapped. Obj_Typ is the type of the new formal |
| -- parameter which handles dispatching and object notation. Formals are |
| -- the original formals of Subp_Id which will be explicitly replicated. |
| |
| ------------------------ |
| -- Build_Wrapper_Body -- |
| ------------------------ |
| |
| function Build_Wrapper_Body |
| (Loc : Source_Ptr; |
| Subp_Id : Entity_Id; |
| Obj_Typ : Entity_Id; |
| Formals : List_Id) return Node_Id |
| is |
| Body_Spec : Node_Id; |
| |
| begin |
| Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); |
| |
| -- The subprogram is not overriding or is not a primitive declared |
| -- between two views. |
| |
| if No (Body_Spec) then |
| return Empty; |
| end if; |
| |
| declare |
| Actuals : List_Id := No_List; |
| Conv_Id : Node_Id; |
| First_Form : Node_Id; |
| Formal : Node_Id; |
| Nam : Node_Id; |
| |
| begin |
| -- Map formals to actuals. Use the list built for the wrapper |
| -- spec, skipping the object notation parameter. |
| |
| First_Form := First (Parameter_Specifications (Body_Spec)); |
| |
| Formal := First_Form; |
| Next (Formal); |
| |
| if Present (Formal) then |
| Actuals := New_List; |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (Formal)))); |
| Next (Formal); |
| end loop; |
| end if; |
| |
| -- Special processing for primitives declared between a private |
| -- type and its completion: the wrapper needs a properly typed |
| -- parameter if the wrapped operation has a controlling first |
| -- parameter. Note that this might not be the case for a function |
| -- with a controlling result. |
| |
| if Is_Private_Primitive_Subprogram (Subp_Id) then |
| if No (Actuals) then |
| Actuals := New_List; |
| end if; |
| |
| if Is_Controlling_Formal (First_Formal (Subp_Id)) then |
| Prepend_To (Actuals, |
| Unchecked_Convert_To |
| (Corresponding_Concurrent_Type (Obj_Typ), |
| Make_Identifier (Loc, Name_uO))); |
| |
| else |
| Prepend_To (Actuals, |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (First_Form)))); |
| end if; |
| |
| Nam := New_Occurrence_Of (Subp_Id, Loc); |
| else |
| -- An access-to-variable object parameter requires an explicit |
| -- dereference in the unchecked conversion. This case occurs |
| -- when a protected entry wrapper must override an interface |
| -- level procedure with interface access as first parameter. |
| |
| -- O.all.Subp_Id (Formal_1, ..., Formal_N) |
| |
| if Nkind (Parameter_Type (First_Form)) = |
| N_Access_Definition |
| then |
| Conv_Id := |
| Make_Explicit_Dereference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uO)); |
| else |
| Conv_Id := Make_Identifier (Loc, Name_uO); |
| end if; |
| |
| Nam := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), |
| Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); |
| end if; |
| |
| -- Create the subprogram body. For a function, the call to the |
| -- actual subprogram has to be converted to the corresponding |
| -- record if it is a controlling result. |
| |
| if Ekind (Subp_Id) = E_Function then |
| declare |
| Res : Node_Id; |
| |
| begin |
| Res := |
| Make_Function_Call (Loc, |
| Name => Nam, |
| Parameter_Associations => Actuals); |
| |
| if Has_Controlling_Result (Subp_Id) then |
| Res := |
| Unchecked_Convert_To |
| (Corresponding_Record_Type (Etype (Subp_Id)), Res); |
| end if; |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Body_Spec, |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, Res)))); |
| end; |
| |
| else |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Body_Spec, |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => Nam, |
| Parameter_Associations => Actuals)))); |
| end if; |
| end; |
| end Build_Wrapper_Body; |
| |
| -- Start of processing for Build_Wrapper_Bodies |
| |
| begin |
| if Is_Concurrent_Type (Typ) then |
| Rec_Typ := Corresponding_Record_Type (Typ); |
| else |
| Rec_Typ := Typ; |
| end if; |
| |
| -- Generate wrapper bodies for a concurrent type which implements an |
| -- interface. |
| |
| if Present (Interfaces (Rec_Typ)) then |
| declare |
| Insert_Nod : Node_Id; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Prim_Decl : Node_Id; |
| Subp : Entity_Id; |
| Wrap_Body : Node_Id; |
| Wrap_Id : Entity_Id; |
| |
| begin |
| Insert_Nod := N; |
| |
| -- Examine all primitive operations of the corresponding record |
| -- type, looking for wrapper specs. Generate bodies in order to |
| -- complete them. |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if (Ekind (Prim) = E_Function |
| or else Ekind (Prim) = E_Procedure) |
| and then Is_Primitive_Wrapper (Prim) |
| then |
| Subp := Wrapped_Entity (Prim); |
| Prim_Decl := Parent (Parent (Prim)); |
| |
| Wrap_Body := |
| Build_Wrapper_Body (Loc, |
| Subp_Id => Subp, |
| Obj_Typ => Rec_Typ, |
| Formals => Parameter_Specifications (Parent (Subp))); |
| Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); |
| |
| Set_Corresponding_Spec (Wrap_Body, Prim); |
| Set_Corresponding_Body (Prim_Decl, Wrap_Id); |
| |
| Insert_After (Insert_Nod, Wrap_Body); |
| Insert_Nod := Wrap_Body; |
| |
| Analyze (Wrap_Body); |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| end if; |
| end Build_Wrapper_Bodies; |
| |
| ------------------------ |
| -- Build_Wrapper_Spec -- |
| ------------------------ |
| |
| function Build_Wrapper_Spec |
| (Subp_Id : Entity_Id; |
| Obj_Typ : Entity_Id; |
| Formals : List_Id) return Node_Id |
| is |
| function Overriding_Possible |
| (Iface_Op : Entity_Id; |
| Wrapper : Entity_Id) return Boolean; |
| -- Determine whether a primitive operation can be overridden by Wrapper. |
| -- Iface_Op is the candidate primitive operation of an interface type, |
| -- Wrapper is the generated entry wrapper. |
| |
| function Replicate_Formals |
| (Loc : Source_Ptr; |
| Formals : List_Id) return List_Id; |
| -- An explicit parameter replication is required due to the Is_Entry_ |
| -- Formal flag being set for all the formals of an entry. The explicit |
| -- replication removes the flag that would otherwise cause a different |
| -- path of analysis. |
| |
| ------------------------- |
| -- Overriding_Possible -- |
| ------------------------- |
| |
| function Overriding_Possible |
| (Iface_Op : Entity_Id; |
| Wrapper : Entity_Id) return Boolean |
| is |
| Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); |
| Wrapper_Spec : constant Node_Id := Parent (Wrapper); |
| |
| function Type_Conformant_Parameters |
| (Iface_Op_Params : List_Id; |
| Wrapper_Params : List_Id) return Boolean; |
| -- Determine whether the parameters of the generated entry wrapper |
| -- and those of a primitive operation are type conformant. During |
| -- this check, the first parameter of the primitive operation is |
| -- skipped if it is a controlling argument: protected functions |
| -- may have a controlling result. |
| |
| -------------------------------- |
| -- Type_Conformant_Parameters -- |
| -------------------------------- |
| |
| function Type_Conformant_Parameters |
| (Iface_Op_Params : List_Id; |
| Wrapper_Params : List_Id) return Boolean |
| is |
| Iface_Op_Param : Node_Id; |
| Iface_Op_Typ : Entity_Id; |
| Wrapper_Param : Node_Id; |
| Wrapper_Typ : Entity_Id; |
| |
| begin |
| -- Skip the first (controlling) parameter of primitive operation |
| |
| Iface_Op_Param := First (Iface_Op_Params); |
| |
| if Present (First_Formal (Iface_Op)) |
| and then Is_Controlling_Formal (First_Formal (Iface_Op)) |
| then |
| Next (Iface_Op_Param); |
| end if; |
| |
| Wrapper_Param := First (Wrapper_Params); |
| while Present (Iface_Op_Param) |
| and then Present (Wrapper_Param) |
| loop |
| Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); |
| Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); |
| |
| -- The two parameters must be mode conformant |
| |
| if not Conforming_Types |
| (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) |
| then |
| return False; |
| end if; |
| |
| Next (Iface_Op_Param); |
| Next (Wrapper_Param); |
| end loop; |
| |
| -- One of the lists is longer than the other |
| |
| if Present (Iface_Op_Param) or else Present (Wrapper_Param) then |
| return False; |
| end if; |
| |
| return True; |
| end Type_Conformant_Parameters; |
| |
| -- Start of processing for Overriding_Possible |
| |
| begin |
| if Chars (Iface_Op) /= Chars (Wrapper) then |
| return False; |
| end if; |
| |
| -- If an inherited subprogram is implemented by a protected procedure |
| -- or an entry, then the first parameter of the inherited subprogram |
| -- must be of mode OUT or IN OUT, or access-to-variable parameter. |
| |
| if Ekind (Iface_Op) = E_Procedure |
| and then Present (Parameter_Specifications (Iface_Op_Spec)) |
| then |
| declare |
| Obj_Param : constant Node_Id := |
| First (Parameter_Specifications (Iface_Op_Spec)); |
| begin |
| if not Out_Present (Obj_Param) |
| and then Nkind (Parameter_Type (Obj_Param)) /= |
| N_Access_Definition |
| then |
| return False; |
| end if; |
| end; |
| end if; |
| |
| return |
| Type_Conformant_Parameters |
| (Parameter_Specifications (Iface_Op_Spec), |
| Parameter_Specifications (Wrapper_Spec)); |
| end Overriding_Possible; |
| |
| ----------------------- |
| -- Replicate_Formals -- |
| ----------------------- |
| |
| function Replicate_Formals |
| (Loc : Source_Ptr; |
| Formals : List_Id) return List_Id |
| is |
| New_Formals : constant List_Id := New_List; |
| Formal : Node_Id; |
| Param_Type : Node_Id; |
| |
| begin |
| Formal := First (Formals); |
| |
| -- Skip the object parameter when dealing with primitives declared |
| -- between two views. |
| |
| if Is_Private_Primitive_Subprogram (Subp_Id) |
| and then not Has_Controlling_Result (Subp_Id) |
| then |
| Next (Formal); |
| end if; |
| |
| while Present (Formal) loop |
| |
| -- Create an explicit copy of the entry parameter |
| |
| -- When creating the wrapper subprogram for a primitive operation |
| -- of a protected interface we must construct an equivalent |
| -- signature to that of the overriding operation. For regular |
| -- parameters we can just use the type of the formal, but for |
| -- access to subprogram parameters we need to reanalyze the |
| -- parameter type to create local entities for the signature of |
| -- the subprogram type. Using the entities of the overriding |
| -- subprogram will result in out-of-scope errors in the back-end. |
| |
| if Nkind (Parameter_Type (Formal)) = N_Access_Definition then |
| Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); |
| else |
| Param_Type := |
| New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); |
| end if; |
| |
| Append_To (New_Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (Formal))), |
| In_Present => In_Present (Formal), |
| Out_Present => Out_Present (Formal), |
| Null_Exclusion_Present => Null_Exclusion_Present (Formal), |
| Parameter_Type => Param_Type)); |
| |
| Next (Formal); |
| end loop; |
| |
| return New_Formals; |
| end Replicate_Formals; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (Subp_Id); |
| First_Param : Node_Id := Empty; |
| Iface : Entity_Id; |
| Iface_Elmt : Elmt_Id; |
| Iface_Op : Entity_Id; |
| Iface_Op_Elmt : Elmt_Id; |
| Overridden_Subp : Entity_Id; |
| |
| -- Start of processing for Build_Wrapper_Spec |
| |
| begin |
| -- No point in building wrappers for untagged concurrent types |
| |
| pragma Assert (Is_Tagged_Type (Obj_Typ)); |
| |
| -- Check if this subprogram has a profile that matches some interface |
| -- primitive. |
| |
| Check_Synchronized_Overriding (Subp_Id, Overridden_Subp); |
| |
| if Present (Overridden_Subp) then |
| First_Param := |
| First (Parameter_Specifications (Parent (Overridden_Subp))); |
| |
| -- An entry or a protected procedure can override a routine where the |
| -- controlling formal is either IN OUT, OUT or is of access-to-variable |
| -- type. Since the wrapper must have the exact same signature as that of |
| -- the overridden subprogram, we try to find the overriding candidate |
| -- and use its controlling formal. |
| |
| -- Check every implemented interface |
| |
| elsif Present (Interfaces (Obj_Typ)) then |
| Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); |
| Search : while Present (Iface_Elmt) loop |
| Iface := Node (Iface_Elmt); |
| |
| -- Check every interface primitive |
| |
| if Present (Primitive_Operations (Iface)) then |
| Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); |
| while Present (Iface_Op_Elmt) loop |
| Iface_Op := Node (Iface_Op_Elmt); |
| |
| -- Ignore predefined primitives |
| |
| if not Is_Predefined_Dispatching_Operation (Iface_Op) then |
| Iface_Op := Ultimate_Alias (Iface_Op); |
| |
| -- The current primitive operation can be overridden by |
| -- the generated entry wrapper. |
| |
| if Overriding_Possible (Iface_Op, Subp_Id) then |
| First_Param := |
| First (Parameter_Specifications (Parent (Iface_Op))); |
| |
| exit Search; |
| end if; |
| end if; |
| |
| Next_Elmt (Iface_Op_Elmt); |
| end loop; |
| end if; |
| |
| Next_Elmt (Iface_Elmt); |
| end loop Search; |
| end if; |
| |
| -- Do not generate the wrapper if no interface primitive is covered by |
| -- the subprogram and it is not a primitive declared between two views |
| -- (see Process_Full_View). |
| |
| if No (First_Param) |
| and then not Is_Private_Primitive_Subprogram (Subp_Id) |
| then |
| return Empty; |
| end if; |
| |
| declare |
| Wrapper_Id : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Chars (Subp_Id)); |
| New_Formals : List_Id; |
| Obj_Param : Node_Id; |
| Obj_Param_Typ : Entity_Id; |
| |
| begin |
| -- Minimum decoration is needed to catch the entity in |
| -- Sem_Ch6.Override_Dispatching_Operation. |
| |
| if Ekind (Subp_Id) = E_Function then |
| Mutate_Ekind (Wrapper_Id, E_Function); |
| else |
| Mutate_Ekind (Wrapper_Id, E_Procedure); |
| end if; |
| |
| Set_Is_Primitive_Wrapper (Wrapper_Id); |
| Set_Wrapped_Entity (Wrapper_Id, Subp_Id); |
| Set_Is_Private_Primitive (Wrapper_Id, |
| Is_Private_Primitive_Subprogram (Subp_Id)); |
| |
| -- Process the formals |
| |
| New_Formals := Replicate_Formals (Loc, Formals); |
| |
| -- A function with a controlling result and no first controlling |
| -- formal needs no additional parameter. |
| |
| if Has_Controlling_Result (Subp_Id) |
| and then |
| (No (First_Formal (Subp_Id)) |
| or else not Is_Controlling_Formal (First_Formal (Subp_Id))) |
| then |
| null; |
| |
| -- Routine Subp_Id has been found to override an interface primitive. |
| -- If the interface operation has an access parameter, create a copy |
| -- of it, with the same null exclusion indicator if present. |
| |
| elsif Present (First_Param) then |
| if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then |
| Obj_Param_Typ := |
| Make_Access_Definition (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Obj_Typ, Loc), |
| Null_Exclusion_Present => |
| Null_Exclusion_Present (Parameter_Type (First_Param)), |
| Constant_Present => |
| Constant_Present (Parameter_Type (First_Param))); |
| else |
| Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); |
| end if; |
| |
| Obj_Param := |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Chars => Name_uO), |
| In_Present => In_Present (First_Param), |
| Out_Present => Out_Present (First_Param), |
| Parameter_Type => Obj_Param_Typ); |
| |
| Prepend_To (New_Formals, Obj_Param); |
| |
| -- If we are dealing with a primitive declared between two views, |
| -- implemented by a synchronized operation, we need to create |
| -- a default parameter. The mode of the parameter must match that |
| -- of the primitive operation. |
| |
| else |
| pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); |
| |
| Obj_Param := |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uO), |
| In_Present => |
| In_Present (Parent (First_Entity (Subp_Id))), |
| Out_Present => Ekind (Subp_Id) /= E_Function, |
| Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); |
| |
| Prepend_To (New_Formals, Obj_Param); |
| end if; |
| |
| -- Build the final spec. If it is a function with a controlling |
| -- result, it is a primitive operation of the corresponding |
| -- record type, so mark the spec accordingly. |
| |
| if Ekind (Subp_Id) = E_Function then |
| declare |
| Res_Def : Node_Id; |
| |
| begin |
| if Has_Controlling_Result (Subp_Id) then |
| Res_Def := |
| New_Occurrence_Of |
| (Corresponding_Record_Type (Etype (Subp_Id)), Loc); |
| else |
| Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); |
| end if; |
| |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Wrapper_Id, |
| Parameter_Specifications => New_Formals, |
| Result_Definition => Res_Def); |
| end; |
| else |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Wrapper_Id, |
| Parameter_Specifications => New_Formals); |
| end if; |
| end; |
| end Build_Wrapper_Spec; |
| |
| ------------------------- |
| -- Build_Wrapper_Specs -- |
| ------------------------- |
| |
| procedure Build_Wrapper_Specs |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| N : in out Node_Id) |
| is |
| Def : Node_Id; |
| Rec_Typ : Entity_Id; |
| procedure Scan_Declarations (L : List_Id); |
| -- Common processing for visible and private declarations |
| -- of a protected type. |
| |
| procedure Scan_Declarations (L : List_Id) is |
| Decl : Node_Id; |
| Wrap_Decl : Node_Id; |
| Wrap_Spec : Node_Id; |
| |
| begin |
| if No (L) then |
| return; |
| end if; |
| |
| Decl := First (L); |
| while Present (Decl) loop |
| Wrap_Spec := Empty; |
| |
| if Nkind (Decl) = N_Entry_Declaration |
| and then Ekind (Defining_Identifier (Decl)) = E_Entry |
| then |
| Wrap_Spec := |
| Build_Wrapper_Spec |
| (Subp_Id => Defining_Identifier (Decl), |
| Obj_Typ => Rec_Typ, |
| Formals => Parameter_Specifications (Decl)); |
| |
| elsif Nkind (Decl) = N_Subprogram_Declaration then |
| Wrap_Spec := |
| Build_Wrapper_Spec |
| (Subp_Id => Defining_Unit_Name (Specification (Decl)), |
| Obj_Typ => Rec_Typ, |
| Formals => |
| Parameter_Specifications (Specification (Decl))); |
| end if; |
| |
| if Present (Wrap_Spec) then |
| Wrap_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Wrap_Spec); |
| |
| Insert_After (N, Wrap_Decl); |
| N := Wrap_Decl; |
| |
| Analyze (Wrap_Decl); |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end Scan_Declarations; |
| |
| -- start of processing for Build_Wrapper_Specs |
| |
| begin |
| if Is_Protected_Type (Typ) then |
| Def := Protected_Definition (Parent (Typ)); |
| else pragma Assert (Is_Task_Type (Typ)); |
| Def := Task_Definition (Parent (Typ)); |
| end if; |
| |
| Rec_Typ := Corresponding_Record_Type (Typ); |
| |
| -- Generate wrapper specs for a concurrent type which implements an |
| -- interface. Operations in both the visible and private parts may |
| -- implement progenitor operations. |
| |
| if Present (Interfaces (Rec_Typ)) and then Present (Def) then |
| Scan_Declarations (Visible_Declarations (Def)); |
| Scan_Declarations (Private_Declarations (Def)); |
| end if; |
| end Build_Wrapper_Specs; |
| |
| --------------------------- |
| -- 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 := Empty; |
| 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_Simple_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 indexes 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_To (Elsif_Parts (If_St), |
| Make_Elsif_Part (Loc, |
| Condition => Cond, |
| Then_Statements => Stats)); |
| 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_Simple_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 (Loc, Typ, Decls); |
| |
| 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 := Entry_Index_Type (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, False)); |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| |
| if Index = 1 then |
| Decls := New_List; |
| Ret := |
| Make_Simple_Return_Statement (Loc, |
| Expression => Make_Integer_Literal (Loc, 1)); |
| |
| else |
| -- Ranges are in increasing order, so last one doesn't need guard |
| |
| declare |
| Nod : constant Node_Id := Last (Elsif_Parts (Ret)); |
| begin |
| Remove (Nod); |
| Set_Else_Statements (Ret, Then_Statements (Nod)); |
| |
| -- If Elsif_Parts becomes empty then remove it entirely, as |
| -- otherwise we would violate the invariant of If_Statement |
| -- node described in Sinfo. |
| |
| if Is_Empty_List (Elsif_Parts (Ret)) then |
| pragma Assert (Elsif_Parts (Ret) /= No_List); |
| Set_Elsif_Parts (Ret, No_List); |
| end if; |
| 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_Occurrence_Of (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Parm2, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), |
| |
| Result_Definition => New_Occurrence_Of ( |
| RTE (RE_Protected_Entry_Index), Loc)); |
| end Build_Find_Body_Index_Spec; |
| |
| ----------------------------------------------- |
| -- Build_Lock_Free_Protected_Subprogram_Body -- |
| ----------------------------------------------- |
| |
| function Build_Lock_Free_Protected_Subprogram_Body |
| (N : Node_Id; |
| Prot_Typ : Node_Id; |
| Unprot_Spec : Node_Id) return Node_Id |
| is |
| Actuals : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (N); |
| Spec : constant Node_Id := Specification (N); |
| Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); |
| Formal : Node_Id; |
| Prot_Spec : Node_Id; |
| Stmt : Node_Id; |
| |
| begin |
| -- Create the protected version of the body |
| |
| Prot_Spec := |
| Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); |
| |
| -- Build the actual parameters which appear in the call to the |
| -- unprotected version of the body. |
| |
| Formal := First (Parameter_Specifications (Prot_Spec)); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); |
| |
| Next (Formal); |
| end loop; |
| |
| -- Function case, generate: |
| -- return <Unprot_Func_Call>; |
| |
| if Nkind (Spec) = N_Function_Specification then |
| Stmt := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| Make_Identifier (Loc, Chars (Unprot_Id)), |
| Parameter_Associations => Actuals)); |
| |
| -- Procedure case, call the unprotected version |
| |
| else |
| Stmt := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Chars (Unprot_Id)), |
| Parameter_Associations => Actuals); |
| end if; |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Declarations => Empty_List, |
| Specification => Prot_Spec, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Stmt))); |
| end Build_Lock_Free_Protected_Subprogram_Body; |
| |
| ------------------------------------------------- |
| -- Build_Lock_Free_Unprotected_Subprogram_Body -- |
| ------------------------------------------------- |
| |
| -- Procedures which meet the lock-free implementation requirements and |
| -- reference a unique scalar component Comp are expanded in the following |
| -- manner: |
| |
| -- procedure P (...) is |
| -- Expected_Comp : constant Comp_Type := |
| -- Comp_Type |
| -- (System.Atomic_Primitives.Lock_Free_Read_N |
| -- (_Object.Comp'Address)); |
| -- begin |
| -- loop |
| -- declare |
| -- <original declarations before the object renaming declaration |
| -- of Comp> |
| -- |
| -- Desired_Comp : Comp_Type := Expected_Comp; |
| -- Comp : Comp_Type renames Desired_Comp; |
| -- |
| -- <original declarations after the object renaming declaration |
| -- of Comp> |
| -- |
| -- begin |
| -- <original statements> |
| -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N |
| -- (_Object.Comp'Address, |
| -- Interfaces.Unsigned_N (Expected_Comp), |
| -- Interfaces.Unsigned_N (Desired_Comp)); |
| -- end; |
| -- end loop; |
| -- end P; |
| |
| -- Each return and raise statement of P is transformed into an atomic |
| -- status check: |
| |
| -- if System.Atomic_Primitives.Lock_Free_Try_Write_N |
| -- (_Object.Comp'Address, |
| -- Interfaces.Unsigned_N (Expected_Comp), |
| -- Interfaces.Unsigned_N (Desired_Comp)); |
| -- then |
| -- <original statement> |
| -- else |
| -- goto L0; |
| -- end if; |
| |
| -- Functions which meet the lock-free implementation requirements and |
| -- reference a unique scalar component Comp are expanded in the following |
| -- manner: |
| |
| -- function F (...) return ... is |
| -- <original declarations before the object renaming declaration |
| -- of Comp> |
| -- |
| -- Expected_Comp : constant Comp_Type := |
| -- Comp_Type |
| -- (System.Atomic_Primitives.Lock_Free_Read_N |
| -- (_Object.Comp'Address)); |
| -- Comp : Comp_Type renames Expected_Comp; |
| -- |
| -- <original declarations after the object renaming declaration of |
| -- Comp> |
| -- |
| -- begin |
| -- <original statements> |
| -- end F; |
| |
| function Build_Lock_Free_Unprotected_Subprogram_Body |
| (N : Node_Id; |
| Prot_Typ : Node_Id) return Node_Id |
| is |
| function Referenced_Component (N : Node_Id) return Entity_Id; |
| -- Subprograms which meet the lock-free implementation criteria are |
| -- allowed to reference only one unique component. Return the prival |
| -- of the said component. |
| |
| -------------------------- |
| -- Referenced_Component -- |
| -------------------------- |
| |
| function Referenced_Component (N : Node_Id) return Entity_Id is |
| Comp : Entity_Id; |
| Decl : Node_Id; |
| Source_Comp : Entity_Id := Empty; |
| |
| begin |
| -- Find the unique source component which N references in its |
| -- statements. |
| |
| for Index in 1 .. Lock_Free_Subprogram_Table.Last loop |
| declare |
| Element : Lock_Free_Subprogram renames |
| Lock_Free_Subprogram_Table.Table (Index); |
| begin |
| if Element.Sub_Body = N then |
| Source_Comp := Element.Comp_Id; |
| exit; |
| end if; |
| end; |
| end loop; |
| |
| if No (Source_Comp) then |
| return Empty; |
| end if; |
| |
| -- Find the prival which corresponds to the source component within |
| -- the declarations of N. |
| |
| Decl := First (Declarations (N)); |
| while Present (Decl) loop |
| |
| -- Privals appear as object renamings |
| |
| if Nkind (Decl) = N_Object_Renaming_Declaration then |
| Comp := Defining_Identifier (Decl); |
| |
| if Present (Prival_Link (Comp)) |
| and then Prival_Link (Comp) = Source_Comp |
| then |
| return Comp; |
| end if; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| |
| return Empty; |
| end Referenced_Component; |
| |
| -- Local variables |
| |
| Comp : constant Entity_Id := Referenced_Component (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); |
| Decls : List_Id := Declarations (N); |
| |
| -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body |
| |
| begin |
| -- Add renamings for the protection object, discriminals, privals, and |
| -- the entry index constant for use by debugger. |
| |
| Debug_Private_Data_Declarations (Decls); |
| |
| -- Perform the lock-free expansion when the subprogram references a |
| -- protected component. |
| |
| if Present (Comp) then |
| Protected_Component_Ref : declare |
| Comp_Decl : constant Node_Id := Parent (Comp); |
| Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); |
| Comp_Type : constant Entity_Id := Etype (Comp); |
| |
| Is_Procedure : constant Boolean := |
| Ekind (Corresponding_Spec (N)) = E_Procedure; |
| -- Indicates if N is a protected procedure body |
| |
| Block_Decls : List_Id := No_List; |
| Try_Write : Entity_Id; |
| Desired_Comp : Entity_Id; |
| Decl : Node_Id; |
| Label : Node_Id; |
| Label_Id : Entity_Id := Empty; |
| Read : Entity_Id; |
| Expected_Comp : Entity_Id; |
| Stmt : Node_Id; |
| Stmts : List_Id := |
| New_Copy_List_Tree (Statements (Hand_Stmt_Seq)); |
| Typ_Size : Int; |
| Unsigned : Entity_Id; |
| |
| function Process_Node (N : Node_Id) return Traverse_Result; |
| -- Transform a single node if it is a return statement, a raise |
| -- statement or a reference to Comp. |
| |
| procedure Process_Stmts (Stmts : List_Id); |
| -- Given a statement sequence Stmts, wrap any return or raise |
| -- statements in the following manner: |
| -- |
| -- if System.Atomic_Primitives.Lock_Free_Try_Write_N |
| -- (_Object.Comp'Address, |
| -- Interfaces.Unsigned_N (Expected_Comp), |
| -- Interfaces.Unsigned_N (Desired_Comp)) |
| -- then |
| -- <Stmt>; |
| -- else |
| -- goto L0; |
| -- end if; |
| |
| ------------------ |
| -- Process_Node -- |
| ------------------ |
| |
| function Process_Node (N : Node_Id) return Traverse_Result is |
| |
| procedure Wrap_Statement (Stmt : Node_Id); |
| -- Wrap an arbitrary statement inside an if statement where the |
| -- condition does an atomic check on the state of the object. |
| |
| -------------------- |
| -- Wrap_Statement -- |
| -------------------- |
| |
| procedure Wrap_Statement (Stmt : Node_Id) is |
| begin |
| -- The first time through, create the declaration of a label |
| -- which is used to skip the remainder of source statements |
| -- if the state of the object has changed. |
| |
| if No (Label_Id) then |
| Label_Id := |
| Make_Identifier (Loc, New_External_Name ('L', 0)); |
| Set_Entity (Label_Id, |
| Make_Defining_Identifier (Loc, Chars (Label_Id))); |
| end if; |
| |
| -- Generate: |
| -- if System.Atomic_Primitives.Lock_Free_Try_Write_N |
| -- (_Object.Comp'Address, |
| -- Interfaces.Unsigned_N (Expected_Comp), |
| -- Interfaces.Unsigned_N (Desired_Comp)) |
| -- then |
| -- <Stmt>; |
| -- else |
| -- goto L0; |
| -- end if; |
| |
| Rewrite (Stmt, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (Try_Write, Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Comp_Sel_Nam), |
| Attribute_Name => Name_Address), |
| |
| Unchecked_Convert_To (Unsigned, |
| New_Occurrence_Of (Expected_Comp, Loc)), |
| |
| Unchecked_Convert_To (Unsigned, |
| New_Occurrence_Of (Desired_Comp, Loc)))), |
| |
| Then_Statements => New_List (Relocate_Node (Stmt)), |
| |
| Else_Statements => New_List ( |
| Make_Goto_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Entity (Label_Id), Loc))))); |
| end Wrap_Statement; |
| |
| -- Start of processing for Process_Node |
| |
| begin |
| -- Wrap each return and raise statement that appear inside a |
| -- procedure. Skip the last return statement which is added by |
| -- default since it is transformed into an exit statement. |
| |
| if Is_Procedure |
| and then ((Nkind (N) = N_Simple_Return_Statement |
| and then N /= Last (Stmts)) |
| or else Nkind (N) = N_Extended_Return_Statement |
| or else (Nkind (N) in |
| N_Raise_xxx_Error | N_Raise_Statement |
| and then Comes_From_Source (N))) |
| then |
| Wrap_Statement (N); |
| return Skip; |
| end if; |
| |
| -- Force reanalysis |
| |
| Set_Analyzed (N, False); |
| |
| return OK; |
| end Process_Node; |
| |
| procedure Process_Nodes is new Traverse_Proc (Process_Node); |
| |
| ------------------- |
| -- Process_Stmts -- |
| ------------------- |
| |
| procedure Process_Stmts (Stmts : List_Id) is |
| Stmt : Node_Id; |
| begin |
| Stmt := First (Stmts); |
| while Present (Stmt) loop |
| Process_Nodes (Stmt); |
| Next (Stmt); |
| end loop; |
| end Process_Stmts; |
| |
| -- Start of processing for Protected_Component_Ref |
| |
| begin |
| -- Get the type size |
| |
| if Known_Static_Esize (Comp_Type) then |
| Typ_Size := UI_To_Int (Esize (Comp_Type)); |
| |
| -- If the Esize (Object_Size) is unknown at compile time, look at |
| -- the RM_Size (Value_Size) since it may have been set by an |
| -- explicit representation clause. |
| |
| elsif Known_Static_RM_Size (Comp_Type) then |
| Typ_Size := UI_To_Int (RM_Size (Comp_Type)); |
| |
| -- Should not happen since this has already been checked in |
| -- Allows_Lock_Free_Implementation (see Sem_Ch9). |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| -- Retrieve all relevant atomic routines and types |
| |
| case Typ_Size is |
| when 8 => |
| Try_Write := RTE (RE_Lock_Free_Try_Write_8); |
| Read := RTE (RE_Lock_Free_Read_8); |
| Unsigned := RTE (RE_Uint8); |
| |
| when 16 => |
| Try_Write := RTE (RE_Lock_Free_Try_Write_16); |
| Read := RTE (RE_Lock_Free_Read_16); |
| Unsigned := RTE (RE_Uint16); |
| |
| when 32 => |
| Try_Write := RTE (RE_Lock_Free_Try_Write_32); |
| Read := RTE (RE_Lock_Free_Read_32); |
| Unsigned := RTE (RE_Uint32); |
| |
| when 64 => |
| Try_Write := RTE (RE_Lock_Free_Try_Write_64); |
| Read := RTE (RE_Lock_Free_Read_64); |
| Unsigned := RTE (RE_Uint64); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Generate: |
| -- Expected_Comp : constant Comp_Type := |
| -- Comp_Type |
| -- (System.Atomic_Primitives.Lock_Free_Read_N |
| -- (_Object.Comp'Address)); |
| |
| Expected_Comp := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Comp), Suffix => "_saved")); |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Expected_Comp, |
| Object_Definition => New_Occurrence_Of (Comp_Type, Loc), |
| Constant_Present => True, |
| Expression => |
| Unchecked_Convert_To (Comp_Type, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Read, Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Comp_Sel_Nam), |
| Attribute_Name => Name_Address))))); |
| |
| -- Protected procedures |
| |
| if Is_Procedure then |
| -- Move the original declarations inside the generated block |
| |
| Block_Decls := Decls; |
| |
| -- Reset the declarations list of the protected procedure to |
| -- contain only Decl. |
| |
| Decls := New_List (Decl); |
| |
| -- Generate: |
| -- Desired_Comp : Comp_Type := Expected_Comp; |
| |
| Desired_Comp := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Comp), Suffix => "_current")); |
| |
| -- Insert the declarations of Expected_Comp and Desired_Comp in |
| -- the block declarations right before the renaming of the |
| -- protected component. |
| |
| Insert_Before (Comp_Decl, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Desired_Comp, |
| Object_Definition => New_Occurrence_Of (Comp_Type, Loc), |
| Expression => |
| New_Occurrence_Of (Expected_Comp, Loc))); |
| |
| -- Protected function |
| |
| else |
| Desired_Comp := Expected_Comp; |
| |
| -- Insert the declaration of Expected_Comp in the function |
| -- declarations right before the renaming of the protected |
| -- component. |
| |
| Insert_Before (Comp_Decl, Decl); |
| end if; |
| |
| -- Rewrite the protected component renaming declaration to be a |
| -- renaming of Desired_Comp. |
| |
| -- Generate: |
| -- Comp : Comp_Type renames Desired_Comp; |
| |
| Rewrite (Comp_Decl, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => |
| Defining_Identifier (Comp_Decl), |
| Subtype_Mark => |
| New_Occurrence_Of (Comp_Type, Loc), |
| Name => |
| New_Occurrence_Of (Desired_Comp, Loc))); |
| |
| -- Wrap any return or raise statements in Stmts in same the manner |
| -- described in Process_Stmts. |
| |
| Process_Stmts (Stmts); |
| |
| -- Generate: |
| -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N |
| -- (_Object.Comp'Address, |
| -- Interfaces.Unsigned_N (Expected_Comp), |
| -- Interfaces.Unsigned_N (Desired_Comp)) |
| |
| if Is_Procedure then |
| Stmt := |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (Try_Write, Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Comp_Sel_Nam), |
| Attribute_Name => Name_Address), |
| |
| Unchecked_Convert_To (Unsigned, |
| New_Occurrence_Of (Expected_Comp, Loc)), |
| |
| Unchecked_Convert_To (Unsigned, |
| New_Occurrence_Of (Desired_Comp, Loc))))); |
| |
| -- Small optimization: transform the default return statement |
| -- of a procedure into the atomic exit statement. |
| |
| if Nkind (Last (Stmts)) = N_Simple_Return_Statement then |
| Rewrite (Last (Stmts), Stmt); |
| else |
| Append_To (Stmts, Stmt); |
| end if; |
| end if; |
| |
| -- Create the declaration of the label used to skip the rest of |
| -- the source statements when the object state changes. |
| |
| if Present (Label_Id) then |
| Label := Make_Label (Loc, Label_Id); |
| Append_To (Decls, |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Entity (Label_Id), |
| Label_Construct => Label)); |
| Append_To (Stmts, Label); |
| end if; |
| |
| -- Generate: |
| -- loop |
| -- declare |
| -- <Decls> |
| -- begin |
| -- <Stmts> |
| -- end; |
| -- end loop; |
| |
| if Is_Procedure then |
| Stmts := |
| New_List ( |
| Make_Loop_Statement (Loc, |
| Statements => New_List ( |
| Make_Block_Statement (Loc, |
| Declarations => Block_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts))), |
| End_Label => Empty)); |
| end if; |
| |
| Hand_Stmt_Seq := |
| Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); |
| end Protected_Component_Ref; |
| end if; |
| |
| -- Make an unprotected version of the subprogram for use within the same |
| -- object, with new name and extra parameter representing the object. |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), |
| Declarations => Decls, |
| Handled_Statement_Sequence => Hand_Stmt_Seq); |
| end Build_Lock_Free_Unprotected_Subprogram_Body; |
| |
| ------------------------- |
| -- Build_Master_Entity -- |
| ------------------------- |
| |
| procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); |
| Context : Node_Id; |
| Context_Id : Entity_Id; |
| Decl : Node_Id; |
| Decls : List_Id; |
| Par : Node_Id; |
| |
| begin |
| -- No action needed if the run-time has no tasking support |
| |
| if Global_No_Tasking then |
| return; |
| end if; |
| |
| if Is_Itype (Obj_Or_Typ) then |
| Par := Associated_Node_For_Itype (Obj_Or_Typ); |
| else |
| Par := Parent (Obj_Or_Typ); |
| end if; |
| |
| -- For transient scopes check if the master entity is already defined |
| |
| if Is_Type (Obj_Or_Typ) |
| and then Ekind (Scope (Obj_Or_Typ)) = E_Block |
| and then Is_Internal (Scope (Obj_Or_Typ)) |
| then |
| declare |
| Master_Scope : constant Entity_Id := |
| Find_Master_Scope (Obj_Or_Typ); |
| begin |
| if Has_Master_Entity (Master_Scope) |
| or else Is_Finalizer (Master_Scope) |
| then |
| return; |
| end if; |
| |
| if Present (Current_Entity_In_Scope (Name_uMaster)) then |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- When creating a master for a record component which is either a task |
| -- or access-to-task, the enclosing record is the master scope and the |
| -- proper insertion point is the component list. |
| |
| if Is_Record_Type (Current_Scope) then |
| Context := Par; |
| Context_Id := Current_Scope; |
| Decls := List_Containing (Context); |
| |
| -- Default case for object declarations and access types. Note that the |
| -- context is updated to the nearest enclosing body, block, package, or |
| -- return statement. |
| |
| else |
| Find_Enclosing_Context (Par, Context, Context_Id, Decls); |
| end if; |
| |
| -- When the enclosing context is a BIP function whose result type has |
| -- tasks, the function has an extra formal that is the master of the |
| -- tasks to be created by its returned object (that is, when its |
| -- enclosing context is a return statement). However, if the body of |
| -- the function creates tasks before its return statements, such tasks |
| -- need their own master. |
| |
| if Has_Master_Entity (Context_Id) |
| and then Ekind (Context_Id) = E_Function |
| and then Is_Build_In_Place_Function (Context_Id) |
| and then Needs_BIP_Task_Actuals (Context_Id) |
| then |
| -- No need to add it again if previously added |
| |
| declare |
| Master_Present : Boolean; |
| |
| begin |
| -- Handle transient scopes |
| |
| if Context_Id /= Current_Scope then |
| Push_Scope (Context_Id); |
| Master_Present := |
| Present (Current_Entity_In_Scope (Name_uMaster)); |
| Pop_Scope; |
| else |
| Master_Present := |
| Present (Current_Entity_In_Scope (Name_uMaster)); |
| end if; |
| |
| if Master_Present then |
| return; |
| end if; |
| end; |
| |
| -- Nothing to do if the context already has a master; internally built |
| -- finalizers don't need a master. |
| |
| elsif Has_Master_Entity (Context_Id) |
| or else Is_Finalizer (Context_Id) |
| then |
| return; |
| end if; |
| |
| Decl := Build_Master_Declaration (Loc); |
| |
| -- The master is inserted at the start of the declarative list of the |
| -- context. |
| |
| Prepend_To (Decls, Decl); |
| |
| -- In certain cases where transient scopes are involved, the immediate |
| -- scope is not always the proper master scope. Ensure that the master |
| -- declaration and entity appear in the same context. |
| |
| if Context_Id /= Current_Scope then |
| Push_Scope (Context_Id); |
| Analyze (Decl); |
| Pop_Scope; |
| else |
| Analyze (Decl); |
| end if; |
| |
| -- Mark the enclosing scope and its associated construct as being task |
| -- masters. |
| |
| Set_Has_Master_Entity (Context_Id); |
| |
| while Present (Context) |
| and then Nkind (Context) /= N_Compilation_Unit |
| loop |
| if Nkind (Context) in |
| N_Block_Statement | N_Subprogram_Body | N_Task_Body |
| then |
| Set_Is_Task_Master (Context); |
| exit; |
| |
| elsif Nkind (Parent (Context)) = N_Subunit then |
| Context := Corresponding_Stub (Parent (Context)); |
| end if; |
| |
| Context := Parent (Context); |
| end loop; |
| end Build_Master_Entity; |
| |
| --------------------------- |
| -- Build_Master_Renaming -- |
| --------------------------- |
| |
| procedure Build_Master_Renaming |
| (Ptr_Typ : Entity_Id; |
| Ins_Nod : Node_Id := Empty) |
| is |
| Loc : constant Source_Ptr := Sloc (Ptr_Typ); |
| Context : Node_Id; |
| Master_Decl : Node_Id; |
| Master_Id : Entity_Id; |
| |
| begin |
| -- No action needed if the run-time has no tasking support |
| |
| if Global_No_Tasking then |
| return; |
| end if; |
| |
| -- Determine the proper context to insert the master renaming |
| |
| if Present (Ins_Nod) then |
| Context := Ins_Nod; |
| |
| elsif Is_Itype (Ptr_Typ) then |
| Context := Associated_Node_For_Itype (Ptr_Typ); |
| |
| -- When the context references a discriminant or a component of a |
| -- private type and we are processing declarations in the private |
| -- part of the enclosing package, we must insert the master renaming |
| -- before the full declaration of the private type; otherwise the |
| -- master renaming would be inserted in the public part of the |
| -- package (and hence before the declaration of _master). |
| |
| if In_Private_Part (Current_Scope) then |
| declare |
| Ctx : Node_Id := Context; |
| |
| begin |
| if Nkind (Context) = N_Discriminant_Specification then |
| Ctx := Parent (Ctx); |
| else |
| while Nkind (Ctx) in |
| N_Component_Declaration | N_Component_List |
| loop |
| Ctx := Parent (Ctx); |
| end loop; |
| end if; |
| |
| if Nkind (Ctx) in N_Private_Type_Declaration |
| | N_Private_Extension_Declaration |
| then |
| Context := Parent (Full_View (Defining_Identifier (Ctx))); |
| end if; |
| end; |
| end if; |
| |
| else |
| Context := Parent (Ptr_Typ); |
| end if; |
| |
| -- Generate: |
| -- <Ptr_Typ>M : Master_Id renames _Master; |
| -- and add a numeric suffix to the name to ensure that it is |
| -- unique in case other access types in nested constructs |
| -- are homonyms of this one. |
| |
| Master_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Ptr_Typ), 'M', -1)); |
| |
| Master_Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Master_Id, |
| Subtype_Mark => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Name => Make_Identifier (Loc, Name_uMaster)); |
| |
| Insert_Action (Context, Master_Decl); |
| |
| -- The renamed master now services the access type |
| |
| Set_Master_Id (Ptr_Typ, Master_Id); |
| end Build_Master_Renaming; |
| |
| --------------------------- |
| -- Build_Protected_Entry -- |
| --------------------------- |
| |
| function Build_Protected_Entry |
| (N : Node_Id; |
| Ent : Entity_Id; |
| Pid : Node_Id) return Node_Id |
| is |
| Bod_Decls : constant List_Id := New_List; |
| Decls : constant List_Id := Declarations (N); |
| End_Lab : constant Node_Id := |
| End_Label (Handled_Statement_Sequence (N)); |
| End_Loc : constant Source_Ptr := |
| Sloc (Last (Statements (Handled_Statement_Sequence (N)))); |
| -- Used for the generated call to Complete_Entry_Body |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Bod_Id : Entity_Id; |
| Bod_Spec : Node_Id; |
| Bod_Stmts : List_Id; |
| Complete : Node_Id; |
| Ohandle : Node_Id; |
| Proc_Body : Node_Id; |
| |
| EH_Loc : Source_Ptr; |
| -- Used for the exception handler, inserted at end of the body |
| |
| begin |
| -- Set the source location on the exception handler only when debugging |
| -- the expanded code (see Make_Implicit_Exception_Handler). |
| |
| if Debug_Generated_Code then |
| EH_Loc := End_Loc; |
| |
| -- Otherwise the inserted code should not be visible to the debugger |
| |
| else |
| EH_Loc := No_Location; |
| end if; |
| |
| Bod_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Protected_Body_Subprogram (Ent))); |
| Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); |
| |
| -- Add the following declarations: |
| |
| -- type poVP is access poV; |
| -- _object : poVP := poVP (_O); |
| |
| -- where _O is the formal parameter associated with the concurrent |
| -- object. These declarations are needed for Complete_Entry_Body. |
| |
| Add_Object_Pointer (Loc, Pid, Bod_Decls); |
| |
| -- Add renamings for all formals, the Protection object, discriminals, |
| -- privals and the entry index constant for use by debugger. |
| |
| Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); |
| Debug_Private_Data_Declarations (Decls); |
| |
| -- Put the declarations and the statements from the entry |
| |
| Bod_Stmts := |
| New_List ( |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => Handled_Statement_Sequence (N))); |
| |
| -- Analyze now and reset scopes for declarations so that Scope fields |
| -- currently denoting the entry will now denote the block scope, and |
| -- the block's scope will be set to the new procedure entity. |
| |
| Analyze_Statements (Bod_Stmts); |
| |
| Set_Scope (Entity (Identifier (First (Bod_Stmts))), |
| Protected_Body_Subprogram (Ent)); |
| |
| Reset_Scopes_To |
| (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts)))); |
| |
| case Corresponding_Runtime_Package (Pid) is |
| when System_Tasking_Protected_Objects_Entries => |
| Append_To (Bod_Stmts, |
| Make_Procedure_Call_Statement (End_Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (End_Loc, |
| Prefix => |
| Make_Selected_Component (End_Loc, |
| Prefix => |
| Make_Identifier (End_Loc, Name_uObject), |
| Selector_Name => |
| Make_Identifier (End_Loc, Name_uObject)), |
| Attribute_Name => Name_Unchecked_Access)))); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| |
| -- Historically, a call to Complete_Single_Entry_Body was |
| -- inserted, but it was a null procedure. |
| |
| null; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- When exceptions cannot be propagated, we never need to call |
| -- Exception_Complete_Entry_Body. |
| |
| if No_Exception_Handlers_Set then |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Bod_Spec, |
| Declarations => Bod_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Bod_Stmts, |
| End_Label => End_Lab)); |
| |
| else |
| Ohandle := Make_Others_Choice (Loc); |
| Set_All_Others (Ohandle); |
| |
| case Corresponding_Runtime_Package (Pid) is |
| when System_Tasking_Protected_Objects_Entries => |
| Complete := |
| New_Occurrence_Of |
| (RTE (RE_Exceptional_Complete_Entry_Body), Loc); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Complete := |
| New_Occurrence_Of |
| (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Create body of entry procedure. The renaming declarations are |
| -- placed ahead of the block that contains the actual entry body. |
| |
| Proc_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => Bod_Spec, |
| Declarations => Bod_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Bod_Stmts, |
| End_Label => End_Lab, |
| Exception_Handlers => New_List ( |
| Make_Implicit_Exception_Handler (EH_Loc, |
| Exception_Choices => New_List (Ohandle), |
| |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (EH_Loc, |
| Name => Complete, |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (EH_Loc, |
| Prefix => |
| Make_Selected_Component (EH_Loc, |
| Prefix => |
| Make_Identifier (EH_Loc, Name_uObject), |
| Selector_Name => |
| Make_Identifier (EH_Loc, Name_uObject)), |
| Attribute_Name => Name_Unchecked_Access), |
| |
| Make_Function_Call (EH_Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Get_GNAT_Exception), Loc))))))))); |
| |
| -- Establish link between subprogram body and source entry body |
| |
| Set_Corresponding_Entry_Body (Proc_Body, N); |
| Set_At_End_Proc (Proc_Body, At_End_Proc (N)); |
| |
| Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); |
| return Proc_Body; |
| end if; |
| end Build_Protected_Entry; |
| |
| ----------------------------------------- |
| -- Build_Protected_Entry_Specification -- |
| ----------------------------------------- |
| |
| function Build_Protected_Entry_Specification |
| (Loc : Source_Ptr; |
| Def_Id : Entity_Id; |
| Ent_Id : Entity_Id) return Node_Id |
| is |
| P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); |
| |
| begin |
| Set_Debug_Info_Needed (Def_Id); |
| |
| 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_Occurrence_Of (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => P, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uE), |
| Parameter_Type => |
| New_Occurrence_Of (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; |
| Ident : Entity_Id; |
| Unprotected : Boolean := False) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Decl : Node_Id; |
| Formal : Entity_Id; |
| New_Formal : Entity_Id; |
| New_Plist : List_Id; |
| |
| begin |
| New_Plist := New_List; |
| |
| Formal := First_Formal (Ident); |
| while Present (Formal) loop |
| New_Formal := |
| Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); |
| Set_Comes_From_Source (New_Formal, Comes_From_Source (Formal)); |
| |
| if Unprotected then |
| Mutate_Ekind (New_Formal, Ekind (Formal)); |
| Set_Protected_Formal (Formal, New_Formal); |
| end if; |
| |
| Append_To (New_Plist, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => New_Formal, |
| Aliased_Present => Aliased_Present (Parent (Formal)), |
| In_Present => In_Present (Parent (Formal)), |
| Out_Present => Out_Present (Parent (Formal)), |
| Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc))); |
| |
| 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. |
| |
| Decl := |
| 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_Occurrence_Of (Obj_Type, Loc)); |
| Set_Debug_Info_Needed (Defining_Identifier (Decl)); |
| Prepend_To (New_Plist, Decl); |
| |
| return New_Plist; |
| end Build_Protected_Spec; |
| |
| --------------------------------------- |
| -- Build_Protected_Sub_Specification -- |
| --------------------------------------- |
| |
| function Build_Protected_Sub_Specification |
| (N : Node_Id; |
| Prot_Typ : Entity_Id; |
| Mode : Subprogram_Protection_Mode) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Decl : Node_Id; |
| Def_Id : Entity_Id; |
| New_Id : Entity_Id; |
| New_Plist : List_Id; |
| New_Spec : Node_Id; |
| |
| Append_Chr : constant array (Subprogram_Protection_Mode) of Character := |
| (Dispatching_Mode => ' ', |
| Protected_Mode => 'P', |
| Unprotected_Mode => 'N'); |
| |
| begin |
| if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body |
| then |
| Decl := Unit_Declaration_Node (Corresponding_Spec (N)); |
| else |
| Decl := N; |
| end if; |
| |
| Def_Id := Defining_Unit_Name (Specification (Decl)); |
| |
| New_Plist := |
| Build_Protected_Spec |
| (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, |
| Mode = Unprotected_Mode); |
| New_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); |
| |
| -- Reference the original nondispatching subprogram since the analysis |
| -- of the object.operation notation may need its original name (see |
| -- Sem_Ch4.Names_Match). |
| |
| if Mode = Dispatching_Mode then |
| Mutate_Ekind (New_Id, Ekind (Def_Id)); |
| Set_Original_Protected_Subprogram (New_Id, Def_Id); |
| end if; |
| |
| -- Link the protected or unprotected version to the original subprogram |
| -- it emulates. |
| |
| Mutate_Ekind (New_Id, Ekind (Def_Id)); |
| Set_Protected_Subprogram (New_Id, Def_Id); |
| |
| -- The unprotected operation carries the user code, and debugging |
| -- information must be generated for it, even though this spec does |
| -- not come from source. It is also convenient to allow gdb to step |
| -- into the protected operation, even though it only contains lock/ |
| -- unlock calls. |
| |
| Set_Debug_Info_Needed (New_Id); |
| |
| -- If a pragma Eliminate applies to the source entity, the internal |
| -- subprograms will be eliminated as well. |
| |
| Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); |
| |
| -- It seems we should set Has_Nested_Subprogram here, but instead we |
| -- currently set it in Expand_N_Protected_Body, because the entity |
| -- created here isn't the one that Corresponding_Spec of the body |
| -- will later be set to, and that's the entity where it's needed. ??? |
| |
| Set_Has_Nested_Subprogram (New_Id, Has_Nested_Subprogram (Def_Id)); |
| |
| if Nkind (Specification (Decl)) = N_Procedure_Specification then |
| New_Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => New_Id, |
| Parameter_Specifications => New_Plist); |
| |
| -- Create a new specification for the anonymous subprogram type |
| |
| else |
| New_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => New_Id, |
| Parameter_Specifications => New_Plist, |
| Result_Definition => |
| Copy_Result_Type (Result_Definition (Specification (Decl)))); |
| |
| Set_Return_Present (Defining_Unit_Name (New_Spec)); |
| end if; |
| |
| return New_Spec; |
| 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 |
| Might_Raise : constant Boolean := Sem_Util.Might_Raise (N); |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| Op_Spec : constant Node_Id := Specification (N); |
| P_Op_Spec : constant Node_Id := |
| Build_Protected_Sub_Specification (N, Pid, Protected_Mode); |
| |
| Lock_Kind : RE_Id; |
| Lock_Name : Node_Id; |
| Lock_Stmt : Node_Id; |
| Object_Parm : Node_Id; |
| Pformal : Node_Id; |
| R : Node_Id; |
| Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning |
| Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning |
| Stmts : List_Id; |
| Sub_Body : Node_Id; |
| Uactuals : List_Id; |
| Unprot_Call : Node_Id; |
| |
| begin |
| -- Build a list of the formal parameters of the protected version of |
| -- the subprogram to use as the actual parameters of the unprotected |
| -- version. |
| |
| Uactuals := New_List; |
| Pformal := First (Parameter_Specifications (P_Op_Spec)); |
| while Present (Pformal) loop |
| Append_To (Uactuals, |
| Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); |
| 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 Might_Raise then |
| Unprot_Call := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Unit_Name (N_Op_Spec))), |
| Parameter_Associations => Uactuals)); |
| |
| else |
| R := Make_Temporary (Loc, 'R'); |
| |
| Unprot_Call := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => R, |
| Constant_Present => True, |
| Object_Definition => |
| New_Copy (Result_Definition (N_Op_Spec)), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Unit_Name (N_Op_Spec))), |
| Parameter_Associations => Uactuals)); |
| |
| Return_Stmt := |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (R, Loc)); |
| end if; |
| |
| if Has_Aspect (Pid, Aspect_Exclusive_Functions) |
| and then |
| (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions)) |
| or else |
| Is_True (Static_Boolean (Find_Value_Of_Aspect |
| (Pid, Aspect_Exclusive_Functions)))) |
| then |
| Lock_Kind := RE_Lock; |
| else |
| Lock_Kind := RE_Lock_Read_Only; |
| end if; |
| else |
| Unprot_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), |
| Parameter_Associations => Uactuals); |
| |
| Lock_Kind := RE_Lock; |
| end if; |
| |
| -- Wrap call in block that will be covered by an at_end handler |
| |
| if Might_Raise 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. |
| |
| case Corresponding_Runtime_Package (Pid) is |
| when System_Tasking_Protected_Objects_Entries => |
| Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); |
| |
| when System_Tasking_Protected_Objects => |
| Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| 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 ( |
| Build_Runtime_Call (Loc, RE_Abort_Defer), |
| Lock_Stmt); |
| |
| else |
| Stmts := New_List (Lock_Stmt); |
| end if; |
| |
| if Might_Raise 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; |
| |
| Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); |
| |
| if Nkind (Op_Spec) = N_Function_Specification then |
| Append_To (Stmts, Return_Stmt); |
| Append_To (Pre_Stmts, |
| Make_Block_Statement (Loc, |
| Declarations => New_List (Unprot_Call), |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => 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)); |
| |
| -- Mark this subprogram as a protected subprogram body so that the |
| -- cleanup will be inserted. This is done only in the Might_Raise |
| -- case because otherwise the cleanup has already been inserted. |
| |
| if Might_Raise 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; |
| |
| -- If the type is an untagged derived type, convert to the root type, |
| -- which is the one on which the operations are defined. |
| |
| if Nkind (Rec) = N_Unchecked_Type_Conversion |
| and then not Is_Tagged_Type (Etype (Rec)) |
| and then Is_Derived_Type (Etype (Rec)) |
| then |
| Set_Etype (Rec, Root_Type (Etype (Rec))); |
| Set_Subtype_Mark (Rec, |
| New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); |
| 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)); |
| |
| -- Preserve type of call for subsequent processing (required for |
| -- call to Wrap_Transient_Expression in the case of a shared passive |
| -- protected). |
| |
| Set_Etype (N, Etype (New_Sub)); |
| 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_Protected_Subprogram_Call_Cleanup -- |
| --------------------------------------------- |
| |
| procedure Build_Protected_Subprogram_Call_Cleanup |
| (Op_Spec : Node_Id; |
| Conc_Typ : Node_Id; |
| Loc : Source_Ptr; |
| Stmts : List_Id) |
| is |
| Nam : Node_Id; |
| |
| begin |
| -- If the associated protected object has entries, a protected |
| -- procedure has to service entry queues. In this case generate: |
| |
| -- Service_Entries (_object._object'Access); |
| |
| if Nkind (Op_Spec) = N_Procedure_Specification |
| and then Has_Entries (Conc_Typ) |
| then |
| case Corresponding_Runtime_Package (Conc_Typ) is |
| when System_Tasking_Protected_Objects_Entries => |
| Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => Nam, |
| 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)))); |
| |
| else |
| -- Generate: |
| -- Unlock (_object._object'Access); |
| |
| case Corresponding_Runtime_Package (Conc_Typ) is |
| when System_Tasking_Protected_Objects_Entries => |
| Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); |
| |
| when System_Tasking_Protected_Objects => |
| Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => Nam, |
| 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)))); |
| end if; |
| |
| -- Generate: |
| -- Abort_Undefer; |
| |
| if Abort_Allowed then |
| Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| end if; |
| end Build_Protected_Subprogram_Call_Cleanup; |
| |
| ------------------------- |
| -- Build_Selected_Name -- |
| ------------------------- |
| |
| function Build_Selected_Name |
| (Prefix : Entity_Id; |
| Selector : Entity_Id; |
| Append_Char : Character := ' ') return Name_Id |
| is |
| Select_Buffer : String (1 .. Hostparm.Max_Name_Length); |
| Select_Len : Natural; |
| |
| begin |
| Get_Name_String (Chars (Selector)); |
| Select_Len := Name_Len; |
| Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); |
| Get_Name_String (Chars (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; |
| |
| Add_Str_To_Name_Buffer ("__"); |
| for J in 1 .. Select_Len loop |
| Add_Char_To_Name_Buffer (Select_Buffer (J)); |
| end loop; |
| |
| -- Now add the Append_Char if specified. The encoding to follow |
| -- depends on the type of entity. If Append_Char is either 'N' or 'P', |
| -- then the entity is associated to a protected type subprogram. |
| -- Otherwise, it is a protected type entry. For each case, the |
| -- encoding to follow for the suffix is documented in exp_dbug.ads. |
| |
| -- It would be better to encapsulate this as a routine in Exp_Dbug ??? |
| |
| if Append_Char /= ' ' then |
| if Append_Char in 'P' | 'N' then |
| Add_Char_To_Name_Buffer (Append_Char); |
| return Name_Find; |
| else |
| Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); |
| return New_External_Name (Name_Find, ' ', -1); |
| end if; |
| else |
| return Name_Find; |
| end if; |
| 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); |
| |
| -- If call has been inlined, nothing left to do |
| |
| if Nkind (N) = N_Block_Statement then |
| return; |
| end if; |
| |
| -- 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; |
| Actual : Node_Id; |
| Call : Node_Id; |
| Comm_Name : Entity_Id; |
| Conctyp : Node_Id; |
| Decls : List_Id; |
| Ent : Entity_Id; |
| Ent_Acc : Entity_Id; |
| Formal : Node_Id; |
| Iface_Tag : Entity_Id; |
| Iface_Typ : Entity_Id; |
| N_Node : Node_Id; |
| N_Var : Node_Id; |
| P : Entity_Id; |
| Parm1 : Node_Id; |
| Parm2 : Node_Id; |
| Parm3 : Node_Id; |
| Pdecl : Node_Id; |
| Plist : List_Id; |
| X : Entity_Id; |
| Xdecl : Node_Id; |
| |
| begin |
| -- Simple entry and entry family cases merge here |
| |
| Ent := Entity (Ename); |
| Ent_Acc := Entry_Parameters_Type (Ent); |
| Conctyp := Etype (Concval); |
| |
| -- Special case for protected subprogram calls |
| |
| if Is_Protected_Type (Conctyp) |
| and then Is_Subprogram (Entity (Ename)) |
| then |
| if not Is_Eliminated (Entity (Ename)) then |
| Build_Protected_Subprogram_Call |
| (N, Ename, Convert_Concurrent (Concval, Conctyp)); |
| Analyze (N); |
| end if; |
| |
| 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. |
| |
| if Nkind (Concval) = N_Function_Call |
| and then Is_Task_Type (Conctyp) |
| and then Ada_Version >= Ada_2005 |
| then |
| declare |
| ExpR : constant Node_Id := Relocate_Node (Concval); |
| Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); |
| Decl : Node_Id; |
| |
| begin |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Obj, |
| Object_Definition => New_Occurrence_Of (Conctyp, Loc), |
| Expression => ExpR); |
| Set_Etype (Obj, Conctyp); |
| Decls := New_List (Decl); |
| Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); |
| end; |
| |
| else |
| Decls := New_List; |
| end if; |
| |
| 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 not Is_Protected_Type (Conctyp) |
| or else |
| Corresponding_Runtime_Package (Conctyp) = |
| System_Tasking_Protected_Objects_Entries |
| then |
| X := Make_Defining_Identifier (Loc, Name_uX); |
| |
| Xdecl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => X, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), |
| Expression => Actual_Index_Expression ( |
| Loc, Entity (Ename), Index, Concval)); |
| |
| Append_To (Decls, Xdecl); |
| Parm2 := New_Occurrence_Of (X, Loc); |
| |
| else |
| Xdecl := Empty; |
| 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_Occurrence_Of (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_Temporary (Loc, 'J'), |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Etype (Formal), Loc)); |
| |
| -- Mark the object as not needing initialization since the |
| -- initialization is performed separately, avoiding errors |
| -- on cases such as formals of null-excluding access types. |
| |
| Set_No_Initialization (N_Node); |
| |
| -- We must make a separate assignment statement for the |
| -- case of limited types. We cannot assign it unless the |
| -- Assignment_OK flag is set first. An out formal of an |
| -- access type or whose type has a Default_Value must also |
| -- be initialized from the actual (see RM 6.4.1 (13-13.1)), |
| -- but no constraint, predicate, or null-exclusion check is |
| -- applied before the call. |
| |
| if Ekind (Formal) /= E_Out_Parameter |
| or else Is_Access_Type (Etype (Formal)) |
| or else |
| (Is_Scalar_Type (Etype (Formal)) |
| and then |
| Present (Default_Aspect_Value (Etype (Formal)))) |
| then |
| N_Var := |
| New_Occurrence_Of (Defining_Identifier (N_Node), Loc); |
| Set_Assignment_OK (N_Var); |
| Append_To (Stats, |
| Make_Assignment_Statement (Loc, |
| Name => N_Var, |
| Expression => Relocate_Node (Actual))); |
| |
| -- Mark the object as internal, so we don't later reset |
| -- No_Initialization flag in Default_Initialize_Object, |
| -- which would lead to needless default initialization. |
| -- We don't set this outside the if statement, because |
| -- out scalar parameters without Default_Value do require |
| -- default initialization if Initialize_Scalars applies. |
| |
| Set_Is_Internal (Defining_Identifier (N_Node)); |
| |
| -- If actual is an out parameter of a null-excluding |
| -- access type, there is access check on entry, so set |
| -- Suppress_Assignment_Checks on the generated statement |
| -- that assigns the actual to the parameter block. |
| |
| Set_Suppress_Assignment_Checks (Last (Stats)); |
| end if; |
| |
| Append (N_Node, Decls); |
| |
| Append_To (Plist, |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Unchecked_Access, |
| Prefix => |
| New_Occurrence_Of |
| (Defining_Identifier (N_Node), Loc))); |
| |
| else |
| -- Interface class-wide formal |
| |
| if Ada_Version >= Ada_2005 |
| and then Ekind (Etype (Formal)) = E_Class_Wide_Type |
| and then Is_Interface (Etype (Formal)) |
| then |
| Iface_Typ := Etype (Etype (Formal)); |
| |
| -- Generate: |
| -- formal_iface_type! (actual.iface_tag)'reference |
| |
| Iface_Tag := |
| Find_Interface_Tag (Etype (Actual), Iface_Typ); |
| pragma Assert (Present (Iface_Tag)); |
| |
| Append_To (Plist, |
| Make_Reference (Loc, |
| Unchecked_Convert_To (Iface_Typ, |
| Make_Selected_Component (Loc, |
| Prefix => |
| Relocate_Node (Actual), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Tag, Loc))))); |
| else |
| -- Generate: |
| -- actual'reference |
| |
| Append_To (Plist, |
| Make_Reference (Loc, Relocate_Node (Actual))); |
| end if; |
| 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_Occurrence_Of (Designated_Type (Ent_Acc), Loc), |
| Expression => |
| Make_Aggregate (Loc, Expressions => Plist)); |
| |
| Parm3 := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (P, Loc), |
| Attribute_Name => Name_Address); |
| |
| Append (Pdecl, Decls); |
| end if; |
| |
| -- Now we can create the call, case of protected type |
| |
| if Is_Protected_Type (Conctyp) then |
| case Corresponding_Runtime_Package (Conctyp) is |
| when System_Tasking_Protected_Objects_Entries => |
| |
| -- Change the type of the index declaration |
| |
| Set_Object_Definition (Xdecl, |
| New_Occurrence_Of (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_Temporary (Loc, 'B'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Comm_Name, |
| Object_Definition => |
| New_Occurrence_Of |
| (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_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), |
| |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Unchecked_Access, |
| Prefix => Parm1), |
| Parm2, |
| Parm3, |
| New_Occurrence_Of (RTE (RE_Simple_Call), Loc), |
| New_Occurrence_Of (Comm_Name, Loc))); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| |
| -- Protected_Single_Entry_Call |
| -- (Object => po._object'Access, |
| -- Uninterpreted_Data => P'Address); |
| |
| Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Protected_Single_Entry_Call), Loc), |
| |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Unchecked_Access, |
| Prefix => Parm1), |
| Parm3)); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Case of task type |
| |
| else |
| Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (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_Occurrence_Of (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 |
| function Activation_Call_Loc return Source_Ptr; |
| -- Find a suitable source location for the activation call |
| |
| ------------------------- |
| -- Activation_Call_Loc -- |
| ------------------------- |
| |
| function Activation_Call_Loc return Source_Ptr is |
| begin |
| -- The activation call must carry the location of the "end" keyword |
| -- when the context is a package declaration. |
| |
| if Nkind (N) = N_Package_Declaration then |
| return End_Keyword_Location (N); |
| |
| -- Otherwise the activation call must carry the location of the |
| -- "begin" keyword. |
| |
| else |
| return Begin_Keyword_Location (N); |
| end if; |
| end Activation_Call_Loc; |
| |
| -- Local variables |
| |
| Chain : Entity_Id; |
| Call : Node_Id; |
| Loc : Source_Ptr; |
| Name : Node_Id; |
| Owner : Node_Id; |
| Stmt : Node_Id; |
| |
| -- Start of processing for Build_Task_Activation_Call |
| |
| begin |
| -- For sequential elaboration policy, all the tasks will be activated at |
| -- the end of the elaboration. |
| |
| if Partition_Elaboration_Policy = 'S' then |
| return; |
| |
| -- Do not create an activation call for a package spec if the package |
| -- has a completing body. The activation call will be inserted after |
| -- the "begin" of the body. |
| |
| elsif Nkind (N) = N_Package_Declaration |
| and then Present (Corresponding_Body (N)) |
| then |
| return; |
| end if; |
| |
| -- Obtain the activation chain entity. Block statements, entry bodies, |
| -- subprogram bodies, and task bodies keep the entity in their nodes. |
| -- Package bodies on the other hand store it in the declaration of the |
| -- corresponding package spec. |
| |
| Owner := N; |
| |
| if Nkind (Owner) = N_Package_Body then |
| Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); |
| end if; |
| |
| Chain := Activation_Chain_Entity (Owner); |
| |
| -- Nothing to do when there are no tasks to activate. This is indicated |
| -- by a missing activation chain entity; also skip generating it when |
| -- it is a ghost entity. |
| |
| if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then |
| return; |
| |
| -- The availability of the activation chain entity does not ensure |
| -- that we have tasks to activate because it may have been declared |
| -- by the frontend to pass a required extra formal to a build-in-place |
| -- subprogram call. If we are within the scope of a protected type and |
| -- pragma Detect_Blocking is active we can assume that no tasks will be |
| -- activated; if tasks are created in a protected object and this pragma |
| -- is active then the frontend emits a warning and Program_Error is |
| -- raised at runtime. |
| |
| elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then |
| return; |
| end if; |
| |
| -- The location of the activation call must be as close as possible to |
| -- the intended semantic location of the activation because the ABE |
| -- mechanism relies heavily on accurate locations. |
| |
| Loc := Activation_Call_Loc; |
| |
| if Restricted_Profile then |
| Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); |
| else |
| Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); |
| end if; |
| |
| 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 (Private_Declarations (Specification (N))) then |
| Append (Call, Private_Declarations (Specification (N))); |
| else |
| Append (Call, Visible_Declarations (Specification (N))); |
| end if; |
| |
| else |
| -- The call goes at the start of the statement sequence after the |
| -- start of exception range label if one is present. |
| |
| if Present (Handled_Statement_Sequence (N)) then |
| Stmt := First (Statements (Handled_Statement_Sequence (N))); |
| |
| -- A special case, skip exception range label if one is present |
| -- (from front end zcx processing). |
| |
| if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then |
| Next (Stmt); |
| end if; |
| |
| -- Another special case, if the first statement is a block from |
| -- optimization of a local raise to a goto, then the call goes |
| -- inside this block. |
| |
| if Nkind (Stmt) = N_Block_Statement |
| and then Exception_Junk (Stmt) |
| then |
| Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); |
| end if; |
| |
| -- Insertion point is after any exception label pushes, since we |
| -- want it covered by any local handlers. |
| |
| while Nkind (Stmt) in N_Push_xxx_Label loop |
| Next (Stmt); |
| end loop; |
| |
| -- Now we have the proper insertion point |
| |
| Insert_Before (Stmt, Call); |
| |
| else |
| Set_Handled_Statement_Sequence (N, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Call))); |
| end if; |
| end if; |
| |
| Analyze (Call); |
| |
| if Legacy_Elaboration_Checks then |
| 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 : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| Block : Node_Id; |
| |
| begin |
| Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blkent, Loc), |
| Declarations => New_List ( |
| |
| -- _Chain : Activation_Chain; |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Chain, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (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_Occurrence_Of (Init, Loc), |
| Parameter_Associations => Args), |
| |
| -- Activate_Tasks (_Chain); |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (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 : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| Block : Node_Id; |
| |
| begin |
| Append_To (Init_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Chain, Loc), |
| Attribute_Name => Name_Unchecked_Access)))); |
| |
| Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blkent, Loc), |
| Declarations => New_List ( |
| |
| -- _Chain : Activation_Chain; |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Chain, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (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); |
| Spec_Id : Entity_Id; |
| |
| begin |
| -- Case of explicit task type, suffix TB |
| |
| if Comes_From_Source (T) then |
| Spec_Id := |
| Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); |
| |
| -- Case of anonymous task type, suffix B |
| |
| else |
| Spec_Id := |
| Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); |
| end if; |
| |
| Set_Is_Internal (Spec_Id); |
| |
| -- Associate the procedure with the task, if this is the declaration |
| -- (and not the body) of the procedure. |
| |
| if No (Task_Body_Procedure (T)) then |
| Set_Task_Body_Procedure (T, Spec_Id); |
| end if; |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Spec_Id, |
| 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_Occurrence_Of (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 |
| Decls : constant List_Id := Declarations (N); |
| |
| begin |
| -- Add renamings for the Protection object, discriminals, privals, and |
| -- the entry index constant for use by debugger. |
| |
| Debug_Private_Data_Declarations (Decls); |
| |
| -- Make an unprotected version of the subprogram for use within the same |
| -- object, with a new name and an additional parameter representing the |
| -- object. |
| |
| return |
| Make_Subprogram_Body (Sloc (N), |
| Specification => |
| Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), |
| Declarations => Decls, |
| Handled_Statement_Sequence => Handled_Statement_Sequence (N), |
| At_End_Proc => At_End_Proc (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_Temporary (Loc, 'F'); |
| |
| declare |
| Eityp : constant Entity_Id := Entry_Index_Type (Efam); |
| Lo : constant Node_Id := Type_Low_Bound (Eityp); |
| Hi : constant Node_Id := Type_High_Bound (Eityp); |
| Bdecl : Node_Id; |
| Bityp : Entity_Id; |
| |
| begin |
| Bityp := Base_Type (Eityp); |
| |
| if Is_Potentially_Large_Family (Bityp, Conctyp, Lo, Hi) then |
| Bityp := Make_Temporary (Loc, 'B'); |
| |
| Bdecl := |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Bityp, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => Make_Range (Loc, |
| Make_Integer_Literal |
| (Loc, -Entry_Family_Bound), |
| Make_Integer_Literal |
| (Loc, Entry_Family_Bound - 1))))); |
| |
| Insert_After (Current_Node, Bdecl); |
| Current_Node := Bdecl; |
| Analyze (Bdecl); |
| end if; |
| |
| 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 (Bityp, Loc))), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (Standard_Character, Loc)))); |
| end; |
| |
| 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 (Entry_Index_Type (Efam), |
| Loc))))))); |
| end if; |
| |
| Next_Entity (Efam); |
| end loop; |
| end Collect_Entry_Families; |
| |
| ----------------------- |
| -- Concurrent_Object -- |
| ----------------------- |
| |
| function Concurrent_Object |
| (Spec_Id : Entity_Id; |
| Conc_Typ : Entity_Id) return Entity_Id |
| is |
| begin |
| -- Parameter _O or _object |
| |
| if Is_Protected_Type (Conc_Typ) then |
| return First_Formal (Protected_Body_Subprogram (Spec_Id)); |
| |
| -- Parameter _task |
| |
| else |
| pragma Assert (Is_Task_Type (Conc_Typ)); |
| return First_Formal (Task_Body_Procedure (Conc_Typ)); |
| end if; |
| end Concurrent_Object; |
| |
| ---------------------- |
| -- Copy_Result_Type -- |
| ---------------------- |
| |
| function Copy_Result_Type (Res : Node_Id) return Node_Id is |
| New_Res : constant Node_Id := New_Copy_Tree (Res); |
| Par_Spec : Node_Id; |
| Formal : Entity_Id; |
| |
| begin |
| -- If the result type is an access_to_subprogram, we must create new |
| -- entities for its spec. |
| |
| if Nkind (New_Res) = N_Access_Definition |
| and then Present (Access_To_Subprogram_Definition (New_Res)) |
| then |
| -- Provide new entities for the formals |
| |
| Par_Spec := First (Parameter_Specifications |
| (Access_To_Subprogram_Definition (New_Res))); |
| while Present (Par_Spec) loop |
| Formal := Defining_Identifier (Par_Spec); |
| Set_Defining_Identifier (Par_Spec, |
| Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); |
| Next (Par_Spec); |
| end loop; |
| end if; |
| |
| return New_Res; |
| end Copy_Result_Type; |
| |
| -------------------- |
| -- 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 |
| -- 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_Occurrence_Of (RTE (RE_Self), Loc)); |
| |
| else |
| declare |
| Decl : Node_Id; |
| T_Self : constant Entity_Id := Make_Temporary (Loc, '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_Occurrence_Of (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_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); |
| end if; |
| |
| else |
| if Is_Protected_Type (Ntyp) then |
| Sel := Name_uObject; |
| elsif Is_Task_Type (Ntyp) then |
| Sel := Name_uTask_Id; |
| else |
| raise Program_Error; |
| 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; |
| |
| ------------------------------------- |
| -- Create_Secondary_Stack_For_Task -- |
| ------------------------------------- |
| |
| function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is |
| begin |
| return |
| (Restriction_Active (No_Implicit_Heap_Allocations) |
| or else Restriction_Active (No_Implicit_Task_Allocations)) |
| and then not Restriction_Active (No_Secondary_Stack) |
| and then Has_Rep_Pragma |
| (T, Name_Secondary_Stack_Size, Check_Parents => False); |
| end Create_Secondary_Stack_For_Task; |
| |
| ------------------------------------- |
| -- Debug_Private_Data_Declarations -- |
| ------------------------------------- |
| |
| procedure Debug_Private_Data_Declarations (Decls : List_Id) is |
| Debug_Nod : Node_Id; |
| Decl : Node_Id; |
| |
| begin |
| Decl := First (Decls); |
| while Present (Decl) and then not Comes_From_Source (Decl) loop |
| |
| -- Declaration for concurrent entity _object and its access type, |
| -- along with the entry index subtype: |
| -- type prot_typVP is access prot_typV; |
| -- _object : prot_typVP := prot_typV (_O); |
| -- subtype Jnn is <Type of Index> range Low .. High; |
| |
| if Nkind (Decl) in N_Full_Type_Declaration | N_Object_Declaration then |
| Set_Debug_Info_Needed (Defining_Identifier (Decl)); |
| |
| -- Declaration for the Protection object, discriminals, privals, and |
| -- entry index constant: |
| -- conc_typR : protection_typ renames _object._object; |
| -- discr_nameD : discr_typ renames _object.discr_name; |
| -- discr_nameD : discr_typ renames _task.discr_name; |
| -- prival_name : comp_typ renames _object.comp_name; |
| -- J : constant Jnn := |
| -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); |
| |
| elsif Nkind (Decl) = N_Object_Renaming_Declaration then |
| Set_Debug_Info_Needed (Defining_Identifier (Decl)); |
| Debug_Nod := Debug_Renaming_Declaration (Decl); |
| |
| if Present (Debug_Nod) then |
| Insert_After (Decl, Debug_Nod); |
| end if; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end Debug_Private_Data_Declarations; |
| |
| ------------------------------ |
| -- Ensure_Statement_Present -- |
| ------------------------------ |
| |
| procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is |
| Stmt : Node_Id; |
| |
| begin |
| if Opt.Suppress_Control_Flow_Optimizations |
| and then Is_Empty_List (Statements (Alt)) |
| then |
| Stmt := Make_Null_Statement (Loc); |
| |
| -- Mark NULL statement as coming from source so that it is not |
| -- eliminated by GIGI. |
| |
| -- Another covert channel. If this is a requirement, it must be |
| -- documented in sinfo/einfo ??? |
| |
| Set_Comes_From_Source (Stmt, True); |
| |
| Set_Statements (Alt, New_List (Stmt)); |
| end if; |
| end Ensure_Statement_Present; |
| |
| ---------------------------- |
| -- 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 := Entry_Index_Type (Ent); |
| |
| -- First make sure the index is in range if requested. The index type |
| -- is the pristine Entry_Index_Type of the entry. |
| |
| if Do_Range_Check (Index) then |
| Generate_Range_Check (Index, S, CE_Range_Check_Failed); |
| end if; |
| |
| Expr := |
| Make_Op_Add (Sloc, |
| Left_Opnd => Num, |
| Right_Opnd => |
| Family_Offset |
| (Sloc, |
| Make_Attribute_Reference (Sloc, |
| Attribute_Name => Name_Pos, |
| Prefix => New_Occurrence_Of (Base_Type (S), Sloc), |
| Expressions => New_List (Relocate_Node (Index))), |
| Type_Low_Bound (S), |
| Ttyp, |
| False)); |
| 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 := Entry_Index_Type (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, False)); |
| |
| -- 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 Restriction_Active (No_Task_Hierarchy) = False then |
| Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); |
| |
| -- The block may have no declarations (and nevertheless be a task |
| -- master) if it contains a call that may return an object that |
| -- contains tasks. |
| |
| if No (Declarations (N)) then |
| Set_Declarations (N, New_List (Call)); |
| else |
| Prepend_To (Declarations (N), Call); |
| end if; |
| |
| 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); |
| Stats : constant Node_Id := Handled_Statement_Sequence (N); |
| Ann : Entity_Id := Empty; |
| Adecl : Node_Id; |
| Lab : Node_Id; |
| Ldecl : Node_Id; |
| Ldecl2 : Node_Id; |
| |
| begin |
| if Expander_Active then |
| |
| -- If we have no handled statement sequence, we may need to build |
| -- a dummy sequence consisting of a null statement. This can be |
| -- skipped if the trivial accept optimization is permitted. |
| |
| if not Trivial_Accept_OK |
| and then (No (Stats) or else Null_Statements (Statements (Stats))) |
| then |
| Set_Handled_Statement_Sequence (N, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => 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 |
| declare |
| Ent : Entity_Id; |
| |
| begin |
| Ent := Make_Temporary (Loc, 'L'); |
| Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); |
| Ldecl := |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Ent, |
| Label_Construct => Lab); |
| Append (Lab, Statements (Handled_Statement_Sequence (N))); |
| |
| Ent := Make_Temporary (Loc, 'L'); |
| Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); |
| Ldecl2 := |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Ent, |
| Label_Construct => Lab); |
| Append (Lab, Statements (Handled_Statement_Sequence (N))); |
| end; |
| |
| 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_Temporary (Loc, 'A'); |
| |
| Adecl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Ann, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Loc)); |
| |
| Insert_Before_And_Analyze (N, Adecl); |
| Insert_Before_And_Analyze (N, Ldecl); |
| Insert_Before_And_Analyze (N, 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 this is 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_Temporary (Loc, 'A'); |
| Adecl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Ann, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Loc)); |
| |
| Insert_Before_And_Analyze (Sel_Acc, Adecl); |
| |
| -- If this is 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_Debug_Info_Needed (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 |
| Comp : Entity_Id; |
| Decl : Node_Id; |
| Formal : Entity_Id; |
| New_F : Entity_Id; |
| Renamed_Formal : Node_Id; |
| |
| begin |
| Push_Scope (Ent); |
| Formal := First_Formal (Ent); |
| |
| while Present (Formal) loop |
| Comp := Entry_Component (Formal); |
| New_F := Make_Defining_Identifier (Loc, Chars (Formal)); |
| |
| Set_Etype (New_F, Etype (Formal)); |
| Set_Scope (New_F, Ent); |
| |
| -- Now we set debug info needed on New_F even though it does |
| -- not come from source, so that the debugger will get the |
| -- right information for these generated names. |
| |
| Set_Debug_Info_Needed (New_F); |
| |
| if Ekind (Formal) = E_In_Parameter then |
| Mutate_Ekind (New_F, E_Constant); |
| else |
| Mutate_Ekind (New_F, E_Variable); |
| Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); |
| end if; |
| |
| Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); |
| |
| Renamed_Formal := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To ( |
| Entry_Parameters_Type (Ent), |
| New_Occurrence_Of (Ann, Loc))), |
| Selector_Name => |
| New_Occurrence_Of (Comp, Loc)); |
| |
| Decl := |
| Build_Renamed_Formal_Declaration |
| (New_F, Formal, Comp, Renamed_Formal); |
| |
| 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); |
| T : constant Entity_Id := Defining_Identifier (N); |
| D_T : constant Entity_Id := Designated_Type (T); |
| D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); |
| E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); |
| P_List : constant List_Id := |
| Build_Protected_Spec (N, RTE (RE_Address), D_T, False); |
| |
| Comps : List_Id; |
| Decl1 : Node_Id; |
| Decl2 : Node_Id; |
| Def1 : Node_Id; |
| |
| begin |
| -- Create access to subprogram with full signature |
| |
| if Etype (D_T) /= Standard_Void_Type then |
| Def1 := |
| Make_Access_Function_Definition (Loc, |
| Parameter_Specifications => P_List, |
| Result_Definition => |
| Copy_Result_Type (Result_Definition (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); |
| |
| -- Declare the new types before the original one since the latter will |
| -- refer to them through the Equivalent_Type slot. |
| |
| Insert_Before_And_Analyze (N, Decl1); |
| |
| -- Associate the access to subprogram with its original access to |
| -- protected subprogram type. Needed by the backend to know that this |
| -- type corresponds with an access to protected subprogram type. |
| |
| Set_Original_Access_Type (D_T2, T); |
| |
| -- Create Equivalent_Type, a record with two components for an access to |
| -- object and an access to subprogram. |
| |
| Comps := New_List ( |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, '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_Temporary (Loc, '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_Before_And_Analyze (N, 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 |
| Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); |
| Prot : constant Entity_Id := Scope (Ent); |
| Spec_Decl : constant Node_Id := Parent (Prot); |
| |
| Func_Id : Entity_Id := Empty; |
| -- The entity of the barrier function |
| |
| function Is_Global_Entity (N : Node_Id) return Traverse_Result; |
| -- Check whether entity in Barrier is external to protected type. |
| -- If so, barrier may not be properly synchronized. |
| |
| function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; |
| -- Check whether N meets the Pure_Barriers restriction. Return OK if |
| -- so. |
| |
| function Is_Simple_Barrier (N : Node_Id) return Boolean; |
| -- Check whether N meets the Simple_Barriers restriction. Return OK if |
| -- so. |
| |
| ---------------------- |
| -- Is_Global_Entity -- |
| ---------------------- |
| |
| function Is_Global_Entity (N : Node_Id) return Traverse_Result is |
| E : Entity_Id; |
| S : Entity_Id; |
| |
| begin |
| if Is_Entity_Name (N) and then Present (Entity (N)) then |
| E := Entity (N); |
| S := Scope (E); |
| |
| if Ekind (E) = E_Variable then |
| |
| -- If the variable is local to the barrier function generated |
| -- during expansion, it is ok. If expansion is not performed, |
| -- then Func is Empty so this test cannot succeed. |
| |
| if Scope (E) = Func_Id then |
| null; |
| |
| -- A protected call from a barrier to another object is ok |
| |
| elsif Ekind (Etype (E)) = E_Protected_Type then |
| null; |
| |
| -- If the variable is within the package body we consider |
| -- this safe. This is a common (if dubious) idiom. |
| |
| elsif S = Scope (Prot) |
| and then Is_Package_Or_Generic_Package (S) |
| and then Nkind (Parent (E)) = N_Object_Declaration |
| and then Nkind (Parent (Parent (E))) = N_Package_Body |
| then |
| null; |
| |
| else |
| Error_Msg_N ("potentially unsynchronized barrier??", N); |
| Error_Msg_N ("\& should be private component of type??", N); |
| end if; |
| end if; |
| end if; |
| |
| return OK; |
| end Is_Global_Entity; |
| |
| procedure Check_Unprotected_Barrier is |
| new Traverse_Proc (Is_Global_Entity); |
| |
| ----------------------- |
| -- Is_Simple_Barrier -- |
| ----------------------- |
| |
| function Is_Simple_Barrier (N : Node_Id) return Boolean is |
| Renamed : Node_Id; |
| |
| begin |
| if Is_Static_Expression (N) then |
| return True; |
| elsif Ada_Version >= Ada_2022 |
| and then Nkind (N) in N_Selected_Component | N_Indexed_Component |
| and then Statically_Names_Object (N) |
| then |
| -- Restriction relaxed in Ada 2022 to allow statically named |
| -- subcomponents. |
| return Is_Simple_Barrier (Prefix (N)); |
| end if; |
| |
| -- Check if the name is a component of the protected object. If |
| -- the expander is active, the component has been transformed into a |
| -- renaming of _object.all.component. Original_Node is needed in case |
| -- validity checking is enabled, in which case the simple object |
| -- reference will have been rewritten. |
| |
| if Expander_Active then |
| |
| -- The expanded name may have been constant folded in which case |
| -- the original node is not necessarily an entity name (e.g. an |
| -- indexed component). |
| |
| if not Is_Entity_Name (Original_Node (N)) then |
| return False; |
| end if; |
| |
| Renamed := Renamed_Object (Entity (Original_Node (N))); |
| |
| return |
| Present (Renamed) |
| and then Nkind (Renamed) = N_Selected_Component |
| and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; |
| elsif not Is_Entity_Name (N) then |
| return False; |
| else |
| return Is_Protected_Component (Entity (N)); |
| end if; |
| end Is_Simple_Barrier; |
| |
| --------------------- |
| -- Is_Pure_Barrier -- |
| --------------------- |
| |
| function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is |
| begin |
| case Nkind (N) is |
| when N_Expanded_Name |
| | N_Identifier |
| => |
| |
| -- Because of N_Expanded_Name case, return Skip instead of OK. |
| |
| if No (Entity (N)) then |
| return Abandon; |
| |
| elsif Is_Numeric_Type (Entity (N)) then |
| return Skip; |
| end if; |
| |
| case Ekind (Entity (N)) is |
| when E_Constant |
| | E_Discriminant |
| => |
| return Skip; |
| |
| when E_Enumeration_Literal |
| | E_Named_Integer |
| | E_Named_Real |
| => |
| if not Is_OK_Static_Expression (N) then |
| return Abandon; |
| end if; |
| return Skip; |
| |
| when E_Component => |
| return Skip; |
| |
| when E_Variable => |
| if Is_Simple_Barrier (N) then |
| return Skip; |
| end if; |
| |
| when E_Function => |
| |
| -- The count attribute has been transformed into run-time |
| -- calls. |
| |
| if Is_RTE (Entity (N), RE_Protected_Count) |
| or else Is_RTE (Entity (N), RE_Protected_Count_Entry) |
| then |
| return Skip; |
| end if; |
| |
| when others => |
| null; |
| end case; |
| |
| when N_Function_Call => |
| |
| -- Function call checks are carried out as part of the analysis |
| -- of the function call name. |
| |
| return OK; |
| |
| when N_Character_Literal |
| | N_Integer_Literal |
| | N_Real_Literal |
| => |
| return OK; |
| |
| when N_Op_Boolean |
| | N_Op_Not |
| => |
| if Ekind (Entity (N)) = E_Operator then |
| return OK; |
| end if; |
| |
| when N_Short_Circuit |
| | N_If_Expression |
| | N_Case_Expression |
| => |
| return OK; |
| |
| when N_Indexed_Component | N_Selected_Component => |
| if Statically_Names_Object (N) then |
| return Is_Pure_Barrier (Prefix (N)); |
| else |
| return Abandon; |
| end if; |
| |
| when N_Case_Expression_Alternative => |
| -- do not traverse Discrete_Choices subtree |
| if Is_Pure_Barrier (Expression (N)) /= Abandon then |
| return Skip; |
| end if; |
| |
| when N_Expression_With_Actions => |
| -- this may occur in the case of a Count attribute reference |
| if Is_Rewrite_Substitution (N) |
| and then Is_Pure_Barrier (Original_Node (N)) /= Abandon |
| then |
| return Skip; |
| end if; |
| |
| when N_Membership_Test => |
| if Is_Pure_Barrier (Left_Opnd (N)) /= Abandon |
| and then All_Membership_Choices_Static (N) |
| then |
| return Skip; |
| end if; |
| |
| when N_Type_Conversion => |
| |
| -- Conversions to Universal_Integer do not raise constraint |
| -- errors. Likewise if the expression's type is statically |
| -- compatible with the target's type. |
| |
| if Etype (N) = Universal_Integer |
| or else Subtypes_Statically_Compatible |
| (Etype (Expression (N)), Etype (N)) |
| then |
| return OK; |
| end if; |
| |
| when N_Unchecked_Type_Conversion => |
| return OK; |
| |
| when others => |
| null; |
| end case; |
| |
| return Abandon; |
| end Is_Pure_Barrier; |
| |
| function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); |
| |
| -- Local variables |
| |
| Cond_Id : Entity_Id; |
| Entry_Body : Node_Id; |
| Func_Body : Node_Id := Empty; |
| |
| -- Start of processing for Expand_Entry_Barrier |
| |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("entry barrier", N); |
| return; |
| end if; |
| |
| -- Prevent cascaded errors |
| |
| if Nkind (Cond) = N_Error then |
| 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 the |
| -- barrier just as a protected function, and discard the protected |
| -- version of it because it is never called. |
| |
| if Expander_Active then |
| Func_Body := Build_Barrier_Function (N, Ent, Prot); |
| Func_Id := Barrier_Function (Ent); |
| Set_Corresponding_Spec (Func_Body, Func_Id); |
| |
| Entry_Body := Parent (Corresponding_Body (Spec_Decl)); |
| |
| if Nkind (Parent (Entry_Body)) = N_Subunit then |
| Entry_Body := Corresponding_Stub (Parent (Entry_Body)); |
| end if; |
| |
| Insert_Before_And_Analyze (Entry_Body, Func_Body); |
| |
| Set_Discriminals (Spec_Decl); |
| Set_Scope (Func_Id, Scope (Prot)); |
| |
| else |
| Analyze_And_Resolve (Cond, Any_Boolean); |
| end if; |
| |
| -- Check Simple_Barriers and Pure_Barriers restrictions. |
| -- Note that it is safe to be calling Check_Restriction from here, even |
| -- though this is part of the expander, since Expand_Entry_Barrier is |
| -- called from Sem_Ch9 even in -gnatc mode. |
| |
| if not Is_Simple_Barrier (Cond) then |
| -- flag restriction violation |
| Check_Restriction (Simple_Barriers, Cond); |
| end if; |
| |
| if Check_Pure_Barriers (Cond) = Abandon then |
| -- flag restriction violation |
| Check_Restriction (Pure_Barriers, Cond); |
| |
| -- Emit warning if barrier contains global entities and is thus |
| -- potentially unsynchronized (if Pure_Barriers restrictions |
| -- are met then no need to check for this). |
| Check_Unprotected_Barrier (Cond); |
| end if; |
| |
| if Is_Entity_Name (Cond) then |
| Cond_Id := Entity (Cond); |
| |
| -- Perform a small optimization of simple barrier functions. If the |
| -- scope of the condition's entity is not the barrier function, then |
| -- the condition does not depend on any of the generated renamings. |
| -- If this is the case, eliminate the renamings as they are useless. |
| -- This optimization is not performed when the condition was folded |
| -- and validity checks are in effect because the original condition |
| -- may have produced at least one check that depends on the generated |
| -- renamings. |
| |
| if Expander_Active |
| and then Scope (Cond_Id) /= Func_Id |
| and then not Validity_Check_Operands |
| then |
| Set_Declarations (Func_Body, Empty_List); |
| end if; |
| |
| -- 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. |
| end if; |
| end Expand_Entry_Barrier; |
| |
| ------------------------------ |
| -- 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; |
| |
| -- A task interface class-wide type object is being aborted. Retrieve |
| -- its _task_id by calling a dispatching routine. |
| |
| if Ada_Version >= Ada_2005 |
| and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type |
| and then Is_Interface (Etype (Tasknm)) |
| and then Is_Task_Interface (Etype (Tasknm)) |
| then |
| Append_To (Component_Associations (Aggr), |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Integer_Literal (Loc, Count)), |
| Expression => |
| |
| -- Task_Id (Tasknm._disp_get_task_id) |
| |
| Unchecked_Convert_To |
| (RTE (RO_ST_Task_Id), |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Tasknm), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); |
| |
| else |
| Append_To (Component_Associations (Aggr), |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Integer_Literal (Loc, Count)), |
| Expression => Concurrent_Ref (Tasknm))); |
| end if; |
| |
| Next (Tasknm); |
| end loop; |
| |
| Rewrite (N, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), |
| Parameter_Associations => New_List ( |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => New_Occurrence_Of (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; |
| |
| begin |
| -- If the 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. |
| |
| elsif Trivial_Accept_OK |
| 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_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), |
| Parameter_Associations => New_List ( |
| Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); |
| |
| Analyze (N); |
| |
| -- Ada 2022 (AI12-0279) |
| |
| if Has_Yield_Aspect (Eent) |
| and then RTE_Available (RE_Yield) |
| then |
| Insert_Action_After (N, |
| Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Yield), Loc))); |
| end if; |
| |
| -- 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_Temporary (Loc, 'A'); |
| Mutate_Ekind (Blkent, E_Block); |
| Set_Etype (Blkent, Standard_Void_Type); |
| Set_Scope (Blkent, Current_Scope); |
| |
| Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blkent, Loc), |
| Declarations => Declarations (N), |
| Handled_Statement_Sequence => Build_Accept_Body (N)); |
| |
| -- Reset the Scope of local entities associated with the accept |
| -- statement (that currently reference the entry scope) to the |
| -- block scope, to avoid having references to the locals treated |
| -- as up-level references. |
| |
| Reset_Scopes_To (Block, Blkent); |
| |
| -- For the analysis of the generated declarations, the parent node |
| -- must be properly set. |
| |
| Set_Parent (Block, Parent (N)); |
| Set_Parent (Blkent, Block); |
| |
| -- 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_Occurrence_Of (RTE (RE_Accept_Call), Loc), |
| Parameter_Associations => New_List ( |
| Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), |
| New_Occurrence_Of (Ann, Loc))); |
| |
| if Parent (Stats) = N then |
| Prepend (Call, Statements (Stats)); |
| else |
| Set_Declarations (Parent (Stats), New_List (Call)); |
| end if; |
| |
| Analyze (Call); |
| |
| Push_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 or |
| -- a dispatching procedure 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 |
| -- a 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>, -- Acceptor |
| -- <entry-index>, -- E |
| -- P'Address, -- Uninterpreted_Data |
| -- Asynchronous_Call, -- Mode |
| -- B); -- Rendezvous_Successful |
| |
| -- 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 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 |
| -- (po._object'Access, -- Object |
| -- <entry index>, -- E |
| -- P'Address, -- Uninterpreted_Data |
| -- Asynchronous_Call, -- Mode |
| -- Bnn); -- Block |
| |
| -- 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; |
| -- 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 |
| -- (po._object'Access, -- Object |
| -- <entry index>, -- E |
| -- P'Address, -- Uninterpreted_Data |
| -- Simple_Call, -- Mode |
| -- Bnn); -- Block |
| -- parm := P.param; |
| -- parm := P.param; |
| -- ... |
| -- end; |
| |
| -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is |
| -- expanded into: |
| |
| -- declare |
| -- B : Boolean := False; |
| -- Bnn : Communication_Block; |
| -- C : Ada.Tags.Prim_Op_Kind; |
| -- D : System.Storage_Elements.Dummy_Communication_Block; |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); |
| -- P : Parameters := (Param1 .. ParamN); |
| -- S : Integer; |
| -- U : Boolean; |
| |
| -- begin |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- <dispatching-call>; |
| -- <triggering-statements>; |
| |
| -- else |
| -- S := |
| -- Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); |
| |
| -- _Disp_Get_Prim_Op_Kind (<object>, S, C); |
| |
| -- if C = POK_Protected_Entry then |
| -- declare |
| -- procedure _clean is |
| -- begin |
| -- if Enqueued (Bnn) then |
| -- Cancel_Protected_Entry_Call (Bnn); |
| -- end if; |
| -- end _clean; |
| |
| -- begin |
| -- begin |
| -- _Disp_Asynchronous_Select |
| -- (<object>, S, P'Address, D, B); |
| -- Bnn := Communication_Block (D); |
| |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| |
| -- if Enqueued (Bnn) then |
| -- <abortable-statements> |
| -- end if; |
| -- at end |
| -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions |
| -- end; |
| -- exception |
| -- when Abort_Signal => Abort_Undefer; |
| -- end; |
| |
| -- if not Cancelled (Bnn) then |
| -- <triggering-statements> |
| -- end if; |
| |
| -- elsif C = POK_Task_Entry then |
| -- declare |
| -- procedure _clean is |
| -- begin |
| -- Cancel_Task_Entry_Call (U); |
| -- end _clean; |
| |
| -- begin |
| -- Abort_Defer; |
| |
| -- _Disp_Asynchronous_Select |
| -- (<object>, S, P'Address, D, B); |
| -- Bnn := Communication_Bloc (D); |
| |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| |
| -- begin |
| -- begin |
| -- Abort_Undefer; |
| -- <abortable-statements> |
| -- at end |
| -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions |
| -- end; |
| -- exception |
| -- when Abort_Signal => Abort_Undefer; |
| -- end; |
| |
| -- if not U then |
| -- <triggering-statements> |
| -- end if; |
| -- end; |
| |
| -- else |
| -- <dispatching-call>; |
| -- <triggering-statements> |
| -- end if; |
| -- end if; |
| -- 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); |
| Abrt : constant Node_Id := Abortable_Part (N); |
| Trig : constant Node_Id := Triggering_Alternative (N); |
| |
| Abort_Block_Ent : Entity_Id; |
| Abortable_Block : Node_Id; |
| Actuals : List_Id; |
| Astats : List_Id; |
| Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| Blk_Typ : Entity_Id; |
| Call : Node_Id; |
| Call_Ent : Entity_Id; |
| Cancel_Param : Entity_Id; |
| Cleanup_Block : Node_Id; |
| Cleanup_Block_Ent : Entity_Id; |
| Cleanup_Stmts : List_Id; |
| Conc_Typ_Stmts : List_Id; |
| Concval : Node_Id; |
| Dblock_Ent : Entity_Id; |
| Decl : Node_Id; |
| Decls : List_Id; |
| Ecall : Node_Id; |
| Ename : Node_Id; |
| Enqueue_Call : Node_Id; |
| Formals : List_Id; |
| Hdle : List_Id; |
| Index : Node_Id; |
| Lim_Typ_Stmts : List_Id; |
| N_Orig : Node_Id; |
| Obj : Entity_Id; |
| Param : Node_Id; |
| Params : List_Id; |
| Pdef : Entity_Id; |
| ProtE_Stmts : List_Id; |
| ProtP_Stmts : List_Id; |
| Stmt : Node_Id; |
| Stmts : List_Id; |
| TaskE_Stmts : List_Id; |
| Tstats : List_Id; |
| |
| B : Entity_Id; -- Call status flag |
| Bnn : Entity_Id; -- Communication block |
| C : Entity_Id; -- Call kind |
| K : Entity_Id; -- Tagged kind |
| P : Entity_Id; -- Parameter block |
| S : Entity_Id; -- Primitive operation slot |
| T : Entity_Id; -- Additional status flag |
| |
| procedure Rewrite_Abortable_Part; |
| -- If the trigger is a dispatching call, the expansion inserts multiple |
| -- copies of the abortable part. This is both inefficient, and may lead |
| -- to duplicate definitions that the back-end will reject, when the |
| -- abortable part includes loops. This procedure rewrites the abortable |
| -- part into a call to a generated procedure. |
| |
| ---------------------------- |
| -- Rewrite_Abortable_Part -- |
| ---------------------------- |
| |
| procedure Rewrite_Abortable_Part is |
| Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); |
| Decl : Node_Id; |
| |
| begin |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Astats)); |
| Insert_Before (N, Decl); |
| Analyze (Decl); |
| |
| -- Rewrite abortable part into a call to this procedure |
| |
| Astats := |
| New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc))); |
| end Rewrite_Abortable_Part; |
| |
| -- Start of processing for Expand_N_Asynchronous_Select |
| |
| begin |
| -- Asynchronous select is not supported on restricted runtimes. Don't |
| -- try to expand. |
| |
| if Restricted_Profile then |
| return; |
| end if; |
| |
| Process_Statements_For_Controlled_Objects (Trig); |
| Process_Statements_For_Controlled_Objects (Abrt); |
| |
| Ecall := Triggering_Statement (Trig); |
| |
| Ensure_Statement_Present (Sloc (Ecall), Trig); |
| |
| -- Retrieve Astats and Tstats now because the finalization machinery may |
| -- wrap them in blocks. |
| |
| Astats := Statements (Abrt); |
| Tstats := Statements (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) not in |
| N_Procedure_Call_Statement | N_Entry_Call_Statement |
| loop |
| Next (Ecall); |
| end loop; |
| end if; |
| |
| -- This is either a dispatching call or a delay statement used as a |
| -- trigger which was expanded into a procedure call. |
| |
| if Nkind (Ecall) = N_Procedure_Call_Statement then |
| if Ada_Version >= Ada_2005 |
| and then |
| (No (Original_Node (Ecall)) |
| or else Nkind (Original_Node (Ecall)) not in N_Delay_Statement) |
| then |
| Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); |
| |
| Rewrite_Abortable_Part; |
| Decls := New_List; |
| Stmts := New_List; |
| |
| -- Call status flag processing, generate: |
| -- B : Boolean := False; |
| |
| B := Build_B (Loc, Decls); |
| |
| -- Communication block processing, generate: |
| -- Bnn : Communication_Block; |
| |
| Bnn := Make_Temporary (Loc, 'B'); |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Bnn, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); |
| |
| -- Call kind processing, generate: |
| -- C : Ada.Tags.Prim_Op_Kind; |
| |
| C := Build_C (Loc, Decls); |
| |
| -- Tagged kind processing, generate: |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); |
| |
| -- Dummy communication block, generate: |
| -- D : Dummy_Communication_Block; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uD), |
| Object_Definition => |
| New_Occurrence_Of |
| (RTE (RE_Dummy_Communication_Block), Loc))); |
| |
| K := Build_K (Loc, Decls, Obj); |
| |
| -- Parameter block processing |
| |
| Blk_Typ := Build_Parameter_Block |
| (Loc, Actuals, Formals, Decls); |
| P := Parameter_Block_Pack |
| (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); |
| |
| -- Dispatch table slot processing, generate: |
| -- S : Integer; |
| |
| S := Build_S (Loc, Decls); |
| |
| -- Additional status flag processing, generate: |
| -- Tnn : Boolean; |
| |
| T := Make_Temporary (Loc, 'T'); |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => T, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| ------------------------------ |
| -- Protected entry handling -- |
| ------------------------------ |
| |
| -- Generate: |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| |
| Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); |
| |
| -- Generate: |
| -- Bnn := Communication_Block (D); |
| |
| Prepend_To (Cleanup_Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Bnn, Loc), |
| Expression => |
| Unchecked_Convert_To |
| (RTE (RE_Communication_Block), |
| Make_Identifier (Loc, Name_uD)))); |
| |
| -- Generate: |
| -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); |
| |
| Prepend_To (Cleanup_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Find_Prim_Op |
| (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), |
| Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Copy_Tree (Obj), -- <object> |
| New_Occurrence_Of (S, Loc), -- S |
| Make_Attribute_Reference (Loc, -- P'Address |
| Prefix => New_Occurrence_Of (P, Loc), |
| Attribute_Name => Name_Address), |
| Make_Identifier (Loc, Name_uD), -- D |
| New_Occurrence_Of (B, Loc)))); -- B |
| |
| -- Generate: |
| -- if Enqueued (Bnn) then |
| -- <abortable-statements> |
| -- end if; |
| |
| Append_To (Cleanup_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Enqueued), Loc), |
| Parameter_Associations => |
| New_List (New_Occurrence_Of (Bnn, Loc))), |
| |
| Then_Statements => |
| New_Copy_List_Tree (Astats))); |
| |
| -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions |
| -- will then generate a _clean for the communication block Bnn. |
| |
| -- Generate: |
| -- declare |
| -- procedure _clean is |
| -- begin |
| -- if Enqueued (Bnn) then |
| -- Cancel_Protected_Entry_Call (Bnn); |
| -- end if; |
| -- end _clean; |
| -- begin |
| -- Cleanup_Stmts |
| -- at end |
| -- _clean; |
| -- end; |
| |
| Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); |
| Cleanup_Block := |
| Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); |
| |
| -- Wrap the cleanup block in an exception handling block |
| |
| -- Generate: |
| -- begin |
| -- Cleanup_Block |
| -- exception |
| -- when Abort_Signal => Abort_Undefer; |
| -- end; |
| |
| Abort_Block_Ent := Make_Temporary (Loc, 'A'); |
| ProtE_Stmts := |
| New_List ( |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Abort_Block_Ent), |
| |
| Build_Abort_Block |
| (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); |
| |
| -- Generate: |
| -- if not Cancelled (Bnn) then |
| -- <triggering-statements> |
| -- end if; |
| |
| Append_To (ProtE_Stmts, |
| 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 (Bnn, Loc)))), |
| |
| Then_Statements => |
| New_Copy_List_Tree (Tstats))); |
| |
| ------------------------- |
| -- Task entry handling -- |
| ------------------------- |
| |
| -- Generate: |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| |
| TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); |
| |
| -- Generate: |
| -- Bnn := Communication_Block (D); |
| |
| Append_To (TaskE_Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Bnn, Loc), |
| Expression => |
| Unchecked_Convert_To |
| (RTE (RE_Communication_Block), |
| Make_Identifier (Loc, Name_uD)))); |
| |
| -- Generate: |
| -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); |
| |
| Prepend_To (TaskE_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| Find_Prim_Op (Etype (Etype (Obj)), |
| Name_uDisp_Asynchronous_Select), |
| Loc), |
| |
| Parameter_Associations => New_List ( |
| New_Copy_Tree (Obj), -- <object> |
| New_Occurrence_Of (S, Loc), -- S |
| Make_Attribute_Reference (Loc, -- P'Address |
| Prefix => New_Occurrence_Of (P, Loc), |
| Attribute_Name => Name_Address), |
| Make_Identifier (Loc, Name_uD), -- D |
| New_Occurrence_Of (B, Loc)))); -- B |
| |
| -- Generate: |
| -- Abort_Defer; |
| |
| Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| |
| -- Generate: |
| -- Abort_Undefer; |
| -- <abortable-statements> |
| |
| Cleanup_Stmts := New_Copy_List_Tree (Astats); |
| |
| Prepend_To |
| (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| |
| -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions |
| -- will generate a _clean for the additional status flag. |
| |
| -- Generate: |
| -- declare |
| -- procedure _clean is |
| -- begin |
| -- Cancel_Task_Entry_Call (U); |
| -- end _clean; |
| -- begin |
| -- Cleanup_Stmts |
| -- at end |
| -- _clean; |
| -- end; |
| |
| Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); |
| Cleanup_Block := |
| Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); |
| |
| -- Wrap the cleanup block in an exception handling block |
| |
| -- Generate: |
| -- begin |
| -- Cleanup_Block |
| -- exception |
| -- when Abort_Signal => Abort_Undefer; |
| -- end; |
| |
| Abort_Block_Ent := Make_Temporary (Loc, 'A'); |
| |
| Append_To (TaskE_Stmts, |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Abort_Block_Ent)); |
| |
| Append_To (TaskE_Stmts, |
| Build_Abort_Block |
| (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); |
| |
| -- Generate: |
| -- if not T then |
| -- <triggering-statements> |
| -- end if; |
| |
| Append_To (TaskE_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), |
| |
| Then_Statements => |
| New_Copy_List_Tree (Tstats))); |
| |
| ---------------------------------- |
| -- Protected procedure handling -- |
| ---------------------------------- |
| |
| -- Generate: |
| -- <dispatching-call>; |
| -- <triggering-statements> |
| |
| ProtP_Stmts := New_Copy_List_Tree (Tstats); |
| Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); |
| |
| -- Generate: |
| -- S := Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); |
| |
| Conc_Typ_Stmts := |
| New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); |
| |
| -- Generate: |
| -- _Disp_Get_Prim_Op_Kind (<object>, S, C); |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Find_Prim_Op (Etype (Etype (Obj)), |
| Name_uDisp_Get_Prim_Op_Kind), |
| Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Copy_Tree (Obj), |
| New_Occurrence_Of (S, Loc), |
| New_Occurrence_Of (C, Loc)))); |
| |
| -- Generate: |
| -- if C = POK_Procedure_Entry then |
| -- ProtE_Stmts |
| -- elsif C = POK_Task_Entry then |
| -- TaskE_Stmts |
| -- else |
| -- ProtP_Stmts |
| -- end if; |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), |
| |
| Then_Statements => |
| ProtE_Stmts, |
| |
| Elsif_Parts => |
| New_List ( |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), |
| |
| Then_Statements => |
| TaskE_Stmts)), |
| |
| Else_Statements => |
| ProtP_Stmts)); |
| |
| -- Generate: |
| -- <dispatching-call>; |
| -- <triggering-statements> |
| |
| Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); |
| Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); |
| |
| -- Generate: |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- Lim_Typ_Stmts |
| -- else |
| -- Conc_Typ_Stmts |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => Build_Dispatching_Tag_Check (K, N), |
| Then_Statements => Lim_Typ_Stmts, |
| Else_Statements => Conc_Typ_Stmts)); |
| |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Declarations => |
| Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts))); |
| |
| Analyze (N); |
| return; |
| |
| -- Delay triggering statement processing |
| |
| else |
| -- 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_Temporary (Loc, 'D'); |
| |
| Pdef := Entity (Name (Ecall)); |
| |
| if Is_RTE (Pdef, RO_CA_Delay_For) then |
| Enqueue_Call := |
| New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); |
| |
| elsif Is_RTE (Pdef, RO_CA_Delay_Until) then |
| Enqueue_Call := |
| New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); |
| |
| else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); |
| Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); |
| end if; |
| |
| Append_To (Parameter_Associations (Ecall), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Dblock_Ent, Loc), |
| Attribute_Name => Name_Unchecked_Access)); |
| |
| -- Create the inner block to protect the abortable part |
| |
| Hdle := New_List (Build_Abort_Block_Handler (Loc)); |
| |
| Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| |
| Abortable_Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blk_Ent, 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 => Blk_Ent, |
| 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_Occurrence_Of ( |
| RTE (RE_Timed_Out), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Dblock_Ent, Loc), |
| Attribute_Name => Name_Unchecked_Access))), |
| Then_Statements => Tstats)); |
| |
| -- The result is the new block |
| |
| Set_Entry_Cancel_Parameter (Blk_Ent, 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_Occurrence_Of (RTE (RE_Delay_Block), Loc))), |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts))); |
| |
| Analyze (N); |
| return; |
| end if; |
| |
| 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); |
| |
| -- 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 ??? |
| |
| Stmt := First (Stmts); |
| while Nkind (Stmt) /= N_Procedure_Call_Statement loop |
| Next (Stmt); |
| end loop; |
| |
| Call := Stmt; |
| |
| Param := First (Parameter_Associations (Call)); |
| while Present (Param) |
| and then not Is_RTE (Etype (Param), RE_Call_Modes) |
| loop |
| Next (Param); |
| end loop; |
| |
| pragma Assert (Present (Param)); |
| Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); |
| Analyze (Param); |
| |
| -- Append an if statement to execute the abortable part |
| |
| -- Generate: |
| -- if Enqueued (Bnn) then |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Cancel_Param, Loc))), |
| Then_Statements => Astats)); |
| |
| Abortable_Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blk_Ent, Loc), |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), |
| Has_Created_Identifier => True, |
| Is_Asynchronous_Call_Block => True); |
| |
| 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 => Blk_Ent, |
| Label_Construct => Abortable_Block), |
| Abortable_Block), |
| |
| -- exception |
| |
| Exception_Handlers => New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| |
| -- when Abort_Signal => |
| -- null; |
| |
| Exception_Choices => |
| New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))))), |
| |
| -- 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_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); |
| |
| -- Insert the declaration of C in the declarations of the existing |
| -- block. The variable is initialized to something (True or False, |
| -- does not matter) to prevent CodePeer from complaining about a |
| -- possible read of an uninitialized variable. |
| |
| Prepend_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Cancel_Param, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc), |
| Has_Init_Expression => True)); |
| |
| -- 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 (Build_Abort_Block_Handler (Loc)); |
| |
| if Abort_Allowed then |
| Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| end if; |
| |
| Abortable_Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Blk_Ent, 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 => Blk_Ent, |
| Label_Construct => Abortable_Block), |
| Abortable_Block), |
| Exception_Handlers => Hdle))); |
| |
| -- Create new call statement |
| |
| Params := Parameter_Associations (Call); |
| |
| Append_To (Params, |
| New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); |
| Append_To (Params, New_Occurrence_Of (B, Loc)); |
| |
| Rewrite (Call, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), |
| Parameter_Associations => Params)); |
| |
| -- Construct statement sequence for new block |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), |
| Then_Statements => Tstats)); |
| |
| -- Protected the call against abort |
| |
| Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| end if; |
| |
| Set_Entry_Cancel_Parameter (Blk_Ent, 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>, -- Acceptor |
| -- <entry-index>, -- E |
| -- P'Address, -- Uninterpreted_Data |
| -- Conditional_Call, -- Mode |
| -- B); -- Rendezvous_Successful |
| -- 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_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 |
| |
| -- The conditional protected entry call is converted to a call to |
| -- Protected_Entry_Call: |
| |
| -- declare |
| -- P : parms := (parm, parm, parm); |
| -- Bnn : Communications_Block; |
| |
| -- begin |
| -- Protected_Entry_Call |
| -- (po._object'Access, -- Object |
| -- <entry index>, -- E |
| -- P'Address, -- Uninterpreted_Data |
| -- Conditional_Call, -- Mode |
| -- Bnn); -- Block |
| -- parm := P.param; |
| -- parm := P.param; |
| -- ... |
| -- if Cancelled (Bnn) then |
| -- else-statements |
| -- else |
| -- normal-statements |
| -- end if; |
| -- end; |
| |
| -- Ada 2005 (AI-345): A dispatching conditional entry call is converted |
| -- into: |
| |
| -- declare |
| -- B : Boolean := False; |
| -- C : Ada.Tags.Prim_Op_Kind; |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); |
| -- P : Parameters := (Param1 .. ParamN); |
| -- S : Integer; |
| |
| -- begin |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- <dispatching-call>; |
| -- <triggering-statements> |
| |
| -- else |
| -- S := |
| -- Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); |
| |
| -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); |
| |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| -- end if; |
| |
| -- if B then |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure |
| -- then |
| -- <dispatching-call>; |
| -- end if; |
| |
| -- <triggering-statements> |
| -- else |
| -- <else-statements> |
| -- end if; |
| -- end if; |
| -- end; |
| |
| procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Alt : constant Node_Id := Entry_Call_Alternative (N); |
| Blk : Node_Id := Entry_Call_Statement (Alt); |
| |
| Actuals : List_Id; |
| Blk_Typ : Entity_Id; |
| Call : Node_Id; |
| Call_Ent : Entity_Id; |
| Conc_Typ_Stmts : List_Id; |
| Decl : Node_Id; |
| Decls : List_Id; |
| Formals : List_Id; |
| Lim_Typ_Stmts : List_Id; |
| N_Stats : List_Id; |
| Obj : Entity_Id; |
| Param : Node_Id; |
| Params : List_Id; |
| Stmt : Node_Id; |
| Stmts : List_Id; |
| Transient_Blk : Node_Id; |
| Unpack : List_Id; |
| |
| B : Entity_Id; -- Call status flag |
| C : Entity_Id; -- Call kind |
| K : Entity_Id; -- Tagged kind |
| P : Entity_Id; -- Parameter block |
| S : Entity_Id; -- Primitive operation slot |
| |
| begin |
| Process_Statements_For_Controlled_Objects (N); |
| |
| if Ada_Version >= Ada_2005 |
| and then Nkind (Blk) = N_Procedure_Call_Statement |
| then |
| Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); |
| |
| Decls := New_List; |
| Stmts := New_List; |
| |
| -- Call status flag processing, generate: |
| -- B : Boolean := False; |
| |
| B := Build_B (Loc, Decls); |
| |
| -- Call kind processing, generate: |
| -- C : Ada.Tags.Prim_Op_Kind; |
| |
| C := Build_C (Loc, Decls); |
| |
| -- Tagged kind processing, generate: |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); |
| |
| K := Build_K (Loc, Decls, Obj); |
| |
| -- Parameter block processing |
| |
| Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); |
| P := Parameter_Block_Pack |
| (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); |
| |
| -- Dispatch table slot processing, generate: |
| -- S : Integer; |
| |
| S := Build_S (Loc, Decls); |
| |
| -- Generate: |
| -- S := Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); |
| |
| Conc_Typ_Stmts := |
| New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); |
| |
| -- Generate: |
| -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| Find_Prim_Op (Etype (Etype (Obj)), |
| Name_uDisp_Conditional_Select), |
| Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Copy_Tree (Obj), -- <object> |
| New_Occurrence_Of (S, Loc), -- S |
| Make_Attribute_Reference (Loc, -- P'Address |
| Prefix => New_Occurrence_Of (P, Loc), |
| Attribute_Name => Name_Address), |
| New_Occurrence_Of (C, Loc), -- C |
| New_Occurrence_Of (B, Loc)))); -- B |
| |
| -- Generate: |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| -- end if; |
| |
| Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); |
| |
| -- Generate the if statement only when the packed parameters need |
| -- explicit assignments to their corresponding actuals. |
| |
| if Present (Unpack) then |
| Append_To (Conc_Typ_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE ( |
| RE_POK_Protected_Entry), Loc)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), |
| |
| Then_Statements => Unpack)); |
| end if; |
| |
| -- Generate: |
| -- if B then |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure |
| -- then |
| -- <dispatching-call> |
| -- end if; |
| -- <normal-statements> |
| -- else |
| -- <else-statements> |
| -- end if; |
| |
| N_Stats := New_Copy_Separate_List (Statements (Alt)); |
| |
| Prepend_To (N_Stats, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), |
| |
| Right_Opnd => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE ( |
| RE_POK_Protected_Procedure), Loc)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE ( |
| RE_POK_Task_Procedure), Loc)))), |
| |
| Then_Statements => |
| New_List (Blk))); |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (B, Loc), |
| Then_Statements => N_Stats, |
| Else_Statements => Else_Statements (N))); |
| |
| -- Generate: |
| -- <dispatching-call>; |
| -- <triggering-statements> |
| |
| Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt)); |
| Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); |
| |
| -- Generate: |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- Lim_Typ_Stmts |
| -- else |
| -- Conc_Typ_Stmts |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => Build_Dispatching_Tag_Check (K, N), |
| Then_Statements => Lim_Typ_Stmts, |
| Else_Statements => Conc_Typ_Stmts)); |
| |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Declarations => |
| Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts))); |
| |
| -- As described above, the entry alternative is transformed into a |
| -- block that contains the gnulli call, and possibly assignment |
| -- statements for in-out parameters. The gnulli call may itself be |
| -- rewritten into a transient block if some unconstrained parameters |
| -- require it. We need to retrieve the call to complete its parameter |
| -- list. |
| |
| else |
| Transient_Blk := |
| First (Statements (Handled_Statement_Sequence (Blk))); |
| |
| if Present (Transient_Blk) |
| and then Nkind (Transient_Blk) = N_Block_Statement |
| then |
| Blk := Transient_Blk; |
| end if; |
| |
| Stmts := Statements (Handled_Statement_Sequence (Blk)); |
| Stmt := First (Stmts); |
| while Nkind (Stmt) /= N_Procedure_Call_Statement loop |
| Next (Stmt); |
| end loop; |
| |
| Call := Stmt; |
| Params := Parameter_Associations (Call); |
| |
| if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then |
| |
| -- Substitute Conditional_Entry_Call for Simple_Call parameter |
| |
| Param := First (Params); |
| while Present (Param) |
| and then not Is_RTE (Etype (Param), RE_Call_Modes) |
| loop |
| Next (Param); |
| end loop; |
| |
| pragma Assert (Present (Param)); |
| Rewrite (Param, |
| New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); |
| |
| Analyze (Param); |
| |
| -- Find the Communication_Block parameter for the call to the |
| -- Cancelled function. |
| |
| Decl := First (Declarations (Blk)); |
| while Present (Decl) |
| and then not Is_RTE (Etype (Object_Definition (Decl)), |
| RE_Communication_Block) |
| loop |
| Next (Decl); |
| end loop; |
| |
| -- Add an if statement to execute the else part if the call |
| -- does not succeed (as indicated by the Cancelled predicate). |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Defining_Identifier (Decl), Loc))), |
| Then_Statements => Else_Statements (N), |
| Else_Statements => Statements (Alt))); |
| |
| else |
| B := Make_Defining_Identifier (Loc, Name_uB); |
| |
| -- Insert declaration of B in declarations of existing block |
| |
| if No (Declarations (Blk)) then |
| Set_Declarations (Blk, New_List); |
| end if; |
| |
| Prepend_To (Declarations (Blk), |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => B, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| -- Create new call statement |
| |
| Append_To (Params, |
| New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); |
| Append_To (Params, New_Occurrence_Of (B, Loc)); |
| |
| Rewrite (Call, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), |
| Parameter_Associations => Params)); |
| |
| -- Construct statement sequence for new block |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (B, Loc), |
| Then_Statements => Statements (Alt), |
| Else_Statements => Else_Statements (N))); |
| end if; |
| |
| -- The result is the new block |
| |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Declarations => Declarations (Blk), |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts))); |
| end if; |
| |
| Analyze (N); |
| |
| Reset_Scopes_To (N, Entity (Identifier (N))); |
| end Expand_N_Conditional_Entry_Call; |
| |
| --------------------------------------- |
| -- Expand_N_Delay_Relative_Statement -- |
| --------------------------------------- |
| |
| -- Delay statement is implemented as a procedure call to Delay_For |
| -- defined in Ada.Calendar.Delays in order to reduce the overhead of |
| -- simple delays imposed by the use of Protected Objects. |
| |
| procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Proc : Entity_Id; |
| |
| begin |
| -- Try to use Ada.Calendar.Delays.Delay_For if available. |
| |
| if RTE_Available (RO_CA_Delay_For) then |
| Proc := RTE (RO_CA_Delay_For); |
| |
| -- Otherwise, use System.Relative_Delays.Delay_For and emit an error |
| -- message if not available. This is the implementation used on |
| -- restricted platforms when Ada.Calendar is not available. |
| |
| else |
| Proc := RTE (RO_RD_Delay_For); |
| end if; |
| |
| Rewrite (N, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => New_List (Expression (N)))); |
| Analyze (N); |
| end Expand_N_Delay_Relative_Statement; |
| |
| ------------------------------------ |
| -- Expand_N_Delay_Until_Statement -- |
| ------------------------------------ |
| |
| -- Delay Until statement is implemented as a procedure call to |
| -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. |
| |
| procedure Expand_N_Delay_Until_Statement (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Typ : Entity_Id; |
| |
| begin |
| if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then |
| Typ := RTE (RO_CA_Delay_Until); |
| else |
| Typ := RTE (RO_RT_Delay_Until); |
| end if; |
| |
| Rewrite (N, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Typ, Loc), |
| Parameter_Associations => New_List (Expression (N)))); |
| |
| Analyze (N); |
| end Expand_N_Delay_Until_Statement; |
| |
| ------------------------- |
| -- Expand_N_Entry_Body -- |
| ------------------------- |
| |
| procedure Expand_N_Entry_Body (N : Node_Id) is |
| begin |
| -- Associate discriminals with the next protected operation body to be |
| -- expanded. |
| |
| if Present (Next_Protected_Operation (N)) then |
| Set_Discriminals (Parent (Current_Scope)); |
| end if; |
| end Expand_N_Entry_Body; |
| |
| ----------------------------------- |
| -- Expand_N_Entry_Call_Statement -- |
| ----------------------------------- |
| |
| -- An entry call is expanded into GNARLI calls to implement a simple entry |
| -- call (see Build_Simple_Entry_Call). |
| |
| procedure Expand_N_Entry_Call_Statement (N : Node_Id) is |
| Concval : Node_Id; |
| Ename : Node_Id; |
| Index : Node_Id; |
| |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("entry call", N); |
| return; |
| end if; |
| |
| -- If this entry call is part of an asynchronous select, don't expand it |
| -- here; it will be expanded with the select statement. Don't expand |
| -- timed entry calls either, as they are translated into asynchronous |
| -- entry calls. |
| |
| -- ??? This whole approach is questionable; it may be better to go back |
| -- to allowing the expansion to take place and then attempting to fix it |
| -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out |
| -- whether the expanded call is on a task or protected entry. |
| |
| if (Nkind (Parent (N)) /= N_Triggering_Alternative |
| or else N /= Triggering_Statement (Parent (N))) |
| and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative |
| or else N /= Entry_Call_Statement (Parent (N)) |
| or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) |
| then |
| Extract_Entry (N, Concval, Ename, Index); |
| Build_Simple_Entry_Call (N, Concval, Ename, Index); |
| end if; |
| end Expand_N_Entry_Call_Statement; |
| |
| -------------------------------- |
| -- Expand_N_Entry_Declaration -- |
| -------------------------------- |
| |
| -- If there are parameters, then first, each of the formals is marked by |
| -- setting Is_Entry_Formal. Next a record type is built which is used to |
| -- hold the parameter values. The name of this record type is entryP where |
| -- entry is the name of the entry, with an additional corresponding access |
| -- type called entryPA. The record type has matching components for each |
| -- formal (the component names are the same as the formal names). For |
| -- elementary types, the component type matches the formal type. For |
| -- composite types, an access type is declared (with the name formalA) |
| -- which designates the formal type, and the type of the component is this |
| -- access type. Finally the Entry_Component of each formal is set to |
| -- reference the corresponding record component. |
| |
| procedure Expand_N_Entry_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Entry_Ent : constant Entity_Id := Defining_Identifier (N); |
| Components : List_Id; |
| Formal : Node_Id; |
| Ftype : Entity_Id; |
| Last_Decl : Node_Id; |
| Component : Entity_Id; |
| Ctype : Entity_Id; |
| Decl : Node_Id; |
| Rec_Ent : Entity_Id; |
| Acc_Ent : Entity_Id; |
| |
| begin |
| Formal := First_Formal (Entry_Ent); |
| Last_Decl := N; |
| |
| -- Most processing is done only if parameters are present |
| |
| if Present (Formal) then |
| Components := New_List; |
| |
| -- Loop through formals |
| |
| while Present (Formal) loop |
| Set_Is_Entry_Formal (Formal); |
| Component := |
| Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); |
| Set_Entry_Component (Formal, Component); |
| Set_Entry_Formal (Component, Formal); |
| Ftype := Etype (Formal); |
| |
| -- Declare new access type and then append |
| |
| Ctype := Make_Temporary (Loc, 'A'); |
| Set_Is_Param_Block_Component_Type (Ctype); |
| |
| Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Ctype, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Constant_Present => Ekind (Formal) = E_In_Parameter, |
| Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); |
| |
| Insert_After (Last_Decl, Decl); |
| Last_Decl := Decl; |
| |
| Append_To (Components, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Component, |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); |
| |
| Next_Formal_With_Extras (Formal); |
| end loop; |
| |
| -- Create the Entry_Parameter_Record declaration |
| |
| Rec_Ent := Make_Temporary (Loc, 'P'); |
| |
| Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Rec_Ent, |
| Type_Definition => |
| Make_Record_Definition (Loc, |
| Component_List => |
| Make_Component_List (Loc, |
| Component_Items => Components))); |
| |
| Insert_After (Last_Decl, Decl); |
| Last_Decl := Decl; |
| |
| -- Construct and link in the corresponding access type |
| |
| Acc_Ent := Make_Temporary (Loc, 'A'); |
| |
| Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); |
| |
| Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Acc_Ent, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); |
| |
| Insert_After (Last_Decl, Decl); |
| end if; |
| end Expand_N_Entry_Declaration; |
| |
| ----------------------------- |
| -- Expand_N_Protected_Body -- |
| ----------------------------- |
| |
| -- Protected bodies are expanded to the completion of the subprograms |
| -- created for the corresponding protected type. These are a protected and |
| -- unprotected version of each protected subprogram in the object, a |
| -- function to calculate each entry barrier, and a procedure to execute the |
| -- sequence of statements of each protected entry body. For example, for |
| -- protected type ptype: |
| |
| -- function entB |
| -- (O : System.Address; |
| -- E : Protected_Entry_Index) |
| -- return Boolean |
| -- is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- begin |
| -- return <barrier expression>; |
| -- end entB; |
| |
| -- procedure pprocN (_object : in out poV;...) is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- begin |
| -- <sequence of statements> |
| -- end pprocN; |
| |
| -- procedure pprocP (_object : in out poV;...) is |
| -- procedure _clean is |
| -- Pn : Boolean; |
| -- begin |
| -- ptypeS (_object, Pn); |
| -- Unlock (_object._object'Access); |
| -- Abort_Undefer.all; |
| -- end _clean; |
| |
| -- begin |
| -- Abort_Defer.all; |
| -- Lock (_object._object'Access); |
| -- pprocN (_object;...); |
| -- at end |
| -- _clean; |
| -- end pproc; |
| |
| -- function pfuncN (_object : poV;...) return Return_Type is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- begin |
| -- <sequence of statements> |
| -- end pfuncN; |
| |
| -- function pfuncP (_object : poV) return Return_Type is |
| -- procedure _clean is |
| -- begin |
| -- Unlock (_object._object'Access); |
| -- Abort_Undefer.all; |
| -- end _clean; |
| |
| -- begin |
| -- Abort_Defer.all; |
| -- Lock (_object._object'Access); |
| -- return pfuncN (_object); |
| |
| -- at end |
| -- _clean; |
| -- end pfunc; |
| |
| -- procedure entE |
| -- (O : System.Address; |
| -- P : System.Address; |
| -- E : Protected_Entry_Index) |
| -- is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- type poVP is access poV; |
| -- _Object : ptVP := ptVP!(O); |
| |
| -- begin |
| -- begin |
| -- <statement sequence> |
| -- Complete_Entry_Body (_Object._Object); |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Entry_Body ( |
| -- _Object._Object, Get_GNAT_Exception); |
| -- end; |
| -- end entE; |
| |
| -- The type poV is the record created for the protected type to hold |
| -- the state of the protected object. |
| |
| procedure Expand_N_Protected_Body (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Pid : constant Entity_Id := Corresponding_Spec (N); |
| |
| Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); |
| -- This flag indicates whether the lock free implementation is active |
| |
| Current_Node : Node_Id; |
| Disp_Op_Body : Node_Id; |
| New_Op_Body : Node_Id; |
| Op_Body : Node_Id; |
| Op_Decl : Node_Id; |
| Op_Id : Entity_Id; |
| |
| function Build_Dispatching_Subprogram_Body |
| (N : Node_Id; |
| Pid : Node_Id; |
| Prot_Bod : Node_Id) return Node_Id; |
| -- Build a dispatching version of the protected subprogram body. The |
| -- newly generated subprogram contains a call to the original protected |
| -- body. The following code is generated: |
| -- |
| -- function <protected-function-name> (Param1 .. ParamN) return |
| -- <return-type> is |
| -- begin |
| -- return <protected-function-name>P (Param1 .. ParamN); |
| -- end <protected-function-name>; |
| -- |
| -- or |
| -- |
| -- procedure <protected-procedure-name> (Param1 .. ParamN) is |
| -- begin |
| -- <protected-procedure-name>P (Param1 .. ParamN); |
| -- end <protected-procedure-name> |
| |
| --------------------------------------- |
| -- Build_Dispatching_Subprogram_Body -- |
| --------------------------------------- |
| |
| function Build_Dispatching_Subprogram_Body |
| (N : Node_Id; |
| Pid : Node_Id; |
| Prot_Bod : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Actuals : List_Id; |
| Formal : Node_Id; |
| Spec : Node_Id; |
| Stmts : List_Id; |
| |
| begin |
| -- Generate a specification without a letter suffix in order to |
| -- override an interface function or procedure. |
| |
| Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); |
| |
| -- The formal parameters become the actuals of the protected function |
| -- or procedure call. |
| |
| Actuals := New_List; |
| Formal := First (Parameter_Specifications (Spec)); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); |
| Next (Formal); |
| end loop; |
| |
| if Nkind (Spec) = N_Procedure_Specification then |
| Stmts := |
| New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), |
| Parameter_Associations => Actuals)); |
| |
| else |
| pragma Assert (Nkind (Spec) = N_Function_Specification); |
| |
| Stmts := |
| New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), |
| Parameter_Associations => Actuals))); |
| end if; |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Declarations => Empty_List, |
| Specification => Spec, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| end Build_Dispatching_Subprogram_Body; |
| |
| -- Start of processing for Expand_N_Protected_Body |
| |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("protected body", N); |
| return; |
| end if; |
| |
| -- This is the proper body corresponding to a stub. The declarations |
| -- must be inserted at the point of the stub, which in turn is in the |
| -- declarative part of the parent unit. |
| |
| if Nkind (Parent (N)) = N_Subunit then |
| Current_Node := Corresponding_Stub (Parent (N)); |
| else |
| Current_Node := N; |
| end if; |
| |
| Op_Body := First (Declarations (N)); |
| |
| -- The protected body is replaced with the bodies of its protected |
| -- operations, and the declarations for internal objects that may |
| -- have been created for entry family bounds. |
| |
| Rewrite (N, Make_Null_Statement (Sloc (N))); |
| Analyze (N); |
| |
| while Present (Op_Body) loop |
| case Nkind (Op_Body) is |
| when N_Subprogram_Declaration => |
| null; |
| |
| when N_Subprogram_Body => |
| |
| -- Do not create bodies for eliminated operations |
| |
| if not Is_Eliminated (Defining_Entity (Op_Body)) |
| and then not Is_Eliminated (Corresponding_Spec (Op_Body)) |
| then |
| if Lock_Free_Active then |
| New_Op_Body := |
| Build_Lock_Free_Unprotected_Subprogram_Body |
| (Op_Body, Pid); |
| else |
| New_Op_Body := |
| Build_Unprotected_Subprogram_Body (Op_Body, Pid); |
| end if; |
| |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| |
| -- When the original protected body has nested subprograms, |
| -- the new body also has them, so set the flag accordingly |
| -- and reset the scopes of the top-level nested subprograms |
| -- and other declaration entities so that they now refer to |
| -- the new body's entity. (It would preferable to do this |
| -- within Build_Protected_Sub_Specification, which is called |
| -- from Build_Unprotected_Subprogram_Body, but the needed |
| -- subprogram entity isn't available via Corresponding_Spec |
| -- until after the above Analyze call.) |
| |
| if Has_Nested_Subprogram (Corresponding_Spec (Op_Body)) then |
| Set_Has_Nested_Subprogram |
| (Corresponding_Spec (New_Op_Body)); |
| |
| Reset_Scopes_To |
| (New_Op_Body, Corresponding_Spec (New_Op_Body)); |
| end if; |
| |
| -- Build the corresponding protected operation. This is |
| -- needed only if this is a public or private operation of |
| -- the type. |
| |
| -- Why do we need to test for Corresponding_Spec being |
| -- present here when it's assumed to be set further above |
| -- in the Is_Eliminated test??? |
| |
| if Present (Corresponding_Spec (Op_Body)) then |
| Op_Decl := |
| Unit_Declaration_Node (Corresponding_Spec (Op_Body)); |
| |
| if Nkind (Parent (Op_Decl)) = N_Protected_Definition then |
| if Lock_Free_Active then |
| New_Op_Body := |
| Build_Lock_Free_Protected_Subprogram_Body |
| (Op_Body, Pid, Specification (New_Op_Body)); |
| else |
| New_Op_Body := |
| Build_Protected_Subprogram_Body ( |
| Op_Body, Pid, Specification (New_Op_Body)); |
| end if; |
| |
| Insert_After (Current_Node, New_Op_Body); |
| Analyze (New_Op_Body); |
| Current_Node := New_Op_Body; |
| |
| -- Generate an overriding primitive operation body for |
| -- this subprogram if the protected type implements |
| -- an interface. |
| |
| if Ada_Version >= Ada_2005 |
| and then Present (Interfaces ( |
| Corresponding_Record_Type (Pid))) |
| then |
| Disp_Op_Body := |
| Build_Dispatching_Subprogram_Body ( |
| Op_Body, Pid, New_Op_Body); |
| |
| Insert_After (Current_Node, Disp_Op_Body); |
| Analyze (Disp_Op_Body); |
| |
| Current_Node := Disp_Op_Body; |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| when N_Entry_Body => |
| Op_Id := Defining_Identifier (Op_Body); |
| New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); |
| |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| |
| when N_Implicit_Label_Declaration => |
| null; |
| |
| when N_Call_Marker |
| | N_Itype_Reference |
| => |
| New_Op_Body := New_Copy (Op_Body); |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| |
| when N_Freeze_Entity => |
| New_Op_Body := New_Copy (Op_Body); |
| |
| if Present (Entity (Op_Body)) |
| and then Freeze_Node (Entity (Op_Body)) = Op_Body |
| then |
| Set_Freeze_Node (Entity (Op_Body), New_Op_Body); |
| end if; |
| |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| |
| when N_Pragma => |
| New_Op_Body := New_Copy (Op_Body); |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| |
| when N_Object_Declaration => |
| pragma Assert (not Comes_From_Source (Op_Body)); |
| New_Op_Body := New_Copy (Op_Body); |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| Next (Op_Body); |
| end loop; |
| |
| -- Finally, create the body of the function that maps an entry index |
| -- into the corresponding body index, except when there is no entry, or |
| -- in a Ravenscar-like profile. |
| |
| if Corresponding_Runtime_Package (Pid) = |
| System_Tasking_Protected_Objects_Entries |
| then |
| New_Op_Body := Build_Find_Body_Index (Pid); |
| Insert_After (Current_Node, New_Op_Body); |
| Current_Node := New_Op_Body; |
| Analyze (New_Op_Body); |
| end if; |
| |
| -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the |
| -- protected body. At this point all wrapper specs have been created, |
| -- frozen and included in the dispatch table for the protected type. |
| |
| if Ada_Version >= Ada_2005 then |
| Build_Wrapper_Bodies (Loc, Pid, Current_Node); |
| end if; |
| end Expand_N_Protected_Body; |
| |
| ----------------------------------------- |
| -- Expand_N_Protected_Type_Declaration -- |
| ----------------------------------------- |
| |
| -- First we create a corresponding record type declaration used to |
| -- represent values of this protected type. |
| -- The general form of this type declaration is |
| |
| -- type poV (discriminants) is record |
| -- _Object : aliased <kind>Protection |
| -- [(<entry count> [, <handler count>])]; |
| -- [entry_family : array (bounds) of Void;] |
| -- <private data fields> |
| -- end record; |
| |
| -- The discriminants are present only if the corresponding protected type |
| -- has discriminants, and they exactly mirror the protected type |
| -- discriminants. The private data fields similarly mirror the private |
| -- declarations of the protected type. |
| |
| -- The Object field is always present. It contains RTS specific data used |
| -- to control the protected object. It is declared as Aliased so that it |
| -- can be passed as a pointer to the RTS. This allows the protected record |
| -- to be referenced within RTS data structures. An appropriate Protection |
| -- type and discriminant are generated. |
| |
| -- The Service field is present for protected objects with entries. It |
| -- contains sufficient information to allow the entry service procedure for |
| -- this object to be called when the object is not known till runtime. |
| |
| -- One entry_family component is present for each entry family in the |
| -- task definition (see Expand_N_Task_Type_Declaration). |
| |
| -- When a protected object is declared, an instance of the protected type |
| -- value record is created. The elaboration of this declaration creates the |
| -- correct bounds for the entry families, and also evaluates the priority |
| -- expression if needed. The initialization routine for the protected type |
| -- itself then calls Initialize_Protection with appropriate parameters to |
| -- initialize the value of the Task_Id field. Install_Handlers may be also |
| -- called if a pragma Attach_Handler applies. |
| |
| -- Note: this record is passed to the subprograms created by the expansion |
| -- of protected subprograms and entries. It is an in parameter to protected |
| -- functions and an in out parameter to procedures and entry bodies. The |
| -- Entity_Id for this created record type is placed in the |
| -- Corresponding_Record_Type field of the associated protected type entity. |
| |
| -- Next we create a procedure specifications for protected subprograms and |
| -- entry bodies. For each protected subprograms two subprograms are |
| -- created, an unprotected and a protected version. The unprotected version |
| -- is called from within other operations of the same protected object. |
| |
| -- We also build the call to register the procedure if a pragma |
| -- Interrupt_Handler applies. |
| |
| -- A single subprogram is created to service all entry bodies; it has an |
| -- additional boolean out parameter indicating that the previous entry call |
| -- made by the current task was serviced immediately, i.e. not by proxy. |
| -- The O parameter contains a pointer to a record object of the type |
| -- described above. An untyped interface is used here to allow this |
| -- procedure to be called in places where the type of the object to be |
| -- serviced is not known. This must be done, for example, when a call that |
| -- may have been requeued is cancelled; the corresponding object must be |
| -- serviced, but which object that is not known till runtime. |
| |
| -- procedure ptypeS |
| -- (O : System.Address; P : out Boolean); |
| -- procedure pprocN (_object : in out poV); |
| -- procedure pproc (_object : in out poV); |
| -- function pfuncN (_object : poV); |
| -- function pfunc (_object : poV); |
| -- ... |
| |
| -- Note that this must come after the record type declaration, since |
| -- the specs refer to this type. |
| |
| procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is |
| Discr_Map : constant Elist_Id := New_Elmt_List; |
| Loc : constant Source_Ptr := Sloc (N); |
| Prot_Typ : constant Entity_Id := Defining_Identifier (N); |
| |
| Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); |
| -- This flag indicates whether the lock free implementation is active |
| |
| Pdef : constant Node_Id := Protected_Definition (N); |
| -- This contains two lists; one for visible and one for private decls |
| |
| Current_Node : Node_Id := N; |
| E_Count : Int; |
| Entries_Aggr : Node_Id; |
| Rec_Decl : Node_Id; |
| Rec_Id : Entity_Id; |
| |
| procedure Check_Inlining (Subp : Entity_Id); |
| -- If the original operation has a pragma Inline, propagate the flag |
| -- to the internal body, for possible inlining later on. The source |
| -- operation is invisible to the back-end and is never actually called. |
| |
| procedure Expand_Entry_Declaration (Decl : Node_Id); |
| -- Create the entry barrier and the procedure body for entry declaration |
| -- Decl. All generated subprograms are added to Entry_Bodies_Array. |
| |
| function Static_Component_Size (Comp : Entity_Id) return Boolean; |
| -- When compiling under the Ravenscar profile, private components must |
| -- have a static size, or else a protected object will require heap |
| -- allocation, violating the corresponding restriction. It is preferable |
| -- to make this check here, because it provides a better error message |
| -- than the back-end, which refers to the object as a whole. |
| |
| procedure Register_Handler; |
| -- For a protected operation that is an interrupt handler, add the |
| -- freeze action that will register it as such. |
| |
| procedure Replace_Access_Definition (Comp : Node_Id); |
| -- If a private component of the type is an access to itself, this |
| -- is not a reference to the current instance, but an access type out |
| -- of which one might construct a list. If such a component exists, we |
| -- create an incomplete type for the equivalent record type, and |
| -- a named access type for it, that replaces the access definition |
| -- of the original component. This is similar to what is done for |
| -- records in Check_Anonymous_Access_Components, but simpler, because |
| -- the corresponding record type has no previous declaration. |
| -- This needs to be done only once, even if there are several such |
| -- access components. The following entity stores the constructed |
| -- access type. |
| |
| Acc_T : Entity_Id := Empty; |
| |
| -------------------- |
| -- Check_Inlining -- |
| -------------------- |
| |
| procedure Check_Inlining (Subp : Entity_Id) is |
| begin |
| if Is_Inlined (Subp) then |
| Set_Is_Inlined (Protected_Body_Subprogram (Subp)); |
| Set_Is_Inlined (Subp, False); |
| end if; |
| |
| if Has_Pragma_No_Inline (Subp) then |
| Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp)); |
| end if; |
| end Check_Inlining; |
| |
| --------------------------- |
| -- Static_Component_Size -- |
| --------------------------- |
| |
| function Static_Component_Size (Comp : Entity_Id) return Boolean is |
| Typ : constant Entity_Id := Etype (Comp); |
| C : Entity_Id; |
| |
| begin |
| if Is_Scalar_Type (Typ) then |
| return True; |
| |
| elsif Is_Array_Type (Typ) then |
| return Compile_Time_Known_Bounds (Typ); |
| |
| elsif Is_Record_Type (Typ) then |
| C := First_Component (Typ); |
| while Present (C) loop |
| if not Static_Component_Size (C) then |
| return False; |
| end if; |
| |
| Next_Component (C); |
| end loop; |
| |
| return True; |
| |
| -- Any other type will be checked by the back-end |
| |
| else |
| return True; |
| end if; |
| end Static_Component_Size; |
| |
| ------------------------------ |
| -- Expand_Entry_Declaration -- |
| ------------------------------ |
| |
| procedure Expand_Entry_Declaration (Decl : Node_Id) is |
| Ent_Id : constant Entity_Id := Defining_Entity (Decl); |
| Bar_Id : Entity_Id; |
| Bod_Id : Entity_Id; |
| Subp : Node_Id; |
| |
| begin |
| E_Count := E_Count + 1; |
| |
| -- Create the protected body subprogram |
| |
| Bod_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); |
| Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); |
| |
| Subp := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); |
| |
| Insert_After (Current_Node, Subp); |
| Current_Node := Subp; |
| |
| Analyze (Subp); |
| |
| -- Build a wrapper procedure to handle contract cases, preconditions, |
| -- and postconditions. |
| |
| Build_Entry_Contract_Wrapper (Ent_Id, N); |
| |
| -- Create the barrier function |
| |
| Bar_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); |
| Set_Barrier_Function (Ent_Id, Bar_Id); |
| |
| Subp := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Barrier_Function_Specification (Loc, Bar_Id)); |
| Set_Is_Entry_Barrier_Function (Subp); |
| |
| Insert_After (Current_Node, Subp); |
| Current_Node := Subp; |
| |
| Analyze (Subp); |
| |
| Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); |
| Set_Scope (Bar_Id, Scope (Ent_Id)); |
| |
| -- Collect pointers to the protected subprogram and the barrier |
| -- of the current entry, for insertion into Entry_Bodies_Array. |
| |
| Append_To (Expressions (Entries_Aggr), |
| Make_Aggregate (Loc, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Bar_Id, Loc), |
| Attribute_Name => Name_Unrestricted_Access), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Bod_Id, Loc), |
| Attribute_Name => Name_Unrestricted_Access)))); |
| end Expand_Entry_Declaration; |
| |
| ---------------------- |
| -- Register_Handler -- |
| ---------------------- |
| |
| procedure Register_Handler is |
| |
| -- All semantic checks already done in Sem_Prag |
| |
| Prot_Proc : constant Entity_Id := |
| Defining_Unit_Name (Specification (Current_Node)); |
| |
| Proc_Address : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Prot_Proc, Loc), |
| Attribute_Name => Name_Address); |
| |
| RTS_Call : constant Entity_Id := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Register_Interrupt_Handler), Loc), |
| Parameter_Associations => New_List (Proc_Address)); |
| begin |
| Append_Freeze_Action (Prot_Proc, RTS_Call); |
| end Register_Handler; |
| |
| ------------------------------- |
| -- Replace_Access_Definition -- |
| ------------------------------- |
| |
| procedure Replace_Access_Definition (Comp : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Comp); |
| Inc_T : Node_Id; |
| Inc_D : Node_Id; |
| Acc_Def : Node_Id; |
| Acc_D : Node_Id; |
| |
| begin |
| if No (Acc_T) then |
| Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id)); |
| Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T); |
| Acc_T := Make_Temporary (Loc, 'S'); |
| Acc_Def := |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => New_Occurrence_Of (Inc_T, Loc)); |
| Acc_D := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Acc_T, |
| Type_Definition => Acc_Def); |
| |
| Insert_Before (Rec_Decl, Inc_D); |
| Analyze (Inc_D); |
| |
| Insert_Before (Rec_Decl, Acc_D); |
| Analyze (Acc_D); |
| end if; |
| |
| Set_Access_Definition (Comp, Empty); |
| Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc)); |
| end Replace_Access_Definition; |
| |
| -- Local variables |
| |
| Body_Arr : Node_Id; |
| Body_Id : Entity_Id; |
| Cdecls : List_Id; |
| Comp : Node_Id; |
| Expr : Node_Id; |
| New_Priv : Node_Id; |
| Obj_Def : Node_Id; |
| Object_Comp : Node_Id; |
| Priv : Node_Id; |
| Sub : Node_Id; |
| |
| -- Start of processing for Expand_N_Protected_Type_Declaration |
| |
| begin |
| if Present (Corresponding_Record_Type (Prot_Typ)) then |
| return; |
| else |
| Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); |
| Rec_Id := Defining_Identifier (Rec_Decl); |
| end if; |
| |
| Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); |
| |
| Qualify_Entity_Names (N); |
| |
| -- If the type has discriminants, their occurrences in the declaration |
| -- have been replaced by the corresponding discriminals. For components |
| -- that are constrained by discriminants, their homologues in the |
| -- corresponding record type must refer to the discriminants of that |
| -- record, so we must apply a new renaming to subtypes_indications: |
| |
| -- protected discriminant => discriminal => record discriminant |
| |
| -- This replacement is not applied to default expressions, for which |
| -- the discriminal is correct. |
| |
| if Has_Discriminants (Prot_Typ) then |
| declare |
| Disc : Entity_Id; |
| Decl : Node_Id; |
| |
| begin |
| Disc := First_Discriminant (Prot_Typ); |
| Decl := First (Discriminant_Specifications (Rec_Decl)); |
| while Present (Disc) loop |
| Append_Elmt (Discriminal (Disc), Discr_Map); |
| Append_Elmt (Defining_Identifier (Decl), Discr_Map); |
| Next_Discriminant (Disc); |
| Next (Decl); |
| end loop; |
| end; |
| end if; |
| |
| -- Fill in the component declarations |
| |
| -- Add components for entry families. For each entry family, create an |
| -- anonymous type declaration with the same size, and analyze the type. |
| |
| Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); |
| |
| pragma Assert (Present (Pdef)); |
| |
| Insert_After (Current_Node, Rec_Decl); |
| Current_Node := Rec_Decl; |
| |
| -- Add private field components |
| |
| Priv := First (Private_Declarations (Pdef)); |
| while Present (Priv) loop |
| if Nkind (Priv) = N_Component_Declaration then |
| if not Static_Component_Size (Defining_Identifier (Priv)) then |
| |
| -- When compiling for a restricted profile, the private |
| -- components must have a static size. If not, this is an error |
| -- for a single protected declaration, and rates a warning on a |
| -- protected type declaration. |
| |
| if not Comes_From_Source (Prot_Typ) then |
| |
| -- It's ok to be checking this restriction at expansion |
| -- time, because this is only for the restricted profile, |
| -- which is not subject to strict RM conformance, so it |
| -- is OK to miss this check in -gnatc mode. |
| |
| Check_Restriction (No_Implicit_Heap_Allocations, Priv); |
| Check_Restriction |
| (No_Implicit_Protected_Object_Allocations, Priv); |
| |
| elsif Restriction_Active (No_Implicit_Heap_Allocations) then |
| if not Discriminated_Size (Defining_Identifier (Priv)) |
| then |
| -- Any object of the type will be non-static |
| |
| Error_Msg_N ("component has non-static size??", Priv); |
| Error_Msg_NE |
| ("\creation of protected object of type& will " |
| & "violate restriction " |
| & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); |
| else |
| -- Object will be non-static if discriminants are |
| |
| Error_Msg_NE |
| ("creation of protected object of type& with " |
| & "non-static discriminants will violate " |
| & "restriction No_Implicit_Heap_Allocations??", |
| Priv, Prot_Typ); |
| end if; |
| |
| -- Likewise for No_Implicit_Protected_Object_Allocations |
| |
| elsif Restriction_Active |
| (No_Implicit_Protected_Object_Allocations) |
| then |
| if not Discriminated_Size (Defining_Identifier (Priv)) then |
| -- Any object of the type will be non-static |
| |
| Error_Msg_N ("component has non-static size??", Priv); |
| Error_Msg_NE |
| ("\creation of protected object of type& will violate " |
| & "restriction " |
| & "No_Implicit_Protected_Object_Allocations??", |
| Priv, Prot_Typ); |
| else |
| -- Object will be non-static if discriminants are |
| |
| Error_Msg_NE |
| ("creation of protected object of type& with " |
| & "non-static discriminants will violate restriction " |
| & "No_Implicit_Protected_Object_Allocations??", |
| Priv, Prot_Typ); |
| end if; |
| end if; |
| end if; |
| |
| -- The component definition consists of a subtype indication, or |
| -- (in Ada 2005) an access definition. Make a copy of the proper |
| -- definition. |
| |
| declare |
| Old_Comp : constant Node_Id := Component_Definition (Priv); |
| Oent : constant Entity_Id := Defining_Identifier (Priv); |
| Nent : constant Entity_Id := |
| Make_Defining_Identifier (Sloc (Oent), |
| Chars => Chars (Oent)); |
| New_Comp : Node_Id; |
| |
| begin |
| if Present (Subtype_Indication (Old_Comp)) then |
| New_Comp := |
| Make_Component_Definition (Sloc (Oent), |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Copy_Tree |
| (Subtype_Indication (Old_Comp), Discr_Map)); |
| else |
| New_Comp := |
| Make_Component_Definition (Sloc (Oent), |
| Aliased_Present => False, |
| Access_Definition => |
| New_Copy_Tree |
| (Access_Definition (Old_Comp), Discr_Map)); |
| |
| -- A self-reference in the private part becomes a |
| -- self-reference to the corresponding record. |
| |
| if Entity (Subtype_Mark (Access_Definition (New_Comp))) |
| = Prot_Typ |
| then |
| Replace_Access_Definition (New_Comp); |
| end if; |
| end if; |
| |
| New_Priv := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Nent, |
| Component_Definition => New_Comp, |
| Expression => Expression (Priv)); |
| |
| Set_Has_Per_Object_Constraint (Nent, |
| Has_Per_Object_Constraint (Oent)); |
| |
| Append_To (Cdecls, New_Priv); |
| end; |
| |
| elsif Nkind (Priv) = N_Subprogram_Declaration then |
| |
| -- Make the unprotected version of the subprogram available for |
| -- expansion of intra object calls. There is need for a protected |
| -- version only if the subprogram is an interrupt handler, |
| -- otherwise this operation can only be called from within the |
| -- body. |
| |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Sub_Specification |
| (Priv, Prot_Typ, Unprotected_Mode)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| |
| Set_Protected_Body_Subprogram |
| (Defining_Unit_Name (Specification (Priv)), |
| Defining_Unit_Name (Specification (Sub))); |
| Check_Inlining (Defining_Unit_Name (Specification (Priv))); |
| Current_Node := Sub; |
| |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Sub_Specification |
| (Priv, Prot_Typ, Protected_Mode)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| Current_Node := Sub; |
| |
| if Is_Interrupt_Handler |
| (Defining_Unit_Name (Specification (Priv))) |
| then |
| if not Restricted_Profile then |
| Register_Handler; |
| end if; |
| end if; |
| end if; |
| |
| Next (Priv); |
| end loop; |
| |
| -- Except for the lock-free implementation, append the _Object field |
| -- with the right type to the component list. We need to compute the |
| -- number of entries, and in some cases the number of Attach_Handler |
| -- pragmas. |
| |
| if not Lock_Free_Active then |
| declare |
| Entry_Count_Expr : constant Node_Id := |
| Build_Entry_Count_Expression |
| (Prot_Typ, Cdecls, Loc); |
| Num_Attach_Handler : Nat := 0; |
| Protection_Subtype : Node_Id; |
| Ritem : Node_Id; |
| |
| begin |
| if Has_Attach_Handler (Prot_Typ) then |
| Ritem := First_Rep_Item (Prot_Typ); |
| while Present (Ritem) loop |
| if Nkind (Ritem) = N_Pragma |
| and then Pragma_Name (Ritem) = Name_Attach_Handler |
| then |
| Num_Attach_Handler := Num_Attach_Handler + 1; |
| end if; |
| |
| Next_Rep_Item (Ritem); |
| end loop; |
| end if; |
| |
| -- Determine the proper protection type. There are two special |
| -- cases: 1) when the protected type has dynamic interrupt |
| -- handlers, and 2) when it has static handlers and we use a |
| -- restricted profile. |
| |
| if Has_Attach_Handler (Prot_Typ) |
| and then not Restricted_Profile |
| then |
| Protection_Subtype := |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Static_Interrupt_Protection), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Entry_Count_Expr, |
| Make_Integer_Literal (Loc, Num_Attach_Handler)))); |
| |
| elsif Has_Interrupt_Handler (Prot_Typ) |
| and then not Restriction_Active (No_Dynamic_Attachment) |
| then |
| Protection_Subtype := |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Dynamic_Interrupt_Protection), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List (Entry_Count_Expr))); |
| |
| else |
| case Corresponding_Runtime_Package (Prot_Typ) is |
| when System_Tasking_Protected_Objects_Entries => |
| Protection_Subtype := |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Protection_Entries), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List (Entry_Count_Expr))); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Protection_Subtype := |
| New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); |
| |
| when System_Tasking_Protected_Objects => |
| Protection_Subtype := |
| New_Occurrence_Of (RTE (RE_Protection), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end if; |
| |
| Object_Comp := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uObject), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => True, |
| Subtype_Indication => Protection_Subtype)); |
| end; |
| |
| -- Put the _Object component after the private component so that it |
| -- be finalized early as required by 9.4 (20) |
| |
| Append_To (Cdecls, Object_Comp); |
| end if; |
| |
| -- Analyze the record declaration immediately after construction, |
| -- because the initialization procedure is needed for single object |
| -- declarations before the next entity is analyzed (the freeze call |
| -- that generates this initialization procedure is found below). |
| |
| Analyze (Rec_Decl, Suppress => All_Checks); |
| |
| -- Ada 2005 (AI-345): Construct the primitive entry wrappers before |
| -- the corresponding record is frozen. If any wrappers are generated, |
| -- Current_Node is updated accordingly. |
| |
| if Ada_Version >= Ada_2005 then |
| Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); |
| end if; |
| |
| -- Collect pointers to entry bodies and their barriers, to be placed |
| -- in the Entry_Bodies_Array for the type. For each entry/family we |
| -- add an expression to the aggregate which is the initial value of |
| -- this array. The array is declared after all protected subprograms. |
| |
| if Has_Entries (Prot_Typ) then |
| Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); |
| else |
| Entries_Aggr := Empty; |
| end if; |
| |
| -- Build two new procedure specifications for each protected subprogram; |
| -- one to call from outside the object and one to call from inside. |
| -- Build a barrier function and an entry body action procedure |
| -- specification for each protected entry. Initialize the entry body |
| -- array. If subprogram is flagged as eliminated, do not generate any |
| -- internal operations. |
| |
| E_Count := 0; |
| Comp := First (Visible_Declarations (Pdef)); |
| while Present (Comp) loop |
| if Nkind (Comp) = N_Subprogram_Declaration then |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Sub_Specification |
| (Comp, Prot_Typ, Unprotected_Mode)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| |
| Set_Protected_Body_Subprogram |
| (Defining_Unit_Name (Specification (Comp)), |
| Defining_Unit_Name (Specification (Sub))); |
| Check_Inlining (Defining_Unit_Name (Specification (Comp))); |
| |
| -- Make the protected version of the subprogram available for |
| -- expansion of external calls. |
| |
| Current_Node := Sub; |
| |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Sub_Specification |
| (Comp, Prot_Typ, Protected_Mode)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| |
| Current_Node := Sub; |
| |
| -- Generate an overriding primitive operation specification for |
| -- this subprogram if the protected type implements an interface |
| -- and Build_Wrapper_Spec did not generate its wrapper. |
| |
| if Ada_Version >= Ada_2005 |
| and then |
| Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) |
| then |
| declare |
| Found : Boolean := False; |
| Prim_Elmt : Elmt_Id; |
| Prim_Op : Node_Id; |
| |
| begin |
| Prim_Elmt := |
| First_Elmt |
| (Primitive_Operations |
| (Corresponding_Record_Type (Prot_Typ))); |
| |
| while Present (Prim_Elmt) loop |
| Prim_Op := Node (Prim_Elmt); |
| |
| if Is_Primitive_Wrapper (Prim_Op) |
| and then Wrapped_Entity (Prim_Op) = |
| Defining_Entity (Specification (Comp)) |
| then |
| Found := True; |
| exit; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| if not Found then |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Build_Protected_Sub_Specification |
| (Comp, Prot_Typ, Dispatching_Mode)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| |
| Current_Node := Sub; |
| end if; |
| end; |
| end if; |
| |
| -- If a pragma Interrupt_Handler applies, build and add a call to |
| -- Register_Interrupt_Handler to the freezing actions of the |
| -- protected version (Current_Node) of the subprogram: |
| |
| -- system.interrupts.register_interrupt_handler |
| -- (prot_procP'address); |
| |
| if not Restricted_Profile |
| and then Is_Interrupt_Handler |
| (Defining_Unit_Name (Specification (Comp))) |
| then |
| Register_Handler; |
| end if; |
| |
| elsif Nkind (Comp) = N_Entry_Declaration then |
| Expand_Entry_Declaration (Comp); |
| end if; |
| |
| Next (Comp); |
| end loop; |
| |
| -- If there are some private entry declarations, expand it as if they |
| -- were visible entries. |
| |
| Comp := First (Private_Declarations (Pdef)); |
| while Present (Comp) loop |
| if Nkind (Comp) = N_Entry_Declaration then |
| Expand_Entry_Declaration (Comp); |
| end if; |
| |
| Next (Comp); |
| end loop; |
| |
| -- Create the declaration of an array object which contains the values |
| -- of aspect/pragma Max_Queue_Length for all entries of the protected |
| -- type. This object is later passed to the appropriate protected object |
| -- initialization routine. |
| |
| if Has_Entries (Prot_Typ) |
| and then Corresponding_Runtime_Package (Prot_Typ) = |
| System_Tasking_Protected_Objects_Entries |
| then |
| declare |
| Count : Int; |
| Item : Entity_Id; |
| Max_Vals : Node_Id; |
| Maxes : List_Id; |
| Maxes_Id : Entity_Id; |
| Need_Array : Boolean := False; |
| |
| begin |
| -- First check if there is any Max_Queue_Length pragma |
| |
| Item := First_Entity (Prot_Typ); |
| while Present (Item) loop |
| if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then |
| Need_Array := True; |
| exit; |
| end if; |
| |
| Next_Entity (Item); |
| end loop; |
| |
| -- Gather the Max_Queue_Length values of all entries in a list. A |
| -- value of zero indicates that the entry has no limitation on its |
| -- queue length. |
| |
| if Need_Array then |
| Count := 0; |
| Item := First_Entity (Prot_Typ); |
| Maxes := New_List; |
| while Present (Item) loop |
| if Is_Entry (Item) then |
| Count := Count + 1; |
| Append_To (Maxes, |
| Make_Integer_Literal |
| (Loc, Get_Max_Queue_Length (Item))); |
| end if; |
| |
| Next_Entity (Item); |
| end loop; |
| |
| -- Create the declaration of the array object. Generate: |
| |
| -- Maxes_Id : aliased constant |
| -- Protected_Entry_Queue_Max_Array |
| -- (1 .. Count) := (..., ...); |
| |
| Maxes_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Prot_Typ), 'B')); |
| |
| Max_Vals := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Maxes_Id, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Range (Loc, |
| Make_Integer_Literal (Loc, 1), |
| Make_Integer_Literal (Loc, Count))))), |
| Expression => Make_Aggregate (Loc, Maxes)); |
| |
| -- A pointer to this array will be placed in the corresponding |
| -- record by its initialization procedure so this needs to be |
| -- analyzed here. |
| |
| Insert_After (Current_Node, Max_Vals); |
| Current_Node := Max_Vals; |
| Analyze (Max_Vals); |
| |
| Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); |
| end if; |
| end; |
| end if; |
| |
| -- Emit declaration for Entry_Bodies_Array, now that the addresses of |
| -- all protected subprograms have been collected. |
| |
| if Has_Entries (Prot_Typ) then |
| Body_Id := |
| Make_Defining_Identifier (Sloc (Prot_Typ), |
| Chars => New_External_Name (Chars (Prot_Typ), 'A')); |
| |
| case Corresponding_Runtime_Package (Prot_Typ) is |
| when System_Tasking_Protected_Objects_Entries => |
| Expr := Entries_Aggr; |
| Obj_Def := |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Protected_Entry_Body_Array), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Range (Loc, |
| Make_Integer_Literal (Loc, 1), |
| Make_Integer_Literal (Loc, E_Count))))); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Expr := Remove_Head (Expressions (Entries_Aggr)); |
| Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| Body_Arr := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Body_Id, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => Obj_Def, |
| Expression => Expr); |
| |
| -- A pointer to this array will be placed in the corresponding record |
| -- by its initialization procedure so this needs to be analyzed here. |
| |
| Insert_After (Current_Node, Body_Arr); |
| Current_Node := Body_Arr; |
| Analyze (Body_Arr); |
| |
| Set_Entry_Bodies_Array (Prot_Typ, Body_Id); |
| |
| -- Finally, build the function that maps an entry index into the |
| -- corresponding body. A pointer to this function is placed in each |
| -- object of the type. Except for a ravenscar-like profile (no abort, |
| -- no entry queue, 1 entry) |
| |
| if Corresponding_Runtime_Package (Prot_Typ) = |
| System_Tasking_Protected_Objects_Entries |
| then |
| Sub := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Build_Find_Body_Index_Spec (Prot_Typ)); |
| |
| Insert_After (Current_Node, Sub); |
| Analyze (Sub); |
| end if; |
| end if; |
| end Expand_N_Protected_Type_Declaration; |
| |
| -------------------------------- |
| -- Expand_N_Requeue_Statement -- |
| -------------------------------- |
| |
| -- A nondispatching requeue statement is expanded into one of four GNARLI |
| -- operations, depending on the source and destination (task or protected |
| -- object). A dispatching requeue statement is expanded into a call to the |
| -- predefined primitive _Disp_Requeue. In addition, code is generated to |
| -- jump around the remainder of processing for the original entry and, if |
| -- the destination is (different) protected object, to attempt to service |
| -- it. The following illustrates the various cases: |
| |
| -- procedure entE |
| -- (O : System.Address; |
| -- P : System.Address; |
| -- E : Protected_Entry_Index) |
| -- is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- type poVP is access poV; |
| -- _object : ptVP := ptVP!(O); |
| |
| -- begin |
| -- begin |
| -- <start of statement sequence for entry> |
| |
| -- -- Requeue from one protected entry body to another protected |
| -- -- entry. |
| |
| -- Requeue_Protected_Entry ( |
| -- _object._object'Access, |
| -- new._object'Access, |
| -- E, |
| -- Abort_Present); |
| -- return; |
| |
| -- <some more of the statement sequence for entry> |
| |
| -- -- Requeue from an entry body to a task entry |
| |
| -- Requeue_Protected_To_Task_Entry ( |
| -- New._task_id, |
| -- E, |
| -- Abort_Present); |
| -- return; |
| |
| -- <rest of statement sequence for entry> |
| -- Complete_Entry_Body (_object._object); |
| |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Entry_Body ( |
| -- _object._object, Get_GNAT_Exception); |
| -- end; |
| -- end entE; |
| |
| -- Requeue of a task entry call to a task entry |
| |
| -- Accept_Call (E, Ann); |
| -- <start of statement sequence for accept statement> |
| -- Requeue_Task_Entry (New._task_id, E, Abort_Present); |
| -- goto Lnn; |
| -- <rest of statement sequence for accept statement> |
| -- <<Lnn>> |
| -- Complete_Rendezvous; |
| |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); |
| |
| -- Requeue of a task entry call to a protected entry |
| |
| -- Accept_Call (E, Ann); |
| -- <start of statement sequence for accept statement> |
| -- Requeue_Task_To_Protected_Entry ( |
| -- new._object'Access, |
| -- E, |
| -- Abort_Present); |
| -- newS (new, Pnn); |
| -- goto Lnn; |
| -- <rest of statement sequence for accept statement> |
| -- <<Lnn>> |
| -- Complete_Rendezvous; |
| |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); |
| |
| -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive |
| -- marked by pragma Implemented (XXX, By_Entry). |
| |
| -- The requeue is inside a protected entry: |
| |
| -- procedure entE |
| -- (O : System.Address; |
| -- P : System.Address; |
| -- E : Protected_Entry_Index) |
| -- is |
| -- <discriminant renamings> |
| -- <private object renamings> |
| -- type poVP is access poV; |
| -- _object : ptVP := ptVP!(O); |
| |
| -- begin |
| -- begin |
| -- <start of statement sequence for entry> |
| |
| -- _Disp_Requeue |
| -- (<interface class-wide object>, |
| -- True, |
| -- _object'Address, |
| -- Ada.Tags.Get_Offset_Index |
| -- (Tag (_object), |
| -- <interface dispatch table index of target entry>), |
| -- Abort_Present); |
| -- return; |
| |
| -- <rest of statement sequence for entry> |
| -- Complete_Entry_Body (_object._object); |
| |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Entry_Body ( |
| -- _object._object, Get_GNAT_Exception); |
| -- end; |
| -- end entE; |
| |
| -- The requeue is inside a task entry: |
| |
| -- Accept_Call (E, Ann); |
| -- <start of statement sequence for accept statement> |
| -- _Disp_Requeue |
| -- (<interface class-wide object>, |
| -- False, |
| -- null, |
| -- Ada.Tags.Get_Offset_Index |
| -- (Tag (_object), |
| -- <interface dispatch table index of target entrt>), |
| -- Abort_Present); |
| -- newS (new, Pnn); |
| -- goto Lnn; |
| -- <rest of statement sequence for accept statement> |
| -- <<Lnn>> |
| -- Complete_Rendezvous; |
| |
| -- exception |
| -- when all others => |
| -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); |
| |
| -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive |
| -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue |
| -- statement is replaced by a dispatching call with actual parameters taken |
| -- from the inner-most accept statement or entry body. |
| |
| -- Target.Primitive (Param1, ..., ParamN); |
| |
| -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive |
| -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked |
| -- at all. |
| |
| -- declare |
| -- S : constant Offset_Index := |
| -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); |
| -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); |
| |
| -- begin |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| -- <statements for dispatching requeue> |
| |
| -- elsif C = POK_Protected_Procedure then |
| -- <dispatching call equivalent> |
| |
| -- else |
| -- raise Program_Error; |
| -- end if; |
| -- end; |
| |
| procedure Expand_N_Requeue_Statement (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Conc_Typ : Entity_Id; |
| Concval : Node_Id; |
| Ename : Node_Id; |
| Enc_Subp : Entity_Id; |
| Index : Node_Id; |
| Old_Typ : Entity_Id; |
| |
| function Build_Dispatching_Call_Equivalent return Node_Id; |
| -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of |
| -- the form Concval.Ename. It is statically known that Ename is allowed |
| -- to be implemented by a protected procedure. Create a dispatching call |
| -- equivalent of Concval.Ename taking the actual parameters from the |
| -- inner-most accept statement or entry body. |
| |
| function Build_Dispatching_Requeue return Node_Id; |
| -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of |
| -- the form Concval.Ename. It is statically known that Ename is allowed |
| -- to be implemented by a protected or a task entry. Create a call to |
| -- primitive _Disp_Requeue which handles the low-level actions. |
| |
| function Build_Dispatching_Requeue_To_Any return Node_Id; |
| -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of |
| -- the form Concval.Ename. Ename is either marked by pragma Implemented |
| -- (XXX, By_Any | Optional) or not marked at all. Create a block which |
| -- determines at runtime whether Ename denotes an entry or a procedure |
| -- and perform the appropriate kind of dispatching select. |
| |
| function Build_Normal_Requeue return Node_Id; |
| -- N denotes a nondispatching requeue statement to either a task or a |
| -- protected entry. Build the appropriate runtime call to perform the |
| -- action. |
| |
| function Build_Skip_Statement (Search : Node_Id) return Node_Id; |
| -- For a protected entry, create a return statement to skip the rest of |
| -- the entry body. Otherwise, create a goto statement to skip the rest |
| -- of a task accept statement. The lookup for the enclosing entry body |
| -- or accept statement starts from Search. |
| |
| --------------------------------------- |
| -- Build_Dispatching_Call_Equivalent -- |
| --------------------------------------- |
| |
| function Build_Dispatching_Call_Equivalent return Node_Id is |
| Call_Ent : constant Entity_Id := Entity (Ename); |
| Obj : constant Node_Id := Original_Node (Concval); |
| Acc_Ent : Node_Id; |
| Actuals : List_Id; |
| Formal : Node_Id; |
| Formals : List_Id; |
| |
| begin |
| -- Climb the parent chain looking for the inner-most entry body or |
| -- accept statement. |
| |
| Acc_Ent := N; |
| while Present (Acc_Ent) |
| and then Nkind (Acc_Ent) not in N_Accept_Statement | N_Entry_Body |
| loop |
| Acc_Ent := Parent (Acc_Ent); |
| end loop; |
| |
| -- A requeue statement should be housed inside an entry body or an |
| -- accept statement at some level. If this is not the case, then the |
| -- tree is malformed. |
| |
| pragma Assert (Present (Acc_Ent)); |
| |
| -- Recover the list of formal parameters |
| |
| if Nkind (Acc_Ent) = N_Entry_Body then |
| Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); |
| end if; |
| |
| Formals := Parameter_Specifications (Acc_Ent); |
| |
| -- Create the actual parameters for the dispatching call. These are |
| -- simply copies of the entry body or accept statement formals in the |
| -- same order as they appear. |
| |
| Actuals := No_List; |
| |
| if Present (Formals) then |
| Actuals := New_List; |
| Formal := First (Formals); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); |
| Next (Formal); |
| end loop; |
| end if; |
| |
| -- Generate: |
| -- Obj.Call_Ent (Actuals); |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Chars (Obj)), |
| Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), |
| |
| Parameter_Associations => Actuals); |
| end Build_Dispatching_Call_Equivalent; |
| |
| ------------------------------- |
| -- Build_Dispatching_Requeue -- |
| ------------------------------- |
| |
| function Build_Dispatching_Requeue return Node_Id is |
| Params : constant List_Id := New_List; |
| |
| begin |
| -- Process the "with abort" parameter |
| |
| Prepend_To (Params, |
| New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); |
| |
| -- Process the entry wrapper's position in the primary dispatch |
| -- table parameter. Generate: |
| |
| -- Ada.Tags.Get_Entry_Index |
| -- (T => To_Tag_Ptr (Obj'Address).all, |
| -- Position => |
| -- Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (Concval), |
| -- <interface dispatch table position of Ename>)); |
| |
| -- Note that Obj'Address is recursively expanded into a call to |
| -- Base_Address (Obj). |
| |
| if Tagged_Type_Expansion then |
| Prepend_To (Params, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), |
| Parameter_Associations => New_List ( |
| |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy_Tree (Concval), |
| Attribute_Name => Name_Address))), |
| |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), Concval), |
| Make_Integer_Literal (Loc, |
| DT_Position (Entity (Ename)))))))); |
| |
| -- VM targets |
| |
| else |
| Prepend_To (Params, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), |
| Parameter_Associations => New_List ( |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Concval, |
| Attribute_Name => Name_Tag), |
| |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), |
| |
| Parameter_Associations => New_List ( |
| |
| -- Obj_Tag |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Concval, |
| Attribute_Name => Name_Tag), |
| |
| -- Tag_Typ |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etype (Concval), Loc), |
| Attribute_Name => Name_Tag), |
| |
| -- Position |
| |
| Make_Integer_Literal (Loc, |
| DT_Position (Entity (Ename)))))))); |
| end if; |
| |
| -- Specific actuals for protected to XXX requeue |
| |
| if Is_Protected_Type (Old_Typ) then |
| Prepend_To (Params, |
| Make_Attribute_Reference (Loc, -- _object'Address |
| Prefix => |
| Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), |
| Attribute_Name => Name_Address)); |
| |
| Prepend_To (Params, -- True |
| New_Occurrence_Of (Standard_True, Loc)); |
| |
| -- Specific actuals for task to XXX requeue |
| |
| else |
| pragma Assert (Is_Task_Type (Old_Typ)); |
| |
| Prepend_To (Params, -- null |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc)); |
| |
| Prepend_To (Params, -- False |
| New_Occurrence_Of (Standard_False, Loc)); |
| end if; |
| |
| -- Add the object parameter |
| |
| Prepend_To (Params, New_Copy_Tree (Concval)); |
| |
| -- Generate: |
| -- _Disp_Requeue (<Params>); |
| |
| -- Find entity for Disp_Requeue operation, which belongs to |
| -- the type and may not be directly visible. |
| |
| declare |
| Elmt : Elmt_Id; |
| Op : Entity_Id := Empty; |
| |
| begin |
| Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); |
| while Present (Elmt) loop |
| Op := Node (Elmt); |
| exit when Chars (Op) = Name_uDisp_Requeue; |
| Next_Elmt (Elmt); |
| end loop; |
| |
| pragma Assert (Present (Op)); |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Op, Loc), |
| Parameter_Associations => Params); |
| end; |
| end Build_Dispatching_Requeue; |
| |
| -------------------------------------- |
| -- Build_Dispatching_Requeue_To_Any -- |
| -------------------------------------- |
| |
| function Build_Dispatching_Requeue_To_Any return Node_Id is |
| Call_Ent : constant Entity_Id := Entity (Ename); |
| Obj : constant Node_Id := Original_Node (Concval); |
| Skip : constant Node_Id := Build_Skip_Statement (N); |
| C : Entity_Id; |
| Decls : List_Id; |
| S : Entity_Id; |
| Stmts : List_Id; |
| |
| begin |
| Decls := New_List; |
| Stmts := New_List; |
| |
| -- Dispatch table slot processing, generate: |
| -- S : Integer; |
| |
| S := Build_S (Loc, Decls); |
| |
| -- Call kind processing, generate: |
| -- C : Ada.Tags.Prim_Op_Kind; |
| |
| C := Build_C (Loc, Decls); |
| |
| -- Generate: |
| -- S := Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); |
| |
| Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); |
| |
| -- Generate: |
| -- _Disp_Get_Prim_Op_Kind (Obj, S, C); |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| Find_Prim_Op (Etype (Etype (Obj)), |
| Name_uDisp_Get_Prim_Op_Kind), |
| Loc), |
| Parameter_Associations => New_List ( |
| New_Copy_Tree (Obj), |
| New_Occurrence_Of (S, Loc), |
| New_Occurrence_Of (C, Loc)))); |
| |
| Append_To (Stmts, |
| |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Or (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), |
| |
| -- Dispatching requeue equivalent |
| |
| Then_Statements => New_List ( |
| Build_Dispatching_Requeue, |
| Skip), |
| |
| -- elsif C = POK_Protected_Procedure then |
| |
| Elsif_Parts => New_List ( |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of ( |
| RTE (RE_POK_Protected_Procedure), Loc)), |
| |
| -- Dispatching call equivalent |
| |
| Then_Statements => New_List ( |
| Build_Dispatching_Call_Equivalent))), |
| |
| -- else |
| -- raise Program_Error; |
| -- end if; |
| |
| Else_Statements => New_List ( |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Explicit_Raise)))); |
| |
| -- Wrap everything into a block |
| |
| return |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| end Build_Dispatching_Requeue_To_Any; |
| |
| -------------------------- |
| -- Build_Normal_Requeue -- |
| -------------------------- |
| |
| function Build_Normal_Requeue return Node_Id is |
| Params : constant List_Id := New_List; |
| Param : Node_Id; |
| RT_Call : Node_Id; |
| |
| begin |
| -- Process the "with abort" parameter |
| |
| Prepend_To (Params, |
| New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); |
| |
| -- Add the index expression to the parameters. It is common among all |
| -- four cases. |
| |
| Prepend_To (Params, |
| Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); |
| |
| if Is_Protected_Type (Old_Typ) then |
| declare |
| Self_Param : Node_Id; |
| |
| begin |
| Self_Param := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), |
| Attribute_Name => |
| Name_Unchecked_Access); |
| |
| -- Protected to protected requeue |
| |
| if Is_Protected_Type (Conc_Typ) then |
| RT_Call := |
| New_Occurrence_Of ( |
| RTE (RE_Requeue_Protected_Entry), Loc); |
| |
| Param := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Concurrent_Ref (Concval), |
| Attribute_Name => |
| Name_Unchecked_Access); |
| |
| -- Protected to task requeue |
| |
| else pragma Assert (Is_Task_Type (Conc_Typ)); |
| RT_Call := |
| New_Occurrence_Of ( |
| RTE (RE_Requeue_Protected_To_Task_Entry), Loc); |
| |
| Param := Concurrent_Ref (Concval); |
| end if; |
| |
| Prepend_To (Params, Param); |
| Prepend_To (Params, Self_Param); |
| end; |
| |
| else pragma Assert (Is_Task_Type (Old_Typ)); |
| |
| -- Task to protected requeue |
| |
| if Is_Protected_Type (Conc_Typ) then |
| RT_Call := |
| New_Occurrence_Of ( |
| RTE (RE_Requeue_Task_To_Protected_Entry), Loc); |
| |
| Param := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Concurrent_Ref (Concval), |
| Attribute_Name => |
| Name_Unchecked_Access); |
| |
| -- Task to task requeue |
| |
| else pragma Assert (Is_Task_Type (Conc_Typ)); |
| RT_Call := |
| New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); |
| |
| Param := Concurrent_Ref (Concval); |
| end if; |
| |
| Prepend_To (Params, Param); |
| end if; |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => RT_Call, |
| Parameter_Associations => Params); |
| end Build_Normal_Requeue; |
| |
| -------------------------- |
| -- Build_Skip_Statement -- |
| -------------------------- |
| |
| function Build_Skip_Statement (Search : Node_Id) return Node_Id is |
| Skip_Stmt : Node_Id; |
| |
| begin |
| -- Build a return statement to skip the rest of the entire body |
| |
| if Is_Protected_Type (Old_Typ) then |
| Skip_Stmt := Make_Simple_Return_Statement (Loc); |
| |
| -- If the requeue is within a task, find the end label of the |
| -- enclosing accept statement and create a goto statement to it. |
| |
| else |
| declare |
| Acc : Node_Id; |
| Label : Node_Id; |
| |
| begin |
| -- Climb the parent chain looking for the enclosing accept |
| -- statement. |
| |
| Acc := Parent (Search); |
| while Present (Acc) |
| and then Nkind (Acc) /= N_Accept_Statement |
| loop |
| Acc := Parent (Acc); |
| end loop; |
| |
| -- The last statement is the second label used for completing |
| -- the rendezvous the usual way. The label we are looking for |
| -- is right before it. |
| |
| Label := |
| Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); |
| |
| pragma Assert (Nkind (Label) = N_Label); |
| |
| -- Generate a goto statement to skip the rest of the accept |
| |
| Skip_Stmt := |
| Make_Goto_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Entity (Identifier (Label)), Loc)); |
| end; |
| end if; |
| |
| Set_Analyzed (Skip_Stmt); |
| |
| return Skip_Stmt; |
| end Build_Skip_Statement; |
| |
| -- Start of processing for Expand_N_Requeue_Statement |
| |
| begin |
| -- Extract the components of the entry call |
| |
| Extract_Entry (N, Concval, Ename, Index); |
| Conc_Typ := Etype (Concval); |
| |
| -- Examine the scope stack in order to find nearest enclosing concurrent |
| -- type. This will constitute our invocation source. |
| |
| Old_Typ := Current_Scope; |
| while Present (Old_Typ) |
| and then not Is_Concurrent_Type (Old_Typ) |
| loop |
| Old_Typ := Scope (Old_Typ); |
| end loop; |
| |
| -- Obtain the innermost enclosing callable construct for use in |
| -- generating a dynamic accessibility check. |
| |
| Enc_Subp := Current_Scope; |
| |
| if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then |
| Enc_Subp := Enclosing_Subprogram (Enc_Subp); |
| end if; |
| |
| -- Generate a dynamic accessibility check on the target object |
| |
| Insert_Before_And_Analyze (N, |
| Make_Raise_Program_Error (Loc, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level), |
| Right_Opnd => Make_Integer_Literal (Loc, |
| Scope_Depth (Enc_Subp))), |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form |
| -- Concval.Ename where the type of Concval is class-wide concurrent |
| -- interface. |
| |
| if Ada_Version >= Ada_2012 |
| and then Present (Concval) |
| and then Is_Class_Wide_Type (Conc_Typ) |
| and then Is_Concurrent_Interface (Conc_Typ) |
| then |
| declare |
| Has_Impl : Boolean := False; |
| Impl_Kind : Name_Id := No_Name; |
| |
| begin |
| -- Check whether the Ename is flagged by pragma Implemented |
| |
| if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then |
| Has_Impl := True; |
| Impl_Kind := Implementation_Kind (Entity (Ename)); |
| end if; |
| |
| -- The procedure_or_entry_NAME is guaranteed to be overridden by |
| -- an entry. Create a call to predefined primitive _Disp_Requeue. |
| |
| if Has_Impl and then Impl_Kind = Name_By_Entry then |
| Rewrite (N, Build_Dispatching_Requeue); |
| Analyze (N); |
| Insert_After (N, Build_Skip_Statement (N)); |
| |
| -- The procedure_or_entry_NAME is guaranteed to be overridden by |
| -- a protected procedure. In this case the requeue is transformed |
| -- into a dispatching call. |
| |
| elsif Has_Impl |
| and then Impl_Kind = Name_By_Protected_Procedure |
| then |
| Rewrite (N, Build_Dispatching_Call_Equivalent); |
| Analyze (N); |
| |
| -- The procedure_or_entry_NAME's implementation kind is either |
| -- By_Any, Optional, or pragma Implemented was not applied at all. |
| -- In this case a runtime test determines whether Ename denotes an |
| -- entry or a protected procedure and performs the appropriate |
| -- call. |
| |
| else |
| Rewrite (N, Build_Dispatching_Requeue_To_Any); |
| Analyze (N); |
| end if; |
| end; |
| |
| -- Processing for regular (nondispatching) requeues |
| |
| else |
| Rewrite (N, Build_Normal_Requeue); |
| Analyze (N); |
| Insert_After (N, Build_Skip_Statement (N)); |
| end if; |
| end Expand_N_Requeue_Statement; |
| |
| ------------------------------- |
| -- Expand_N_Selective_Accept -- |
| ------------------------------- |
| |
| procedure Expand_N_Selective_Accept (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Alts : constant List_Id := Select_Alternatives (N); |
| |
| -- Note: in the below declarations a lot of new lists are allocated |
| -- unconditionally which may well not end up being used. That's not |
| -- a good idea since it wastes space gratuitously ??? |
| |
| Accept_Case : List_Id; |
| Accept_List : constant List_Id := New_List; |
| |
| Alt : Node_Id; |
| Alt_List : constant List_Id := New_List; |
| Alt_Stats : List_Id; |
| Ann : Entity_Id := Empty; |
| |
| Check_Guard : Boolean := True; |
| |
| Decls : constant List_Id := New_List; |
| Stats : constant List_Id := New_List; |
| Body_List : constant List_Id := New_List; |
| Trailing_List : constant List_Id := New_List; |
| |
| Choices : List_Id; |
| Else_Present : Boolean := False; |
| Terminate_Alt : Node_Id := Empty; |
| Select_Mode : Node_Id; |
| |
| Delay_Case : List_Id; |
| Delay_Count : Integer := 0; |
| Delay_Val : Entity_Id; |
| Delay_Index : Entity_Id; |
| Delay_Min : Entity_Id; |
| Delay_Num : Pos := 1; |
| Delay_Alt_List : List_Id := New_List; |
| Delay_List : constant List_Id := New_List; |
| D : Entity_Id; |
| M : Entity_Id; |
| |
| First_Delay : Boolean := True; |
| Guard_Open : Entity_Id; |
| |
| End_Lab : Node_Id; |
| Index : Pos := 1; |
| Lab : Node_Id; |
| Num_Alts : Nat; |
| Num_Accept : Nat := 0; |
| Proc : Node_Id; |
| Time_Type : Entity_Id := Empty; |
| Select_Call : Node_Id; |
| |
| Qnam : constant Entity_Id := |
| Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); |
| |
| Xnam : constant Entity_Id := |
| Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); |
| |
| ----------------------- |
| -- Local subprograms -- |
| ----------------------- |
| |
| function Accept_Or_Raise return List_Id; |
| -- For the rare case where delay alternatives all have guards, and |
| -- all of them are closed, it is still possible that there were open |
| -- accept alternatives with no callers. We must reexamine the |
| -- Accept_List, and execute a selective wait with no else if some |
| -- accept is open. If none, we raise program_error. |
| |
| procedure Add_Accept (Alt : Node_Id); |
| -- Process a single accept statement in a select alternative. Build |
| -- procedure for body of accept, and add entry to dispatch table with |
| -- expression for guard, in preparation for call to run time select. |
| |
| function Make_And_Declare_Label (Num : Int) return Node_Id; |
| -- Manufacture a label using Num as a serial number and declare it. |
| -- The declaration is appended to Decls. The label marks the trailing |
| -- statements of an accept or delay alternative. |
| |
| function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; |
| -- Build call to Selective_Wait runtime routine |
| |
| procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); |
| -- Add code to compare value of delay with previous values, and |
| -- generate case entry for trailing statements. |
| |
| procedure Process_Accept_Alternative |
| (Alt : Node_Id; |
| Index : Int; |
| Proc : Node_Id); |
| -- Add code to call corresponding procedure, and branch to |
| -- trailing statements, if any. |
| |
| --------------------- |
| -- Accept_Or_Raise -- |
| --------------------- |
| |
| function Accept_Or_Raise return List_Id is |
| Cond : Node_Id; |
| Stats : List_Id; |
| J : constant Entity_Id := Make_Temporary (Loc, 'J'); |
| |
| begin |
| -- We generate the following: |
| |
| -- for J in q'range loop |
| -- if q(J).S /=null_task_entry then |
| -- selective_wait (simple_mode,...); |
| -- done := True; |
| -- exit; |
| -- end if; |
| -- end loop; |
| -- |
| -- if no rendez_vous then |
| -- raise program_error; |
| -- end if; |
| |
| -- Note that the code needs to know that the selector name |
| -- in an Accept_Alternative is named S. |
| |
| Cond := Make_Op_Ne (Loc, |
| Left_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Qnam, Loc), |
| Expressions => New_List (New_Occurrence_Of (J, Loc))), |
| Selector_Name => Make_Identifier (Loc, Name_S)), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); |
| |
| Stats := New_List ( |
| Make_Implicit_Loop_Statement (N, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => J, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Qnam, Loc), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, 1))))), |
| |
| Statements => New_List ( |
| Make_Implicit_If_Statement (N, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Select_Call ( |
| New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), |
| Make_Exit_Statement (Loc)))))); |
| |
| Append_To (Stats, |
| Make_Raise_Program_Error (Loc, |
| Condition => Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Xnam, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), |
| Reason => PE_All_Guards_Closed)); |
| |
| return Stats; |
| end Accept_Or_Raise; |
| |
| ---------------- |
| -- Add_Accept -- |
| ---------------- |
| |
| procedure Add_Accept (Alt : Node_Id) is |
| Acc_Stm : constant Node_Id := Accept_Statement (Alt); |
| Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); |
| Eloc : constant Source_Ptr := Sloc (Ename); |
| Eent : constant Entity_Id := Entity (Ename); |
| Index : constant Node_Id := Entry_Index (Acc_Stm); |
| |
| Call : Node_Id; |
| Expr : Node_Id; |
| Null_Body : Node_Id; |
| PB_Ent : Entity_Id; |
| Proc_Body : Node_Id; |
| |
| -- Start of processing for Add_Accept |
| |
| begin |
| if No (Ann) then |
| Ann := Node (Last_Elmt (Accept_Address (Eent))); |
| end if; |
| |
| if Present (Condition (Alt)) then |
| Expr := |
| Make_If_Expression (Eloc, New_List ( |
| Condition (Alt), |
| Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), |
| New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); |
| else |
| Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); |
| end if; |
| |
| if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then |
| Null_Body := New_Occurrence_Of (Standard_False, Eloc); |
| |
| -- Always add call to Abort_Undefer when generating code, since |
| -- this is what the runtime expects (abort deferred in |
| -- Selective_Wait). In CodePeer mode this only confuses the |
| -- analysis with unknown calls, so don't do it. |
| |
| if not CodePeer_Mode then |
| Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); |
| Insert_Before |
| (First (Statements (Handled_Statement_Sequence |
| (Accept_Statement (Alt)))), |
| Call); |
| Analyze (Call); |
| end if; |
| |
| PB_Ent := |
| Make_Defining_Identifier (Eloc, |
| New_External_Name (Chars (Ename), 'A', Num_Accept)); |
| |
| -- Link the acceptor to the original receiving entry |
| |
| Mutate_Ekind (PB_Ent, E_Procedure); |
| Set_Receiving_Entry (PB_Ent, Eent); |
| |
| if Comes_From_Source (Alt) then |
| Set_Debug_Info_Needed (PB_Ent); |
| end if; |
| |
| Proc_Body := |
| Make_Subprogram_Body (Eloc, |
| Specification => |
| Make_Procedure_Specification (Eloc, |
| Defining_Unit_Name => PB_Ent), |
| Declarations => Declarations (Acc_Stm), |
| Handled_Statement_Sequence => |
| Build_Accept_Body (Accept_Statement (Alt))); |
| |
| Reset_Scopes_To (Proc_Body, PB_Ent); |
| |
| -- During the analysis of the body of the accept statement, any |
| -- zero cost exception handler records were collected in the |
| -- Accept_Handler_Records field of the N_Accept_Alternative node. |
| -- This is where we move them to where they belong, namely the |
| -- newly created procedure. |
| |
| Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); |
| Append (Proc_Body, Body_List); |
| |
| else |
| Null_Body := New_Occurrence_Of (Standard_True, Eloc); |
| |
| -- if accept statement has declarations, insert above, given that |
| -- we are not creating a body for the accept. |
| |
| if Present (Declarations (Acc_Stm)) then |
| Insert_Actions (N, Declarations (Acc_Stm)); |
| end if; |
| end if; |
| |
| Append_To (Accept_List, |
| Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); |
| |
| Num_Accept := Num_Accept + 1; |
| end Add_Accept; |
| |
| ---------------------------- |
| -- Make_And_Declare_Label -- |
| ---------------------------- |
| |
| function Make_And_Declare_Label (Num : Int) return Node_Id is |
| Lab_Id : Node_Id; |
| |
| begin |
| Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); |
| Lab := |
| Make_Label (Loc, Lab_Id); |
| |
| Append_To (Decls, |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Chars (Lab_Id)), |
| Label_Construct => Lab)); |
| |
| return Lab; |
| end Make_And_Declare_Label; |
| |
| ---------------------- |
| -- Make_Select_Call -- |
| ---------------------- |
| |
| function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is |
| Params : constant List_Id := New_List; |
| |
| begin |
| Append_To (Params, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Qnam, Loc), |
| Attribute_Name => Name_Unchecked_Access)); |
| Append_To (Params, Select_Mode); |
| Append_To (Params, New_Occurrence_Of (Ann, Loc)); |
| Append_To (Params, New_Occurrence_Of (Xnam, Loc)); |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), |
| Parameter_Associations => Params); |
| end Make_Select_Call; |
| |
| -------------------------------- |
| -- Process_Accept_Alternative -- |
| -------------------------------- |
| |
| procedure Process_Accept_Alternative |
| (Alt : Node_Id; |
| Index : Int; |
| Proc : Node_Id) |
| is |
| Astmt : constant Node_Id := Accept_Statement (Alt); |
| Alt_Stats : List_Id; |
| |
| begin |
| Adjust_Condition (Condition (Alt)); |
| |
| -- Accept with body |
| |
| if Present (Handled_Statement_Sequence (Astmt)) then |
| Alt_Stats := |
| New_List ( |
| Make_Procedure_Call_Statement (Sloc (Proc), |
| Name => |
| New_Occurrence_Of |
| (Defining_Unit_Name (Specification (Proc)), |
| Sloc (Proc)))); |
| |
| -- Accept with no body (followed by trailing statements) |
| |
| else |
| declare |
| Entry_Id : constant Entity_Id := |
| Entity (Entry_Direct_Name (Accept_Statement (Alt))); |
| begin |
| -- Ada 2022 (AI12-0279) |
| |
| if Has_Yield_Aspect (Entry_Id) |
| and then RTE_Available (RE_Yield) |
| then |
| Alt_Stats := |
| New_List ( |
| Make_Procedure_Call_Statement (Sloc (Proc), |
| New_Occurrence_Of (RTE (RE_Yield), Sloc (Proc)))); |
| else |
| Alt_Stats := Empty_List; |
| end if; |
| end; |
| end if; |
| |
| Ensure_Statement_Present (Sloc (Astmt), Alt); |
| |
| -- After the call, if any, branch to trailing statements, if any. |
| -- We create a label for each, as well as the corresponding label |
| -- declaration. |
| |
| if not Is_Empty_List (Statements (Alt)) then |
| Lab := Make_And_Declare_Label (Index); |
| Append (Lab, Trailing_List); |
| Append_List (Statements (Alt), Trailing_List); |
| Append_To (Trailing_List, |
| Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (End_Lab)))); |
| |
| else |
| Lab := End_Lab; |
| end if; |
| |
| Append_To (Alt_Stats, |
| Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); |
| |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), |
| Statements => Alt_Stats)); |
| end Process_Accept_Alternative; |
| |
| ------------------------------- |
| -- Process_Delay_Alternative -- |
| ------------------------------- |
| |
| procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is |
| Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); |
| Cond : Node_Id; |
| Delay_Alt : List_Id; |
| |
| begin |
| -- Deal with C/Fortran boolean as delay condition |
| |
| Adjust_Condition (Condition (Alt)); |
| |
| -- Determine the smallest specified delay |
| |
| -- for each delay alternative generate: |
| |
| -- if guard-expression then |
| -- Delay_Val := delay-expression; |
| -- Guard_Open := True; |
| -- if Delay_Val < Delay_Min then |
| -- Delay_Min := Delay_Val; |
| -- Delay_Index := Index; |
| -- end if; |
| -- end if; |
| |
| -- The enclosing if-statement is omitted if there is no guard |
| |
| if Delay_Count = 1 or else First_Delay then |
| First_Delay := False; |
| |
| Delay_Alt := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Delay_Min, Loc), |
| Expression => Expression (Delay_Statement (Alt)))); |
| |
| if Delay_Count > 1 then |
| Append_To (Delay_Alt, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Delay_Index, Loc), |
| Expression => Make_Integer_Literal (Loc, Index))); |
| end if; |
| |
| else |
| Delay_Alt := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Delay_Val, Loc), |
| Expression => Expression (Delay_Statement (Alt)))); |
| |
| if Time_Type = Standard_Duration then |
| Cond := |
| Make_Op_Lt (Loc, |
| Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), |
| Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); |
| |
| else |
| -- The scope of the time type must define a comparison |
| -- operator. The scope itself may not be visible, so we |
| -- construct a node with entity information to insure that |
| -- semantic analysis can find the proper operator. |
| |
| Cond := |
| Make_Function_Call (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of (Scope (Time_Type), Loc), |
| Selector_Name => |
| Make_Operator_Symbol (Loc, |
| Chars => Name_Op_Lt, |
| Strval => No_String)), |
| Parameter_Associations => |
| New_List ( |
| New_Occurrence_Of (Delay_Val, Loc), |
| New_Occurrence_Of (Delay_Min, Loc))); |
| |
| Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); |
| end if; |
| |
| Append_To (Delay_Alt, |
| Make_Implicit_If_Statement (N, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Delay_Min, Loc), |
| Expression => New_Occurrence_Of (Delay_Val, Loc)), |
| |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Delay_Index, Loc), |
| Expression => Make_Integer_Literal (Loc, Index))))); |
| end if; |
| |
| if Check_Guard then |
| Append_To (Delay_Alt, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Guard_Open, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| end if; |
| |
| if Present (Condition (Alt)) then |
| Delay_Alt := New_List ( |
| Make_Implicit_If_Statement (N, |
| Condition => Condition (Alt), |
| Then_Statements => Delay_Alt)); |
| end if; |
| |
| Append_List (Delay_Alt, Delay_List); |
| |
| Ensure_Statement_Present (Dloc, Alt); |
| |
| -- If the delay alternative has a statement part, add choice to the |
| -- case statements for delays. |
| |
| if not Is_Empty_List (Statements (Alt)) then |
| |
| if Delay_Count = 1 then |
| Append_List (Statements (Alt), Delay_Alt_List); |
| |
| else |
| Append_To (Delay_Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Integer_Literal (Loc, Index)), |
| Statements => Statements (Alt))); |
| end if; |
| |
| elsif Delay_Count = 1 then |
| |
| -- If the single delay has no trailing statements, add a branch |
| -- to the exit label to the selective wait. |
| |
| Delay_Alt_List := New_List ( |
| Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (End_Lab)))); |
| |
| end if; |
| end Process_Delay_Alternative; |
| |
| -- Start of processing for Expand_N_Selective_Accept |
| |
| begin |
| Process_Statements_For_Controlled_Objects (N); |
| |
| -- First insert some declarations before the select. The first is: |
| |
| -- Ann : Address |
| |
| -- This variable holds the parameters passed to the accept body. This |
| -- declaration has already been inserted by the time we get here by |
| -- a call to Expand_Accept_Declarations made from the semantics when |
| -- processing the first accept statement contained in the select. We |
| -- can find this entity as Accept_Address (E), where E is any of the |
| -- entries references by contained accept statements. |
| |
| -- The first step is to scan the list of Selective_Accept_Statements |
| -- to find this entity, and also count the number of accepts, and |
| -- determine if terminated, delay or else is present: |
| |
| Num_Alts := 0; |
| |
| Alt := First (Alts); |
| while Present (Alt) loop |
| Process_Statements_For_Controlled_Objects (Alt); |
| |
| if Nkind (Alt) = N_Accept_Alternative then |
| Add_Accept (Alt); |
| |
| elsif Nkind (Alt) = N_Delay_Alternative then |
| Delay_Count := Delay_Count + 1; |
| |
| -- If the delays are relative delays, the delay expressions have |
| -- type Standard_Duration. Otherwise they must have some time type |
| -- recognized by GNAT. |
| |
| if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then |
| Time_Type := Standard_Duration; |
| else |
| Time_Type := Etype (Expression (Delay_Statement (Alt))); |
| |
| if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) |
| or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) |
| then |
| null; |
| else |
| -- Move this check to sem??? |
| Error_Msg_NE ( |
| "& is not a time type (RM 9.6(6))", |
| Expression (Delay_Statement (Alt)), Time_Type); |
| Time_Type := Standard_Duration; |
| Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); |
| end if; |
| end if; |
| |
| if No (Condition (Alt)) then |
| |
| -- This guard will always be open |
| |
| Check_Guard := False; |
| end if; |
| |
| elsif Nkind (Alt) = N_Terminate_Alternative then |
| Adjust_Condition (Condition (Alt)); |
| Terminate_Alt := Alt; |
| end if; |
| |
| Num_Alts := Num_Alts + 1; |
| Next (Alt); |
| end loop; |
| |
| Else_Present := Present (Else_Statements (N)); |
| |
| -- At the same time (see procedure Add_Accept) we build the accept list: |
| |
| -- Qnn : Accept_List (1 .. num-select) := ( |
| -- (null-body, entry-index), |
| -- (null-body, entry-index), |
| -- .. |
| -- (null_body, entry-index)); |
| |
| -- In the above declaration, null-body is True if the corresponding |
| -- accept has no body, and false otherwise. The entry is either the |
| -- entry index expression if there is no guard, or if a guard is |
| -- present, then an if expression of the form: |
| |
| -- (if guard then entry-index else Null_Task_Entry) |
| |
| -- If a guard is statically known to be false, the entry can simply |
| -- be omitted from the accept list. |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Qnam, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), |
| Aliased_Present => True, |
| Expression => |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Accept_List), Loc), |
| Expression => |
| Make_Aggregate (Loc, Expressions => Accept_List)))); |
| |
| -- Then we declare the variable that holds the index for the accept |
| -- that will be selected for service: |
| |
| -- Xnn : Select_Index; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Xnam, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Select_Index), Loc), |
| Expression => |
| New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); |
| |
| -- After this follow procedure declarations for each accept body |
| |
| -- procedure Pnn is |
| -- begin |
| -- ... |
| -- end; |
| |
| -- where the ... are statements from the corresponding procedure body. |
| -- No parameters are involved, since the parameters are passed via Ann |
| -- and the parameter references have already been expanded to be direct |
| -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, |
| -- any embedded tasking statements (which would normally be illegal in |
| -- procedures), have been converted to calls to the tasking runtime so |
| -- there is no problem in putting them into procedures. |
| |
| -- The original accept statement has been expanded into a block in |
| -- the same fashion as for simple accepts (see Build_Accept_Body). |
| |
| -- Note: we don't really need to build these procedures for the case |
| -- where no delay statement is present, but it is just as easy to |
| -- build them unconditionally, and not significantly inefficient, |
| -- since if they are short they will be inlined anyway. |
| |
| -- The procedure declarations have been assembled in Body_List |
| |
| -- If delays are present, we must compute the required delay. |
| -- We first generate the declarations: |
| |
| -- Delay_Index : Boolean := 0; |
| -- Delay_Min : Some_Time_Type.Time; |
| -- Delay_Val : Some_Time_Type.Time; |
| |
| -- Delay_Index will be set to the index of the minimum delay, i.e. the |
| -- active delay that is actually chosen as the basis for the possible |
| -- delay if an immediate rendez-vous is not possible. |
| |
| -- In the most common case there is a single delay statement, and this |
| -- is handled specially. |
| |
| if Delay_Count > 0 then |
| |
| -- Generate the required declarations |
| |
| Delay_Val := |
| Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); |
| Delay_Index := |
| Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); |
| Delay_Min := |
| Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); |
| |
| pragma Assert (Present (Time_Type)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Delay_Val, |
| Object_Definition => New_Occurrence_Of (Time_Type, Loc))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Delay_Index, |
| Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => Make_Integer_Literal (Loc, 0))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Delay_Min, |
| Object_Definition => New_Occurrence_Of (Time_Type, Loc), |
| Expression => |
| Unchecked_Convert_To (Time_Type, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Underlying_Type (Time_Type), Loc), |
| Attribute_Name => Name_Last)))); |
| |
| -- Create Duration and Delay_Mode objects used for passing a delay |
| -- value to RTS |
| |
| D := Make_Temporary (Loc, 'D'); |
| M := Make_Temporary (Loc, 'M'); |
| |
| declare |
| Discr : Entity_Id; |
| |
| begin |
| -- Note that these values are defined in s-osprim.ads and must |
| -- be kept in sync: |
| -- |
| -- Relative : constant := 0; |
| -- Absolute_Calendar : constant := 1; |
| -- Absolute_RT : constant := 2; |
| |
| if Time_Type = Standard_Duration then |
| Discr := Make_Integer_Literal (Loc, 0); |
| |
| elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then |
| Discr := Make_Integer_Literal (Loc, 1); |
| |
| else |
| pragma Assert |
| (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); |
| Discr := Make_Integer_Literal (Loc, 2); |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => D, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Duration, Loc))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => M, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => Discr)); |
| end; |
| |
| if Check_Guard then |
| Guard_Open := |
| Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Guard_Open, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc))); |
| end if; |
| |
| -- Delay_Count is zero, don't need M and D set (suppress warning) |
| |
| else |
| M := Empty; |
| D := Empty; |
| end if; |
| |
| if Present (Terminate_Alt) then |
| |
| -- If the terminate alternative guard is False, use |
| -- Simple_Mode; otherwise use Terminate_Mode. |
| |
| if Present (Condition (Terminate_Alt)) then |
| Select_Mode := Make_If_Expression (Loc, |
| New_List (Condition (Terminate_Alt), |
| New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), |
| New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); |
| else |
| Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); |
| end if; |
| |
| elsif Else_Present or Delay_Count > 0 then |
| Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); |
| |
| else |
| Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); |
| end if; |
| |
| Select_Call := Make_Select_Call (Select_Mode); |
| Append (Select_Call, Stats); |
| |
| -- Now generate code to act on the result. There is an entry |
| -- in this case for each accept statement with a non-null body, |
| -- followed by a branch to the statements that follow the Accept. |
| -- In the absence of delay alternatives, we generate: |
| |
| -- case X is |
| -- when No_Rendezvous => -- omitted if simple mode |
| -- goto Lab0; |
| |
| -- when 1 => |
| -- P1n; |
| -- goto Lab1; |
| |
| -- when 2 => |
| -- P2n; |
| -- goto Lab2; |
| |
| -- when others => |
| -- goto Exit; |
| -- end case; |
| -- |
| -- Lab0: Else_Statements; |
| -- goto exit; |
| |
| -- Lab1: Trailing_Statements1; |
| -- goto Exit; |
| -- |
| -- Lab2: Trailing_Statements2; |
| -- goto Exit; |
| -- ... |
| -- Exit: |
| |
| -- Generate label for common exit |
| |
| End_Lab := Make_And_Declare_Label (Num_Alts + 1); |
| |
| -- First entry is the default case, when no rendezvous is possible |
| |
| Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); |
| |
| if Else_Present then |
| |
| -- If no rendezvous is possible, the else part is executed |
| |
| Lab := Make_And_Declare_Label (0); |
| Alt_Stats := New_List ( |
| Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (Lab)))); |
| |
| Append (Lab, Trailing_List); |
| Append_List (Else_Statements (N), Trailing_List); |
| Append_To (Trailing_List, |
| Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (End_Lab)))); |
| else |
| Alt_Stats := New_List ( |
| Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (End_Lab)))); |
| end if; |
| |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => Choices, |
| Statements => Alt_Stats)); |
| |
| -- We make use of the fact that Accept_Index is an integer type, and |
| -- generate successive literals for entries for each accept. Only those |
| -- for which there is a body or trailing statements get a case entry. |
| |
| Alt := First (Select_Alternatives (N)); |
| Proc := First (Body_List); |
| while Present (Alt) loop |
| |
| if Nkind (Alt) = N_Accept_Alternative then |
| Process_Accept_Alternative (Alt, Index, Proc); |
| Index := Index + 1; |
| |
| if Present |
| (Handled_Statement_Sequence (Accept_Statement (Alt))) |
| then |
| Next (Proc); |
| end if; |
| |
| elsif Nkind (Alt) = N_Delay_Alternative then |
| Process_Delay_Alternative (Alt, Delay_Num); |
| Delay_Num := Delay_Num + 1; |
| end if; |
| |
| Next (Alt); |
| end loop; |
| |
| -- An others choice is always added to the main case, as well |
| -- as the delay case (to satisfy the compiler). |
| |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_List (Make_Others_Choice (Loc)), |
| Statements => |
| New_List (Make_Goto_Statement (Loc, |
| Name => New_Copy (Identifier (End_Lab)))))); |
| |
| Accept_Case := New_List ( |
| Make_Case_Statement (Loc, |
| Expression => New_Occurrence_Of (Xnam, Loc), |
| Alternatives => Alt_List)); |
| |
| Append_List (Trailing_List, Accept_Case); |
| Append_List (Body_List, Decls); |
| |
| -- Construct case statement for trailing statements of delay |
| -- alternatives, if there are several of them. |
| |
| if Delay_Count > 1 then |
| Append_To (Delay_Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_List (Make_Others_Choice (Loc)), |
| Statements => |
| New_List (Make_Null_Statement (Loc)))); |
| |
| Delay_Case := New_List ( |
| Make_Case_Statement (Loc, |
| Expression => New_Occurrence_Of (Delay_Index, Loc), |
| Alternatives => Delay_Alt_List)); |
| else |
| Delay_Case := Delay_Alt_List; |
| end if; |
| |
| -- If there are no delay alternatives, we append the case statement |
| -- to the statement list. |
| |
| if Delay_Count = 0 then |
| Append_List (Accept_Case, Stats); |
| |
| -- Delay alternatives present |
| |
| else |
| -- If delay alternatives are present we generate: |
| |
| -- find minimum delay. |
| -- DX := minimum delay; |
| -- M := <delay mode>; |
| -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, |
| -- DX, MX, X); |
| -- |
| -- if X = No_Rendezvous then |
| -- case statement for delay statements. |
| -- else |
| -- case statement for accept alternatives. |
| -- end if; |
| |
| declare |
| Cases : Node_Id; |
| Stmt : Node_Id; |
| Parms : List_Id; |
| Parm : Node_Id; |
| Conv : Node_Id; |
| |
| begin |
| -- The type of the delay expression is known to be legal |
| |
| if Time_Type = Standard_Duration then |
| Conv := New_Occurrence_Of (Delay_Min, Loc); |
| |
| elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then |
| Conv := Make_Function_Call (Loc, |
| New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), |
| New_List (New_Occurrence_Of (Delay_Min, Loc))); |
| |
| else |
| pragma Assert |
| (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); |
| |
| Conv := Make_Function_Call (Loc, |
| New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), |
| New_List (New_Occurrence_Of (Delay_Min, Loc))); |
| end if; |
| |
| Stmt := Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (D, Loc), |
| Expression => Conv); |
| |
| -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) |
| |
| Parms := Parameter_Associations (Select_Call); |
| |
| Parm := First (Parms); |
| while Present (Parm) and then Parm /= Select_Mode loop |
| Next (Parm); |
| end loop; |
| |
| pragma Assert (Present (Parm)); |
| Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); |
| Analyze (Parm); |
| |
| -- Prepare two new parameters of Duration and Delay_Mode type |
| -- which represent the value and the mode of the minimum delay. |
| |
| Next (Parm); |
| Insert_After (Parm, New_Occurrence_Of (M, Loc)); |
| Insert_After (Parm, New_Occurrence_Of (D, Loc)); |
| |
| -- Create a call to RTS |
| |
| Rewrite (Select_Call, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), |
| Parameter_Associations => Parms)); |
| |
| -- This new call should follow the calculation of the minimum |
| -- delay. |
| |
| Insert_List_Before (Select_Call, Delay_List); |
| |
| if Check_Guard then |
| Stmt := |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (Guard_Open, Loc), |
| Then_Statements => New_List ( |
| New_Copy_Tree (Stmt), |
| New_Copy_Tree (Select_Call)), |
| Else_Statements => Accept_Or_Raise); |
| Rewrite (Select_Call, Stmt); |
| else |
| Insert_Before (Select_Call, Stmt); |
| end if; |
| |
| Cases := |
| Make_Implicit_If_Statement (N, |
| Condition => Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Xnam, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), |
| |
| Then_Statements => Delay_Case, |
| Else_Statements => Accept_Case); |
| |
| Append (Cases, Stats); |
| end; |
| end if; |
| |
| Append (End_Lab, Stats); |
| |
| -- Replace accept statement with appropriate block |
| |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); |
| Analyze (N); |
| |
| -- Note: have to worry more about abort deferral in above code ??? |
| |
| -- Final step is to unstack the Accept_Address entries for all accept |
| -- statements appearing in accept alternatives in the select statement |
| |
| Alt := First (Alts); |
| while Present (Alt) loop |
| if Nkind (Alt) = N_Accept_Alternative then |
| Remove_Last_Elmt (Accept_Address |
| (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); |
| end if; |
| |
| Next (Alt); |
| end loop; |
| end Expand_N_Selective_Accept; |
| |
| ------------------------------------------- |
| -- Expand_N_Single_Protected_Declaration -- |
| ------------------------------------------- |
| |
| -- A single protected declaration should never be present after semantic |
| -- analysis because it is transformed into a protected type declaration |
| -- and an accompanying anonymous object. This routine ensures that the |
| -- transformation takes place. |
| |
| procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is |
| begin |
| raise Program_Error; |
| end Expand_N_Single_Protected_Declaration; |
| |
| -------------------------------------- |
| -- Expand_N_Single_Task_Declaration -- |
| -------------------------------------- |
| |
| -- A single task declaration should never be present after semantic |
| -- analysis because it is transformed into a task type declaration and |
| -- an accompanying anonymous object. This routine ensures that the |
| -- transformation takes place. |
| |
| procedure Expand_N_Single_Task_Declaration (N : Node_Id) is |
| begin |
| raise Program_Error; |
| end Expand_N_Single_Task_Declaration; |
| |
| ------------------------ |
| -- Expand_N_Task_Body -- |
| ------------------------ |
| |
| -- Given a task body |
| |
| -- task body tname is |
| -- <declarations> |
| -- begin |
| -- <statements> |
| -- end x; |
| |
| -- This expansion routine converts it into a procedure and sets the |
| -- elaboration flag for the procedure to true, to represent the fact |
| -- that the task body is now elaborated: |
| |
| -- procedure tnameB (_Task : access tnameV) is |
| -- discriminal : dtype renames _Task.discriminant; |
| |
| -- procedure _clean is |
| -- begin |
| -- Abort_Defer.all; |
| -- Complete_Task; |
| -- Abort_Undefer.all; |
| -- return; |
| -- end _clean; |
| |
| -- begin |
| -- Abort_Undefer.all; |
| -- <declarations> |
| -- System.Task_Stages.Complete_Activation; |
| -- <statements> |
| -- at end |
| -- _clean; |
| -- end tnameB; |
| |
| -- tnameE := True; |
| |
| -- In addition, if the task body is an activator, then a call to activate |
| -- tasks is added at the start of the statements, before the call to |
| -- Complete_Activation, and if in addition the task is a master then it |
| -- must be established as a master. These calls are inserted and analyzed |
| -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is |
| -- expanded. |
| |
| -- There is one discriminal declaration line generated for each |
| -- discriminant that is present to provide an easy reference point for |
| -- discriminant references inside the body (see Exp_Ch2.Expand_Name). |
| |
| -- Note on relationship to GNARLI definition. In the GNARLI definition, |
| -- task body procedures have a profile (Arg : System.Address). That is |
| -- needed because GNARLI has to use the same access-to-subprogram type |
| -- for all task types. We depend here on knowing that in GNAT, passing |
| -- an address argument by value is identical to passing a record value |
| -- by access (in either case a single pointer is passed), so even though |
| -- this procedure has the wrong profile. In fact it's all OK, since the |
| -- callings sequence is identical. |
| |
| procedure Expand_N_Task_Body (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Ttyp : constant Entity_Id := Corresponding_Spec (N); |
| Call : Node_Id; |
| New_N : Node_Id; |
| |
| Insert_Nod : Node_Id; |
| -- Used to determine the proper location of wrapper body insertions |
| |
| begin |
| -- if no task body procedure, means we had an error in configurable |
| -- run-time mode, and there is no point in proceeding further. |
| |
| if No (Task_Body_Procedure (Ttyp)) then |
| return; |
| end if; |
| |
| -- Add renaming declarations for discriminals and a declaration for the |
| -- entry family index (if applicable). |
| |
| Install_Private_Data_Declarations |
| (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); |
| |
| -- Add a call to Abort_Undefer at the very beginning of the task |
| -- body since this body is called with abort still deferred. |
| |
| if Abort_Allowed then |
| Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); |
| Prepend (Call, Declarations (N)); |
| Analyze (Call); |
| end if; |
| |
| -- Place call to Complete_Activation at the head of the statement list. |
| |
| if Restricted_Profile then |
| Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); |
| else |
| Call := Build_Runtime_Call (Loc, RE_Complete_Activation); |
| end if; |
| |
| Insert_Before |
| (First (Statements (Handled_Statement_Sequence (N))), Call); |
| Analyze (Call); |
| |
| New_N := |
| Make_Subprogram_Body (Loc, |
| Specification => Build_Task_Proc_Specification (Ttyp), |
| Declarations => Declarations (N), |
| Handled_Statement_Sequence => Handled_Statement_Sequence (N)); |
| Set_Is_Task_Body_Procedure (New_N); |
| Set_At_End_Proc (New_N, At_End_Proc (N)); |
| |
| -- If the task contains generic instantiations, cleanup actions are |
| -- delayed until after instantiation. Transfer the activation chain to |
| -- the subprogram, to insure that the activation call is properly |
| -- generated. It the task body contains inner tasks, indicate that the |
| -- subprogram is a task master. |
| |
| if Delay_Cleanups (Ttyp) then |
| Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); |
| Set_Is_Task_Master (New_N, Is_Task_Master (N)); |
| end if; |
| |
| Rewrite (N, New_N); |
| Analyze (N); |
| |
| -- Set elaboration flag immediately after task body. If the body is a |
| -- subunit, the flag is set in the declarative part containing the stub. |
| |
| if Nkind (Parent (N)) /= N_Subunit then |
| Insert_After (N, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| end if; |
| |
| -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after |
| -- the task body. At this point all wrapper specs have been created, |
| -- frozen and included in the dispatch table for the task type. |
| |
| if Ada_Version >= Ada_2005 then |
| if Nkind (Parent (N)) = N_Subunit then |
| Insert_Nod := Corresponding_Stub (Parent (N)); |
| else |
| Insert_Nod := N; |
| end if; |
| |
| Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); |
| end if; |
| end Expand_N_Task_Body; |
| |
| ------------------------------------ |
| -- Expand_N_Task_Type_Declaration -- |
| ------------------------------------ |
| |
| -- We have several things to do. First we must create a Boolean flag used |
| -- to mark if the body is elaborated yet. This variable gets set to True |
| -- when the body of the task is elaborated (we can't rely on the normal |
| -- ABE mechanism for the task body, since we need to pass an access to |
| -- this elaboration boolean to the runtime routines). |
| |
| -- taskE : aliased Boolean := False; |
| |
| -- Next a variable is declared to hold the task stack size (either the |
| -- default : Unspecified_Size, or a value that is set by a pragma |
| -- Storage_Size). If the value of the pragma Storage_Size is static, then |
| -- the variable is initialized with this value: |
| |
| -- taskZ : Size_Type := Unspecified_Size; |
| -- or |
| -- taskZ : Size_Type := Size_Type (size_expression); |
| |
| -- Note: No variable is needed to hold the task relative deadline since |
| -- its value would never be static because the parameter is of a private |
| -- type (Ada.Real_Time.Time_Span). |
| |
| -- Next we create a corresponding record type declaration used to represent |
| -- values of this task. The general form of this type declaration is |
| |
| -- type taskV (discriminants) is record |
| -- _Task_Id : Task_Id; |
| -- entry_family : array (bounds) of Void; |
| -- _Priority : Integer := priority_expression; |
| -- _Size : Size_Type := size_expression; |
| -- _Secondary_Stack_Size : Size_Type := size_expression; |
| -- _Task_Info : Task_Info_Type := task_info_expression; |
| -- _CPU : Integer := cpu_range_expression; |
| -- _Relative_Deadline : Time_Span := time_span_expression; |
| -- _Domain : Dispatching_Domain := dd_expression; |
| -- end record; |
| |
| -- The discriminants are present only if the corresponding task type has |
| -- discriminants, and they exactly mirror the task type discriminants. |
| |
| -- The Id field is always present. It contains the Task_Id value, as set by |
| -- the call to Create_Task. Note that although the task is limited, the |
| -- task value record type is not limited, so there is no problem in passing |
| -- this field as an out parameter to Create_Task. |
| |
| -- One entry_family component is present for each entry family in the task |
| -- definition. The bounds correspond to the bounds of the entry family |
| -- (which may depend on discriminants). The element type is void, since we |
| -- only need the bounds information for determining the entry index. Note |
| -- that the use of an anonymous array would normally be illegal in this |
| -- context, but this is a parser check, and the semantics is quite prepared |
| -- to handle such a case. |
| |
| -- The _Size field is present only if a Storage_Size pragma appears in the |
| -- task definition. The expression captures the argument that was present |
| -- in the pragma, and is used to override the task stack size otherwise |
| -- associated with the task type. |
| |
| -- The _Secondary_Stack_Size field is present only the task entity has a |
| -- Secondary_Stack_Size rep item. It will be filled at the freeze point, |
| -- when the record init proc is built, to capture the expression of the |
| -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot |
| -- be filled here since aspect evaluations are delayed till the freeze |
| -- point. |
| |
| -- The _Priority field is present only if the task entity has a Priority or |
| -- Interrupt_Priority rep item (pragma, aspect specification or attribute |
| -- definition clause). It will be filled at the freeze point, when the |
| -- record init proc is built, to capture the expression of the rep item |
| -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled |
| -- here since aspect evaluations are delayed till the freeze point. |
| |
| -- The _Task_Info field is present only if a Task_Info pragma appears in |
| -- the task definition. The expression captures the argument that was |
| -- present in the pragma, and is used to provide the Task_Image parameter |
| -- to the call to Create_Task. |
| |
| -- The _CPU field is present only if the task entity has a CPU rep item |
| -- (pragma, aspect specification or attribute definition clause). It will |
| -- be filled at the freeze point, when the record init proc is built, to |
| -- capture the expression of the rep item (see Build_Record_Init_Proc in |
| -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations |
| -- are delayed till the freeze point. |
| |
| -- The _Relative_Deadline field is present only if a Relative_Deadline |
| -- pragma appears in the task definition. The expression captures the |
| -- argument that was present in the pragma, and is used to provide the |
| -- Relative_Deadline parameter to the call to Create_Task. |
| |
| -- The _Domain field is present only if the task entity has a |
| -- Dispatching_Domain rep item (pragma, aspect specification or attribute |
| -- definition clause). It will be filled at the freeze point, when the |
| -- record init proc is built, to capture the expression of the rep item |
| -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled |
| -- here since aspect evaluations are delayed till the freeze point. |
| |
| -- When a task is declared, an instance of the task value record is |
| -- created. The elaboration of this declaration creates the correct bounds |
| -- for the entry families, and also evaluates the size, priority, and |
| -- task_Info expressions if needed. The initialization routine for the task |
| -- type itself then calls Create_Task with appropriate parameters to |
| -- initialize the value of the Task_Id field. |
| |
| -- Note: the address of this record is passed as the "Discriminants" |
| -- parameter for Create_Task. Since Create_Task merely passes this onto the |
| -- body procedure, it does not matter that it does not quite match the |
| -- GNARLI model of what is being passed (the record contains more than just |
| -- the discriminants, but the discriminants can be found from the record |
| -- value). |
| |
| -- The Entity_Id for this created record type is placed in the |
| -- Corresponding_Record_Type field of the associated task type entity. |
| |
| -- Next we create a procedure specification for the task body procedure: |
| |
| -- procedure taskB (_Task : access taskV); |
| |
| -- Note that this must come after the record type declaration, since |
| -- the spec refers to this type. It turns out that the initialization |
| -- procedure for the value type references the task body spec, but that's |
| -- fine, since it won't be generated till the freeze point for the type, |
| -- which is certainly after the task body spec declaration. |
| |
| -- Finally, we set the task index value field of the entry attribute in |
| -- the case of a simple entry. |
| |
| procedure Expand_N_Task_Type_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| TaskId : constant Entity_Id := Defining_Identifier (N); |
| Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); |
| Tasknm : constant Name_Id := Chars (Tasktyp); |
| Taskdef : constant Node_Id := Task_Definition (N); |
| |
| Body_Decl : Node_Id; |
| Cdecls : List_Id; |
| Decl_Stack : Node_Id; |
| Decl_SS : Node_Id; |
| Elab_Decl : Node_Id; |
| Ent_Stack : Entity_Id; |
| Proc_Spec : Node_Id; |
| Rec_Decl : Node_Id; |
| Rec_Ent : Entity_Id; |
| Size_Decl : Entity_Id; |
| Task_Size : Node_Id; |
| |
| function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; |
| -- Searches the task definition T for the first occurrence of the pragma |
| -- Relative Deadline. The caller has ensured that the pragma is present |
| -- in the task definition. Note that this routine cannot be implemented |
| -- with the Rep Item chain mechanism since Relative_Deadline pragmas are |
| -- not chained because their expansion into a procedure call statement |
| -- would cause a break in the chain. |
| |
| ---------------------------------- |
| -- Get_Relative_Deadline_Pragma -- |
| ---------------------------------- |
| |
| function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is |
| N : Node_Id; |
| |
| begin |
| N := First (Visible_Declarations (T)); |
| while Present (N) loop |
| if Nkind (N) = N_Pragma |
| and then Pragma_Name (N) = Name_Relative_Deadline |
| then |
| return N; |
| end if; |
| |
| Next (N); |
| end loop; |
| |
| N := First (Private_Declarations (T)); |
| while Present (N) loop |
| if Nkind (N) = N_Pragma |
| and then Pragma_Name (N) = Name_Relative_Deadline |
| then |
| return N; |
| end if; |
| |
| Next (N); |
| end loop; |
| |
| raise Program_Error; |
| end Get_Relative_Deadline_Pragma; |
| |
| -- Start of processing for Expand_N_Task_Type_Declaration |
| |
| begin |
| -- If already expanded, nothing to do |
| |
| if Present (Corresponding_Record_Type (Tasktyp)) then |
| return; |
| end if; |
| |
| -- Here we will do the expansion |
| |
| Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); |
| |
| Rec_Ent := Defining_Identifier (Rec_Decl); |
| Cdecls := Component_Items (Component_List |
| (Type_Definition (Rec_Decl))); |
| |
| Qualify_Entity_Names (N); |
| |
| -- First create the elaboration variable |
| |
| Elab_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Sloc (Tasktyp), |
| Chars => New_External_Name (Tasknm, 'E')), |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc)); |
| |
| Insert_After (N, Elab_Decl); |
| |
| -- Next create the declaration of the size variable (tasknmZ) |
| |
| Set_Storage_Size_Variable (Tasktyp, |
| Make_Defining_Identifier (Sloc (Tasktyp), |
| Chars => New_External_Name (Tasknm, 'Z'))); |
| |
| if Present (Taskdef) |
| and then Has_Storage_Size_Pragma (Taskdef) |
| and then |
| Is_OK_Static_Expression |
| (Expression |
| (First (Pragma_Argument_Associations |
| (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) |
| then |
| Size_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Storage_Size_Variable (Tasktyp), |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Size_Type), Loc), |
| Expression => |
| Convert_To (RTE (RE_Size_Type), |
| Relocate_Node |
| (Expression (First (Pragma_Argument_Associations |
| (Get_Rep_Pragma |
| (TaskId, Name_Storage_Size))))))); |
| |
| else |
| Size_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Storage_Size_Variable (Tasktyp), |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Size_Type), Loc), |
| Expression => |
| New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); |
| end if; |
| |
| Insert_After (Elab_Decl, Size_Decl); |
| |
| -- Next build the rest of the corresponding record declaration. This is |
| -- done last, since the corresponding record initialization procedure |
| -- will reference the previously created entities. |
| |
| -- Fill in the component declarations -- first the _Task_Id field |
| |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uTask_Id), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), |
| Loc)))); |
| |
| -- Declare static ATCB (that is, created by the expander) if we are |
| -- using the Restricted run time. |
| |
| if Restricted_Profile then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uATCB), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => True, |
| Subtype_Indication => Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), |
| |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => |
| New_List (Make_Integer_Literal (Loc, 0))))))); |
| |
| end if; |
| |
| -- Declare static stack (that is, created by the expander) if we are |
| -- using the Restricted run time on a bare board configuration. |
| |
| if Restricted_Profile and then Preallocated_Stacks_On_Target then |
| |
| -- First we need to extract the appropriate stack size |
| |
| Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); |
| |
| if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then |
| declare |
| Expr_N : constant Node_Id := |
| Expression (First ( |
| Pragma_Argument_Associations ( |
| Get_Rep_Pragma (TaskId, Name_Storage_Size)))); |
| Etyp : constant Entity_Id := Etype (Expr_N); |
| P : constant Node_Id := Parent (Expr_N); |
| |
| begin |
| -- The stack is defined inside the corresponding record. |
| -- Therefore if the size of the stack is set by means of |
| -- a discriminant, we must reference the discriminant of the |
| -- corresponding record type. |
| |
| if Nkind (Expr_N) in N_Has_Entity |
| and then Present (Discriminal_Link (Entity (Expr_N))) |
| then |
| Task_Size := |
| New_Occurrence_Of |
| (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), |
| Loc); |
| Set_Parent (Task_Size, P); |
| Set_Etype (Task_Size, Etyp); |
| Set_Analyzed (Task_Size); |
| |
| else |
| Task_Size := New_Copy_Tree (Expr_N); |
| end if; |
| end; |
| |
| else |
| Task_Size := |
| New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); |
| end if; |
| |
| Decl_Stack := Make_Component_Declaration (Loc, |
| Defining_Identifier => Ent_Stack, |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => True, |
| Subtype_Indication => Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Storage_Array), Loc), |
| |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List (Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Convert_To (RTE (RE_Storage_Offset), |
| Task_Size))))))); |
| |
| Append_To (Cdecls, Decl_Stack); |
| |
| -- The appropriate alignment for the stack is ensured by the run-time |
| -- code in charge of task creation. |
| |
| end if; |
| |
| -- Declare a static secondary stack if the conditions for a statically |
| -- generated stack are met. |
| |
| if Create_Secondary_Stack_For_Task (TaskId) then |
| declare |
| Size_Expr : constant Node_Id := |
| Expression (First ( |
| Pragma_Argument_Associations ( |
| Get_Rep_Pragma (TaskId, |
| Name_Secondary_Stack_Size)))); |
| |
| Stack_Size : Node_Id; |
| |
| begin |
| -- The secondary stack is defined inside the corresponding |
| -- record. Therefore if the size of the stack is set by means |
| -- of a discriminant, we must reference the discriminant of the |
| -- corresponding record type. |
| |
| if Nkind (Size_Expr) in N_Has_Entity |
| and then Present (Discriminal_Link (Entity (Size_Expr))) |
| then |
| Stack_Size := |
| New_Occurrence_Of |
| (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), |
| Loc); |
| Set_Parent (Stack_Size, Parent (Size_Expr)); |
| Set_Etype (Stack_Size, Etype (Size_Expr)); |
| Set_Analyzed (Stack_Size); |
| |
| else |
| Stack_Size := New_Copy_Tree (Size_Expr); |
| end if; |
| |
| -- Create the secondary stack for the task |
| |
| Decl_SS := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uSecondary_Stack), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => True, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_SS_Stack), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Convert_To (RTE (RE_Size_Type), |
| Stack_Size)))))); |
| |
| Append_To (Cdecls, Decl_SS); |
| end; |
| end if; |
| |
| -- Add components for entry families |
| |
| Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); |
| |
| -- Add the _Priority component if a Interrupt_Priority or Priority rep |
| -- item is present. |
| |
| if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uPriority), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (Standard_Integer, Loc)))); |
| end if; |
| |
| -- Add the _Size component if a Storage_Size pragma is present |
| |
| if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uSize), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Size_Type), Loc)), |
| |
| Expression => |
| Convert_To (RTE (RE_Size_Type), |
| New_Copy_Tree ( |
| Expression (First ( |
| Pragma_Argument_Associations ( |
| Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); |
| end if; |
| |
| -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size |
| -- pragma is present. |
| |
| if Has_Rep_Pragma |
| (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) |
| then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); |
| end if; |
| |
| -- Add the _Task_Info component if a Task_Info pragma is present |
| |
| if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uTask_Info), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), |
| |
| Expression => New_Copy ( |
| Expression (First ( |
| Pragma_Argument_Associations ( |
| Get_Rep_Pragma |
| (TaskId, Name_Task_Info, Check_Parents => False))))))); |
| end if; |
| |
| -- Add the _CPU component if a CPU rep item is present |
| |
| if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uCPU), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); |
| end if; |
| |
| -- Add the _Relative_Deadline component if a Relative_Deadline pragma is |
| -- present. If we are using a restricted run time this component will |
| -- not be added (deadlines are not allowed by the Ravenscar profile), |
| -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF |
| -- profile). |
| |
| if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') |
| and then Present (Taskdef) |
| and then Has_Relative_Deadline_Pragma (Taskdef) |
| then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uRelative_Deadline), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Time_Span), Loc)), |
| |
| Expression => |
| Convert_To (RTE (RE_Time_Span), |
| New_Copy_Tree ( |
| Expression (First ( |
| Pragma_Argument_Associations ( |
| Get_Relative_Deadline_Pragma (Taskdef)))))))); |
| end if; |
| |
| -- Add the _Dispatching_Domain component if a Dispatching_Domain rep |
| -- item is present. If we are using a restricted run time this component |
| -- will not be added (dispatching domains are not allowed by the |
| -- Ravenscar profile). |
| |
| if not Restricted_Profile |
| and then |
| Has_Rep_Item |
| (TaskId, Name_Dispatching_Domain, Check_Parents => False) |
| then |
| Append_To (Cdecls, |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uDispatching_Domain), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of |
| (RTE (RE_Dispatching_Domain_Access), Loc)))); |
| end if; |
| |
| Insert_After (Size_Decl, Rec_Decl); |
| |
| -- Analyze the record declaration immediately after construction, |
| -- because the initialization procedure is needed for single task |
| -- declarations before the next entity is analyzed. |
| |
| Analyze (Rec_Decl); |
| |
| -- Create the declaration of the task body procedure |
| |
| Proc_Spec := Build_Task_Proc_Specification (Tasktyp); |
| Body_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Proc_Spec); |
| Set_Is_Task_Body_Procedure (Body_Decl); |
| |
| Insert_After (Rec_Decl, Body_Decl); |
| |
| -- The subprogram does not comes from source, so we have to indicate the |
| -- need for debugging information explicitly. |
| |
| if Comes_From_Source (Original_Node (N)) then |
| Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); |
| end if; |
| |
| -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before |
| -- the corresponding record has been frozen. |
| |
| if Ada_Version >= Ada_2005 then |
| Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); |
| end if; |
| |
| -- Ada 2005 (AI-345): We must defer freezing to allow further |
| -- declaration of primitive subprograms covering task interfaces |
| |
| if Ada_Version <= Ada_95 then |
| |
| -- Now we can freeze the corresponding record. This needs manually |
| -- freezing, since it is really part of the task type, and the task |
| -- type is frozen at this stage. We of course need the initialization |
| -- procedure for this corresponding record type and we won't get it |
| -- in time if we don't freeze now. |
| |
| Insert_List_After (Body_Decl, List => Freeze_Entity (Rec_Ent, N)); |
| end if; |
| |
| -- Complete the expansion of access types to the current task type, if |
| -- any were declared. |
| |
| Expand_Previous_Access_Type (Tasktyp); |
| |
| -- Create wrappers for entries that have contract cases, preconditions |
| -- and postconditions. |
| |
| declare |
| Ent : Entity_Id; |
| |
| begin |
| Ent := First_Entity (Tasktyp); |
| while Present (Ent) loop |
| if Ekind (Ent) in E_Entry | E_Entry_Family then |
| Build_Entry_Contract_Wrapper (Ent, N); |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| end; |
| end Expand_N_Task_Type_Declaration; |
| |
| ------------------------------- |
| -- Expand_N_Timed_Entry_Call -- |
| ------------------------------- |
| |
| -- A timed entry call in normal case is not implemented using ATC mechanism |
| -- anymore for efficiency reason. |
| |
| -- select |
| -- T.E; |
| -- S1; |
| -- or |
| -- delay D; |
| -- S2; |
| -- end select; |
| |
| -- is expanded as follows: |
| |
| -- 1) When T.E is a task entry_call; |
| |
| -- declare |
| -- B : Boolean; |
| -- X : Task_Entry_Index := <entry index>; |
| -- DX : Duration := To_Duration (D); |
| -- M : Delay_Mode := <discriminant>; |
| -- P : parms := (parm, parm, parm); |
| |
| -- begin |
| -- Timed_Protected_Entry_Call |
| -- (<acceptor-task>, X, P'Address, DX, M, B); |
| -- if B then |
| -- S1; |
| -- else |
| -- S2; |
| -- end if; |
| -- end; |
| |
| -- 2) When T.E is a protected entry_call; |
| |
| -- declare |
| -- B : Boolean; |
| -- X : Protected_Entry_Index := <entry index>; |
| -- DX : Duration := To_Duration (D); |
| -- M : Delay_Mode := <discriminant>; |
| -- P : parms := (parm, parm, parm); |
| |
| -- begin |
| -- Timed_Protected_Entry_Call |
| -- (<object>'unchecked_access, X, P'Address, DX, M, B); |
| -- if B then |
| -- S1; |
| -- else |
| -- S2; |
| -- end if; |
| -- end; |
| |
| -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there |
| -- is no delay and the triggering statements are executed. We first |
| -- determine the kind of the triggering call and then execute a |
| -- synchronized operation or a direct call. |
| |
| -- declare |
| -- B : Boolean := False; |
| -- C : Ada.Tags.Prim_Op_Kind; |
| -- DX : Duration := To_Duration (D) |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); |
| -- M : Integer :=...; |
| -- P : Parameters := (Param1 .. ParamN); |
| -- S : Integer; |
| |
| -- begin |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- <dispatching-call>; |
| -- B := True; |
| |
| -- else |
| -- S := |
| -- Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); |
| |
| -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); |
| |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| -- end if; |
| |
| -- if B then |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure |
| -- then |
| -- <dispatching-call>; |
| -- end if; |
| -- end if; |
| -- end if; |
| |
| -- if B then |
| -- <triggering-statements> |
| -- else |
| -- <timed-statements> |
| -- end if; |
| -- end; |
| |
| -- The triggering statement and the sequence of timed statements have not |
| -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain |
| -- global references if within an instantiation. |
| |
| procedure Expand_N_Timed_Entry_Call (N : Node_Id) is |
| Actuals : List_Id; |
| Blk_Typ : Entity_Id; |
| Call : Node_Id; |
| Call_Ent : Entity_Id; |
| Conc_Typ_Stmts : List_Id; |
| Concval : Node_Id := Empty; -- init to avoid warning |
| D_Alt : constant Node_Id := Delay_Alternative (N); |
| D_Conv : Node_Id; |
| D_Disc : Node_Id; |
| D_Stat : Node_Id := Delay_Statement (D_Alt); |
| D_Stats : List_Id; |
| D_Type : Entity_Id; |
| Decls : List_Id; |
| Dummy : Node_Id; |
| E_Alt : constant Node_Id := Entry_Call_Alternative (N); |
| E_Call : Node_Id := Entry_Call_Statement (E_Alt); |
| E_Stats : List_Id; |
| Ename : Node_Id; |
| Formals : List_Id; |
| Index : Node_Id; |
| Is_Disp_Select : Boolean; |
| Lim_Typ_Stmts : List_Id; |
| Loc : constant Source_Ptr := Sloc (D_Stat); |
| N_Stats : List_Id; |
| Obj : Entity_Id; |
| Param : Node_Id; |
| Params : List_Id; |
| Stmt : Node_Id; |
| Stmts : List_Id; |
| Unpack : List_Id; |
| |
| B : Entity_Id; -- Call status flag |
| C : Entity_Id; -- Call kind |
| D : Entity_Id; -- Delay |
| K : Entity_Id; -- Tagged kind |
| M : Entity_Id; -- Delay mode |
| P : Entity_Id; -- Parameter block |
| S : Entity_Id; -- Primitive operation slot |
| |
| -- Start of processing for Expand_N_Timed_Entry_Call |
| |
| begin |
| -- Under the Ravenscar profile, timed entry calls are excluded. An error |
| -- was already reported on spec, so do not attempt to expand the call. |
| |
| if Restriction_Active (No_Select_Statements) then |
| return; |
| end if; |
| |
| Process_Statements_For_Controlled_Objects (E_Alt); |
| Process_Statements_For_Controlled_Objects (D_Alt); |
| |
| Ensure_Statement_Present (Sloc (D_Stat), D_Alt); |
| |
| -- Retrieve E_Stats and D_Stats now because the finalization machinery |
| -- may wrap them in blocks. |
| |
| E_Stats := Statements (E_Alt); |
| D_Stats := Statements (D_Alt); |
| |
| -- 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 (E_Call) = N_Block_Statement then |
| E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); |
| while Nkind (E_Call) not in |
| N_Procedure_Call_Statement | N_Entry_Call_Statement |
| loop |
| Next (E_Call); |
| end loop; |
| end if; |
| |
| Is_Disp_Select := |
| Ada_Version >= Ada_2005 |
| and then Nkind (E_Call) = N_Procedure_Call_Statement; |
| |
| if Is_Disp_Select then |
| Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); |
| Decls := New_List; |
| |
| Stmts := New_List; |
| |
| -- Generate: |
| -- B : Boolean := False; |
| |
| B := Build_B (Loc, Decls); |
| |
| -- Generate: |
| -- C : Ada.Tags.Prim_Op_Kind; |
| |
| C := Build_C (Loc, Decls); |
| |
| -- Because the analysis of all statements was disabled, manually |
| -- analyze the delay statement. |
| |
| Analyze (D_Stat); |
| D_Stat := Original_Node (D_Stat); |
| |
| else |
| -- Build an entry call using Simple_Entry_Call |
| |
| Extract_Entry (E_Call, Concval, Ename, Index); |
| Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); |
| |
| Decls := Declarations (E_Call); |
| Stmts := Statements (Handled_Statement_Sequence (E_Call)); |
| |
| if No (Decls) then |
| Decls := New_List; |
| end if; |
| |
| -- Generate: |
| -- B : Boolean; |
| |
| B := Make_Defining_Identifier (Loc, Name_uB); |
| |
| Prepend_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => B, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| end if; |
| |
| -- Duration and mode processing |
| |
| D_Type := Base_Type (Etype (Expression (D_Stat))); |
| |
| -- Use the type of the delay expression (Calendar or Real_Time) to |
| -- generate the appropriate conversion. |
| |
| if Nkind (D_Stat) = N_Delay_Relative_Statement then |
| D_Disc := Make_Integer_Literal (Loc, 0); |
| D_Conv := Relocate_Node (Expression (D_Stat)); |
| |
| elsif Is_RTE (D_Type, RO_CA_Time) then |
| D_Disc := Make_Integer_Literal (Loc, 1); |
| D_Conv := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), |
| Parameter_Associations => |
| New_List (New_Copy (Expression (D_Stat)))); |
| |
| else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); |
| D_Disc := Make_Integer_Literal (Loc, 2); |
| D_Conv := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), |
| Parameter_Associations => |
| New_List (New_Copy (Expression (D_Stat)))); |
| end if; |
| |
| D := Make_Temporary (Loc, 'D'); |
| |
| -- Generate: |
| -- D : Duration; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => D, |
| Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); |
| |
| M := Make_Temporary (Loc, 'M'); |
| |
| -- Generate: |
| -- M : Integer := (0 | 1 | 2); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => M, |
| Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => D_Disc)); |
| |
| -- Parameter block processing |
| |
| -- Manually create the parameter block for dispatching calls. In the |
| -- case of entries, the block has already been created during the call |
| -- to Build_Simple_Entry_Call. |
| |
| if Is_Disp_Select then |
| |
| -- Compute the delay at this stage because the evaluation of its |
| -- expression must not occur earlier (see ACVC C97302A). |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (D, Loc), |
| Expression => D_Conv)); |
| |
| -- Tagged kind processing, generate: |
| -- K : Ada.Tags.Tagged_Kind := |
| -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); |
| |
| K := Build_K (Loc, Decls, Obj); |
| |
| Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); |
| P := |
| Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); |
| |
| -- Dispatch table slot processing, generate: |
| -- S : Integer; |
| |
| S := Build_S (Loc, Decls); |
| |
| -- Generate: |
| -- S := Ada.Tags.Get_Offset_Index |
| -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); |
| |
| Conc_Typ_Stmts := |
| New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); |
| |
| -- Generate: |
| -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); |
| |
| -- where Obj is the controlling formal parameter, S is the dispatch |
| -- table slot number of the dispatching operation, P is the wrapped |
| -- parameter block, D is the duration, M is the duration mode, C is |
| -- the call kind and B is the call status. |
| |
| Params := New_List; |
| |
| Append_To (Params, New_Copy_Tree (Obj)); |
| Append_To (Params, New_Occurrence_Of (S, Loc)); |
| Append_To (Params, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (P, Loc), |
| Attribute_Name => Name_Address)); |
| Append_To (Params, New_Occurrence_Of (D, Loc)); |
| Append_To (Params, New_Occurrence_Of (M, Loc)); |
| Append_To (Params, New_Occurrence_Of (C, Loc)); |
| Append_To (Params, New_Occurrence_Of (B, Loc)); |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Find_Prim_Op |
| (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), |
| Parameter_Associations => Params)); |
| |
| -- Generate: |
| -- if C = POK_Protected_Entry |
| -- or else C = POK_Task_Entry |
| -- then |
| -- Param1 := P.Param1; |
| -- ... |
| -- ParamN := P.ParamN; |
| -- end if; |
| |
| Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); |
| |
| -- Generate the if statement only when the packed parameters need |
| -- explicit assignments to their corresponding actuals. |
| |
| if Present (Unpack) then |
| Append_To (Conc_Typ_Stmts, |
| Make_Implicit_If_Statement (N, |
| |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of |
| (RTE (RE_POK_Protected_Entry), Loc)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), |
| |
| Then_Statements => Unpack)); |
| end if; |
| |
| -- Generate: |
| |
| -- if B then |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure |
| -- then |
| -- <dispatching-call> |
| -- end if; |
| -- end if; |
| |
| N_Stats := New_List ( |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), |
| |
| Right_Opnd => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (RTE ( |
| RE_POK_Protected_Procedure), Loc)), |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (C, Loc), |
| Right_Opnd => |
| New_Occurrence_Of |
| (RTE (RE_POK_Task_Procedure), Loc)))), |
| |
| Then_Statements => New_List (E_Call))); |
| |
| Append_To (Conc_Typ_Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (B, Loc), |
| Then_Statements => N_Stats)); |
| |
| -- Generate: |
| -- <dispatching-call>; |
| -- B := True; |
| |
| Lim_Typ_Stmts := |
| New_List (New_Copy_Tree (E_Call), |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (B, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| |
| -- Generate: |
| -- if K = Ada.Tags.TK_Limited_Tagged |
| -- or else K = Ada.Tags.TK_Tagged |
| -- then |
| -- Lim_Typ_Stmts |
| -- else |
| -- Conc_Typ_Stmts |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => Build_Dispatching_Tag_Check (K, N), |
| Then_Statements => Lim_Typ_Stmts, |
| Else_Statements => Conc_Typ_Stmts)); |
| |
| -- Generate: |
| |
| -- if B then |
| -- <triggering-statements> |
| -- else |
| -- <timed-statements> |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (B, Loc), |
| Then_Statements => E_Stats, |
| Else_Statements => D_Stats)); |
| |
| else |
| -- Simple case of a nondispatching trigger. 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 ??? |
| |
| Stmt := First (Stmts); |
| while Nkind (Stmt) /= N_Procedure_Call_Statement loop |
| Next (Stmt); |
| end loop; |
| |
| -- Compute the delay at this stage because the evaluation of |
| -- its expression must not occur earlier (see ACVC C97302A). |
| |
| Insert_Before (Stmt, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (D, Loc), |
| Expression => D_Conv)); |
| |
| Call := Stmt; |
| Params := Parameter_Associations (Call); |
| |
| -- For a protected type, we build a Timed_Protected_Entry_Call |
| |
| if Is_Protected_Type (Etype (Concval)) then |
| |
| -- Create a new call statement |
| |
| Param := First (Params); |
| while Present (Param) |
| and then not Is_RTE (Etype (Param), RE_Call_Modes) |
| loop |
| Next (Param); |
| end loop; |
| |
| Dummy := Remove_Next (Next (Param)); |
| |
| -- Remove garbage is following the Cancel_Param if present |
| |
| Dummy := Next (Param); |
| |
| -- Remove the mode of the Protected_Entry_Call call, then remove |
| -- the Communication_Block of the Protected_Entry_Call call, and |
| -- finally add Duration and a Delay_Mode parameter |
| |
| pragma Assert (Present (Param)); |
| Rewrite (Param, New_Occurrence_Of (D, Loc)); |
| |
| Rewrite (Dummy, New_Occurrence_Of (M, Loc)); |
| |
| -- Add a Boolean flag for successful entry call |
| |
| Append_To (Params, New_Occurrence_Of (B, Loc)); |
| |
| case Corresponding_Runtime_Package (Etype (Concval)) is |
| when System_Tasking_Protected_Objects_Entries => |
| Rewrite (Call, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Timed_Protected_Entry_Call), Loc), |
| Parameter_Associations => Params)); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- For the task case, build a Timed_Task_Entry_Call |
| |
| else |
| -- Create a new call statement |
| |
| Append_To (Params, New_Occurrence_Of (D, Loc)); |
| Append_To (Params, New_Occurrence_Of (M, Loc)); |
| Append_To (Params, New_Occurrence_Of (B, Loc)); |
| |
| Rewrite (Call, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), |
| Parameter_Associations => Params)); |
| end if; |
| |
| Append_To (Stmts, |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (B, Loc), |
| Then_Statements => E_Stats, |
| Else_Statements => D_Stats)); |
| end if; |
| |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts))); |
| |
| Analyze (N); |
| |
| -- Some items in Decls used to be in the N_Block in E_Call that is |
| -- constructed in Expand_Entry_Call, and are now in the new Block |
| -- into which N has been rewritten. Adjust their scopes to reflect that. |
| |
| if Nkind (E_Call) = N_Block_Statement then |
| Obj := First_Entity (Entity (Identifier (E_Call))); |
| while Present (Obj) loop |
| Set_Scope (Obj, Entity (Identifier (N))); |
| Next_Entity (Obj); |
| end loop; |
| end if; |
| |
| Reset_Scopes_To (N, Entity (Identifier (N))); |
| end Expand_N_Timed_Entry_Call; |
| |
| ---------------------------------------- |
| -- Expand_Protected_Body_Declarations -- |
| ---------------------------------------- |
| |
| procedure Expand_Protected_Body_Declarations |
| (N : Node_Id; |
| Spec_Id : Entity_Id) |
| is |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("protected body", N); |
| return; |
| |
| elsif Expander_Active then |
| |
| -- Associate discriminals with the first subprogram or entry body to |
| -- be expanded. |
| |
| if Present (First_Protected_Operation (Declarations (N))) then |
| Set_Discriminals (Parent (Spec_Id)); |
| end if; |
| end if; |
| end Expand_Protected_Body_Declarations; |
| |
| ------------------------- |
| -- External_Subprogram -- |
| ------------------------- |
| |
| function External_Subprogram (E : Entity_Id) return Entity_Id is |
| Subp : constant Entity_Id := Protected_Body_Subprogram (E); |
| |
| begin |
| -- The internal and external subprograms follow each other on the entity |
| -- chain. Note that previously private operations had no separate |
| -- external subprogram. We now create one in all cases, because a |
| -- private operation may actually appear in an external call, through |
| -- a 'Access reference used for a callback. |
| |
| -- If the operation is a function that returns an anonymous access type, |
| -- the corresponding itype appears before the operation, and must be |
| -- skipped. |
| |
| -- This mechanism is fragile, there should be a real link between the |
| -- two versions of the operation, but there is no place to put it ??? |
| |
| if Is_Access_Type (Next_Entity (Subp)) then |
| return Next_Entity (Next_Entity (Subp)); |
| else |
| return Next_Entity (Subp); |
| end if; |
| end External_Subprogram; |
| |
| ------------------------------ |
| -- Extract_Dispatching_Call -- |
| ------------------------------ |
| |
| procedure Extract_Dispatching_Call |
| (N : Node_Id; |
| Call_Ent : out Entity_Id; |
| Object : out Entity_Id; |
| Actuals : out List_Id; |
| Formals : out List_Id) |
| is |
| Call_Nam : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (N) = N_Procedure_Call_Statement); |
| |
| if Present (Original_Node (N)) then |
| Call_Nam := Name (Original_Node (N)); |
| else |
| Call_Nam := Name (N); |
| end if; |
| |
| -- Retrieve the name of the dispatching procedure. It contains the |
| -- dispatch table slot number. |
| |
| loop |
| case Nkind (Call_Nam) is |
| when N_Identifier => |
| exit; |
| |
| when N_Selected_Component => |
| Call_Nam := Selector_Name (Call_Nam); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end loop; |
| |
| Actuals := Parameter_Associations (N); |
| Call_Ent := Entity (Call_Nam); |
| Formals := Parameter_Specifications (Parent (Call_Ent)); |
| Object := First (Actuals); |
| |
| if Present (Original_Node (Object)) then |
| Object := Original_Node (Object); |
| end if; |
| |
| -- If the type of the dispatching object is an access type then return |
| -- an explicit dereference of a copy of the object, and note that this |
| -- is the controlling actual of the call. |
| |
| if Is_Access_Type (Etype (Object)) then |
| Object := |
| Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); |
| Analyze (Object); |
| Set_Is_Controlling_Actual (Object); |
| end if; |
| end Extract_Dispatching_Call; |
| |
| ------------------- |
| -- Extract_Entry -- |
| ------------------- |
| |
| procedure Extract_Entry |
| (N : Node_Id; |
| Concval : out Node_Id; |
| Ename : out Node_Id; |
| Index : out Node_Id) |
| is |
| Nam : constant Node_Id := Name (N); |
| |
| begin |
| -- For a simple entry, the name is a selected component, with the |
| -- prefix being the task value, and the selector being the entry. |
| |
| if Nkind (Nam) = N_Selected_Component then |
| Concval := Prefix (Nam); |
| Ename := Selector_Name (Nam); |
| Index := Empty; |
| |
| -- For a member of an entry family, the name is an indexed component |
| -- where the prefix is a selected component, whose prefix in turn is |
| -- the task value, and whose selector is the entry family. The single |
| -- expression in the expressions list of the indexed component is the |
| -- subscript for the family. |
| |
| else pragma Assert (Nkind (Nam) = N_Indexed_Component); |
| Concval := Prefix (Prefix (Nam)); |
| Ename := Selector_Name (Prefix (Nam)); |
| Index := First (Expressions (Nam)); |
| end if; |
| |
| -- Through indirection, the type may actually be a limited view of a |
| -- concurrent type. When compiling a call, the non-limited view of the |
| -- type is visible. |
| |
| if From_Limited_With (Etype (Concval)) then |
| Set_Etype (Concval, Non_Limited_View (Etype (Concval))); |
| end if; |
| end Extract_Entry; |
| |
| ------------------- |
| -- Family_Offset -- |
| ------------------- |
| |
| function Family_Offset |
| (Loc : Source_Ptr; |
| Hi : Node_Id; |
| Lo : Node_Id; |
| Ttyp : Entity_Id; |
| Cap : Boolean) return Node_Id |
| is |
| Ityp : Entity_Id; |
| Real_Hi : Node_Id; |
| Real_Lo : Node_Id; |
| |
| function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; |
| -- If one of the bounds is a reference to a discriminant, replace with |
| -- corresponding discriminal of type. Within the body of a task retrieve |
| -- the renamed discriminant by simple visibility, using its generated |
| -- name. Within a protected object, find the original discriminant and |
| -- replace it with the discriminal of the current protected operation. |
| |
| ------------------------------ |
| -- Convert_Discriminant_Ref -- |
| ------------------------------ |
| |
| function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (Bound); |
| B : Node_Id; |
| D : Entity_Id; |
| |
| begin |
| if Is_Entity_Name (Bound) |
| and then Ekind (Entity (Bound)) = E_Discriminant |
| then |
| if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then |
| B := Make_Identifier (Loc, Chars (Entity (Bound))); |
| Find_Direct_Name (B); |
| |
| elsif Is_Protected_Type (Ttyp) then |
| D := First_Discriminant (Ttyp); |
| while Chars (D) /= Chars (Entity (Bound)) loop |
| Next_Discriminant (D); |
| end loop; |
| |
| B := New_Occurrence_Of (Discriminal (D), Loc); |
| |
| else |
| B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); |
| end if; |
| |
| elsif Nkind (Bound) = N_Attribute_Reference then |
| return Bound; |
| |
| else |
| B := New_Copy_Tree (Bound); |
| end if; |
| |
| return |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Pos, |
| Prefix => New_Occurrence_Of (Etype (Bound), Loc), |
| Expressions => New_List (B)); |
| end Convert_Discriminant_Ref; |
| |
| -- Start of processing for Family_Offset |
| |
| begin |
| Real_Hi := Convert_Discriminant_Ref (Hi); |
| Real_Lo := Convert_Discriminant_Ref (Lo); |
| |
| if Cap then |
| if Is_Task_Type (Ttyp) then |
| Ityp := RTE (RE_Task_Entry_Index); |
| else |
| Ityp := RTE (RE_Protected_Entry_Index); |
| end if; |
| |
| Real_Hi := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Ityp, Loc), |
| Attribute_Name => Name_Min, |
| Expressions => New_List ( |
| Real_Hi, |
| Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); |
| |
| Real_Lo := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Ityp, Loc), |
| Attribute_Name => Name_Max, |
| Expressions => New_List ( |
| Real_Lo, |
| Make_Integer_Literal (Loc, -Entry_Family_Bound))); |
| end if; |
| |
| return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); |
| end Family_Offset; |
| |
| ----------------- |
| -- Family_Size -- |
| ----------------- |
| |
| function Family_Size |
| (Loc : Source_Ptr; |
| Hi : Node_Id; |
| Lo : Node_Id; |
| Ttyp : Entity_Id; |
| Cap : Boolean) return Node_Id |
| is |
| Ityp : Entity_Id; |
| |
| begin |
| if Is_Task_Type (Ttyp) then |
| Ityp := RTE (RE_Task_Entry_Index); |
| else |
| Ityp := RTE (RE_Protected_Entry_Index); |
| end if; |
| |
| return |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Ityp, Loc), |
| Attribute_Name => Name_Max, |
| Expressions => New_List ( |
| Make_Op_Add (Loc, |
| Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), |
| Right_Opnd => Make_Integer_Literal (Loc, 1)), |
| Make_Integer_Literal (Loc, 0))); |
| end Family_Size; |
| |
| ---------------------------- |
| -- Find_Enclosing_Context -- |
| ---------------------------- |
| |
| procedure Find_Enclosing_Context |
| (N : Node_Id; |
| Context : out Node_Id; |
| Context_Id : out Entity_Id; |
| Context_Decls : out List_Id) |
| is |
| begin |
| -- Traverse the parent chain looking for an enclosing body, block, |
| -- package or return statement. |
| |
| Context := Parent (N); |
| while Present (Context) loop |
| if Nkind (Context) in N_Entry_Body |
| | N_Extended_Return_Statement |
| | N_Package_Body |
| | N_Package_Declaration |
| | N_Subprogram_Body |
| | N_Task_Body |
| then |
| exit; |
| |
| -- Do not consider block created to protect a list of statements with |
| -- an Abort_Defer / Abort_Undefer_Direct pair. |
| |
| elsif Nkind (Context) = N_Block_Statement |
| and then not Is_Abort_Block (Context) |
| then |
| exit; |
| end if; |
| |
| Context := Parent (Context); |
| end loop; |
| |
| pragma Assert (Present (Context)); |
| |
| -- Extract the constituents of the context |
| |
| if Nkind (Context) = N_Extended_Return_Statement then |
| Context_Decls := Return_Object_Declarations (Context); |
| Context_Id := Return_Statement_Entity (Context); |
| |
| -- Package declarations and bodies use a common library-level activation |
| -- chain or task master, therefore return the package declaration as the |
| -- proper carrier for the appropriate flag. |
| |
| elsif Nkind (Context) = N_Package_Body then |
| Context_Decls := Declarations (Context); |
| Context_Id := Corresponding_Spec (Context); |
| Context := Parent (Context_Id); |
| |
| if Nkind (Context) = N_Defining_Program_Unit_Name then |
| Context := Parent (Parent (Context)); |
| else |
| Context := Parent (Context); |
| end if; |
| |
| elsif Nkind (Context) = N_Package_Declaration then |
| Context_Decls := Visible_Declarations (Specification (Context)); |
| Context_Id := Defining_Unit_Name (Specification (Context)); |
| |
| if Nkind (Context_Id) = N_Defining_Program_Unit_Name then |
| Context_Id := Defining_Identifier (Context_Id); |
| end if; |
| |
| else |
| if Nkind (Context) = N_Block_Statement then |
| Context_Id := Entity (Identifier (Context)); |
| |
| if No (Declarations (Context)) then |
| Set_Declarations (Context, New_List); |
| end if; |
| |
| elsif Nkind (Context) = N_Entry_Body then |
| Context_Id := Defining_Identifier (Context); |
| |
| elsif Nkind (Context) = N_Subprogram_Body then |
| if Present (Corresponding_Spec (Context)) then |
| Context_Id := Corresponding_Spec (Context); |
| else |
| Context_Id := Defining_Unit_Name (Specification (Context)); |
| |
| if Nkind (Context_Id) = N_Defining_Program_Unit_Name then |
| Context_Id := Defining_Identifier (Context_Id); |
| end if; |
| end if; |
| |
| elsif Nkind (Context) = N_Task_Body then |
| Context_Id := Corresponding_Spec (Context); |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| Context_Decls := Declarations (Context); |
| end if; |
| |
| pragma Assert (Present (Context_Id)); |
| pragma Assert (Present (Context_Decls)); |
| end Find_Enclosing_Context; |
| |
| ----------------------- |
| -- Find_Master_Scope -- |
| ----------------------- |
| |
| function Find_Master_Scope (E : Entity_Id) return Entity_Id is |
| S : Entity_Id; |
| |
| begin |
| -- In Ada 2005, the master is the innermost enclosing scope that is not |
| -- transient. If the enclosing block is the rewriting of a call or the |
| -- scope is an extended return statement this is valid master. The |
| -- master in an extended return is only used within the return, and is |
| -- subsequently overwritten in Move_Activation_Chain, but it must exist |
| -- now before that overwriting occurs. |
| |
| S := Scope (E); |
| |
| if Ada_Version >= Ada_2005 then |
| while Is_Internal (S) loop |
| if Nkind (Parent (S)) = N_Block_Statement |
| and then Has_Master_Entity (S) |
| then |
| exit; |
| |
| elsif Ekind (S) = E_Return_Statement then |
| exit; |
| |
| else |
| S := Scope (S); |
| end if; |
| end loop; |
| end if; |
| |
| return S; |
| end Find_Master_Scope; |
| |
| ------------------------------- |
| -- First_Protected_Operation -- |
| ------------------------------- |
| |
| function First_Protected_Operation (D : List_Id) return Node_Id is |
| First_Op : Node_Id; |
| |
| begin |
| First_Op := First (D); |
| while Present (First_Op) |
| and then Nkind (First_Op) not in N_Subprogram_Body | N_Entry_Body |
| loop |
| Next (First_Op); |
| end loop; |
| |
| return First_Op; |
| end First_Protected_Operation; |
| |
| --------------------------------------- |
| -- Install_Private_Data_Declarations -- |
| --------------------------------------- |
| |
| procedure Install_Private_Data_Declarations |
| (Loc : Source_Ptr; |
| Spec_Id : Entity_Id; |
| Conc_Typ : Entity_Id; |
| Body_Nod : Node_Id; |
| Decls : List_Id; |
| Barrier : Boolean := False; |
| Family : Boolean := False) |
| is |
| Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); |
| Decl : Node_Id; |
| Def : Node_Id; |
| Insert_Node : Node_Id := Empty; |
| Obj_Ent : Entity_Id; |
| |
| procedure Add (Decl : Node_Id); |
| -- Add a single declaration after Insert_Node. If this is the first |
| -- addition, Decl is added to the front of Decls and it becomes the |
| -- insertion node. |
| |
| function Replace_Bound (Bound : Node_Id) return Node_Id; |
| -- The bounds of an entry index may depend on discriminants, create a |
| -- reference to the corresponding prival. Otherwise return a duplicate |
| -- of the original bound. |
| |
| --------- |
| -- Add -- |
| --------- |
| |
| procedure Add (Decl : Node_Id) is |
| begin |
| if No (Insert_Node) then |
| Prepend_To (Decls, Decl); |
| else |
| Insert_After (Insert_Node, Decl); |
| end if; |
| |
| Insert_Node := Decl; |
| end Add; |
| |
| ------------------- |
| -- Replace_Bound -- |
| ------------------- |
| |
| function Replace_Bound (Bound : Node_Id) return Node_Id is |
| begin |
| if Nkind (Bound) = N_Identifier |
| and then Is_Discriminal (Entity (Bound)) |
| then |
| return Make_Identifier (Loc, Chars (Entity (Bound))); |
| else |
| return Duplicate_Subexpr (Bound); |
| end if; |
| end Replace_Bound; |
| |
| -- Start of processing for Install_Private_Data_Declarations |
| |
| begin |
| -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote |
| -- formal parameter _O, _object or _task depending on the context. |
| |
| Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); |
| |
| -- Special processing of _O for barrier functions, protected entries |
| -- and families. |
| |
| if Barrier |
| or else |
| (Is_Protected |
| and then |
| (Ekind (Spec_Id) = E_Entry |
| or else Ekind (Spec_Id) = E_Entry_Family)) |
| then |
| declare |
| Conc_Rec : constant Entity_Id := |
| Corresponding_Record_Type (Conc_Typ); |
| Typ_Id : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Conc_Rec), 'P')); |
| begin |
| -- Generate: |
| -- type prot_typVP is access prot_typV; |
| |
| Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Typ_Id, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (Conc_Rec, Loc))); |
| Add (Decl); |
| |
| -- Generate: |
| -- _object : prot_typVP := prot_typV (_O); |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uObject), |
| Object_Definition => New_Occurrence_Of (Typ_Id, Loc), |
| Expression => |
| Unchecked_Convert_To (Typ_Id, |
| New_Occurrence_Of (Obj_Ent, Loc))); |
| Add (Decl); |
| |
| -- Set the reference to the concurrent object |
| |
| Obj_Ent := Defining_Identifier (Decl); |
| end; |
| end if; |
| |
| -- Step 2: Create the Protection object and build its declaration for |
| -- any protected entry (family) of subprogram. Note for the lock-free |
| -- implementation, the Protection object is not needed anymore. |
| |
| if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then |
| declare |
| Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Prot_Typ : RE_Id; |
| |
| begin |
| Set_Protection_Object (Spec_Id, Prot_Ent); |
| |
| -- Determine the proper protection type |
| |
| if Has_Attach_Handler (Conc_Typ) |
| and then not Restricted_Profile |
| then |
| Prot_Typ := RE_Static_Interrupt_Protection; |
| |
| elsif Has_Interrupt_Handler (Conc_Typ) |
| and then not Restriction_Active (No_Dynamic_Attachment) |
| then |
| Prot_Typ := RE_Dynamic_Interrupt_Protection; |
| |
| else |
| case Corresponding_Runtime_Package (Conc_Typ) is |
| when System_Tasking_Protected_Objects_Entries => |
| Prot_Typ := RE_Protection_Entries; |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Prot_Typ := RE_Protection_Entry; |
| |
| when System_Tasking_Protected_Objects => |
| Prot_Typ := RE_Protection; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end if; |
| |
| -- Generate: |
| -- conc_typR : protection_typ renames _object._object; |
| |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Prot_Ent, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (Prot_Typ), Loc), |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Obj_Ent, Loc), |
| Selector_Name => Make_Identifier (Loc, Name_uObject))); |
| |
| Add (Decl); |
| end; |
| end if; |
| |
| -- Step 3: Add discriminant renamings (if any) |
| |
| if Has_Discriminants (Conc_Typ) then |
| declare |
| D : Entity_Id; |
| |
| begin |
| D := First_Discriminant (Conc_Typ); |
| while Present (D) loop |
| |
| -- Adjust the source location |
| |
| Set_Sloc (Discriminal (D), Loc); |
| |
| -- Generate: |
| -- discr_name : discr_typ renames _object.discr_name; |
| -- or |
| -- discr_name : discr_typ renames _task.discr_name; |
| |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Discriminal (D), |
| Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Obj_Ent, Loc), |
| Selector_Name => Make_Identifier (Loc, Chars (D)))); |
| |
| Add (Decl); |
| |
| -- Set debug info needed on this renaming declaration even |
| -- though it does not come from source, so that the debugger |
| -- will get the right information for these generated names. |
| |
| Set_Debug_Info_Needed (Discriminal (D)); |
| |
| Next_Discriminant (D); |
| end loop; |
| end; |
| end if; |
| |
| -- Step 4: Add private component renamings (if any) |
| |
| if Is_Protected then |
| Def := Protected_Definition (Parent (Conc_Typ)); |
| |
| if Present (Private_Declarations (Def)) then |
| declare |
| Comp : Node_Id; |
| Comp_Id : Entity_Id; |
| Decl_Id : Entity_Id; |
| Nam : Name_Id; |
| |
| begin |
| Comp := First (Private_Declarations (Def)); |
| while Present (Comp) loop |
| if Nkind (Comp) = N_Component_Declaration then |
| Comp_Id := Defining_Identifier (Comp); |
| Nam := Chars (Comp_Id); |
| Decl_Id := Make_Defining_Identifier (Sloc (Comp_Id), Nam); |
| |
| -- Minimal decoration |
| |
| if Ekind (Spec_Id) = E_Function then |
| Mutate_Ekind (Decl_Id, E_Constant); |
| else |
| Mutate_Ekind (Decl_Id, E_Variable); |
| end if; |
| |
| Set_Prival (Comp_Id, Decl_Id); |
| Set_Prival_Link (Decl_Id, Comp_Id); |
| Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); |
| Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id)); |
| |
| -- Copy the Comes_From_Source flag of the component, as |
| -- the renaming may be the only entity directly seen by |
| -- the user in the context, but do not warn for it. |
| |
| Set_Comes_From_Source |
| (Decl_Id, Comes_From_Source (Comp_Id)); |
| Set_Warnings_Off (Decl_Id); |
| |
| -- Generate: |
| -- comp_name : comp_typ renames _object.comp_name; |
| |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Decl_Id, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Comp_Id), Loc), |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Obj_Ent, Loc), |
| Selector_Name => Make_Identifier (Loc, Nam))); |
| |
| Add (Decl); |
| end if; |
| |
| Next (Comp); |
| end loop; |
| end; |
| end if; |
| end if; |
| |
| -- Step 5: Add the declaration of the entry index and the associated |
| -- type for barrier functions and entry families. |
| |
| if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then |
| declare |
| E : constant Entity_Id := Index_Object (Spec_Id); |
| Index : constant Entity_Id := |
| Defining_Identifier |
| (Entry_Index_Specification |
| (Entry_Body_Formal_Part (Body_Nod))); |
| Index_Con : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Chars (Index)); |
| High : Node_Id; |
| Index_Typ : Entity_Id; |
| Low : Node_Id; |
| |
| begin |
| -- Minimal decoration |
| |
| Mutate_Ekind (Index_Con, E_Constant); |
| Set_Entry_Index_Constant (Index, Index_Con); |
| Set_Discriminal_Link (Index_Con, Index); |
| |
| -- Retrieve the bounds of the entry family |
| |
| High := Type_High_Bound (Etype (Index)); |
| Low := Type_Low_Bound (Etype (Index)); |
| |
| -- In the simple case the entry family is given by a subtype mark |
| -- and the index constant has the same type. |
| |
| if Is_Entity_Name (Original_Node ( |
| Discrete_Subtype_Definition (Parent (Index)))) |
| then |
| Index_Typ := Etype (Index); |
| |
| -- Otherwise a new subtype declaration is required |
| |
| else |
| High := Replace_Bound (High); |
| Low := Replace_Bound (Low); |
| |
| Index_Typ := Make_Temporary (Loc, 'J'); |
| |
| -- Generate: |
| -- subtype Jnn is <Etype of Index> range Low .. High; |
| |
| Decl := |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Index_Typ, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Base_Type (Etype (Index)), Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, Low, High)))); |
| Add (Decl); |
| end if; |
| |
| Set_Etype (Index_Con, Index_Typ); |
| |
| -- Create the object which designates the index: |
| -- J : constant Jnn := |
| -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); |
| -- |
| -- where Jnn is the subtype created above or the original type of |
| -- the index, _E is a formal of the protected body subprogram and |
| -- <index expr> is the index of the first family member. |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Index_Con, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Index_Typ, Loc), |
| |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index_Typ, Loc), |
| Attribute_Name => Name_Val, |
| |
| Expressions => New_List ( |
| |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => New_Occurrence_Of (E, Loc), |
| Right_Opnd => |
| Entry_Index_Expression (Loc, |
| Defining_Identifier (Body_Nod), |
| Empty, Conc_Typ)), |
| |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index_Typ, Loc), |
| Attribute_Name => Name_Pos, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index_Typ, Loc), |
| Attribute_Name => Name_First))))))); |
| Add (Decl); |
| end; |
| end if; |
| end Install_Private_Data_Declarations; |
| |
| --------------------------------- |
| -- Is_Potentially_Large_Family -- |
| --------------------------------- |
| |
| function Is_Potentially_Large_Family |
| (Base_Index : Entity_Id; |
| Conctyp : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id) return Boolean |
| is |
| begin |
| return Scope (Base_Index) = Standard_Standard |
| and then Base_Index = Base_Type (Standard_Integer) |
| and then Has_Defaulted_Discriminants (Conctyp) |
| and then |
| (Denotes_Discriminant (Lo, True) |
| or else |
| Denotes_Discriminant (Hi, True)); |
| end Is_Potentially_Large_Family; |
| |
| ------------------------------------- |
| -- Is_Private_Primitive_Subprogram -- |
| ------------------------------------- |
| |
| function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is |
| begin |
| return |
| (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) |
| and then Is_Private_Primitive (Id); |
| end Is_Private_Primitive_Subprogram; |
| |
| ------------------ |
| -- Index_Object -- |
| ------------------ |
| |
| function Index_Object (Spec_Id : Entity_Id) return Entity_Id is |
| Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); |
| Formal : Entity_Id; |
| |
| begin |
| Formal := First_Formal (Bod_Subp); |
| while Present (Formal) loop |
| |
| -- Look for formal parameter _E |
| |
| if Chars (Formal) = Name_uE then |
| return Formal; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| -- A protected body subprogram should always have the parameter in |
| -- question. |
| |
| raise Program_Error; |
| end Index_Object; |
| |
| -------------------------------- |
| -- Make_Initialize_Protection -- |
| -------------------------------- |
| |
| function Make_Initialize_Protection |
| (Protect_Rec : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Protect_Rec); |
| P_Arr : Entity_Id; |
| Pdec : Node_Id; |
| Ptyp : constant Node_Id := |
| Corresponding_Concurrent_Type (Protect_Rec); |
| Args : List_Id; |
| L : constant List_Id := New_List; |
| Has_Entry : constant Boolean := Has_Entries (Ptyp); |
| Prio_Type : Entity_Id; |
| Prio_Var : Entity_Id := Empty; |
| Restricted : constant Boolean := Restricted_Profile; |
| |
| begin |
| -- We may need two calls to properly initialize the object, one to |
| -- Initialize_Protection, and possibly one to Install_Handlers if we |
| -- have a pragma Attach_Handler. |
| |
| -- Get protected declaration. In the case of a task type declaration, |
| -- this is simply the parent of the protected type entity. In the single |
| -- protected object declaration, this parent will be the implicit type, |
| -- and we can find the corresponding single protected object declaration |
| -- by searching forward in the declaration list in the tree. |
| |
| -- Is the test for N_Single_Protected_Declaration needed here??? Nodes |
| -- of this type should have been removed during semantic analysis. |
| |
| Pdec := Parent (Ptyp); |
| while Nkind (Pdec) not in |
| N_Protected_Type_Declaration | N_Single_Protected_Declaration |
| loop |
| Next (Pdec); |
| end loop; |
| |
| -- Build the parameter list for the call. Note that _Init is the name |
| -- of the formal for the object to be initialized, which is the task |
| -- value record itself. |
| |
| Args := New_List; |
| |
| -- For lock-free implementation, skip initializations of the Protection |
| -- object. |
| |
| if not Uses_Lock_Free (Defining_Identifier (Pdec)) then |
| |
| -- Object parameter. This is a pointer to the object of type |
| -- Protection used by the GNARL to control the protected object. |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uObject)), |
| Attribute_Name => Name_Unchecked_Access)); |
| |
| -- Priority parameter. Set to Unspecified_Priority unless there is a |
| -- Priority rep item, in which case we take the value from the pragma |
| -- or attribute definition clause, or there is an Interrupt_Priority |
| -- rep item and no Priority rep item, and we set the ceiling to |
| -- Interrupt_Priority'Last, an implementation-defined value, see |
| -- (RM D.3(10)). |
| |
| if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then |
| declare |
| Prio_Clause : constant Node_Id := |
| Get_Rep_Item |
| (Ptyp, Name_Priority, Check_Parents => False); |
| |
| Prio : Node_Id; |
| |
| begin |
| -- Pragma Priority |
| |
| if Nkind (Prio_Clause) = N_Pragma then |
| Prio := |
| Expression |
| (First (Pragma_Argument_Associations (Prio_Clause))); |
| |
| -- Get_Rep_Item returns either priority pragma |
| |
| if Pragma_Name (Prio_Clause) = Name_Priority then |
| Prio_Type := RTE (RE_Any_Priority); |
| else |
| Prio_Type := RTE (RE_Interrupt_Priority); |
| end if; |
| |
| -- Attribute definition clause Priority |
| |
| else |
| if Chars (Prio_Clause) = Name_Priority then |
| Prio_Type := RTE (RE_Any_Priority); |
| else |
| Prio_Type := RTE (RE_Interrupt_Priority); |
| end if; |
| |
| Prio := Expression (Prio_Clause); |
| end if; |
| |
| -- Always create a locale variable to capture the priority. |
| -- The priority is also passed to Install_Restriced_Handlers. |
| -- Note that it is really necessary to create this variable |
| -- explicitly. It might be thought that removing side effects |
| -- would the appropriate approach, but that could generate |
| -- declarations improperly placed in the enclosing scope. |
| |
| Prio_Var := Make_Temporary (Loc, 'R', Prio); |
| Append_To (L, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Prio_Var, |
| Object_Definition => New_Occurrence_Of (Prio_Type, Loc), |
| Expression => Relocate_Node (Prio))); |
| |
| Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); |
| end; |
| |
| -- When no priority is specified but an xx_Handler pragma is, we |
| -- default to System.Interrupts.Default_Interrupt_Priority, see |
| -- D.3(10). |
| |
| elsif Has_Attach_Handler (Ptyp) |
| or else Has_Interrupt_Handler (Ptyp) |
| then |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); |
| |
| -- Normal case, no priority or xx_Handler specified, default priority |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); |
| end if; |
| |
| -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes |
| |
| if Restricted_Profile and Task_Dispatching_Policy = 'E' then |
| Deadline_Floor : declare |
| Item : constant Node_Id := |
| Get_Rep_Item |
| (Ptyp, Name_Deadline_Floor, Check_Parents => False); |
| |
| Deadline : Node_Id; |
| |
| begin |
| if Present (Item) then |
| |
| -- Pragma Deadline_Floor |
| |
| if Nkind (Item) = N_Pragma then |
| Deadline := |
| Expression |
| (First (Pragma_Argument_Associations (Item))); |
| |
| -- Attribute definition clause Deadline_Floor |
| |
| else |
| pragma Assert |
| (Nkind (Item) = N_Attribute_Definition_Clause); |
| |
| Deadline := Expression (Item); |
| end if; |
| |
| Append_To (Args, Deadline); |
| |
| -- Unusual case: default deadline |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); |
| end if; |
| end Deadline_Floor; |
| end if; |
| |
| -- Test for Compiler_Info parameter. This parameter allows entry body |
| -- procedures and barrier functions to be called from the runtime. It |
| -- is a pointer to the record generated by the compiler to represent |
| -- the protected object. |
| |
| -- A protected type without entries that covers an interface and |
| -- overrides the abstract routines with protected procedures is |
| -- considered equivalent to a protected type with entries in the |
| -- context of dispatching select statements. |
| |
| -- Protected types with interrupt handlers (when not using a |
| -- restricted profile) are also considered equivalent to protected |
| -- types with entries. |
| |
| -- The types which are used (Static_Interrupt_Protection and |
| -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. |
| |
| declare |
| Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); |
| |
| Called_Subp : RE_Id; |
| |
| begin |
| case Pkg_Id is |
| when System_Tasking_Protected_Objects_Entries => |
| Called_Subp := RE_Initialize_Protection_Entries; |
| |
| -- Argument Compiler_Info |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Address)); |
| |
| when System_Tasking_Protected_Objects_Single_Entry => |
| Called_Subp := RE_Initialize_Protection_Entry; |
| |
| -- Argument Compiler_Info |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Address)); |
| |
| when System_Tasking_Protected_Objects => |
| Called_Subp := RE_Initialize_Protection; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Entry_Queue_Maxes parameter. This is an access to an array of |
| -- naturals representing the entry queue maximums for each entry |
| -- in the protected type. Zero represents no max. The access is |
| -- null if there is no limit for all entries (usual case). |
| |
| if Has_Entry |
| and then Pkg_Id = System_Tasking_Protected_Objects_Entries |
| then |
| if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), |
| Attribute_Name => Name_Unrestricted_Access)); |
| else |
| Append_To (Args, Make_Null (Loc)); |
| end if; |
| |
| -- Edge cases exist where entry initialization functions are |
| -- called, but no entries exist, so null is appended. |
| |
| elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then |
| Append_To (Args, Make_Null (Loc)); |
| end if; |
| |
| -- Entry_Bodies parameter. This is a pointer to an array of |
| -- pointers to the entry body procedures and barrier functions of |
| -- the object. If the protected type has no entries this object |
| -- will not exist, in this case, pass a null (it can happen when |
| -- there are protected interrupt handlers or interfaces). |
| |
| if Has_Entry then |
| P_Arr := Entry_Bodies_Array (Ptyp); |
| |
| -- Argument Entry_Body (for single entry) or Entry_Bodies (for |
| -- multiple entries). |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (P_Arr, Loc), |
| Attribute_Name => Name_Unrestricted_Access)); |
| |
| if Pkg_Id = System_Tasking_Protected_Objects_Entries then |
| |
| -- Find index mapping function (clumsy but ok for now) |
| |
| while Ekind (P_Arr) /= E_Function loop |
| Next_Entity (P_Arr); |
| end loop; |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (P_Arr, Loc), |
| Attribute_Name => Name_Unrestricted_Access)); |
| end if; |
| |
| elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then |
| |
| -- This is the case where we have a protected object with |
| -- interfaces and no entries, and the single entry restriction |
| -- is in effect. We pass a null pointer for the entry |
| -- parameter because there is no actual entry. |
| |
| Append_To (Args, Make_Null (Loc)); |
| |
| elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then |
| |
| -- This is the case where we have a protected object with no |
| -- entries and: |
| -- - either interrupt handlers with non restricted profile, |
| -- - or interfaces |
| -- Note that the types which are used for interrupt handlers |
| -- (Static/Dynamic_Interrupt_Protection) are derived from |
| -- Protection_Entries. We pass two null pointers because there |
| -- is no actual entry, and the initialization procedure needs |
| -- both Entry_Bodies and Find_Body_Index. |
| |
| Append_To (Args, Make_Null (Loc)); |
| Append_To (Args, Make_Null (Loc)); |
| end if; |
| |
| Append_To (L, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (Called_Subp), Loc), |
| Parameter_Associations => Args)); |
| end; |
| end if; |
| |
| if Has_Attach_Handler (Ptyp) then |
| |
| -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to |
| -- make the following call: |
| |
| -- Install_Handlers (_object, |
| -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); |
| |
| -- or, in the case of Ravenscar: |
| |
| -- Install_Restricted_Handlers |
| -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); |
| |
| declare |
| Args : constant List_Id := New_List; |
| Table : constant List_Id := New_List; |
| Ritem : Node_Id := First_Rep_Item (Ptyp); |
| |
| begin |
| -- Build the Priority parameter (only for ravenscar) |
| |
| if Restricted then |
| |
| -- Priority comes from a pragma |
| |
| if Present (Prio_Var) then |
| Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); |
| |
| -- Priority is the default one |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of |
| (RTE (RE_Default_Interrupt_Priority), Loc)); |
| end if; |
| end if; |
| |
| -- Build the Attach_Handler table argument |
| |
| while Present (Ritem) loop |
| if Nkind (Ritem) = N_Pragma |
| and then Pragma_Name (Ritem) = Name_Attach_Handler |
| then |
| declare |
| Handler : constant Node_Id := |
| First (Pragma_Argument_Associations (Ritem)); |
| |
| Interrupt : constant Node_Id := Next (Handler); |
| Expr : constant Node_Id := Expression (Interrupt); |
| |
| begin |
| Append_To (Table, |
| Make_Aggregate (Loc, Expressions => New_List ( |
| Unchecked_Convert_To |
| (RTE (RE_System_Interrupt_Id), Expr), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Duplicate_Subexpr_No_Checks |
| (Expression (Handler))), |
| Attribute_Name => Name_Access)))); |
| end; |
| end if; |
| |
| Next_Rep_Item (Ritem); |
| end loop; |
| |
| -- Append the table argument we just built |
| |
| Append_To (Args, Make_Aggregate (Loc, Table)); |
| |
| -- Append the Install_Handlers (or Install_Restricted_Handlers) |
| -- call to the statements. |
| |
| if Restricted then |
| -- Call a simplified version of Install_Handlers to be used |
| -- when the Ravenscar restrictions are in effect |
| -- (Install_Restricted_Handlers). |
| |
| Append_To (L, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Install_Restricted_Handlers), Loc), |
| Parameter_Associations => Args)); |
| |
| else |
| if not Uses_Lock_Free (Defining_Identifier (Pdec)) then |
| |
| -- First, prepends the _object argument |
| |
| Prepend_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject)), |
| Attribute_Name => Name_Unchecked_Access)); |
| end if; |
| |
| -- Then, insert call to Install_Handlers |
| |
| Append_To (L, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), |
| Parameter_Associations => Args)); |
| end if; |
| end; |
| end if; |
| |
| return L; |
| end Make_Initialize_Protection; |
| |
| --------------------------- |
| -- Make_Task_Create_Call -- |
| --------------------------- |
| |
| function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (Task_Rec); |
| Args : List_Id; |
| Ecount : Node_Id; |
| Name : Node_Id; |
| Tdec : Node_Id; |
| Tdef : Node_Id; |
| Tnam : Name_Id; |
| Ttyp : Node_Id; |
| |
| begin |
| Ttyp := Corresponding_Concurrent_Type (Task_Rec); |
| Tnam := Chars (Ttyp); |
| |
| -- Get task declaration. In the case of a task type declaration, this is |
| -- simply the parent of the task type entity. In the single task |
| -- declaration, this parent will be the implicit type, and we can find |
| -- the corresponding single task declaration by searching forward in the |
| -- declaration list in the tree. |
| |
| -- Is the test for N_Single_Task_Declaration needed here??? Nodes of |
| -- this type should have been removed during semantic analysis. |
| |
| Tdec := Parent (Ttyp); |
| while Nkind (Tdec) not in |
| N_Task_Type_Declaration | N_Single_Task_Declaration |
| loop |
| Next (Tdec); |
| end loop; |
| |
| -- Now we can find the task definition from this declaration |
| |
| Tdef := Task_Definition (Tdec); |
| |
| -- Build the parameter list for the call. Note that _Init is the name |
| -- of the formal for the object to be initialized, which is the task |
| -- value record itself. |
| |
| Args := New_List; |
| |
| -- Priority parameter. Set to Unspecified_Priority unless there is a |
| -- Priority rep item, in which case we take the value from the rep item. |
| -- Not used on Ravenscar_EDF profile. |
| |
| if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then |
| if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uPriority))); |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); |
| end if; |
| end if; |
| |
| -- Optional Stack parameter |
| |
| if Restricted_Profile then |
| |
| -- If the stack has been preallocated by the expander then |
| -- pass its address. Otherwise, pass a null address. |
| |
| if Preallocated_Stacks_On_Target then |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uStack)), |
| Attribute_Name => Name_Address)); |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc)); |
| end if; |
| end if; |
| |
| -- Size parameter. If no Storage_Size pragma is present, then |
| -- the size is taken from the taskZ variable for the type, which |
| -- is either Unspecified_Size, or has been reset by the use of |
| -- a Storage_Size attribute definition clause. If a pragma is |
| -- present, then the size is taken from the _Size field of the |
| -- task value record, which was set from the pragma value. |
| |
| if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uSize))); |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); |
| end if; |
| |
| -- Secondary_Stack parameter used for restricted profiles |
| |
| if Restricted_Profile then |
| |
| -- If the secondary stack has been allocated by the expander then |
| -- pass its access pointer. Otherwise, pass null. |
| |
| if Create_Secondary_Stack_For_Task (Ttyp) then |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uSecondary_Stack)), |
| Attribute_Name => Name_Unrestricted_Access)); |
| |
| else |
| Append_To (Args, Make_Null (Loc)); |
| end if; |
| end if; |
| |
| -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there |
| -- is a Secondary_Stack_Size pragma, in which case take the value from |
| -- the pragma. If the restriction No_Secondary_Stack is active then a |
| -- size of 0 is passed regardless to prevent the allocation of the |
| -- unused stack. |
| |
| if Restriction_Active (No_Secondary_Stack) then |
| Append_To (Args, Make_Integer_Literal (Loc, 0)); |
| |
| elsif Has_Rep_Pragma |
| (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) |
| then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uSecondary_Stack_Size))); |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); |
| end if; |
| |
| -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a |
| -- Task_Info pragma, in which case we take the value from the pragma. |
| |
| if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); |
| end if; |
| |
| -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, |
| -- in which case we take the value from the rep item. The parameter is |
| -- passed as an Integer because in the case of unspecified CPU the |
| -- value is not in the range of CPU_Range. |
| |
| if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then |
| Append_To (Args, |
| Convert_To (Standard_Integer, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uCPU)))); |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); |
| end if; |
| |
| if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then |
| |
| -- Deadline parameter. If no Relative_Deadline pragma is present, |
| -- then the deadline is Time_Span_Zero. If a pragma is present, then |
| -- the deadline is taken from the _Relative_Deadline field of the |
| -- task value record, which was set from the pragma value. Note that |
| -- this parameter must not be generated for the restricted profiles |
| -- since Ravenscar does not allow deadlines. |
| |
| -- Case where pragma Relative_Deadline applies: use given value |
| |
| if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uRelative_Deadline))); |
| |
| -- No pragma Relative_Deadline apply to the task |
| |
| else |
| Append_To (Args, |
| New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); |
| end if; |
| end if; |
| |
| if not Restricted_Profile then |
| |
| -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is |
| -- present, then the dispatching domain is null. If a rep item is |
| -- present, then the dispatching domain is taken from the |
| -- _Dispatching_Domain field of the task value record, which was set |
| -- from the rep item value. |
| |
| -- Case where Dispatching_Domain rep item applies: use given value |
| |
| if Has_Rep_Item |
| (Ttyp, Name_Dispatching_Domain, Check_Parents => False) |
| then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uDispatching_Domain))); |
| |
| -- No pragma or aspect Dispatching_Domain applies to the task |
| |
| else |
| Append_To (Args, Make_Null (Loc)); |
| end if; |
| |
| -- Number of entries. This is an expression of the form: |
| |
| -- n + _Init.a'Length + _Init.a'B'Length + ... |
| |
| -- where a,b... are the entry family names for the task definition |
| |
| Ecount := |
| Build_Entry_Count_Expression |
| (Ttyp, |
| Component_Items |
| (Component_List |
| (Type_Definition |
| (Parent (Corresponding_Record_Type (Ttyp))))), |
| Loc); |
| Append_To (Args, Ecount); |
| |
| -- Master parameter. This is a reference to the _Master parameter of |
| -- the initialization procedure, except in the case of the pragma |
| -- Restrictions (No_Task_Hierarchy) where the value is fixed to |
| -- System.Tasking.Library_Task_Level. |
| |
| if Restriction_Active (No_Task_Hierarchy) = False then |
| Append_To (Args, Make_Identifier (Loc, Name_uMaster)); |
| else |
| Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level)); |
| end if; |
| end if; |
| |
| -- State parameter. This is a pointer to the task body procedure. The |
| -- required value is obtained by taking 'Unrestricted_Access of the task |
| -- body procedure and converting it (with an unchecked conversion) to |
| -- the type required by the task kernel. For further details, see the |
| -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather |
| -- than 'Address in order to avoid creating trampolines. |
| |
| declare |
| Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); |
| Subp_Ptr_Typ : constant Node_Id := |
| Create_Itype (E_Access_Subprogram_Type, Tdec); |
| Ref : constant Node_Id := Make_Itype_Reference (Loc); |
| |
| begin |
| Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); |
| Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); |
| |
| -- Be sure to freeze a reference to the access-to-subprogram type, |
| -- otherwise gigi will complain that it's in the wrong scope, because |
| -- it's actually inside the init procedure for the record type that |
| -- corresponds to the task type. |
| |
| Set_Itype (Ref, Subp_Ptr_Typ); |
| Append_Freeze_Action (Task_Rec, Ref); |
| |
| Append_To (Args, |
| Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Body_Proc, Loc), |
| Attribute_Name => Name_Unrestricted_Access)))); |
| end; |
| |
| -- Discriminants parameter. This is just the address of the task |
| -- value record itself (which contains the discriminant values |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Address)); |
| |
| -- Elaborated parameter. This is an access to the elaboration Boolean |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), |
| Attribute_Name => Name_Unchecked_Access)); |
| |
| -- Add Chain parameter (not done for sequential elaboration policy, see |
| -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). |
| |
| if Partition_Elaboration_Policy /= 'S' then |
| Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
| end if; |
| |
| -- Task name parameter. Take this from the _Task_Id parameter to the |
| -- init call unless there is a Task_Name pragma, in which case we take |
| -- the value from the pragma. |
| |
| if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then |
| -- Copy expression in full, because it may be dynamic and have |
| -- side effects. |
| |
| Append_To (Args, |
| New_Copy_Tree |
| (Expression |
| (First |
| (Pragma_Argument_Associations |
| (Get_Rep_Pragma |
| (Ttyp, Name_Task_Name, Check_Parents => False)))))); |
| |
| else |
| Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); |
| end if; |
| |
| -- Created_Task parameter. This is the _Task_Id field of the task |
| -- record value |
| |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); |
| |
| declare |
| Create_RE : RE_Id; |
| |
| begin |
| if Restricted_Profile then |
| if Partition_Elaboration_Policy = 'S' then |
| Create_RE := RE_Create_Restricted_Task_Sequential; |
| else |
| Create_RE := RE_Create_Restricted_Task; |
| end if; |
| else |
| Create_RE := RE_Create_Task; |
| end if; |
| |
| Name := New_Occurrence_Of (RTE (Create_RE), Loc); |
| end; |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => Name, |
| Parameter_Associations => Args); |
| end Make_Task_Create_Call; |
| |
| ------------------------------ |
| -- Next_Protected_Operation -- |
| ------------------------------ |
| |
| function Next_Protected_Operation (N : Node_Id) return Node_Id is |
| Next_Op : Node_Id; |
| |
| begin |
| -- Check whether there is a subsequent body for a protected operation |
| -- in the current protected body. In Ada2012 that includes expression |
| -- functions that are completions. |
| |
| Next_Op := Next (N); |
| while Present (Next_Op) |
| and then Nkind (Next_Op) not in |
| N_Subprogram_Body | N_Entry_Body | N_Expression_Function |
| loop |
| Next (Next_Op); |
| end loop; |
| |
| return Next_Op; |
| end Next_Protected_Operation; |
| |
| --------------------- |
| -- 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) in N_Null_Statement | N_Label |
| or else |
| (Nkind (Stmt) = N_Pragma |
| and then |
| Pragma_Name_Unmapped (Stmt) in Name_Unreferenced |
| | Name_Unmodified |
| | Name_Warnings)) |
| loop |
| Next (Stmt); |
| end loop; |
| |
| return Nkind (Stmt) = N_Empty; |
| end Null_Statements; |
| |
| -------------------------- |
| -- Parameter_Block_Pack -- |
| -------------------------- |
| |
| function Parameter_Block_Pack |
| (Loc : Source_Ptr; |
| Blk_Typ : Entity_Id; |
| Actuals : List_Id; |
| Formals : List_Id; |
| Decls : List_Id; |
| Stmts : List_Id) return Entity_Id |
| is |
| Actual : Entity_Id; |
| Expr : Node_Id := Empty; |
| Formal : Entity_Id; |
| Has_Param : Boolean := False; |
| P : Entity_Id; |
| Params : List_Id; |
| Temp_Asn : Node_Id; |
| Temp_Nam : Node_Id; |
| |
| begin |
| Actual := First (Actuals); |
| Formal := Defining_Identifier (First (Formals)); |
| Params := New_List; |
| while Present (Actual) loop |
| if Is_By_Copy_Type (Etype (Actual)) then |
| -- Generate: |
| -- Jnn : aliased <formal-type> |
| |
| Temp_Nam := Make_Temporary (Loc, 'J'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Aliased_Present => True, |
| Defining_Identifier => Temp_Nam, |
| Object_Definition => |
| New_Occurrence_Of (Etype (Formal), Loc))); |
| |
| -- The object is initialized with an explicit assignment |
| -- later. Indicate that it does not need an initialization |
| -- to prevent spurious warnings if the type excludes null. |
| |
| Set_No_Initialization (Last (Decls)); |
| |
| if Ekind (Formal) /= E_Out_Parameter then |
| |
| -- Generate: |
| -- Jnn := <actual> |
| |
| Temp_Asn := |
| New_Occurrence_Of (Temp_Nam, Loc); |
| |
| Set_Assignment_OK (Temp_Asn); |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => Temp_Asn, |
| Expression => New_Copy_Tree (Actual))); |
| end if; |
| |
| -- If the actual is not controlling, generate: |
| |
| -- Jnn'unchecked_access |
| |
| -- and add it to aggegate for access to formals. Note that the |
| -- actual may be by-copy but still be a controlling actual if it |
| -- is an access to class-wide interface. |
| |
| if not Is_Controlling_Actual (Actual) then |
| Append_To (Params, |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Unchecked_Access, |
| Prefix => New_Occurrence_Of (Temp_Nam, Loc))); |
| |
| Has_Param := True; |
| end if; |
| |
| -- The controlling parameter is omitted |
| |
| else |
| if not Is_Controlling_Actual (Actual) then |
| Append_To (Params, |
| Make_Reference (Loc, New_Copy_Tree (Actual))); |
| |
| Has_Param := True; |
| end if; |
| end if; |
| |
| Next_Actual (Actual); |
| Next_Formal_With_Extras (Formal); |
| end loop; |
| |
| if Has_Param then |
| Expr := Make_Aggregate (Loc, Params); |
| end if; |
| |
| -- Generate: |
| -- P : Ann := ( |
| -- J1'unchecked_access; |
| -- <actual2>'reference; |
| -- ...); |
| |
| P := Make_Temporary (Loc, 'P'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => P, |
| Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), |
| Expression => Expr)); |
| |
| return P; |
| end Parameter_Block_Pack; |
| |
| ---------------------------- |
| -- Parameter_Block_Unpack -- |
| ---------------------------- |
| |
| function Parameter_Block_Unpack |
| (Loc : Source_Ptr; |
| P : Entity_Id; |
| Actuals : List_Id; |
| Formals : List_Id) return List_Id |
| is |
| Actual : Entity_Id; |
| Asnmt : Node_Id; |
| Formal : Entity_Id; |
| Has_Asnmt : Boolean := False; |
| Result : constant List_Id := New_List; |
| |
| begin |
| Actual := First (Actuals); |
| Formal := Defining_Identifier (First (Formals)); |
| while Present (Actual) loop |
| if Is_By_Copy_Type (Etype (Actual)) |
| and then Ekind (Formal) /= E_In_Parameter |
| then |
| -- Generate: |
| -- <actual> := P.<formal>; |
| |
| Asnmt := |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Copy (Actual), |
| Expression => |
| Make_Explicit_Dereference (Loc, |
| Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of (P, Loc), |
| Selector_Name => |
| Make_Identifier (Loc, Chars (Formal))))); |
| |
| Set_Assignment_OK (Name (Asnmt)); |
| Append_To (Result, Asnmt); |
| |
| Has_Asnmt := True; |
| end if; |
| |
| Next_Actual (Actual); |
| Next_Formal_With_Extras (Formal); |
| end loop; |
| |
| if Has_Asnmt then |
| return Result; |
| else |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| end Parameter_Block_Unpack; |
| |
| --------------------- |
| -- Reset_Scopes_To -- |
| --------------------- |
| |
| procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is |
| function Reset_Scope (N : Node_Id) return Traverse_Result; |
| -- Temporaries may have been declared during expansion of the procedure |
| -- created for an entry body or an accept alternative. Indicate that |
| -- their scope is the new body, to ensure proper generation of uplevel |
| -- references where needed during unnesting. |
| |
| procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); |
| |
| ----------------- |
| -- Reset_Scope -- |
| ----------------- |
| |
| function Reset_Scope (N : Node_Id) return Traverse_Result is |
| Decl : Node_Id; |
| |
| begin |
| -- If this is a block statement with an Identifier, it forms a scope, |
| -- so we want to reset its scope but not look inside. |
| |
| if N /= Bod |
| and then Nkind (N) = N_Block_Statement |
| and then Present (Identifier (N)) |
| then |
| Set_Scope (Entity (Identifier (N)), E); |
| return Skip; |
| |
| -- Ditto for a package declaration or a full type declaration, etc. |
| |
| elsif (Nkind (N) = N_Package_Declaration |
| and then N /= Specification (N)) |
| or else Nkind (N) in N_Declaration |
| or else Nkind (N) in N_Renaming_Declaration |
| then |
| Set_Scope (Defining_Entity (N), E); |
| return Skip; |
| |
| elsif N = Bod then |
| |
| -- Scan declarations in new body. Declarations in the statement |
| -- part will be handled during later traversal. |
| |
| Decl := First (Declarations (N)); |
| while Present (Decl) loop |
| Reset_Scopes (Decl); |
| Next (Decl); |
| end loop; |
| |
| elsif Nkind (N) = N_Freeze_Entity then |
| |
| -- Scan the actions associated with a freeze node, which may |
| -- actually be declarations with entities that need to have |
| -- their scopes reset. |
| |
| Decl := First (Actions (N)); |
| while Present (Decl) loop |
| Reset_Scopes (Decl); |
| Next (Decl); |
| end loop; |
| |
| elsif N /= Bod and then Nkind (N) in N_Proper_Body then |
| |
| -- A subprogram without a separate declaration may be encountered, |
| -- and we need to reset the subprogram's entity's scope. |
| |
| if Nkind (N) = N_Subprogram_Body then |
| Set_Scope (Defining_Entity (Specification (N)), E); |
| end if; |
| |
| return Skip; |
| end if; |
| |
| return OK; |
| end Reset_Scope; |
| |
| -- Start of processing for Reset_Scopes_To |
| |
| begin |
| Reset_Scopes (Bod); |
| end Reset_Scopes_To; |
| |
| ---------------------- |
| -- Set_Discriminals -- |
| ---------------------- |
| |
| procedure Set_Discriminals (Dec : Node_Id) is |
| D : Entity_Id; |
| Pdef : Entity_Id; |
| D_Minal : Entity_Id; |
| |
| begin |
| pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); |
| Pdef := Defining_Identifier (Dec); |
| |
| if Has_Discriminants (Pdef) then |
| D := First_Discriminant (Pdef); |
| while Present (D) loop |
| D_Minal := |
| Make_Defining_Identifier (Sloc (D), |
| Chars => New_External_Name (Chars (D), 'D')); |
| |
| Mutate_Ekind (D_Minal, E_Constant); |
| Set_Etype (D_Minal, Etype (D)); |
| Set_Scope (D_Minal, Pdef); |
| Set_Discriminal (D, D_Minal); |
| Set_Discriminal_Link (D_Minal, D); |
| |
| Next_Discriminant (D); |
| end loop; |
| end if; |
| end Set_Discriminals; |
| |
| ----------------------- |
| -- Trivial_Accept_OK -- |
| ----------------------- |
| |
| function Trivial_Accept_OK return Boolean is |
| begin |
| case Opt.Task_Dispatching_Policy is |
| |
| -- If we have the default task dispatching policy in effect, we can |
| -- definitely do the optimization (one way of looking at this is to |
| -- think of the formal definition of the default policy being allowed |
| -- to run any task it likes after a rendezvous, so even if notionally |
| -- a full rescheduling occurs, 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. |
| |
| when ' ' => |
| return True; |
| |
| -- FIFO_Within_Priorities certainly does not permit this |
| -- optimization since the Rendezvous is a scheduling action that may |
| -- require some other task to be run. |
| |
| when 'F' => |
| return False; |
| |
| -- For now, disallow the optimization for all other policies. This |
| -- may be over-conservative, but it is certainly not incorrect. |
| |
| when others => |
| return False; |
| end case; |
| end Trivial_Accept_OK; |
| |
| end Exp_Ch9; |