diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 2074 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.ads | 151 | ||||
| -rw-r--r-- | gcc/ada/exp_pakd.adb | 78 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 257 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 118 |
6 files changed, 1442 insertions, 1262 deletions
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 2fa47520947..b999bfaa6c4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -38,6 +38,8 @@ 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; @@ -79,28 +81,27 @@ package body Exp_Ch9 is 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. + -- 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 - (Decls : List_Id; - Pid : Entity_Id; - Loc : Source_Ptr); - -- Prepend an object pointer declaration to the declaration list - -- Decls. This object pointer is initialized to a type conversion - -- of the System.Address pointer passed to entry barrier functions - -- and entry body procedures. + (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. + -- 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. @@ -118,10 +119,10 @@ package body Exp_Ch9 is -- for the specified entry body. function Build_Barrier_Function_Specification - (Def_Id : Entity_Id; - Loc : Source_Ptr) return Node_Id; - -- Build a specification for a function implementing - -- the protected entry barrier of the specified entry body. + (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_Entry_Count_Expression (Concurrent_Type : Node_Id; @@ -187,17 +188,29 @@ package body Exp_Ch9 is (N : Node_Id; Ent : Entity_Id; Pid : Node_Id) return Node_Id; - -- Build the procedure implementing the statement sequence of - -- the specified entry body. + -- Build the procedure implementing the statement sequence of the specified + -- entry body. function Build_Protected_Entry_Specification - (Def_Id : Entity_Id; - Ent_Id : Entity_Id; - Loc : Source_Ptr) return Node_Id; - -- Build a specification for a procedure implementing - -- the statement sequence of the specified entry body. - -- Add attributes associating it with the entry defining identifier - -- Ent_Id. + (Loc : Source_Ptr; + Def_Id : Entity_Id; + Ent_Id : Entity_Id) return Node_Id; + -- Build a specification for the procedure implementing the statemens 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; @@ -211,19 +224,6 @@ package body Exp_Ch9 is -- a cleanup handler that unlocks the object in all cases. -- (see Exp_Ch7.Expand_Cleanup_Actions). - function Build_Protected_Spec - (N : Node_Id; - Obj_Type : Entity_Id; - Unprotected : Boolean := False; - Ident : Entity_Id) return List_Id; - -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ - -- Subprogram_Type. Builds signature of protected subprogram, adding the - -- formal that corresponds to the object itself. For an access to protected - -- subprogram, there is no object type to specify, so the additional - -- parameter has type Address and mode In. An indirect call through such - -- a pointer converts the address to a reference to the actual object. - -- The object is a limited record and therefore a by_reference type. - function Build_Selected_Name (Prefix : Entity_Id; Selector : Entity_Id; @@ -271,6 +271,14 @@ package body Exp_Ch9 is -- 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 @@ -279,6 +287,13 @@ package body Exp_Ch9 is -- same parameter names and the same resolved types, but with new entities -- for the formals. + 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. + function Family_Offset (Loc : Source_Ptr; Hi : Node_Id; @@ -330,16 +345,11 @@ package body Exp_Ch9 is -- when P is Name_uPriority, the call will also find Interrupt_Priority. -- ??? Should be implemented with the rep item chain mechanism. - function Index_Constant_Declaration - (N : Node_Id; - Index_Id : Entity_Id; - Prot : Entity_Id) return List_Id; - -- For an entry family and its barrier function, we define a local entity - -- that maps the index in the call into the entry index into the object: - -- - -- I : constant Index_Type := Index_Type'Val ( - -- E - <<index of first family member>> + - -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); + 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; @@ -394,16 +404,6 @@ package body Exp_Ch9 is -- a rescheduling is required, so this optimization is not allowed. This -- function returns True if the optimization is permitted. - procedure Update_Prival_Subtypes (N : Node_Id); - -- The actual subtypes of the privals will differ from the type of the - -- private declaration in the original protected type, if the protected - -- type has discriminants or if the prival has constrained components. - -- This is because the privals are generated out of sequence w.r.t. the - -- analysis of a protected body. After generating the bodies for protected - -- operations, we set correctly the type of all references to privals, by - -- means of a recursive tree traversal, which is heavy-handed but - -- correct. - ----------------------------- -- Actual_Index_Expression -- ----------------------------- @@ -599,84 +599,6 @@ package body Exp_Ch9 is return Expr; end Actual_Index_Expression; - ---------------------------------- - -- Add_Discriminal_Declarations -- - ---------------------------------- - - procedure Add_Discriminal_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr) - is - D : Entity_Id; - - begin - if Has_Discriminants (Typ) then - D := First_Discriminant (Typ); - - while Present (D) loop - - Prepend_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Discriminal (D), - Subtype_Mark => New_Reference_To (Etype (D), Loc), - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Chars (D))))); - - Next_Discriminant (D); - end loop; - end if; - end Add_Discriminal_Declarations; - - ------------------------ - -- Add_Object_Pointer -- - ------------------------ - - procedure Add_Object_Pointer - (Decls : List_Id; - Pid : Entity_Id; - Loc : Source_Ptr) - is - Decl : Node_Id; - Obj_Ptr : Node_Id; - - begin - -- Prepend the declaration of _object. This must be first in the - -- declaration list, since it is used by the discriminal and - -- prival declarations. - -- ??? An attempt to make this a renaming was unsuccessful. - -- - -- type poVP is access poV; - -- _object : poVP := poVP!O; - - Obj_Ptr := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name - (Chars (Corresponding_Record_Type (Pid)), 'P')); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uObject), - Object_Definition => New_Reference_To (Obj_Ptr, Loc), - Expression => - Unchecked_Convert_To (Obj_Ptr, - Make_Identifier (Loc, Name_uO))); - Set_Debug_Info_Needed (Defining_Identifier (Decl)); - Prepend_To (Decls, Decl); - - Prepend_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Obj_Ptr, - Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Reference_To (Corresponding_Record_Type (Pid), Loc)))); - end Add_Object_Pointer; - -------------------------- -- Add_Formal_Renamings -- -------------------------- @@ -701,8 +623,8 @@ package body Exp_Ch9 is begin Formal := First_Formal (Ent); while Present (Formal) loop - Comp := Entry_Component (Formal); - New_F := + Comp := Entry_Component (Formal); + New_F := Make_Defining_Identifier (Sloc (Formal), Chars => Chars (Formal)); Set_Etype (New_F, Etype (Formal)); @@ -726,7 +648,8 @@ package body Exp_Ch9 is Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => New_F, - Subtype_Mark => New_Reference_To (Etype (Formal), Loc), + Subtype_Mark => + New_Reference_To (Etype (Formal), Loc), Name => Make_Explicit_Dereference (Loc, Make_Selected_Component (Loc, @@ -742,117 +665,59 @@ package body Exp_Ch9 is end loop; end Add_Formal_Renamings; - ------------------------------ - -- Add_Private_Declarations -- - ------------------------------ + ------------------------ + -- Add_Object_Pointer -- + ------------------------ - procedure Add_Private_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr) + procedure Add_Object_Pointer + (Loc : Source_Ptr; + Conc_Typ : Entity_Id; + Decls : List_Id) is - Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ)); - Def : constant Node_Id := Protected_Definition (Parent (Typ)); - - Decl : Node_Id; - P : Node_Id; - Pdef : Entity_Id; + Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); + Decl : Node_Id; + Obj_Ptr : Node_Id; begin - pragma Assert (Nkind (Def) = N_Protected_Definition); - - if Present (Private_Declarations (Def)) then - P := First (Private_Declarations (Def)); - while Present (P) loop - if Nkind (P) = N_Component_Declaration then - Pdef := Defining_Identifier (P); - - -- The privals are declared before the current body is - -- analyzed, for visibility reasons. Set their Sloc so - -- that it is consistent with their renaming declaration, - -- to prevent anomalies in gdb. - - -- This kludgy model for privals should be redesigned ??? - - Set_Sloc (Prival (Pdef), Loc); - - Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Prival (Pdef), - Subtype_Mark => New_Reference_To (Etype (Pdef), Loc), - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Chars (Pdef)))); - Set_Debug_Info_Needed (Defining_Identifier (Decl)); - Prepend_To (Decls, Decl); - end if; - - Next (P); - end loop; - end if; - - -- One more "prival" for object itself, with the right protection type - - declare - Protection_Type : RE_Id; - - begin - -- Could this be simplified using Corresponding_Runtime_Package??? - - if Has_Attach_Handler (Typ) then - if Restricted_Profile then - if Has_Entries (Typ) then - Protection_Type := RE_Protection_Entry; - else - Protection_Type := RE_Protection; - end if; - else - Protection_Type := RE_Static_Interrupt_Protection; - end if; - - elsif Has_Interrupt_Handler (Typ) then - Protection_Type := RE_Dynamic_Interrupt_Protection; - - -- The type has explicit entries or generated primitive entry - -- wrappers. - - elsif Has_Entries (Typ) - or else (Ada_Version >= Ada_05 - and then Present (Interface_List (Parent (Typ)))) - then - case Corresponding_Runtime_Package (Typ) is - when System_Tasking_Protected_Objects_Entries => - Protection_Type := RE_Protection_Entries; + -- 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. - when System_Tasking_Protected_Objects_Single_Entry => - Protection_Type := RE_Protection_Entry; + -- Build the entity for the access type - when others => - raise Program_Error; - end case; + Obj_Ptr := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Rec_Typ), 'P')); - else - Protection_Type := RE_Protection; - end if; + -- Generate: + -- _object : poVP := poVP!O; - -- Adjust Sloc, as for the other privals + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Object_Definition => + New_Reference_To (Obj_Ptr, Loc), + Expression => + Unchecked_Convert_To (Obj_Ptr, + Make_Identifier (Loc, Name_uO))); + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); - Set_Sloc (Object_Ref (Body_Ent), Loc); + -- Generate: + -- type poVP is access poV; - Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Object_Ref (Body_Ent), - Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc), - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Name_uObject))); - Set_Debug_Info_Needed (Defining_Identifier (Decl)); - Prepend_To (Decls, Decl); - end; - end Add_Private_Declarations; + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Obj_Ptr, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Rec_Typ, Loc))); + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); + end Add_Object_Pointer; ----------------------- -- Build_Accept_Body -- @@ -1018,67 +883,37 @@ package body Exp_Ch9 is Pid : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); + Func_Id : constant Entity_Id := Barrier_Function (Ent); Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); - Index_Spec : constant Node_Id := Entry_Index_Specification - (Ent_Formals); - Op_Decls : constant List_Id := New_List; - Bdef : Entity_Id; - Bspec : Node_Id; - EBF : Node_Id; + Op_Decls : constant List_Id := New_List; + Func_Body : Node_Id; begin - Bdef := - Make_Defining_Identifier (Loc, - Chars => Chars (Barrier_Function (Ent))); - Bspec := Build_Barrier_Function_Specification (Bdef, Loc); - - -- <object pointer declaration> - -- <discriminant renamings> - -- <private object renamings> - -- Add discriminal and private renamings. These names have - -- already been used to expand references to discriminants - -- and private data. - - Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc); - Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc); - Add_Object_Pointer (Op_Decls, Pid, Loc); - - -- If this is the barrier for an entry family, the entry index is - -- visible in the body of the barrier. Create a local variable that - -- converts the entry index (which is the last formal of the barrier - -- function) into the appropriate offset into the entry array. The - -- entry index constant must be set, as for the entry body, so that - -- local references to the entry index are correctly replaced with - -- the local variable. This parallels what is done for entry bodies. - - if Present (Index_Spec) then - declare - Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec); - Index_Con : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('J')); - begin - Set_Entry_Index_Constant (Index_Id, Index_Con); - Append_List_To (Op_Decls, - Index_Constant_Declaration (N, Index_Id, Pid)); - end; - end if; + -- 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 + (Loc, Func_Id, Pid, N, Op_Decls, True, Ekind (Ent) = E_Entry_Family); -- 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. - EBF := + Func_Body := Make_Subprogram_Body (Loc, - Specification => Bspec, + 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 ( Make_Simple_Return_Statement (Loc, Expression => Condition (Ent_Formals))))); - Set_Is_Entry_Barrier_Function (EBF); - return EBF; + Set_Is_Entry_Barrier_Function (Func_Body); + + return Func_Body; end Build_Barrier_Function; ------------------------------------------ @@ -1086,25 +921,29 @@ package body Exp_Ch9 is ------------------------------------------ function Build_Barrier_Function_Specification - (Def_Id : Entity_Id; - Loc : Source_Ptr) return Node_Id + (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), + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uE), Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), - Result_Definition => New_Reference_To (Standard_Boolean, Loc)); + Result_Definition => + New_Reference_To (Standard_Boolean, Loc)); end Build_Barrier_Function_Specification; -------------------------- @@ -1629,6 +1468,7 @@ package body Exp_Ch9 is is New_Formals : constant List_Id := New_List; Formal : Node_Id; + Param_Type : Node_Id; begin Formal := First (Formals); @@ -1636,6 +1476,22 @@ package body Exp_Ch9 is -- 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_Reference_To (Etype (Parameter_Type (Formal)), Loc); + end if; + Append_To (New_Formals, Make_Parameter_Specification (Loc, Defining_Identifier => @@ -1643,8 +1499,7 @@ package body Exp_Ch9 is Chars => Chars (Defining_Identifier (Formal))), In_Present => In_Present (Formal), Out_Present => Out_Present (Formal), - Parameter_Type => New_Reference_To (Etype ( - Parameter_Type (Formal)), Loc))); + Parameter_Type => Param_Type)); Next (Formal); end loop; @@ -1748,12 +1603,18 @@ package body Exp_Ch9 is -- not implement any interfaces and are compiled with the -gnat05 -- switch. In this case, a default first parameter is created. + -- If the interface operation has an access parameter, create a copy + -- of it, with the same null exclusion indicator if present. + if Present (First_Param) then if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then Obj_Param_Typ := Make_Access_Definition (Loc, Subtype_Mark => New_Reference_To (Obj_Typ, Loc)); + Set_Null_Exclusion_Present (Obj_Param_Typ, + Null_Exclusion_Present (Parameter_Type (First_Param))); + else Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); end if; @@ -1945,7 +1806,7 @@ package body Exp_Ch9 is Siz := Empty; Ent := First_Entity (Typ); - Add_Object_Pointer (Decls, Typ, Loc); + Add_Object_Pointer (Loc, Typ, Decls); while Present (Ent) loop @@ -2036,11 +1897,20 @@ package body Exp_Ch9 is -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder -- in internal scopes, unless present already.. Required for nested - -- limited aggregates. This could use some more explanation ???? + -- limited aggregates, where the expansion of task components may + -- generate inner blocks. If the block is the rewriting of a call + -- this is valid master. if Ada_Version >= Ada_05 then while Is_Internal (S) loop - S := Scope (S); + if Nkind (Parent (S)) = N_Block_Statement + and then + Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement + then + exit; + else + S := Scope (S); + end if; end loop; end if; @@ -2111,6 +1981,7 @@ package body Exp_Ch9 is is Loc : constant Source_Ptr := Sloc (N); + Decls : constant List_Id := Declarations (N); End_Lab : constant Node_Id := End_Label (Handled_Statement_Sequence (N)); End_Loc : constant Source_Ptr := @@ -2120,12 +1991,12 @@ package body Exp_Ch9 is Han_Loc : Source_Ptr; -- Used for the exception handler, inserted at end of the body - Op_Decls : constant List_Id := New_List; + Op_Decls : constant List_Id := New_List; + Complete : Node_Id; Edef : Entity_Id; Espec : Node_Id; - Op_Stats : List_Id; Ohandle : Node_Id; - Complete : Node_Id; + Op_Stats : List_Id; begin -- Set the source location on the exception handler only when debugging @@ -2143,19 +2014,23 @@ package body Exp_Ch9 is Edef := Make_Defining_Identifier (Loc, Chars => Chars (Protected_Body_Subprogram (Ent))); - Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc); - - -- <object pointer declaration> + Espec := + Build_Protected_Entry_Specification (Loc, Edef, Empty); - -- Add object pointer declaration. This is needed by the discriminal and - -- prival renamings, which should already have been inserted into the - -- declaration list. + -- 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 (Op_Decls, Pid, Loc); + Add_Object_Pointer (Loc, Pid, Op_Decls); - -- Add renamings for formals for use by debugger + -- Add renamings for all formals, the Protection object, discriminals, + -- privals and the entry indix constant for use by debugger. Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); + Debug_Private_Data_Declarations (Decls); case Corresponding_Runtime_Package (Pid) is when System_Tasking_Protected_Objects_Entries => @@ -2171,22 +2046,21 @@ package body Exp_Ch9 is end case; Op_Stats := New_List ( - Make_Block_Statement (Loc, - Declarations => Declarations (N), - Handled_Statement_Sequence => - Handled_Statement_Sequence (N)), - - Make_Procedure_Call_Statement (End_Loc, - Name => Complete, - Parameter_Associations => New_List ( - Make_Attribute_Reference (End_Loc, - Prefix => - Make_Selected_Component (End_Loc, - Prefix => - Make_Identifier (End_Loc, Name_uObject), + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)), - Selector_Name => - Make_Identifier (End_Loc, Name_uObject)), + Make_Procedure_Call_Statement (End_Loc, + Name => Complete, + 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 exceptions can not be propagated, we never need to call @@ -2199,8 +2073,8 @@ package body Exp_Ch9 is Declarations => Op_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Op_Stats, - End_Label => End_Lab)); + Statements => Op_Stats, + End_Label => End_Lab)); else Ohandle := Make_Others_Choice (Loc); @@ -2260,37 +2134,39 @@ package body Exp_Ch9 is ----------------------------------------- function Build_Protected_Entry_Specification - (Def_Id : Entity_Id; - Ent_Id : Entity_Id; - Loc : Source_Ptr) return Node_Id + (Loc : Source_Ptr; + Def_Id : Entity_Id; + Ent_Id : Entity_Id) return Node_Id is - P : Entity_Id; + P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); begin Set_Debug_Info_Needed (Def_Id); - P := Make_Defining_Identifier (Loc, Name_uP); if Present (Ent_Id) then Append_Elmt (P, Accept_Address (Ent_Id)); end if; - return Make_Procedure_Specification (Loc, - Defining_Unit_Name => Def_Id, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), - Parameter_Type => - New_Reference_To (RTE (RE_Address), Loc)), + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), - Make_Parameter_Specification (Loc, - Defining_Identifier => P, - Parameter_Type => - New_Reference_To (RTE (RE_Address), Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => P, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), - Parameter_Type => - New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); end Build_Protected_Entry_Specification; -------------------------- @@ -2300,27 +2176,27 @@ package body Exp_Ch9 is function Build_Protected_Spec (N : Node_Id; Obj_Type : Entity_Id; - Unprotected : Boolean := False; - Ident : Entity_Id) return List_Id + Ident : Entity_Id; + Unprotected : Boolean := False) return List_Id is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; - Formal : Entity_Id; - New_Plist : List_Id; - New_Param : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Formal : Entity_Id; + New_Plist : List_Id; + New_Param : Node_Id; begin New_Plist := New_List; + Formal := First_Formal (Ident); while Present (Formal) loop New_Param := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Parameter_Type => - New_Reference_To (Etype (Formal), Loc)); + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => New_Reference_To (Etype (Formal), Loc)); if Unprotected then Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); @@ -2340,9 +2216,10 @@ package body Exp_Ch9 is Make_Defining_Identifier (Loc, Name_uObject), In_Present => True, Out_Present => - (Etype (Ident) = Standard_Void_Type - and then not Is_RTE (Obj_Type, RE_Address)), - Parameter_Type => New_Reference_To (Obj_Type, Loc)); + (Etype (Ident) = Standard_Void_Type + and then not Is_RTE (Obj_Type, RE_Address)), + Parameter_Type => + New_Reference_To (Obj_Type, Loc)); Set_Debug_Info_Needed (Defining_Identifier (Decl)); Prepend_To (New_Plist, Decl); @@ -2354,13 +2231,13 @@ package body Exp_Ch9 is --------------------------------------- function Build_Protected_Sub_Specification - (N : Node_Id; - Prottyp : Entity_Id; - Mode : Subprogram_Protection_Mode) return Node_Id + (N : Node_Id; + Prot_Typ : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; - Ident : Entity_Id; + Def_Id : Entity_Id; New_Id : Entity_Id; New_Plist : List_Id; New_Spec : Node_Id; @@ -2371,24 +2248,23 @@ package body Exp_Ch9 is Unprotected_Mode => 'N'); begin - if Ekind - (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body + if Ekind (Defining_Unit_Name (Specification (N))) = + E_Subprogram_Body then Decl := Unit_Declaration_Node (Corresponding_Spec (N)); else Decl := N; end if; - Ident := Defining_Unit_Name (Specification (Decl)); + Def_Id := Defining_Unit_Name (Specification (Decl)); New_Plist := - Build_Protected_Spec (Decl, - Corresponding_Record_Type (Prottyp), - Mode = Unprotected_Mode, Ident); - + Build_Protected_Spec + (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, + Mode = Unprotected_Mode); New_Id := Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Prottyp, Ident, Append_Chr (Mode))); + Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does @@ -2399,15 +2275,14 @@ package body Exp_Ch9 is Set_Debug_Info_Needed (New_Id); if Nkind (Specification (Decl)) = N_Procedure_Specification then - return + New_Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist); - else - -- We need to create a new specification for the anonymous - -- subprogram type. + -- Create a new specification for the anonymous subprogram type + else New_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => New_Id, @@ -2416,8 +2291,9 @@ package body Exp_Ch9 is Copy_Result_Type (Result_Definition (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); - return New_Spec; end if; + + return New_Spec; end Build_Protected_Sub_Specification; ------------------------------------- @@ -2591,11 +2467,12 @@ package body Exp_Ch9 is end if; else - Unprot_Call := Make_Procedure_Call_Statement (Loc, - Name => - Make_Identifier (Loc, - Chars (Defining_Unit_Name (N_Op_Spec))), - Parameter_Associations => Uactuals); + Unprot_Call := + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, + Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals); end if; -- Wrap call in block that will be covered by an at_end handler @@ -2941,6 +2818,30 @@ package body Exp_Ch9 is -- 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_05 + then + declare + Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Conctyp, Loc), + Expression => Relocate_Node (Concval)); + 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 @@ -2966,12 +2867,11 @@ package body Exp_Ch9 is Expression => Actual_Index_Expression ( Loc, Entity (Ename), Index, Concval)); - Decls := New_List (Xdecl); + Append_To (Decls, Xdecl); Parm2 := New_Reference_To (X, Loc); else Xdecl := Empty; - Decls := New_List; Parm2 := Empty; end if; @@ -3488,36 +3388,33 @@ package body Exp_Ch9 is ----------------------------------- function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (T); - Nam : constant Name_Id := Chars (T); - Ent : Entity_Id; + Loc : constant Source_Ptr := Sloc (T); + Spec_Id : Entity_Id; begin - Ent := + Spec_Id := Make_Defining_Identifier (Loc, - Chars => New_External_Name (Nam, 'B')); - Set_Is_Internal (Ent); + Chars => New_External_Name (Chars (T), 'B')); + 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, Ent); + Set_Task_Body_Procedure (T, Spec_Id); end if; return Make_Procedure_Specification (Loc, - Defining_Unit_Name => Ent, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uTask), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To - (Corresponding_Record_Type (T), Loc))))); + 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_Reference_To (Corresponding_Record_Type (T), Loc))))); end Build_Task_Proc_Specification; --------------------------------------- @@ -3528,25 +3425,24 @@ package body Exp_Ch9 is (N : Node_Id; Pid : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - N_Op_Spec : Node_Id; - Op_Decls : List_Id; + Decls : constant List_Id := Declarations (N); begin + -- Add renamings for the Protection object, discriminals, privals and + -- the entry indix 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. - Op_Decls := Declarations (N); - N_Op_Spec := - Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode); - return - Make_Subprogram_Body (Loc, - Specification => N_Op_Spec, - Declarations => Op_Decls, - Handled_Statement_Sequence => - Handled_Statement_Sequence (N)); + Make_Subprogram_Body (Sloc (N), + Specification => + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), + Declarations => Decls, + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); end Build_Unprotected_Subprogram_Body; ---------------------------- @@ -3565,9 +3461,7 @@ package body Exp_Ch9 is begin Efam := First_Entity (Conctyp); - while Present (Efam) loop - if Ekind (Efam) = E_Entry_Family then Efam_Type := Make_Defining_Identifier (Loc, @@ -3577,6 +3471,7 @@ package body Exp_Ch9 is Bas : Entity_Id := Base_Type (Etype (Discrete_Subtype_Definition (Parent (Efam)))); + Bas_Decl : Node_Id := Empty; Lo, Hi : Node_Id; @@ -3586,15 +3481,17 @@ package body Exp_Ch9 is if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then Bas := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); + Bas_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Bas, - Subtype_Indication => + Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), - Constraint => + Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Make_Integer_Literal @@ -3652,6 +3549,28 @@ package body Exp_Ch9 is 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 -- ---------------------- @@ -3823,10 +3742,9 @@ package body Exp_Ch9 is else pragma Assert (Is_Protected_Type (Entity (N))); + return - New_Reference_To ( - Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))), - Loc); + New_Reference_To (Find_Protection_Object (Current_Scope), Loc); end if; else @@ -3867,6 +3785,50 @@ package body Exp_Ch9 is end if; end Convert_Concurrent; + ------------------------------------- + -- 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_In (Decl, 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; + ---------------------------- -- Entry_Index_Expression -- ---------------------------- @@ -4276,7 +4238,7 @@ package body Exp_Ch9 is E_T : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('E')); P_List : constant List_Id := Build_Protected_Spec - (N, RTE (RE_Address), False, D_T); + (N, RTE (RE_Address), D_T, False); Decl1 : Node_Id; Decl2 : Node_Id; Def1 : Node_Id; @@ -4288,7 +4250,7 @@ package body Exp_Ch9 is Def1 := Make_Access_Function_Definition (Loc, Parameter_Specifications => P_List, - Result_Definition => + Result_Definition => Copy_Result_Type (Result_Definition (Type_Definition (N)))); else @@ -4314,7 +4276,7 @@ package body Exp_Ch9 is Make_Defining_Identifier (Loc, New_Internal_Name ('P')), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Address), Loc))), @@ -4323,13 +4285,13 @@ package body Exp_Ch9 is Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); Decl2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => E_T, - Type_Definition => + Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, @@ -4345,11 +4307,10 @@ package body Exp_Ch9 is -------------------------- procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Prot : constant Entity_Id := Scope (Ent); - Spec_Decl : constant Node_Id := Parent (Prot); - Cond : constant Node_Id := + Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); + Prot : constant Entity_Id := Scope (Ent); + Spec_Decl : constant Node_Id := Parent (Prot); Func : Node_Id; B_F : Node_Id; Body_Decl : Node_Id; @@ -4365,7 +4326,7 @@ package body Exp_Ch9 is -- 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 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. @@ -4382,9 +4343,6 @@ package body Exp_Ch9 is Insert_Before_And_Analyze (Body_Decl, B_F); - Update_Prival_Subtypes (B_F); - - Set_Privals (Spec_Decl, N, Loc, After_Barrier => True); Set_Discriminals (Spec_Decl); Set_Scope (Func, Scope (Prot)); @@ -4447,43 +4405,6 @@ package body Exp_Ch9 is Check_Restriction (Simple_Barriers, Cond); end Expand_Entry_Barrier; - ------------------------------------ - -- Expand_Entry_Body_Declarations -- - ------------------------------------ - - procedure Expand_Entry_Body_Declarations (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Index_Spec : Node_Id; - - begin - if Expander_Active then - - -- Expand entry bodies corresponding to entry families - -- by assigning a placeholder for the constant that will - -- be used to expand references to the entry index parameter. - - Index_Spec := - Entry_Index_Specification (Entry_Body_Formal_Part (N)); - - if Present (Index_Spec) then - declare - Index_Con : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('J')); - begin - -- Mark the index constant as having a valid value since it - -- will act as a renaming of the original entry index which - -- is known to be valid. - - Set_Is_Known_Valid (Index_Con); - - Set_Entry_Index_Constant - (Defining_Identifier (Index_Spec), Index_Con); - end; - end if; - end if; - end Expand_Entry_Body_Declarations; - ------------------------------ -- Expand_N_Abort_Statement -- ------------------------------ @@ -6395,48 +6316,12 @@ package body Exp_Ch9 is ------------------------- procedure Expand_N_Entry_Body (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Dec : constant Node_Id := Parent (Current_Scope); - Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); - Index_Spec : constant Node_Id := - Entry_Index_Specification (Ent_Formals); - Next_Op : Node_Id; - First_Decl : constant Node_Id := First (Declarations (N)); - Index_Decl : List_Id; - begin - -- Add the renamings for private declarations and discriminants - - Add_Discriminal_Declarations - (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); - Add_Private_Declarations - (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); + -- Associate discriminals with the next protected operation body to be + -- expanded. - if Present (Index_Spec) then - Index_Decl := - Index_Constant_Declaration - (N, - Defining_Identifier (Index_Spec), Defining_Identifier (Dec)); - - -- If the entry has local declarations, insert index declaration - -- before them, because the index may be used therein. - - if Present (First_Decl) then - Insert_List_Before (First_Decl, Index_Decl); - else - Append_List_To (Declarations (N), Index_Decl); - end if; - end if; - - -- Associate privals and discriminals with the next protected operation - -- body to be expanded. These are used to expand references to private - -- data objects and discriminants, respectively. - - Next_Op := Next_Protected_Operation (N); - - if Present (Next_Op) then - Set_Privals (Dec, Next_Op, Loc); - Set_Discriminals (Dec); + if Present (Next_Protected_Operation (N)) then + Set_Discriminals (Parent (Current_Scope)); end if; end Expand_N_Entry_Body; @@ -6444,8 +6329,8 @@ package body Exp_Ch9 is -- Expand_N_Entry_Call_Statement -- ----------------------------------- - -- An entry call is expanded into GNARLI calls to implement - -- a simple entry call (see Build_Simple_Entry_Call). + -- 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; @@ -6846,10 +6731,8 @@ package body Exp_Ch9 is Current_Node := New_Op_Body; Analyze (New_Op_Body); - Update_Prival_Subtypes (New_Op_Body); - -- Build the corresponding protected operation. It may - -- appear that this is needed only this is a visible + -- appear that this is needed only if this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. -- However, the operation may be exported through a @@ -6860,14 +6743,14 @@ package body Exp_Ch9 is if Present (Corresponding_Spec (Op_Body)) then Op_Decl := - Unit_Declaration_Node (Corresponding_Spec (Op_Body)); + Unit_Declaration_Node (Corresponding_Spec (Op_Body)); - if - Nkind (Parent (Op_Decl)) = N_Protected_Definition + if Nkind (Parent (Op_Decl)) = + N_Protected_Definition then New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); + Build_Protected_Subprogram_Body ( + Op_Body, Pid, Specification (New_Op_Body)); Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); @@ -6905,8 +6788,6 @@ package body Exp_Ch9 is Current_Node := New_Op_Body; Analyze (New_Op_Body); - Update_Prival_Subtypes (New_Op_Body); - when N_Implicit_Label_Declaration => null; @@ -7098,10 +6979,10 @@ package body Exp_Ch9 is -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Prottyp : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + Prot_Typ : constant Entity_Id := Defining_Identifier (N); - Pdef : constant Node_Id := Protected_Definition (N); + Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls Rec_Decl : Node_Id; @@ -7156,10 +7037,10 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Protected_Type_Declaration begin - if Present (Corresponding_Record_Type (Prottyp)) then + if Present (Corresponding_Record_Type (Prot_Typ)) then return; else - Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc); + Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); end if; Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); @@ -7182,12 +7063,13 @@ package body Exp_Ch9 is -- This replacement is not applied to default expressions, for which -- the discriminal is correct. - if Has_Discriminants (Prottyp) then + if Has_Discriminants (Prot_Typ) then declare Disc : Entity_Id; Decl : Node_Id; + begin - Disc := First_Discriminant (Prottyp); + Disc := First_Discriminant (Prot_Typ); Decl := First (Discriminant_Specifications (Rec_Decl)); while Present (Disc) loop Append_Elmt (Discriminal (Disc), Discr_Map); @@ -7203,7 +7085,7 @@ package body Exp_Ch9 is -- 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, Prottyp); + Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); -- Prepend the _Object field with the right type to the component list. -- We need to compute the number of entries, and in some cases the @@ -7215,13 +7097,13 @@ package body Exp_Ch9 is Protection_Subtype : Node_Id; Entry_Count_Expr : constant Node_Id := Build_Entry_Count_Expression - (Prottyp, Cdecls, Loc); + (Prot_Typ, Cdecls, Loc); begin -- Could this be simplified using Corresponding_Runtime_Package??? - if Has_Attach_Handler (Prottyp) then - Ritem := First_Rep_Item (Prottyp); + 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 @@ -7233,7 +7115,7 @@ package body Exp_Ch9 is end loop; if Restricted_Profile then - if Has_Entries (Prottyp) then + if Has_Entries (Prot_Typ) then Protection_Subtype := New_Reference_To (RTE (RE_Protection_Entry), Loc); else @@ -7255,7 +7137,7 @@ package body Exp_Ch9 is Make_Integer_Literal (Loc, Num_Attach_Handler)))); end if; - elsif Has_Interrupt_Handler (Prottyp) then + elsif Has_Interrupt_Handler (Prot_Typ) then Protection_Subtype := Make_Subtype_Indication ( Sloc => Loc, @@ -7268,11 +7150,11 @@ package body Exp_Ch9 is -- Type has explicit entries or generated primitive entry wrappers - elsif Has_Entries (Prottyp) + elsif Has_Entries (Prot_Typ) or else (Ada_Version >= Ada_05 and then Present (Interface_List (N))) then - case Corresponding_Runtime_Package (Prottyp) is + case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => Protection_Subtype := Make_Subtype_Indication (Loc, @@ -7364,7 +7246,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Priv, Prottyp, Unprotected_Mode)); + (Priv, Prot_Typ, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7379,7 +7261,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Priv, Prottyp, Protected_Mode)); + (Priv, Prot_Typ, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7482,7 +7364,7 @@ package body Exp_Ch9 is -- 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 (Prottyp) then + if Has_Entries (Prot_Typ) then Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); @@ -7509,7 +7391,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Comp, Prottyp, Unprotected_Mode)); + (Comp, Prot_Typ, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7527,7 +7409,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Comp, Prottyp, Protected_Mode)); + (Comp, Prot_Typ, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7540,13 +7422,13 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Present (Abstract_Interfaces - (Corresponding_Record_Type (Prottyp))) + (Corresponding_Record_Type (Prot_Typ))) then Sub := Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Comp, Prottyp, Dispatching_Mode)); + (Comp, Prot_Typ, Dispatching_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7571,31 +7453,31 @@ package body Exp_Ch9 is elsif Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); - Set_Privals_Chain (Comp_Id, New_Elmt_List); + Edef := Make_Defining_Identifier (Loc, - Build_Selected_Name (Prottyp, Comp_Id, 'E')); + Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => - Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); + Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); Insert_After (Current_Node, Sub); Analyze (Sub); - Set_Protected_Body_Subprogram ( - Defining_Identifier (Comp), - Defining_Unit_Name (Specification (Sub))); + Set_Protected_Body_Subprogram + (Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, - Build_Selected_Name (Prottyp, Comp_Id, 'B')); + Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); Sub := Make_Subprogram_Declaration (Loc, Specification => - Build_Barrier_Function_Specification (Bdef, Loc)); + Build_Barrier_Function_Specification (Loc, Bdef)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7632,33 +7514,32 @@ package body Exp_Ch9 is if Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); - Set_Privals_Chain (Comp_Id, New_Elmt_List); + Edef := Make_Defining_Identifier (Loc, - Build_Selected_Name (Prottyp, Comp_Id, 'E')); - + Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => - Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); + Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); Insert_After (Current_Node, Sub); Analyze (Sub); - Set_Protected_Body_Subprogram ( - Defining_Identifier (Comp), - Defining_Unit_Name (Specification (Sub))); + Set_Protected_Body_Subprogram + (Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, - Build_Selected_Name (Prottyp, Comp_Id, 'E')); + Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => - Build_Barrier_Function_Specification (Bdef, Loc)); + Build_Barrier_Function_Specification (Loc, Bdef)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -7670,7 +7551,7 @@ package body Exp_Ch9 is -- Collect pointers to the protected subprogram and the barrier -- of the current entry, for insertion into Entry_Bodies_Array. - Append ( + Append_To (Expressions (Entries_Aggr), Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, @@ -7678,8 +7559,7 @@ package body Exp_Ch9 is Attribute_Name => Name_Unrestricted_Access), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Edef, Loc), - Attribute_Name => Name_Unrestricted_Access))), - Expressions (Entries_Aggr)); + Attribute_Name => Name_Unrestricted_Access)))); end if; Next (Comp); @@ -7689,11 +7569,12 @@ package body Exp_Ch9 is -- Emit declaration for Entry_Bodies_Array, now that the addresses of -- all protected subprograms have been collected. - if Has_Entries (Prottyp) then - Body_Id := Make_Defining_Identifier (Sloc (Prottyp), - New_External_Name (Chars (Prottyp), 'A')); + 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 (Prottyp) is + case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => Body_Arr := Make_Object_Declaration (Loc, Defining_Identifier => Body_Id, @@ -7737,19 +7618,19 @@ package body Exp_Ch9 is Current_Node := Body_Arr; Analyze (Body_Arr); - Set_Entry_Bodies_Array (Prottyp, Body_Id); + 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 (Prottyp) - = System_Tasking_Protected_Objects_Entries + if Corresponding_Runtime_Package (Prot_Typ) = + System_Tasking_Protected_Objects_Entries then Sub := Make_Subprogram_Declaration (Loc, - Specification => Build_Find_Body_Index_Spec (Prottyp)); + Specification => Build_Find_Body_Index_Spec (Prot_Typ)); Insert_After (Current_Node, Sub); Analyze (Sub); end if; @@ -9253,9 +9134,11 @@ package body Exp_Ch9 is New_N : Node_Id; begin - -- Here we start the expansion by generating discriminal declarations + -- Add renaming declarations for discriminals and a declaration for the + -- entry family index (if applicable). - Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); + 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. @@ -9286,15 +9169,15 @@ package body Exp_Ch9 is New_N := Make_Subprogram_Body (Loc, - Specification => Build_Task_Proc_Specification (Ttyp), - Declarations => Declarations (N), + Specification => Build_Task_Proc_Specification (Ttyp), + Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (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 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)); @@ -9348,7 +9231,6 @@ package body Exp_Ch9 is if Nkind (Vis_Decl) = N_Entry_Declaration and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry then - -- Create the specification of the wrapper Wrap_Body := @@ -9392,6 +9274,10 @@ package body Exp_Ch9 is -- 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 @@ -9434,6 +9320,11 @@ package body Exp_Ch9 is -- present in the pragma, and is used to provide the Task_Image parameter -- to the call to Create_Task. + -- 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. + -- 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 @@ -9465,10 +9356,10 @@ package body Exp_Ch9 is -- the case of a simple entry. procedure Expand_N_Task_Type_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); - Tasknm : constant Name_Id := Chars (Tasktyp); - Taskdef : constant Node_Id := Task_Definition (N); + Loc : constant Source_Ptr := Sloc (N); + Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); + Tasknm : constant Name_Id := Chars (Tasktyp); + Taskdef : constant Node_Id := Task_Definition (N); Proc_Spec : Node_Id; Rec_Decl : Node_Id; @@ -9752,6 +9643,34 @@ package body Exp_Ch9 is (Taskdef, Name_Task_Info))))))); 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). + + if not Restricted_Profile + 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_Reference_To (RTE (RE_Time_Span), Loc)), + + Expression => + Convert_To (RTE (RE_Time_Span), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Relative_Deadline)))))))); + end if; + Insert_After (Size_Decl, Rec_Decl); -- Analyze the record declaration immediately after construction, @@ -10425,56 +10344,10 @@ package body Exp_Ch9 is -- Expand_Protected_Body_Declarations -- ---------------------------------------- - -- Part of the expansion of a protected body involves the creation of a - -- declaration that can be referenced from the statement sequences of the - -- entry bodies: - - -- A : Address; - - -- This declaration is inserted in the declarations of the service entries - -- procedure for the protected body, and it is important that it be - -- inserted before the statements of the entry body statement sequences are - -- analyzed. Thus it would be too late to create this declaration in the - -- Expand_N_Protected_Body 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. - - -- No stack is needed for entry bodies, since they cannot be nested, but it - -- is kept for consistency between protected and task entries. The stack - -- will never contain more than one element. There is also only one such - -- variable for a given protected body, but this is placed on the - -- Accept_Address stack of all of the entries, again for consistency. - - -- To expand the requeue statement, a label is provided at the end of the - -- loop in the entry service routine created by the expander (see - -- Expand_N_Protected_Body for details), so that the statement can be - -- skipped after the requeue is complete. This label is created during the - -- expansion of the entry body, which will take place after the expansion - -- of the requeue statements that it contains, so a placeholder defining - -- identifier is associated with the task type here. - - -- Another label is provided following case statement created by the - -- expander. This label is need for implementing return statement from - -- entry body so that a return can be expanded as a goto to this label. - -- This label is created during the expansion of the entry body, which - -- will take place after the expansion of the return statements that it - -- contains. Therefore, just like the label for expanding requeues, we - -- need another placeholder for the label. - procedure Expand_Protected_Body_Declarations (N : Node_Id; Spec_Id : Entity_Id) is - Op : Node_Id; - begin if No_Run_Time_Mode then Error_Msg_CRT ("protected body", N); @@ -10482,15 +10355,11 @@ package body Exp_Ch9 is elsif Expander_Active then - -- Associate privals with the first subprogram or entry body to be - -- expanded. These are used to expand references to private data - -- objects. - - Op := First_Protected_Operation (Declarations (N)); + -- Associate discriminals with the first subprogram or entry body to + -- be expanded. - if Present (Op) then + if Present (First_Protected_Operation (Declarations (N))) then Set_Discriminals (Parent (Spec_Id)); - Set_Privals (Parent (Spec_Id), Op, Sloc (N)); end if; end if; end Expand_Protected_Body_Declarations; @@ -10811,131 +10680,434 @@ package body Exp_Ch9 is return First_Op; end First_Protected_Operation; - --------------------------------- - -- 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_Discriminants (Conctyp) - and then Present - (Discriminant_Default_Value (First_Discriminant (Conctyp))) - and then - (Denotes_Discriminant (Lo, True) - or else Denotes_Discriminant (Hi, True)); - end Is_Potentially_Large_Family; - - -------------------------------- - -- Index_Constant_Declaration -- - -------------------------------- + --------------------------------------- + -- Install_Private_Data_Declarations -- + --------------------------------------- - function Index_Constant_Declaration - (N : Node_Id; - Index_Id : Entity_Id; - Prot : Entity_Id) return List_Id + 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 - Loc : constant Source_Ptr := Sloc (N); - Decls : constant List_Id := New_List; - Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id); - Index_Typ : Entity_Id; - - Hi : Node_Id := Type_High_Bound (Etype (Index_Id)); - Lo : Node_Id := Type_Low_Bound (Etype (Index_Id)); + 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; - function Replace_Discriminant (Bound : Node_Id) return Node_Id; - -- The bounds of the entry index may depend on discriminants, so each - -- declaration of an entry_index_constant must have its own subtype - -- declaration, using the local renaming of the object discriminant. + Insert_Node := Decl; + end Add; -------------------------- -- Replace_Discriminant -- -------------------------- - function Replace_Discriminant (Bound : Node_Id) return Node_Id is + function Replace_Bound (Bound : Node_Id) return Node_Id is begin if Nkind (Bound) = N_Identifier - and then Ekind (Entity (Bound)) = E_Constant - and then Present (Discriminal_Link (Entity (Bound))) + and then Is_Discriminal (Entity (Bound)) then return Make_Identifier (Loc, Chars (Entity (Bound))); else return Duplicate_Subexpr (Bound); end if; - end Replace_Discriminant; + end Replace_Bound; - -- Start of processing for Index_Constant_Declaration + -- Start of processing for Install_Private_Data_Declarations begin - Set_Discriminal_Link (Index_Con, Index_Id); + -- 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); - if Is_Entity_Name ( - Original_Node (Discrete_Subtype_Definition (Parent (Index_Id)))) + -- 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 - -- Simple case: entry family is given by a subtype mark, and index - -- constant has the same type, no replacement needed. + 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; - Index_Typ := Etype (Index_Id); + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Typ_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Conc_Rec, Loc))); + Add (Decl); - else - Hi := Replace_Discriminant (Hi); - Lo := Replace_Discriminant (Lo); + -- Generate: + -- _object : prot_typVP := prot_typV (_O); - Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Object_Definition => New_Reference_To (Typ_Id, Loc), + Expression => + Unchecked_Convert_To (Typ_Id, + New_Reference_To (Obj_Ent, Loc))); + Add (Decl); - Append ( - Make_Subtype_Declaration (Loc, - Defining_Identifier => Index_Typ, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc), - Constraint => - Make_Range_Constraint (Loc, - Range_Expression => Make_Range (Loc, Lo, Hi)))), - Decls); + -- Set the reference to the concurrent object + Obj_Ent := Defining_Identifier (Decl); + end; end if; - Append ( - Make_Object_Declaration (Loc, - Defining_Identifier => Index_Con, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Index_Typ, Loc), + -- Step 2: Create the Protection object and build its declaration for + -- any protected entry (family) of subprogram. - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Index_Typ, Loc), - Attribute_Name => Name_Val, + if Is_Protected then + declare + Prot_Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + Prot_Typ : RE_Id; - Expressions => New_List ( + begin + Set_Protection_Object (Spec_Id, Prot_Ent); - Make_Op_Add (Loc, - Left_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => Make_Identifier (Loc, Name_uE), - Right_Opnd => - Entry_Index_Expression (Loc, - Defining_Identifier (N), Empty, Prot)), + -- Determine the proper protection type - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Index_Typ, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Index_Typ, Loc), - Attribute_Name => Name_First))))))), - Decls); + if Has_Attach_Handler (Conc_Typ) + and then not Restricted_Profile + then + Prot_Typ := RE_Static_Interrupt_Protection; + + elsif Has_Interrupt_Handler (Conc_Typ) then + Prot_Typ := RE_Dynamic_Interrupt_Protection; + + -- The type has explicit entries or generated primitive entry + -- wrappers. + + elsif Has_Entries (Conc_Typ) + or else + (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Conc_Typ)))) + then + 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 others => + raise Program_Error; + end case; + + else + Prot_Typ := RE_Protection; + end if; + + -- Generate: + -- conc_typR : protection_typ renames _object._object; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Prot_Ent, + Subtype_Mark => + New_Reference_To (RTE (Prot_Typ), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (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 - return Decls; - end Index_Constant_Declaration; + -- 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_Reference_To (Etype (D), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Obj_Ent, Loc), + Selector_Name => Make_Identifier (Loc, Chars (D)))); + Add (Decl); + + 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; + + begin + Comp := First (Private_Declarations (Def)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration then + Comp_Id := Defining_Identifier (Comp); + Decl_Id := + Make_Defining_Identifier (Loc, Chars (Comp_Id)); + + -- Minimal decoration + + if Ekind (Spec_Id) = E_Function then + Set_Ekind (Decl_Id, E_Constant); + else + Set_Ekind (Decl_Id, E_Variable); + end if; + + Set_Prival (Comp_Id, Decl_Id); + Set_Prival_Link (Decl_Id, Comp_Id); + Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); + + -- Generate: + -- comp_name : comp_typ renames _object.comp_name; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Decl_Id, + Subtype_Mark => + New_Reference_To (Etype (Comp_Id), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Obj_Ent, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Comp_Id)))); + 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 then 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 + + Set_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_Defining_Identifier (Loc, New_Internal_Name ('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_Reference_To (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_Reference_To (Index_Typ, Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Val, + + Expressions => New_List ( + + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + New_Reference_To (E, Loc), + Right_Opnd => + Entry_Index_Expression (Loc, + Defining_Identifier (Body_Nod), + Empty, Conc_Typ)), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (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_Discriminants (Conctyp) + and then Present + (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + (Denotes_Discriminant (Lo, True) + or else Denotes_Discriminant (Hi, True)); + end Is_Potentially_Large_Family; + + ------------------ + -- 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 -- @@ -11162,7 +11334,7 @@ package body Exp_Ch9 is -- or, in the case of Ravenscar: - -- Install_Handlers + -- Install_Restricted_Handlers -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); declare @@ -11171,19 +11343,6 @@ package body Exp_Ch9 is Ritem : Node_Id := First_Rep_Item (Ptyp); begin - if not Restricted then - - -- Appends the _object argument - - 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)); - end if; - -- Build the Attach_Handler table argument while Present (Ritem) loop @@ -11218,12 +11377,39 @@ package body Exp_Ch9 is Append_To (Args, Make_Aggregate (Loc, Table)); - -- Append the Install_Handler call to the statements + -- Append the Install_Handlers (or Install_Restricted_Handlers) + -- call to the statements. - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), - Parameter_Associations => Args)); + 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_Reference_To + (RTE (RE_Install_Restricted_Handlers), Loc), + Parameter_Associations => Args)); + + else + -- 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)); + + -- Then, insert call to Install_Handlers + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), + Parameter_Associations => Args)); + end if; end; end if; @@ -11347,18 +11533,43 @@ package body Exp_Ch9 is if not Restricted_Profile 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_Reference_To (RTE (RE_Time_Span_Zero), 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); + 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 @@ -11375,17 +11586,55 @@ package body Exp_Ch9 is end if; -- State parameter. This is a pointer to the task body procedure. The - -- required value is obtained by taking the address 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 + -- 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. - Append_To (Args, - Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc), - Attribute_Name => Name_Address))); + 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. + + -- This processing is causing a crash in the .NET/JVM back ends that + -- is not yet understood, so skip it in these cases ??? + + if VM_Target = No_VM then + 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_Reference_To (Subp_Ptr_Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + -- For the .NET/JVM cases revert to the original code below ??? + + else + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Address))); + end if; + end; -- Discriminants parameter. This is just the address of the task -- value record itself (which contains the discriminant values @@ -11684,125 +11933,6 @@ package body Exp_Ch9 is end if; end Set_Discriminals; - ----------------- - -- Set_Privals -- - ----------------- - - procedure Set_Privals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr; - After_Barrier : Boolean := False) - is - P_Decl : Node_Id; - P_Id : Entity_Id; - Priv : Entity_Id; - Def : Node_Id; - Body_Ent : Entity_Id; - For_Barrier : constant Boolean := - Nkind (Op) = N_Entry_Body and then not After_Barrier; - - Prec_Decl : constant Node_Id := - Parent (Corresponding_Record_Type - (Defining_Identifier (Dec))); - Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl); - Obj_Decl : Node_Id; - P_Subtype : Entity_Id; - Assoc_L : constant Elist_Id := New_Elmt_List; - Op_Id : Entity_Id; - - begin - pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); - pragma Assert (Nkind_In (Op, N_Subprogram_Body, N_Entry_Body)); - - Def := Protected_Definition (Dec); - - if Present (Private_Declarations (Def)) then - P_Decl := First (Private_Declarations (Def)); - while Present (P_Decl) loop - if Nkind (P_Decl) = N_Component_Declaration then - P_Id := Defining_Identifier (P_Decl); - - if For_Barrier then - Priv := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (P_Id), 'P')); - else - Priv := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (P_Id))); - end if; - - Set_Ekind (Priv, E_Variable); - Set_Etype (Priv, Etype (P_Id)); - Set_Scope (Priv, Scope (P_Id)); - Set_Esize (Priv, Esize (Etype (P_Id))); - Set_Is_Aliased (Priv, Is_Aliased (P_Id)); - Set_Alignment (Priv, Alignment (Etype (P_Id))); - - -- If the type of the component is an itype, we must create a - -- new itype for the corresponding prival in each protected - -- operation, to avoid scoping problems. We create new itypes - -- by copying the tree for the component definition. - -- (Ada 2005) If the itype is an anonymous access type created - -- for an access definition for a component, it is declared in - -- the enclosing scope, and we do no create a local version of - -- it, to prevent scoping anomalies in gigi. - - if Is_Itype (Etype (P_Id)) - and then not - (Is_Access_Type (Etype (P_Id)) - and then Is_Local_Anonymous_Access (Etype (P_Id))) - then - Append_Elmt (P_Id, Assoc_L); - Append_Elmt (Priv, Assoc_L); - - if Nkind (Op) = N_Entry_Body then - Op_Id := Defining_Identifier (Op); - else - Op_Id := Defining_Unit_Name (Specification (Op)); - end if; - - Discard_Node - (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id)); - end if; - - Set_Protected_Operation (P_Id, Op); - Set_Prival (P_Id, Priv); - end if; - - Next (P_Decl); - end loop; - end if; - - -- There is one more implicit private decl: the object itself. "prival" - -- for this is attached to the protected body defining identifier. - - Body_Ent := Corresponding_Body (Dec); - - Priv := - Make_Defining_Identifier (Sloc (Body_Ent), - Chars => New_External_Name (Chars (Body_Ent), 'R')); - - -- Set the Etype to the implicit subtype of Protection created when - -- the protected type declaration was expanded. This node will not - -- be analyzed until it is used as the defining identifier for the - -- renaming declaration in the protected operation body, and it will - -- be needed in the references expanded before that body is expanded. - -- Since the Protection field is aliased, set Is_Aliased as well. - - Obj_Decl := First (Component_Items (Component_List (Prec_Def))); - while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop - Next (Obj_Decl); - end loop; - - P_Subtype := Etype (Defining_Identifier (Obj_Decl)); - Set_Ekind (Priv, E_Variable); - Set_Etype (Priv, P_Subtype); - Set_Is_Aliased (Priv); - Set_Object_Ref (Body_Ent, Priv); - end Set_Privals; - ----------------------- -- Trivial_Accept_OK -- ----------------------- @@ -11838,168 +11968,4 @@ package body Exp_Ch9 is end case; end Trivial_Accept_OK; - ---------------------------- - -- Update_Prival_Subtypes -- - ---------------------------- - - procedure Update_Prival_Subtypes (N : Node_Id) is - - function Process (N : Node_Id) return Traverse_Result; - -- Update the etype of occurrences of privals whose etype does not - -- match the current Etype of the prival entity itself. - - procedure Update_Array_Bounds (E : Entity_Id); - -- Itypes generated for array expressions may depend on the - -- determinants of the protected object, and need to be processed - -- separately because they are not attached to the tree. - - procedure Update_Index_Types (N : Node_Id); - -- Similarly, update the types of expressions in indexed components - -- which may depend on other discriminants. - - ------------- - -- Process -- - ------------- - - function Process (N : Node_Id) return Traverse_Result is - begin - if Is_Entity_Name (N) then - declare - E : constant Entity_Id := Entity (N); - begin - if Present (E) - and then (Ekind (E) = E_Constant - or else Ekind (E) = E_Variable) - and then Nkind (Parent (E)) = N_Object_Renaming_Declaration - and then not Is_Scalar_Type (Etype (E)) - and then Etype (N) /= Etype (E) - then - - -- Ensure that reference and entity have the same Etype, - -- to prevent back-end inconsistencies. - - Set_Etype (N, Etype (E)); - Update_Index_Types (N); - - elsif Present (E) - and then Ekind (E) = E_Constant - and then Present (Discriminal_Link (E)) - then - Set_Etype (N, Etype (E)); - end if; - end; - - return OK; - - elsif Nkind_In (N, N_Defining_Identifier, - N_Defining_Operator_Symbol, - N_Defining_Character_Literal) - then - return Skip; - - elsif Nkind (N) = N_String_Literal then - - -- Array type, but bounds are constant - - return OK; - - elsif Nkind (N) = N_Object_Declaration - and then Is_Itype (Etype (Defining_Identifier (N))) - and then Is_Array_Type (Etype (Defining_Identifier (N))) - then - Update_Array_Bounds (Etype (Defining_Identifier (N))); - return OK; - - -- For array components of discriminated records, use the base type - -- directly, because it may depend indirectly on the discriminants of - -- the protected type. - - -- Cleaner would be a systematic mechanism to compute actual subtypes - -- of private components??? - - elsif Nkind (N) in N_Has_Etype - and then Present (Etype (N)) - and then Is_Array_Type (Etype (N)) - and then Nkind (N) = N_Selected_Component - and then Has_Discriminants (Etype (Prefix (N))) - then - Set_Etype (N, Base_Type (Etype (N))); - Update_Index_Types (N); - return OK; - - else - if Nkind (N) in N_Has_Etype - and then Present (Etype (N)) - and then Is_Itype (Etype (N)) then - - if Is_Array_Type (Etype (N)) then - Update_Array_Bounds (Etype (N)); - - elsif Is_Scalar_Type (Etype (N)) then - Update_Prival_Subtypes (Type_Low_Bound (Etype (N))); - Update_Prival_Subtypes (Type_High_Bound (Etype (N))); - end if; - end if; - - return OK; - end if; - end Process; - - ------------------------- - -- Update_Array_Bounds -- - ------------------------- - - procedure Update_Array_Bounds (E : Entity_Id) is - Ind : Node_Id; - begin - Ind := First_Index (E); - while Present (Ind) loop - Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind))); - Update_Prival_Subtypes (Type_High_Bound (Etype (Ind))); - Next_Index (Ind); - end loop; - end Update_Array_Bounds; - - ------------------------ - -- Update_Index_Types -- - ------------------------ - - procedure Update_Index_Types (N : Node_Id) is - Indx1 : Node_Id; - I_Typ : Node_Id; - - begin - -- If the prefix has an actual subtype that is different from the - -- nominal one, update the types of the indices, so that the proper - -- constraints are applied. Do not apply this transformation to a - -- packed array, where the index type is computed for a byte array - -- and is different from the source index. - - if Nkind (Parent (N)) = N_Indexed_Component - and then - not Is_Bit_Packed_Array (Etype (Prefix (Parent (N)))) - then - Indx1 := First (Expressions (Parent (N))); - I_Typ := First_Index (Etype (N)); - - while Present (Indx1) and then Present (I_Typ) loop - - if not Is_Entity_Name (Indx1) then - Set_Etype (Indx1, Base_Type (Etype (I_Typ))); - end if; - - Next (Indx1); - Next_Index (I_Typ); - end loop; - end if; - end Update_Index_Types; - - procedure Traverse is new Traverse_Proc (Process); - - -- Start of processing for Update_Prival_Subtypes - - begin - Traverse (N); - end Update_Prival_Subtypes; - end Exp_Ch9; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index df3cdeb9fbf..71c1e830c3c 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -25,7 +25,6 @@ -- Expand routines for chapter 9 constructs -with Namet; use Namet; with Types; use Types; package Exp_Ch9 is @@ -37,41 +36,6 @@ package Exp_Ch9 is -- This type is used to distinguish the different protection modes of a -- protected subprogram. - procedure Add_Discriminal_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr); - -- This routine is used to add discriminal declarations to task and - -- protected operation bodies. The discriminants are available by normal - -- selection from the concurrent object (whose name is passed as the third - -- parameter). Discriminant references inside the body have already - -- been replaced by references to the corresponding discriminals. The - -- declarations constructed by this procedure hook the references up with - -- the objects: - -- - -- discriminal_name : discr_type renames name.discriminant_name; - -- - -- Obviously we could have expanded the discriminant references in the - -- first place to be the appropriate selection, but this turns out to - -- be hard to do because it would introduce difference in handling of - -- discriminant references depending on their location. - - procedure Add_Private_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr); - -- This routine is used to add private declarations to protected bodies. - -- These are analogous to the discriminal declarations added to tasks - -- and protected operations, and consist of a renaming of each private - -- object to a selection from the concurrent object passed as an extra - -- parameter to each such operation: - -- private_name : private_type renames name.private_name; - -- As with discriminals, private references inside the protected - -- subprogram bodies have already been replaced by references to the - -- corresponding privals. - procedure Build_Activation_Chain_Entity (N : Node_Id); -- Given a declaration N of an object that is a task, or contains tasks -- (other than allocators to tasks) this routine ensures that an activation @@ -113,12 +77,12 @@ package Exp_Ch9 is -- declarative part. function Build_Protected_Sub_Specification - (N : Node_Id; - Prottyp : Entity_Id; - Mode : Subprogram_Protection_Mode) return Node_Id; - -- Build specification for protected subprogram. This is called when + (N : Node_Id; + Prot_Typ : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id; + -- Build the specification for protected subprogram. This is called when -- expanding a protected type, and also when expanding the declaration for - -- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is + -- an Access_To_Protected_Subprogram type. In the latter case, Prot_Typ is -- empty, and the first parameter of the signature of the protected op is -- of type System.Address. @@ -242,10 +206,6 @@ package Exp_Ch9 is -- now, within the context of the protected object, to resolve calls to -- other protected functions. - procedure Expand_Entry_Body_Declarations (N : Node_Id); - -- Expand declarations required for the expansion of the - -- statements of the body. - procedure Expand_N_Abort_Statement (N : Node_Id); procedure Expand_N_Accept_Statement (N : Node_Id); procedure Expand_N_Asynchronous_Select (N : Node_Id); @@ -277,11 +237,10 @@ package Exp_Ch9 is procedure Expand_Protected_Body_Declarations (N : Node_Id; Spec_Id : Entity_Id); - -- Expand declarations required for a protected body. See bodies of - -- both Expand_Protected_Body_Declarations and Expand_N_Protected_Body - -- for full details of the nature and use of these declarations. - -- The second argument is the entity for the corresponding - -- protected type declaration. + -- Expand declarations required for a protected body. See bodies of both + -- Expand_Protected_Body_Declarations and Expand_N_Protected_Body for full + -- details of the nature and use of these declarations. The second argument + -- is the entity for the corresponding protected type declaration. function External_Subprogram (E : Entity_Id) return Entity_Id; -- return the external version of a protected operation, which locks @@ -291,43 +250,79 @@ package Exp_Ch9 is -- Given the declarations list for a protected body, find the -- first protected operation body. + 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); + -- This routines generates several types, objects and object renamings used + -- in the handling of discriminants and private components of protected and + -- task types. It also generates the entry index for entry families. Formal + -- Spec_Id denotes an entry, entry family or a subprogram, Conc_Typ is the + -- concurrent type where Spec_Id resides, Body_Nod is the corresponding + -- body of Spec_Id, Decls are the declarations of the subprogram or entry. + -- Flag Barrier denotes whether the context is an entry barrier function. + -- Flag Family is used in conjunction with Barrier to denote a barrier for + -- an entry family. + -- + -- The generated types, entities and renamings are: + -- + -- * If flag Barrier is set or Spec_Id denotes a protected entry or an + -- entry family, generate: + -- + -- type prot_typVP is access prot_typV; + -- _object : prot_typVP := prot_typV (_O); + -- + -- where prot_typV is the corresponding record of a protected type and + -- _O is a formal parameter representing the concurrent object of either + -- the barrier function or the entry (family). + -- + -- * If Conc_Typ is a protected type, create a renaming for the Protection + -- field _object: + -- + -- conc_typR : protection_typ renames _object._object; + -- + -- * If Conc_Typ has discriminants, create renamings of the form: + -- + -- discr_nameD : discr_typ renames _object.discr_name; + -- or + -- discr_nameD : discr_typ renames _task.discr_name; + -- + -- * If Conc_Typ denotes a protected type and has private components, + -- generate renamings of the form: + -- + -- comp_name : comp_typ renames _object.comp_name; + -- + -- * Finally, is flag Barrier and Family are set or Spec_Id denotes an + -- entry family, generate the entry index constant: + -- + -- subtype Jnn is <Type of Index> range Low .. High; + -- J : constant Jnn := + -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); + -- + -- All the above declarations are inserted in the order shown to the front + -- of Decls. + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; -- Given the entity of the record type created for a task type, build -- the call to Create_Task function Make_Initialize_Protection - (Protect_Rec : Entity_Id) - return List_Id; + (Protect_Rec : Entity_Id) return List_Id; -- Given the entity of the record type created for a protected type, build -- a list of statements needed for proper initialization of the object. function Next_Protected_Operation (N : Node_Id) return Node_Id; - -- Given a protected operation node (a subprogram or entry body), - -- find the following node in the declarations list. + -- Given a protected operation node (a subprogram or entry body), find the + -- following node in the declarations list. procedure Set_Discriminals (Dec : Node_Id); - -- Replace discriminals in a protected type for use by the - -- next protected operation on the type. Each operation needs a - -- new set of discriminals, since it needs a unique renaming of - -- the discriminant fields in the record used to implement the - -- protected type. - - procedure Set_Privals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr; - After_Barrier : Boolean := False); - -- Associates a new set of privals (placeholders for later access to - -- private components of protected objects) with the private object - -- declarations of a protected object. These will be used to expand - -- the references to private objects in the next protected - -- subprogram or entry body to be expanded. - -- - -- The flag After_Barrier indicates whether this is called after building - -- the barrier function for an entry body. This flag determines whether - -- the privals should have source names (which simplifies debugging) or - -- internally generated names. Entry barriers contain no debuggable code, - -- and there may be visibility conflicts between an entry index and a - -- a prival, so privals for barrier function have internal names. + -- Replace discriminals in a protected type for use by the next protected + -- operation on the type. Each operation needs a new set of discirminals, + -- since it needs a unique renaming of the discriminant fields in the + -- record used to implement the protected type. end Exp_Ch9; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 21a78ac80a4..8f191be3a36 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -1092,7 +1092,7 @@ package body Exp_Pakd is -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); - Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer); + Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); -- Use a modular type if possible. We can do this if we have -- static bounds, and the length is small enough, and the length @@ -1774,47 +1774,11 @@ package body Exp_Pakd is Ltyp := Etype (L); Rtyp := Etype (R); - -- First an odd and silly test. We explicitly check for the XOR - -- case where the component type is True .. True, since this will - -- raise constraint error. A special check is required since CE - -- will not be required other wise (cf Expand_Packed_Not). - - -- No such check is required for AND and OR, since for both these - -- cases False op False = False, and True op True = True. + -- Deeal with silly case of XOR where the subcomponent has a range + -- True .. True where an exception must be raised. if Nkind (N) = N_Op_Xor then - declare - CT : constant Entity_Id := Component_Type (Rtyp); - BT : constant Entity_Id := Base_Type (CT); - - begin - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_And (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (CT, Loc), - Attribute_Name => Name_First), - - Right_Opnd => - Convert_To (BT, - New_Occurrence_Of (Standard_True, Loc))), - - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (CT, Loc), - Attribute_Name => Name_Last), - - Right_Opnd => - Convert_To (BT, - New_Occurrence_Of (Standard_True, Loc)))), - Reason => CE_Range_Check_Failed)); - end; + Silly_Boolean_Array_Xor_Test (N, Rtyp); end if; -- Now that that silliness is taken care of, get packed array type @@ -2186,37 +2150,11 @@ package body Exp_Pakd is Convert_To_Actual_Subtype (Opnd); Rtyp := Etype (Opnd); - -- First an odd and silly test. We explicitly check for the case - -- where the 'First of the component type is equal to the 'Last of - -- this component type, and if this is the case, we make sure that - -- constraint error is raised. The reason is that the NOT is bound - -- to cause CE in this case, and we will not otherwise catch it. + -- Deal with silly False..False and True..True subtype case - -- Believe it or not, this was reported as a bug. Note that nearly - -- always, the test will evaluate statically to False, so the code - -- will be statically removed, and no extra overhead caused. + Silly_Boolean_Array_Not_Test (N, Rtyp); - declare - CT : constant Entity_Id := Component_Type (Rtyp); - - begin - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (CT, Loc), - Attribute_Name => Name_First), - - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (CT, Loc), - Attribute_Name => Name_Last)), - Reason => CE_Range_Check_Failed)); - end; - - -- Now that that silliness is taken care of, get packed array type + -- Now that the silliness is taken care of, get packed array type Convert_To_PAT_Type (Opnd); PAT := Etype (Opnd); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 82f3fcfc201..12fea51a197 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -336,7 +336,7 @@ package body Exp_Util is -- component, whose prefix is the outer variable of the array type. -- The n-dimensional array type has known indices Index, Index2... -- Id_Ref is an indexed component form created by the enclosing init proc. - -- Its successive indices are Val1, Val2,.. which are the loop variables + -- Its successive indices are Val1, Val2, ... which are the loop variables -- in the loops that call the individual task init proc on each component. -- The generated function has the following structure: @@ -962,9 +962,16 @@ package body Exp_Util is if Has_Entries (Typ) or else Has_Interrupt_Handler (Typ) or else (Has_Attach_Handler (Typ) - and then not Restricted_Profile) - or else (Ada_Version >= Ada_05 - and then Present (Interface_List (Parent (Typ)))) + and then not Restricted_Profile) + + -- 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. It is sufficent to + -- check for the presence of an interface list in the declaration + -- node to recognize this case. + + or else Present (Interface_List (Parent (Typ))) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False @@ -1814,6 +1821,34 @@ package body Exp_Util is return Node (Prim); end Find_Prim_Op; + ---------------------------- + -- Find_Protection_Object -- + ---------------------------- + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + S := Scop; + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Present (Protection_Object (S)) + then + return Protection_Object (S); + end if; + + S := Scope (S); + end loop; + + -- If we do not find a Protection object in the scope chain, then + -- something has gone wrong, most likely the object was never created. + + raise Program_Error; + end Find_Protection_Object; + ---------------------- -- Force_Evaluation -- ---------------------- @@ -2292,13 +2327,14 @@ package body Exp_Util is return; end if; - -- Ignore insert of actions from inside default expression in the - -- special preliminary analyze mode. Any insertions at this point - -- have no relevance, since we are only doing the analyze to freeze - -- the types of any static expressions. See section "Handling of - -- Default Expressions" in the spec of package Sem for further details. + -- Ignore insert of actions from inside default expression (or other + -- similar "spec expression") in the special spec-expression analyze + -- mode. Any insertions at this point have no relevance, since we are + -- only doing the analyze to freeze the types of any static expressions. + -- See section "Handling of Default Expressions" in the spec of package + -- Sem for further details. - if In_Default_Expression then + if In_Spec_Expression then return; end if; @@ -3028,6 +3064,10 @@ package body Exp_Util is Get_Name_String (Chars (E)); + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homgeneous binary operator that returns Boolean. + if Name_Len > TSS_Name_Type'Last then TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); @@ -3441,6 +3481,40 @@ package body Exp_Util is and then Etype (Full_View (T)) /= T); end Is_Untagged_Derivation; + --------------------------- + -- Is_Volatile_Reference -- + --------------------------- + + function Is_Volatile_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Treat_As_Volatile (Etype (N)) + then + return True; + + elsif Is_Entity_Name (N) then + return Treat_As_Volatile (Entity (N)); + + elsif Nkind (N) = N_Slice then + return Is_Volatile_Reference (Prefix (N)); + + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if (Is_Entity_Name (Prefix (N)) + and then Has_Volatile_Components (Entity (Prefix (N)))) + or else (Present (Etype (Prefix (N))) + and then Has_Volatile_Components (Etype (Prefix (N)))) + then + return True; + else + return Is_Volatile_Reference (Prefix (N)); + end if; + + else + return False; + end if; + end Is_Volatile_Reference; + -------------------- -- Kill_Dead_Code -- -------------------- @@ -4257,9 +4331,15 @@ package body Exp_Util is end if; end; - -- If we have neither a record nor array component, it means that we - -- have fallen off the top testing prefixes recursively, and we now - -- have a stand alone object, where we don't have a problem. + -- For a slice, test the prefix, if that is possibly misaligned, + -- then for sure the slice is! + + when N_Slice => + return Possible_Bit_Aligned_Component (Prefix (N)); + + -- If we have none of the above, it means that we have fallen off the + -- top testing prefixes recursively, and we now have a stand alone + -- object, where we don't have a problem. when others => return False; @@ -4375,7 +4455,7 @@ package body Exp_Util is -- hand, if we do not consider them to be side effect free, then -- we get some awkward expansions in -gnato mode, resulting in -- code insertions at a point where we do not have a clear model - -- for performing the insertions. See 4908-002/comment for details. + -- for performing the insertions. -- Special handling for entity names @@ -4399,14 +4479,13 @@ package body Exp_Util is return False; -- Variables are considered to be a side effect if Variable_Ref - -- is set or if we have a volatile variable and Name_Req is off. + -- is set or if we have a volatile reference and Name_Req is off. -- If Name_Req is True then we can't help returning a name which -- effectively allows multiple references in any case. elsif Is_Variable (N) then return not Variable_Ref - and then (not Treat_As_Volatile (Entity (N)) - or else Name_Req); + and then (not Is_Volatile_Reference (N) or else Name_Req); -- Any other entity (e.g. a subtype name) is definitely side -- effect free. @@ -4631,17 +4710,16 @@ package body Exp_Util is Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function or operator call. And if we have a - -- volatile variable and Nam_Req is not set (see comments above for - -- Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference or an + -- operator. And if we have a volatile reference and Name_Req is not + -- set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call + or else Nkind (Exp) = N_Attribute_Reference or else Nkind (Exp) in N_Op - or else (not Name_Req - and then Is_Entity_Name (Exp) - and then Treat_As_Volatile (Entity (Exp)))) + or else (not Name_Req and then Is_Volatile_Reference (Exp))) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Set_Etype (Def_Id, Exp_Type); @@ -4686,9 +4764,9 @@ package body Exp_Util is -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several - -- circumstances: for change of representations, and also when this - -- is a view conversion to a smaller object, where gigi can end up - -- creating its own temporary of the wrong size. + -- circumstances: for change of representations, and also when this is + -- a view conversion to a smaller object, where gigi can end up creating + -- its own temporary of the wrong size. elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); @@ -4732,14 +4810,12 @@ package body Exp_Util is end if; -- For expressions that denote objects, we can use a renaming scheme. - -- We skip using this if we have a volatile variable and we do not - -- have Nam_Req set true (see comments above for Side_Effect_Free). + -- We skip using this if we have a volatile reference and we do not + -- have Name_Req set true (see comments above for Side_Effect_Free). elsif Is_Object_Reference (Exp) and then Nkind (Exp) /= N_Function_Call - and then (Name_Req - or else not Is_Entity_Name (Exp) - or else not Treat_As_Volatile (Entity (Exp))) + and then (Name_Req or else not Is_Volatile_Reference (Exp)) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); @@ -4778,7 +4854,7 @@ package body Exp_Util is -- If this is a packed reference, or a selected component with a -- non-standard representation, a reference to the temporary will -- be replaced by a copy of the original expression (see - -- exp_ch2.Expand_Renaming). Otherwise the temporary must be + -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line -- by the expression it renames, which would defeat the purpose of -- removing the side-effect. @@ -4795,6 +4871,36 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else + -- Special processing for function calls that return a task. We need + -- to build a declaration that will enable build-in-place expansion + -- of the call. + + -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have + -- to accommodate functions returning limited objects by reference. + + if Nkind (Exp) = N_Function_Call + and then Is_Task_Type (Etype (Exp)) + and then Ada_Version >= Ada_05 + then + declare + Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Expression => Relocate_Node (Exp)); + Insert_Action (Exp, Decl); + Set_Etype (Obj, Exp_Type); + Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); + return; + end; + end if; + Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Ptr_Typ_Decl := @@ -5202,9 +5308,9 @@ package body Exp_Util is Analyze (Asn); - -- Kill current value indication. This is necessary because - -- the tests of this flag are inserted out of sequence and must - -- not pick up bogus indications of the wrong constant value. + -- Kill current value indication. This is necessary because the + -- tests of this flag are inserted out of sequence and must not + -- pick up bogus indications of the wrong constant value. Set_Current_Value (Ent, Empty); end if; @@ -5237,6 +5343,87 @@ package body Exp_Util is end if; end Set_Renamed_Subprogram; + ---------------------------------- + -- Silly_Boolean_Array_Not_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the case where the 'First of the component type is equal to the + -- 'Last of this component type, and if this is the case, we make sure + -- that constraint error is raised. The reason is that the NOT is bound + -- to cause CE in this case, and we will not otherwise catch it. + + -- Believe it or not, this was reported as a bug. Note that nearly + -- always, the test will evaluate statically to False, so the code will + -- be statically removed, and no extra overhead caused. + + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last)), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Not_Test; + + ---------------------------------- + -- Silly_Boolean_Array_Xor_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the XOR case where the component type is True .. True, since this + -- will raise constraint error. A special check is required since CE + -- will not be required otherwise (cf Expand_Packed_Not). + + -- No such check is required for AND and OR, since for both these cases + -- False op False = False, and True op True = True. + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + BT : constant Entity_Id := Base_Type (CT); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc))), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc)))), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Xor_Test; + -------------------------- -- Target_Has_Fixed_Ops -- -------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 9c99323e8e4..73277afe16b 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -372,6 +372,13 @@ package Exp_Util is -- operation which is not directly visible. If T is a class wide type, -- then the reference is to an operation of the corresponding root type. + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id; + -- Traverse the scope stack starting from Scop and look for an entry, + -- entry family, or a subprogram that has a Protection_Object and return + -- it. Raises Program_Error if no such entity is found since the context + -- in which this routine is invoked should always have a protection + -- object. + procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False); @@ -491,6 +498,13 @@ package Exp_Util is -- Returns true if type T is not tagged and is a derived type, -- or is a private type whose completion is such a type. + function Is_Volatile_Reference (N : Node_Id) return Boolean; + -- Checks if the node N represents a volatile reference, which can be + -- either a direct reference to a variable treated as volatile, or an + -- indexed/selected component where the prefix is treated as volatile, + -- or has Volatile_Components set. A slice of a volatile variable is + -- also volatile. + procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); -- N represents a node for a section of code that is known to be dead. Any -- exception handler references and warning messages relating to this code @@ -613,6 +627,18 @@ package Exp_Util is -- renamed subprogram. The node is rewritten to be an identifier that -- refers directly to the renamed subprogram, given by entity E. + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array NOT operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is False..False or True..True, where it is required + -- that a Constraint_Error exception be raised (RM 4.5.6(6)). + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array XOR operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is True..True, where a raise of a Constraint_Error + -- exception is required (RM 4.5.6(6)). + function Target_Has_Fixed_Ops (Left_Typ : Entity_Id; Right_Typ : Entity_Id; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index ec4ce80bff1..86de33e78b7 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -570,9 +570,9 @@ package body Sem_Ch9 is -- expression is only evaluated if the guard is open. if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then - Pre_Analyze_And_Resolve (Expr, Standard_Duration); + Preanalyze_And_Resolve (Expr, Standard_Duration); else - Pre_Analyze_And_Resolve (Expr); + Preanalyze_And_Resolve (Expr); end if; Typ := First_Subtype (Etype (Expr)); @@ -646,8 +646,8 @@ package body Sem_Ch9 is Stats : constant Node_Id := Handled_Statement_Sequence (N); Formals : constant Node_Id := Entry_Body_Formal_Part (N); P_Type : constant Entity_Id := Current_Scope; - Entry_Name : Entity_Id; E : Entity_Id; + Entry_Name : Entity_Id; begin Tasking_Used := True; @@ -765,7 +765,6 @@ package body Sem_Ch9 is Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); Push_Scope (Entry_Name); - Exp_Ch9.Expand_Entry_Body_Declarations (N); Install_Declarations (Entry_Name); Set_Actual_Subtypes (N, Current_Scope); @@ -783,6 +782,17 @@ package body Sem_Ch9 is Set_Entry_Parameters_Type (Id, Entry_Parameters_Type (Entry_Name)); + -- 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). + + if Expander_Active + and then Is_Protected_Type (P_Type) + then + Install_Private_Data_Declarations + (Sloc (N), Entry_Name, P_Type, N, Decls); + end if; + if Present (Decls) then Analyze_Declarations (Decls); end if; @@ -926,40 +936,40 @@ package body Sem_Ch9 is ------------------------------- procedure Analyze_Entry_Declaration (N : Node_Id) is - Formals : constant List_Id := Parameter_Specifications (N); - Id : constant Entity_Id := Defining_Identifier (N); D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Formals : constant List_Id := Parameter_Specifications (N); begin - Generate_Definition (Id); + Generate_Definition (Def_Id); Tasking_Used := True; if No (D_Sdef) then - Set_Ekind (Id, E_Entry); + Set_Ekind (Def_Id, E_Entry); else - Enter_Name (Id); - Set_Ekind (Id, E_Entry_Family); + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Entry_Family); Analyze (D_Sdef); - Make_Index (D_Sdef, N, Id); + Make_Index (D_Sdef, N, Def_Id); end if; - Set_Etype (Id, Standard_Void_Type); - Set_Convention (Id, Convention_Entry); - Set_Accept_Address (Id, New_Elmt_List); + Set_Etype (Def_Id, Standard_Void_Type); + Set_Convention (Def_Id, Convention_Entry); + Set_Accept_Address (Def_Id, New_Elmt_List); if Present (Formals) then - Set_Scope (Id, Current_Scope); - Push_Scope (Id); + Set_Scope (Def_Id, Current_Scope); + Push_Scope (Def_Id); Process_Formals (Formals, N); - Create_Extra_Formals (Id); + Create_Extra_Formals (Def_Id); End_Scope; end if; - if Ekind (Id) = E_Entry then - New_Overloaded_Entity (Id); + if Ekind (Def_Id) = E_Entry then + New_Overloaded_Entity (Def_Id); end if; - Generate_Reference_To_Formals (Id); + Generate_Reference_To_Formals (Def_Id); end Analyze_Entry_Declaration; --------------------------------------- @@ -1061,7 +1071,7 @@ package body Sem_Ch9 is Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); - Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id); + Expand_Protected_Body_Declarations (N, Spec_Id); Last_E := Last_Entity (Spec_Id); @@ -1093,6 +1103,55 @@ package body Sem_Ch9 is E : Entity_Id; L : Entity_Id; + procedure Undelay_Itypes (T : Entity_Id); + -- Itypes created for the private components of a protected type + -- do not receive freeze nodes, because there is no scope in which + -- they can be elaborated, and they can depend on discriminants of + -- the enclosed protected type. Given that the components can be + -- composite types with inner components, we traverse recursively + -- the private components of the protected type, and indicate that + -- all itypes within are frozen. This ensures that no freeze nodes + -- will be generated for them. + -- + -- On the other hand, components of the correesponding record are + -- frozen (or receive itype references) as for other records. + + -------------------- + -- Undelay_Itypes -- + -------------------- + + procedure Undelay_Itypes (T : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Protected_Type (T) then + Comp := First_Private_Entity (T); + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + else + return; + end if; + + while Present (Comp) loop + if Is_Type (Comp) + and then Is_Itype (Comp) + then + Set_Has_Delayed_Freeze (Comp, False); + Set_Is_Frozen (Comp); + + if Is_Record_Type (Comp) + or else Is_Protected_Type (Comp) + then + Undelay_Itypes (Comp); + end if; + end if; + + Next_Entity (Comp); + end loop; + end Undelay_Itypes; + + -- Start of processing for Analyze_Protected_Definition + begin Tasking_Used := True; Analyze_Declarations (Visible_Declarations (N)); @@ -1127,6 +1186,8 @@ package body Sem_Ch9 is Next_Entity (E); end loop; + Undelay_Itypes (Current_Scope); + Check_Max_Entries (N, Max_Protected_Entries); Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; @@ -1151,7 +1212,10 @@ package body Sem_Ch9 is T := Find_Type_Name (N); - if Ekind (T) = E_Incomplete_Type then + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then T := Full_View (T); Set_Completion_Referenced (T); end if; @@ -1776,6 +1840,7 @@ package body Sem_Ch9 is procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); HSS : constant Node_Id := Handled_Statement_Sequence (N); Last_E : Entity_Id; @@ -1842,7 +1907,7 @@ package body Sem_Ch9 is Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); - Analyze_Declarations (Declarations (N)); + Analyze_Declarations (Decls); -- For visibility purposes, all entities in the body are private. Set -- First_Private_Entity accordingly, if there was no private part in the @@ -1946,7 +2011,10 @@ package body Sem_Ch9 is T := Find_Type_Name (N); Generate_Definition (T); - if Ekind (T) = E_Incomplete_Type then + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then T := Full_View (T); Set_Completion_Referenced (T); end if; |
